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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5