source: trunk/source/level-1/l1-boot-2.lisp @ 11081

Last change on this file since 11081 was 11081, checked in by gb, 12 years ago

Stop wrapping (pseudo) file-descriptors around Windows file handlers;
there seem to be cases where this definitely loses, because the MSVCRT
runtime tries to flush buffers associated with (e.g.) a listening socket
when it's closed, and we often have to do I/O in Windows-specific ways
and can't always use the C runtime, anyway.

Handles are (depending on which function you're dealing with) either
pointers or pointer-sized integers; they can be used interchangably
with ints on Win32, but porting this change to Win64 may require some
changes (in l1-io.lisp, in the PIPE function, perhaps elsewhere.)

Supporting this requires some changss in the kernel (mostly in
windows-calls.c) To bootstrap it, most of the I/O functions in
that file assume that very small integers [0 .. 31] are fds wrapped
around a handle and that anything larger is the handle itself. All
of the actual work done by those functions is done on the handle,
without involving the C runtime.

I'll check in a win32 kernel and image in a few minutes. Mixing
older kernels/images won't work, but I don't want to change the
kernel/image compatibility stuff until this is further along.

SLIME sort of works, but not very reliably yet.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.8 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17;; l1-boot-2.lisp
18;; Second part of l1-boot
19
20(in-package "CCL")
21
22(macrolet ((l1-load (name)
23             (let* ((namestring
24                     (concatenate 'simple-base-string
25                                  "./l1-fasls/"
26                                  (string name)
27                                  (namestring (backend-target-fasl-pathname
28                                               *target-backend*)))))
29       `(let* ((*loading-file-source-file* *loading-file-source-file*))
30                 (%fasload ,namestring))))
31           (bin-load (name)
32             (let* ((namestring
33                     (concatenate 'simple-base-string
34                                  "./bin/"
35                                  (string name)
36                                  (namestring (backend-target-fasl-pathname
37                                               *target-backend*)))))
38               `(let* ((*loading-file-source-file* *loading-file-source-file*))
39                 (%fasload ,namestring)))))
40
41
42(catch :toplevel
43    #+ppc-target
44    (l1-load "ppc-error-signal")
45    #+x86-target
46    (l1-load "x86-error-signal")
47    (l1-load "l1-error-signal")
48    (l1-load "l1-sockets")
49    (setq *LEVEL-1-LOADED* t))
50
51#+ppc-target
52(defun altivec-available-p ()
53  "Return non-NIL if AltiVec is available."
54  (not (eql (%get-kernel-global 'ppc::altivec-present) 0)))
55
56#+ppc-target
57(defloadvar *altivec-available* (altivec-available-p)
58  "This variable is intitialized each time an OpenMCL session starts based
59on information provided by the lisp kernel. Its value is true if AltiVec is
60present and false otherwise. This variable shouldn't be set by user code.")
61
62       
63(defstatic *auto-flush-streams* ())
64(def-ccl-pointers *auto-flush-streams* () (setq *auto-flush-streams* nil))
65(defstatic *auto-flush-streams-lock* (make-lock))
66
67
68(defloadvar *batch-flag* (not (eql (%get-kernel-global 'batch-flag) 0)))
69(defloadvar *quiet-flag* nil)
70(defvar *terminal-input* ())
71(defvar *terminal-output* ())
72(defvar *stdin* ())
73(defvar *stdout* ())
74(defvar *stderr* ())
75
76
77(defun set-basic-stream-prototype (class)
78  (when (subtypep class 'basic-stream)
79    (setf (%class.prototype class) (or (%class.prototype class)
80                                       (allocate-basic-stream class)))
81    (dolist (subclass (class-direct-subclasses class))
82      (set-basic-stream-prototype subclass))))
83
84(set-basic-stream-prototype (find-class 'basic-stream))
85
86
87;;; The hard parts here have to do with setting up *TERMINAL-IO*.
88;;; Note that opening /dev/tty can fail, and that failure would
89;;; be reported as a negative return value from FD-OPEN.
90;;; It's pretty important that nothing signals an error here,
91;;; since there may not be any valid streams to write an error
92;;; message to.
93
94(defglobal *interactive-streams-initialized* nil)
95
96(defun initialize-interactive-streams ()
97  (let* ((encoding (lookup-character-encoding *terminal-character-encoding-name*))
98         (encoding-name (if encoding (character-encoding-name encoding))))
99    (setq *stdin* (make-fd-stream #-windows-target 0
100                                  #+windows-target (%ptr-to-int
101                                                    (#_GetStdHandle #$STD_INPUT_HANDLE))
102                                  :basic t
103                                  :sharing :lock
104                                  :direction :input
105                                  :interactive (not *batch-flag*)
106                                  :encoding encoding-name))
107    (setq *stdout* (make-fd-stream #-windows-target 1
108                                   #+windows-target (%ptr-to-int
109                                                     (#_GetStdHandle #$STD_OUTPUT_HANDLE))
110                                   :basic t :direction :output :sharing :lock :encoding encoding-name))
111
112    (setq *stderr* (make-fd-stream #-windows-target 2
113                                   #+windows-target (%ptr-to-int
114                                                     (#_GetStdHandle #$STD_ERROR_HANDLE))
115                    :basic t :direction :output :sharing :lock :encoding encoding-name))
116    (if *batch-flag*
117      (let* ((tty-fd
118               #-windows-target
119               (let* ((fd (fd-open "/dev/tty" #$O_RDWR)))
120                 (if (>= fd 0) fd)))
121             (can-use-tty #-windows-target (and tty-fd (eql (tcgetpgrp tty-fd) (getpid)))))
122        (if can-use-tty
123          (setq
124           *terminal-input* (make-fd-stream tty-fd
125                                            :basic t
126                                            :direction :input
127                                            :interactive t
128                                            :sharing :lock
129                                            :encoding encoding-name)
130           *terminal-output* (make-fd-stream tty-fd :basic t :direction :output :sharing :lock :encoding encoding-name)
131           *terminal-io* (make-echoing-two-way-stream
132                          *terminal-input* *terminal-output*))
133          (progn
134            (when tty-fd (fd-close tty-fd))
135            (setq *terminal-input* *stdin*
136                  *terminal-output* *stdout*
137                  *terminal-io* (make-two-way-stream
138                                 *terminal-input* *terminal-output*))))
139        (setq *standard-input* *stdin*
140              *standard-output* *stdout*))
141      (progn
142        (setq *terminal-input* *stdin*
143              *terminal-output* *stdout*
144              *terminal-io* (make-echoing-two-way-stream
145                             *terminal-input* *terminal-output*))
146        (setq *standard-input* (make-synonym-stream '*terminal-io*)
147              *standard-output* (make-synonym-stream '*terminal-io*))))
148    (setq *error-output* (if *batch-flag*
149                           (make-synonym-stream '*stderr*)
150                           (make-synonym-stream '*terminal-io*)))
151    (setq *query-io* (make-synonym-stream '*terminal-io*))
152    (setq *debug-io* *query-io*)
153    (setq *trace-output* *standard-output*)
154    (push *stdout* *auto-flush-streams*)
155    (setf (input-stream-shared-resource *terminal-input*)
156          (make-shared-resource "Shared Terminal Input")))
157  (setq *interactive-streams-initialized* t))
158
159(initialize-interactive-streams)
160
161(def-standard-initial-binding *standard-input*)
162(def-standard-initial-binding *standard-output*)
163(def-standard-initial-binding *error-output*)
164(def-standard-initial-binding *trace-output*)
165(def-standard-initial-binding *debug-io*)
166(def-standard-initial-binding *query-io*)
167
168
169(defun set-terminal-encoding (encoding-name)
170  (let* ((exformat (normalize-external-format t encoding-name)))
171    (setf (stream-external-format *stdin*) exformat
172          (stream-external-format *stdout*) exformat
173          (stream-external-format *stderr*) exformat
174          (stream-external-format *terminal-input*) exformat
175          (stream-external-format *terminal-output*) exformat))
176  encoding-name)
177
178(catch :toplevel
179    (macrolet ((l1-load-provide (module path)
180                 `(let* ((*package* *package*))
181                   (l1-load ,path)
182                   (provide ,module)))
183               (bin-load-provide (module path)
184                 `(let* ((*package* *package*))
185                   (bin-load ,path)
186                   (provide ,module))))
187      (bin-load-provide "SORT" "sort")
188      (bin-load-provide "NUMBERS" "numbers")
189     
190      (bin-load-provide "SUBPRIMS" "subprims")
191      #+ppc32-target
192      (bin-load-provide "PPC32-ARCH" "ppc32-arch") 
193      #+ppc64-target
194      (bin-load-provide "PPC64-ARCH" "ppc64-arch")
195      #+x86-target
196      (bin-load-provide "X8632-ARCH" "x8632-arch")
197      #+x86-target
198      (bin-load-provide "X8664-ARCH" "x8664-arch")
199      (bin-load-provide "VREG" "vreg")
200     
201      #+ppc-target
202      (bin-load-provide "PPC-ASM" "ppc-asm")
203     
204      (bin-load-provide "VINSN" "vinsn")
205      (bin-load-provide "REG" "reg")
206     
207      #+ppc-target
208      (bin-load-provide "PPC-LAP" "ppc-lap")
209      (bin-load-provide "BACKEND" "backend")
210     
211      #+ppc-target
212      (provide "PPC2")                  ; Lie, load the module manually
213
214      #+x86-target
215      (provide "X862")
216     
217      (l1-load-provide "NX" "nx")
218     
219      #+ppc-target
220      (bin-load "ppc2")
221
222      #+x86-target
223      (bin-load "x862")
224     
225      (bin-load-provide "LEVEL-2" "level-2")
226      (bin-load-provide "MACROS" "macros")
227      (bin-load-provide "SETF" "setf")
228      (bin-load-provide "SETF-RUNTIME" "setf-runtime")
229      (bin-load-provide "FORMAT" "format")
230      (bin-load-provide "STREAMS" "streams")
231      (bin-load-provide "OPTIMIZERS" "optimizers")     
232      (bin-load-provide "DEFSTRUCT-MACROS" "defstruct-macros")
233      (bin-load-provide "DEFSTRUCT-LDS" "defstruct-lds")
234      (bin-load-provide "NFCOMP" "nfcomp")
235      (bin-load-provide "BACKQUOTE" "backquote")
236      (bin-load-provide "BACKTRACE-LDS" "backtrace-lds")
237      (bin-load-provide "BACKTRACE" "backtrace")
238      (bin-load-provide "READ" "read")
239      (bin-load-provide "ARRAYS-FRY" "arrays-fry")
240      (bin-load-provide "APROPOS" "apropos")
241     
242      #+ppc-target
243      (progn
244        (bin-load-provide "PPC-DISASSEMBLE" "ppc-disassemble")
245        (bin-load-provide "PPC-LAPMACROS" "ppc-lapmacros"))
246
247      #+x86-target
248      (progn
249        (bin-load-provide "X86-DISASSEMBLE" "x86-disassemble")
250        (bin-load-provide "X86-LAPMACROS" "x86-lapmacros"))
251     
252
253      (bin-load-provide "FOREIGN-TYPES" "foreign-types")
254      (install-standard-foreign-types *host-ftd*)
255     
256      #+(and ppc32-target linux-target)
257      (bin-load-provide "FFI-LINUXPPC32" "ffi-linuxppc32")
258      #+(and ppc32-target darwin-target)
259      (bin-load-provide "FFI-DARWINPPC32" "ffi-darwinppc32")
260      #+(and ppc64-target darwin-target)
261      (bin-load-provide "FFI-DARWINPPC64" "ffi-darwinppc64")
262      #+(and ppc64-target linux-target)
263      (bin-load-provide "FFI-LINUXPPC64" "ffi-linuxppc64")
264      #+(and x8632-target darwin-target)
265      (bin-load-provide "FFI-DARWINX8632" "ffi-darwinx8632")
266      #+(and x8664-target linux-target) 
267      (bin-load-provide "FFI-LINUXX8664" "ffi-linuxx8664")
268      #+(and x8664-target darwin-target) 
269      (bin-load-provide "FFI-DARWINX8664" "ffi-darwinx8664")
270      #+(and x8664-target freebsd-target) 
271      (bin-load-provide "FFI-FREEBSDX8664" "ffi-freebsdx8664")
272      #+(and x8664-target solaris-target)
273      (bin-load-provide "FFI-SOLARISX8664" "ffi-solarisx8664")
274      #+win64-target
275      (bin-load-provide "FFI-WIN64" "ffi-win64")
276      #+linuxx8632-target
277      (bin-load-provide "FFI-LINUXX8632" "ffi-linuxx8632")
278      #+win32-target
279      (bin-load-provide "FFI-WIN32" "ffi-win32")
280     
281      (bin-load-provide "DB-IO" "db-io")
282
283      (canonicalize-foreign-type-ordinals *host-ftd*)
284     
285      (bin-load-provide "CASE-ERROR" "case-error")
286      (bin-load-provide "ENCAPSULATE" "encapsulate")
287      (bin-load-provide "METHOD-COMBINATION" "method-combination")
288      (bin-load-provide "MISC" "misc")
289      (bin-load-provide "PPRINT" "pprint")
290      (bin-load-provide "DUMPLISP" "dumplisp")
291      (bin-load-provide "PATHNAMES" "pathnames")
292      (bin-load-provide "TIME" "time")
293      (bin-load-provide "COMPILE-CCL" "compile-ccl")
294      (bin-load-provide "ARGLIST" "arglist")
295      (bin-load-provide "EDIT-CALLERS" "edit-callers")
296      (bin-load-provide "DESCRIBE" "describe")
297      (bin-load-provide "SOURCE-FILES" "source-files")
298      (bin-load-provide "MCL-COMPAT" "mcl-compat")
299      (require "LOOP")
300      (bin-load-provide "CCL-EXPORT-SYMS" "ccl-export-syms")
301      (l1-load-provide "VERSION" "version")
302      (require "LISPEQU") ; Shouldn't need this at load time ...
303      )
304    (setq *%fasload-verbose* nil)
305    )
306)
307
308
309
310
311
312
Note: See TracBrowser for help on using the repository browser.