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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5