/[cmucl]/src/code/lispinit.lisp
ViewVC logotype

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29 - (hide annotations)
Tue Feb 18 02:03:49 1992 UTC (22 years, 2 months ago) by wlott
Branch: MAIN
Changes since 1.28: +4 -1 lines
Added a call to PROCLAIM-INIT, so that the *DEFAULT-COOKIE* and *DEFAULT-
INTERFACE-COOKIE* start up with known values instead of whatever the last
cold loaded file left them as.
1 ram 1.1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.20 ;;; This code was written as part of the CMU Common Lisp project at
5     ;;; Carnegie Mellon University, and has been placed in the public domain.
6     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8     ;;;
9     (ext:file-comment
10 wlott 1.29 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/lispinit.lisp,v 1.29 1992/02/18 02:03:49 wlott Exp $")
11 ram 1.20 ;;;
12 ram 1.1 ;;; **********************************************************************
13 wlott 1.10 ;;;
14 wlott 1.14 ;;; Initialization stuff for CMU Common Lisp, plus some other random functions
15     ;;; that we don't have any better place for.
16     ;;;
17 ram 1.1 ;;; Written by Skef Wholey and Rob MacLachlan.
18     ;;;
19     (in-package "LISP" :use '("SYSTEM" "DEBUG"))
20    
21     (export '(most-positive-fixnum most-negative-fixnum sleep
22     ++ +++ ** *** // ///))
23    
24    
25 ram 1.4 (in-package "SYSTEM" :nicknames '("SYS"))
26 ram 1.1 (export '(add-port-death-handler remove-port-death-handler sap-int
27     int-sap sap-ref-8 sap-ref-16 sap-ref-32 without-gcing
28     *in-the-compiler* compiler-version *pornography-of-death*
29     *port-receive-rights-handlers* *port-ownership-rights-handlers*
30     without-interrupts with-reply-port map-port add-port-object
31     remove-port-object make-object-set object-set-operation
32     server-message *xwindow-table* map-xwindow add-xwindow-object
33     remove-xwindow-object server-event coerce-to-key-event
34     coerce-to-motion-event coerce-to-expose-event
35     coerece-to-exposecopy-event coerce-to-focuschange-event server
36 ram 1.8 *task-self* *task-data* *task-notify* with-interrupts
37     with-enabled-interrupts enable-interrupt ignore-interrupt
38 wlott 1.25 default-interrupt scrub-control-stack))
39 ram 1.1
40     (in-package "EXTENSIONS")
41 wlott 1.10 (export '(quit *prompt* save-lisp gc-on gc-off *clx-server-displays*))
42 ram 1.1
43     (in-package "LISP")
44    
45     ;;; Make the error system enable interrupts.
46    
47 wlott 1.10 (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum
48 ram 1.1 "The fixnum closest in value to positive infinity.")
49    
50 wlott 1.10 (defconstant most-negative-fixnum #.vm:target-most-negative-fixnum
51 ram 1.1 "The fixnum closest in value to negative infinity.")
52    
53    
54     ;;; Random information:
55    
56 wlott 1.10 (defvar *lisp-implementation-version* "4.0(?)")
57 ram 1.1
58 wlott 1.10 (defvar *in-the-compiler* nil
59 ram 1.1 "Bound to T while running code inside the compiler. Macros may test this to
60     see where they are being expanded.")
61    
62    
63 ram 1.5 ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...
64     (proclaim '(special *gc-inhibit* *already-maybe-gcing*
65 ram 1.6 *need-to-collect-garbage* *gc-verbose*
66 ram 1.7 *before-gc-hooks* *after-gc-hooks*
67 wlott 1.28 unix::*interrupts-enabled*
68     unix::*interrupt-pending*
69 ram 1.7 c::*type-system-initialized*))
70 ram 1.1
71    
72 wlott 1.10 ;;;; Random magic specials.
73 ram 1.1
74    
75 wlott 1.10 ;;; These are filled in by Genesis.
76 ram 1.1
77 wlott 1.10 (defvar *current-catch-block*)
78     (defvar *current-unwind-block*)
79     (defvar *free-interrupt-context-index*)
80 ram 1.1
81    
82 wlott 1.10
83     ;;;; Global ports:
84    
85 wlott 1.16 (defvar *task-self* nil
86 wlott 1.10 "Port that refers to the current task.")
87 ram 1.1
88 wlott 1.16 (defvar *task-data* nil
89 wlott 1.10 "Port used to receive data for the current task.")
90 ram 1.1
91    
92    
93     ;;;; Reply port allocation.
94     ;;;
95     ;;; We maintain a global stack of reply ports which is shared among
96     ;;; all matchmaker interfaces, and could be used by other people as well.
97     ;;;
98 wlott 1.10
99     #| More stuff that will probably be drastically different.
100    
101 ram 1.1 ;;; The stack is represented by a vector, and a pointer to the first
102     ;;; free port. The stack grows upward. There is always at least one
103     ;;; NIL entry in the stack after the last allocated port.
104     ;;;
105     (defvar *reply-port-stack* (make-array 16)) ; Vector of reply ports.
106     (defvar *reply-port-pointer* 0) ; Index of first free port.
107     (defvar *reply-port-depth* 0) ; Dynamic depth in With-Reply-Port forms.
108    
109     ;;; We use this as the reply port when allocating or deallocating reply
110     ;;; ports to get around potentially nasty interactions. Interrupts
111     ;;; are always off when we are doing this, so we don't have to have
112     ;;; more than one of these, or worry about unwinding.
113     (defvar *allocate-reply-port* (mach:mach-task_data))
114    
115     ;;; Reset-Reply-Port-Stack -- Internal
116     ;;;
117     ;;; This is a before-save initialization which Nil's out the reply
118     ;;; port stack and sets *allocate-reply-port* back to DataPort so that
119     ;;; things initialize right at OS-Init time.
120     ;;;
121     (defun reset-reply-port-stack ()
122 wlott 1.12 (setf *reply-port-pointer* 0 *reply-port-depth* 0)
123 ram 1.1 (fill (the simple-vector *reply-port-stack*) nil)
124 wlott 1.12 (setf *allocate-reply-port* (mach:mach-task_data)))
125 ram 1.1 (pushnew 'reset-reply-port-stack *before-save-initializations*)
126    
127     ;;; Allocate-New-Reply-Ports -- Internal
128     ;;;
129     ;;; If we run out of reply ports, we allocate another one, possibly
130     ;;; growing the stack.
131     ;;;
132     (defun allocate-new-reply-ports ()
133     (let* ((stack *reply-port-stack*)
134     (pointer *reply-port-pointer*)
135     (len (length stack)))
136     (declare (simple-vector stack) (fixnum len))
137     (when (eql pointer (1- len))
138     (let ((new (make-array (* len 2))))
139     (replace new stack :end1 len :end2 len)
140 wlott 1.12 (setf stack new *reply-port-stack* new)))
141 ram 1.1 (setf (svref stack pointer) *allocate-reply-port*)
142     (let ((port (gr-call* mach:port_allocate (mach:mach-task_self))))
143     (gr-call mach:port_disable (mach:mach-task_self) port)
144     ;;
145     ;; Nil out the allocate reply port so it isn't used for mundane purposes.
146     (setf (svref stack pointer) nil)
147     (setf (svref stack (1- pointer)) port)
148     port)))
149    
150     ;;; Reallocate-Reply-Ports -- Internal
151     ;;;
152     ;;; This function is called when With-Reply-Port finds the stack pointer
153     ;;; to be other than what it expected when it finishes. Reallocates all
154     ;;; of the ports on the stack from Start to *reply-port-pointer*. We
155     ;;; stick the *allocate-reply-port* out at *reply-port-pointer*, and
156     ;;; bind *reply-port-depth*, so that the allocation functions are happy.
157     ;;;
158     (defun reallocate-reply-ports (start)
159     (let* ((pointer *reply-port-pointer*)
160     (*reply-port-depth* pointer)
161     (stack *reply-port-stack*)
162     (save-port (svref stack pointer)))
163     (when (> start pointer)
164     (error "More ports in use than allocated???"))
165     (setf (svref stack pointer) *allocate-reply-port*)
166     (do ((i start (1+ i)))
167     ((= i pointer)
168     (setf (svref stack pointer) save-port))
169     (let ((port (svref stack i)))
170     (gr-call mach:port_deallocate *task-self* port)
171     (setf (svref stack i)
172     (gr-call* mach:port_allocate *task-self*))))))
173 wlott 1.10 |#
174 ram 1.1
175    
176     ;;;; Server stuff:
177     ;;;
178     ;;; There is a fair amount of stuff to support Matchmaker RPC servers
179     ;;; and asynchonous message service. RPC message service needs to be
180     ;;; centralized since a server must receive on all ports, and there is
181     ;;; no way for a particular server to know about all other servers
182     ;;; in the same lisp.
183     ;;;
184     ;;; The idea is that you receive the message, and then dispatch off
185     ;;; of the port received on and the message ID received. Ports correspond
186     ;;; to objects that the server manages. Message ID's correspond to the
187     ;;; operations on the objects. Objects are grouped into object sets, which
188     ;;; are sets of objects having the same operations defined.
189     ;;;
190     ;;; The same mechanism is used for handling asynchronous messages.
191     ;;;
192    
193     ;;; The current implementation uses standard eq[l] hashtables for both
194     ;;; levels of dispatching. Special purpose data structures would be more
195     ;;; efficient, but the ~1ms overhead will probably be lost in the noise.
196    
197     ;;;
198     ;;; Hashtable from ports to objects. Each entry is a cons (object . set).
199     ;;;
200     (defvar *port-table* (make-hash-table :test #'eql))
201    
202     ;;; Hashtable from windows to objects. Each entry is a cons (object . set).
203     ;;;
204     (defvar *xwindow-table* (make-hash-table :test #'eql))
205    
206    
207     (defstruct (object-set
208     (:constructor make-object-set
209     (name &optional
210     (default-handler #'default-default-handler)))
211     (:print-function
212     (lambda (s stream d)
213     (declare (ignore d))
214     (format stream "#<Object Set ~S>" (object-set-name s)))))
215     name ; Name, for descriptive purposes.
216     (table (make-hash-table :test #'eq)) ; Message-ID or xevent-type --> handler fun.
217     default-handler)
218    
219     (setf (documentation 'make-object-set 'function)
220     "Make an object set for use by a RPC/xevent server. Name is for
221     descriptive purposes only.")
222    
223 ram 1.5 ;;; Default-Default-Handler -- Internal
224     ;;;
225     ;;; If no such operation defined, signal an error.
226     ;;;
227     (defun default-default-handler (object)
228 wlott 1.11 #+nil
229 ram 1.5 (alien-bind ((msg (server-message-msg server-message)))
230     (error "No operation for ID ~D on ~S in ~S."
231     (alien-access (mach:msg-id (alien-value msg))) object
232     (car (gethash (alien-access (mach:msg-localport (alien-value msg)))
233 wlott 1.11 *port-table*))))
234     (error "You lose, object: ~S" object))
235 ram 1.1
236 ram 1.5
237 ram 1.1 ;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and
238     ;;; object set mapped to by a xwindow or port in *xwindow-table* or
239     ;;; *port-table*.
240     ;;;
241     (macrolet ((defmapper (name table)
242     `(defun ,(intern (concatenate 'simple-string
243     "MAP-" (symbol-name name)))
244     (,name)
245     ,(format nil "Return as multiple values the object and ~
246     object-set mapped to by ~A."
247     (string-downcase (symbol-name name)))
248     (let ((temp (gethash ,name ,table)))
249     (if temp
250     (values (car temp) (cdr temp))
251     (values nil nil))))))
252     (defmapper port *port-table*)
253     (defmapper xwindow *xwindow-table*))
254    
255    
256     ;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair
257     ;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*.
258     ;;;
259     (macrolet ((def-add-object (name table)
260     `(defun ,(intern (concatenate 'simple-string
261     "ADD-" (symbol-name name)
262     "-OBJECT"))
263     (,name object object-set)
264     ,(format nil "Add a new ~A/object/object-set association."
265     (string-downcase (symbol-name name)))
266     (check-type object-set object-set)
267     (setf (gethash ,name ,table) (cons object object-set))
268     object)))
269     (def-add-object port *port-table*)
270     (def-add-object xwindow *xwindow-table*))
271    
272    
273     ;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and
274     ;;; its associated object/object-set pair from *port-table* or *xwindow-table*.
275     ;;;
276     (macrolet ((def-remove-object (name table)
277     `(defun ,(intern (concatenate 'simple-string
278     "REMOVE-" (symbol-name name)
279     "-OBJECT"))
280     (,name)
281     ,(format nil
282     "Remove ~A and its associated object/object-set pair."
283     (string-downcase (symbol-name name)))
284     (remhash ,name ,table))))
285     (def-remove-object port *port-table*)
286     (def-remove-object xwindow *xwindow-table*))
287    
288    
289     ;;; Object-Set-Operation -- Public
290     ;;;
291     ;;; Look up the handler function for a given message ID.
292     ;;;
293     (defun object-set-operation (object-set message-id)
294     "Return the handler function in Object-Set for the operation specified by
295     Message-ID, if none, NIL is returned. The handler function is passed
296     the object. The received message is in server-Message."
297     (check-type object-set object-set)
298     (check-type message-id fixnum)
299     (values (gethash message-id (object-set-table object-set))))
300    
301     ;;; %Set-Object-Set-Operation -- Internal
302     ;;;
303     ;;; The setf inverse for Object-Set-Operation.
304     ;;;
305     (defun %set-object-set-operation (object-set message-id new-value)
306     (check-type object-set object-set)
307     (check-type message-id fixnum)
308     (setf (gethash message-id (object-set-table object-set)) new-value))
309     ;;;
310     (defsetf object-set-operation %set-object-set-operation
311     "Sets the handler function for an object set operation.")
312 wlott 1.10
313    
314 ram 1.1
315     ;;;; Emergency Message Handling:
316     ;;;
317     ;;; We use the same mechanism for asynchronous messages as is used for
318     ;;; normal server messages. The only tricky part is that we don't want
319     ;;; some random server function being called when we really want to
320     ;;; receive an emergency message, so we can't receive on all ports.
321     ;;; Instead, we use MessagesWaiting to find the ports with emergency
322     ;;; messages.
323    
324 wlott 1.10 #| still more noise that will be different.
325    
326 ram 1.1 (defalien waiting-ports nil (long-words 128))
327    
328     ;;; Service-Emergency-Message-Interrupt -- Internal
329     ;;;
330     ;;; This is a lot like the server function, but we only receive on
331     ;;; ports with one emergency message. We only receive one message because
332     ;;; the handler function might have caused any other messages to be received.
333     ;;; When we re-enable interrupts, if any emergency messages are left, we
334     ;;; should be interrupted again.
335     ;;;
336     (defun service-emergency-message-interrupt ()
337     (grab-message-loop))
338    
339     ;;;
340     ;;; This object set is used for DataPort, which is the port various magical
341     ;;; message from the kernel are received on...
342     (defvar *kernel-messages* (make-object-set "Kernel Messages"))
343    
344     (compiler-let ((*alien-eval-when* '(compile eval)))
345     (defrecord port-death-msg
346     (msg mach:msg #.(record-size 'mach:msg))
347     (ex-port-tt pad (long-words 1))
348     (ex-port (signed-byte 32) (long-words 1)))
349    
350     (defoperator (server-message-port-death-msg port-death-msg)
351     ((msg server-message))
352     `(alien-index (alien-value ,msg) 0 (record-size 'port-death-msg)))
353     ); Compiler-Let
354    
355    
356     ;;; *Port-Death-Handlers* is an EQ hash table of lists of functions that are
357     ;;; called upon port death. If a port dies that is not in the table, we print
358     ;;; out a message on *Trace-Output* describing its death. If
359     ;;; *Pornography-Of-Death* is true, we don't even print that message.
360    
361     (defvar *port-death-handlers* (make-hash-table :test #'eql)
362     "Don't use this --- use Add-Port-Death-Handler instead.")
363    
364     ;;; Add-Port-Death-Handler, Remove-Port-Death-Handler -- Public
365     ;;;
366     (defun add-port-death-handler (port function)
367     "Make Function a handler for port death on Port. When the port dies,
368     Function is called with the port and an argument. See also
369     Remove-Port-Death-Handler."
370     (pushnew function (gethash port *port-death-handlers*))
371     nil)
372     ;;;
373     (defun remove-port-death-handler (port function)
374     "Undoes the effect of Add-Port-Death-Handler."
375     (setf (gethash port *port-death-handlers*)
376     (delete function (gethash port *port-death-handlers*)))
377     nil)
378    
379     (setf (object-set-operation *kernel-messages* mach:notify-port-deleted)
380     #'(lambda (obj)
381     (declare (ignore obj))
382     (let* ((ex-port (alien-access
383     (port-death-msg-ex-port
384     (server-message-port-death-msg server-message))))
385     (handlers (gethash ex-port *port-death-handlers*)))
386     (remhash ex-port *port-table*)
387     (remhash ex-port *port-death-handlers*)
388     (if (null handlers)
389     (handle-unclaimed-port-death ex-port)
390     (dolist (fun handlers) (funcall fun ex-port))))
391     mach:kern-success))
392    
393     (defvar *pornography-of-death* t
394     "If true, nothing is said about port deaths.")
395    
396     (defun handle-unclaimed-port-death (port)
397     (unless *pornography-of-death*
398     (format *trace-output* "~&[Port ~S just bit the dust.]~%" port)))
399    
400     ;;; Port receive and ownership rights messages are handled simlarly, but
401     ;;; by default we deallocate the port to make sure it's really dead. This
402     ;;; gets around problems with ports being exhausted because some servers
403     ;;; don't really nuke the port when the deallocate the object.
404     ;;;
405    
406     (defvar *port-receive-rights-handlers* (make-hash-table :test #'eql)
407     "This is a hashtable from ports to functions. The function is called with
408     the port as its argument when a port receive rights message for that port
409     is received from the kernel.")
410    
411     (defvar *port-ownership-rights-handlers* (make-hash-table :test #'eql)
412     "This is a hashtable from ports to functions. The function is called with
413     the port as its argument when a port ownership rights message for that port
414     is received from the kernel.")
415    
416     (setf (object-set-operation *kernel-messages* mach:notify-receive-rights)
417     #'(lambda (obj)
418     (declare (ignore obj))
419     (let ((ex-port (alien-access
420     (port-death-msg-ex-port
421     (server-message-port-death-msg server-message)))))
422     (funcall (gethash ex-port *port-receive-rights-handlers*
423     #'handle-unclaimed-port-rights)
424     ex-port))
425     mach:kern-success))
426    
427     (setf (object-set-operation *kernel-messages* mach:notify-ownership-rights)
428     #'(lambda (obj)
429     (declare (ignore obj))
430     (let ((ex-port (alien-access
431     (port-death-msg-ex-port
432     (server-message-port-death-msg server-message)))))
433     (funcall (gethash ex-port *port-ownership-rights-handlers*
434     #'handle-unclaimed-port-rights)
435     ex-port))
436     mach:kern-success))
437    
438     (defun handle-unclaimed-port-rights (port)
439     (unless *pornography-of-death*
440     (format *trace-output* "~&[Rights received for port ~D, deallocating it.]~%"
441     port))
442     (mach:port_deallocate *task-self* port)
443     (remhash port *port-receive-rights-handlers*)
444     (remhash port *port-ownership-rights-handlers*)
445     (remhash port *port-table*))
446    
447     (add-port-object *task-data* nil *kernel-messages*)
448    
449     ;;; Clear-Port-Tables -- Internal
450     ;;;
451     ;;; A before-save initialization which clears all of the port hashtables.
452     ;;;
453     (defun clear-port-tables ()
454     (clrhash *port-table*)
455     (clrhash *port-death-handlers*)
456     (clrhash *port-receive-rights-handlers*)
457     (clrhash *port-ownership-rights-handlers*))
458    
459     (pushnew 'clear-port-tables *before-save-initializations*)
460    
461 wlott 1.10 |#
462    
463    
464 ram 1.1
465     ;;; %Initial-Function is called when a cold system starts up. First we zoom
466     ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
467     ;;; at "load time." Then we initialize the various subsystems and call the
468     ;;; read-eval-print loop. The top-level Read-Eval-Print loop is executed until
469     ;;; someone (most likely the Quit function) throws to the tag
470     ;;; %End-Of-The-World. We quit this way so that all outstanding cleanup forms
471     ;;; in Unwind-Protects will get executed.
472    
473 wlott 1.26 (proclaim '(special *lisp-initialization-functions*
474     *load-time-values*))
475 ram 1.1
476     (eval-when (compile)
477     (defmacro print-and-call (name)
478     `(progn
479 wlott 1.10 (%primitive print ,(symbol-name name))
480 ram 1.1 (,name))))
481    
482     (defun %initial-function ()
483     "Gives the world a shove and hopes it spins."
484 wlott 1.12 (setf *already-maybe-gcing* t)
485 ram 1.2 (setf *gc-inhibit* t)
486 ram 1.1 (setf *need-to-collect-garbage* nil)
487 wlott 1.12 (setf *gc-verbose* t)
488     (setf *before-gc-hooks* nil)
489     (setf *after-gc-hooks* nil)
490 wlott 1.28 (setf unix::*interrupts-enabled* t)
491     (setf unix::*interrupt-pending* nil)
492 wlott 1.12 (setf c::*type-system-initialized* nil)
493 ram 1.1 (%primitive print "In initial-function, and running.")
494    
495     ;; Many top-level forms call INFO, (SETF INFO).
496     (print-and-call c::globaldb-init)
497    
498     ;; Some of the random top-level forms call Make-Array, which calls Subtypep...
499 wlott 1.10 (print-and-call type-init)
500 ram 1.1
501 wlott 1.26 (let ((funs (nreverse *lisp-initialization-functions*)))
502     (%primitive print "Calling top-level forms.")
503     (dolist (fun funs)
504     (typecase fun
505     (function
506     (funcall fun))
507     (cons
508     (case (car fun)
509     (:load-time-value
510     (setf (svref *load-time-values* (third fun))
511     (funcall (second fun))))
512     (:load-time-value-fixup
513     (setf (sap-ref-32 (second fun) 0)
514     (get-lisp-obj-address
515     (svref *load-time-values* (third fun)))))
516     (t
517     (%primitive print
518     "Bogus fixup in *lisp-initialization-functions*")
519     (%halt))))
520     (t
521     (%primitive print
522     "Bogus function in *lisp-initialization-functions*")
523     (%halt)))))
524 ram 1.1 (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
525 wlott 1.26 (makunbound '*load-time-values*)
526 ram 1.1
527 wlott 1.10 ;; Only do this after top level forms have run, 'cause thats where
528     ;; deftypes are.
529 wlott 1.12 (setf c::*type-system-initialized* t)
530 wlott 1.10
531 ram 1.1 (print-and-call os-init)
532     (print-and-call filesys-init)
533    
534     (print-and-call reader-init)
535     (print-and-call backq-init)
536     (print-and-call sharp-init)
537     ;; After the various reader subsystems have done their thing to the standard
538     ;; readtable, copy it to *readtable*.
539 wlott 1.12 (setf *readtable* (copy-readtable std-lisp-readtable))
540 ram 1.1
541     (print-and-call stream-init)
542 wlott 1.10 (print-and-call loader-init)
543 ram 1.1 (print-and-call package-init)
544 wlott 1.16 (print-and-call kernel::signal-init)
545 wlott 1.28 (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
546 ram 1.17 (set-floating-point-modes :traps '(:overflow :underflow :invalid
547     :divide-by-zero))
548 wlott 1.29 ;; This is necessary because some of the initial top level forms might
549     ;; have changed the compliation policy in strange ways.
550     (print-and-call c::proclaim-init)
551 ram 1.1
552 wlott 1.10 (%primitive print "Done initializing.")
553    
554 wlott 1.12 (setf *already-maybe-gcing* nil)
555 ram 1.1 (terpri)
556     (princ "CMU Common Lisp kernel core image ")
557     (princ (lisp-implementation-version))
558     (princ ".")
559     (terpri)
560     (princ "[You are in the LISP package.]")
561     (terpri)
562     (catch '%end-of-the-world
563     (loop
564     (%top-level)
565     (write-line "You're certainly a clever child.")))
566 wlott 1.28 (unix:unix-exit 0))
567 ram 1.1
568    
569     ;;;; Initialization functions:
570    
571     ;;; Reinit is called to reinitialize the world when a saved core image
572     ;;; is resumed.
573     (defvar *task-notify* NIL)
574    
575     (defun reinit ()
576     (without-interrupts
577 wlott 1.12 (setf *already-maybe-gcing* t)
578 wlott 1.14 (os-init)
579 wlott 1.16 (stream-reinit)
580 wlott 1.14 (kernel::signal-init)
581 wlott 1.28 (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
582 wlott 1.12 (setf *already-maybe-gcing* nil))
583 ram 1.18 (set-floating-point-modes :traps '(:overflow :underflow :invalid
584     :divide-by-zero))
585 wlott 1.10 #+nil
586 ram 1.1 (mach:port_enable (mach:mach-task_self) *task-notify*)
587 wlott 1.10 #+nil
588     (add-port-object *task-notify* nil *kernel-messages*))
589 ram 1.1
590     ;;; OS-Init initializes our operating-system interface. It sets the values
591     ;;; of the global port variables to what they should be and calls the functions
592     ;;; that set up the argument blocks for the server interfaces.
593    
594     (defun os-init ()
595 wlott 1.12 (setf *task-self* (mach:mach-task_self))
596     (setf *task-data* (mach:mach-task_data))
597     (setf *task-notify* (mach:mach-task_notify)))
598 ram 1.1
599    
600     ;;;; Miscellaneous external functions:
601    
602     ;;; Quit gets us out, one way or another.
603    
604     (defun quit (&optional recklessly-p)
605     "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
606     non-Nil."
607     (if recklessly-p
608 wlott 1.28 (unix:unix-exit 0)
609 ram 1.1 (throw '%end-of-the-world nil)))
610    
611    
612     (defun sleep (n)
613     "This function causes execution to be suspended for N seconds. N may
614     be any non-negative, non-complex number."
615 wlott 1.13 (when (or (not (realp n))
616     (minusp n))
617     (error "Invalid argument to SLEEP: ~S.~%~
618     Must be a non-negative, non-complex number."
619     n))
620     (multiple-value-bind (sec usec)
621     (if (integerp n)
622     (values n 0)
623     (values (truncate n)
624     (truncate (* n 1000000))))
625 wlott 1.28 (unix:unix-select 0 0 0 0 sec usec))
626 ram 1.1 nil)
627    
628    
629 wlott 1.25 ;;;; SCRUB-CONTROL-STACK
630    
631    
632     (defconstant words-per-scrub-unit 512)
633    
634     (defun scrub-control-stack ()
635     "Zero the unused portion of the control stack so that old objects are not
636     kept alive because of uninitialized stack variables."
637     (declare (optimize (speed 3) (safety 0))
638     (values (unsigned-byte 20)))
639     (labels
640     ((scrub (ptr offset count)
641     (declare (type system-area-pointer ptr)
642     (type (unsigned-byte 16) offset)
643     (type (unsigned-byte 20) count)
644     (values (unsigned-byte 20)))
645     (cond ((= offset words-per-scrub-unit)
646     (look (sap+ ptr (* words-per-scrub-unit vm:word-bytes))
647     0
648     count))
649     (t
650     (setf (sap-ref-32 ptr offset) 0)
651     (scrub ptr (1+ offset) count))))
652     (look (ptr offset count)
653     (declare (type system-area-pointer ptr)
654     (type (unsigned-byte 16) offset)
655     (type (unsigned-byte 20) count)
656     (values (unsigned-byte 20)))
657     (cond ((= offset words-per-scrub-unit)
658     count)
659     ((zerop (sap-ref-32 ptr offset))
660     (look ptr (1+ offset) count))
661     (t
662     (scrub ptr offset (1+ count))))))
663     (let* ((csp (sap-int (c::control-stack-pointer-sap)))
664     (initial-offset
665     (logand csp (1- (* words-per-scrub-unit vm:word-bytes)))))
666     (declare (type (unsigned-byte 32) csp))
667     (scrub (int-sap (- csp initial-offset))
668     (floor initial-offset vm:word-bytes)
669     0))))
670    
671    
672    
673 ram 1.1 ;;;; TOP-LEVEL loop.
674    
675     (defvar / nil
676     "Holds a list of all the values returned by the most recent top-level EVAL.")
677     (defvar // nil "Gets the previous value of / when a new value is computed.")
678     (defvar /// nil "Gets the previous value of // when a new value is computed.")
679     (defvar * nil "Holds the value of the most recent top-level EVAL.")
680     (defvar ** nil "Gets the previous value of * when a new value is computed.")
681     (defvar *** nil "Gets the previous value of ** when a new value is computed.")
682     (defvar + nil "Holds the value of the most recent top-level READ.")
683     (defvar ++ nil "Gets the previous value of + when a new value is read.")
684     (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
685     (defvar - nil "Holds the form curently being evaluated.")
686 ram 1.3 (defvar *prompt* "* "
687     "The top-level prompt string. This also may be a function of no arguments
688     that returns a simple-string.")
689 ram 1.1 (defvar *in-top-level-catcher* nil
690     "True if we are within the Top-Level-Catcher. This is used by interrupt
691     handlers to see whether it is o.k. to throw.")
692    
693 ram 1.3 (defun interactive-eval (form)
694     "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
695     +, ///, //, /, and -."
696 ram 1.21 (setf - form)
697 ram 1.3 (let ((results (multiple-value-list (eval form))))
698     (setf /// //
699     // /
700     / results
701     *** **
702     ** *
703     * (car results)))
704 ram 1.21 (setf +++ ++
705     ++ +
706     + -)
707 ram 1.3 (unless (boundp '*)
708     ;; The bogon returned an unbound marker.
709     (setf * nil)
710     (cerror "Go on with * set to NIL."
711     "EVAL returned an unbound marker."))
712     (values-list /))
713 ram 1.21
714 ram 1.3
715     (defconstant eofs-before-quit 10)
716    
717 ram 1.1 (defun %top-level ()
718     "Top-level READ-EVAL-PRINT loop. Do not call this."
719 ram 1.3 (let ((* nil) (** nil) (*** nil)
720 ram 1.1 (- nil) (+ nil) (++ nil) (+++ nil)
721 ram 1.3 (/// nil) (// nil) (/ nil)
722     (magic-eof-cookie (cons :eof nil))
723     (number-of-eofs 0))
724 ram 1.1 (loop
725 wlott 1.25 (with-simple-restart (abort "Return to Top-Level.")
726     (catch 'top-level-catcher
727 wlott 1.28 (unix:unix-sigsetmask 0)
728 wlott 1.25 (let ((*in-top-level-catcher* t))
729     (loop
730     (scrub-control-stack)
731     (fresh-line)
732     (princ (if (functionp *prompt*)
733     (funcall *prompt*)
734     *prompt*))
735     (force-output)
736     (let ((form (read *standard-input* nil magic-eof-cookie)))
737     (cond ((not (eq form magic-eof-cookie))
738     (let ((results
739     (multiple-value-list (interactive-eval form))))
740     (dolist (result results)
741     (fresh-line)
742     (prin1 result)))
743     (setf number-of-eofs 0))
744     ((eql (incf number-of-eofs) 1)
745     (let ((stream (make-synonym-stream '*terminal-io*)))
746     (setf *standard-input* stream)
747     (setf *standard-output* stream)
748     (format t "~&Received EOF on *standard-input*, ~
749     switching to *terminal-io*.~%")))
750     ((> number-of-eofs eofs-before-quit)
751     (format t "~&Received more than ~D EOFs; Aborting.~%"
752     eofs-before-quit)
753     (quit))
754     (t
755     (format t "~&Received EOF.~%")))))))))))
756 ram 1.1
757    
758 ram 1.3
759 ram 1.1 ;;; %Halt -- Interface
760     ;;;
761     ;;; A convenient way to get into the assembly level debugger.
762     ;;;
763     (defun %halt ()
764     (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5