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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (hide annotations)
Fri Feb 23 11:56:30 1990 UTC (24 years, 1 month ago) by ram
Branch: MAIN
Changes since 1.3: +25 -200 lines
.../systems-work/code/lispinit.lisp, 18-Jan-90 22:52:28, Edit by Chiles.
  Modified calls to MACH:SIGMASK for new stuff in syscall.

.../systems-work/code/lispinit.lisp, 11-Jan-90 18:21:48, Edit by Wlott.
  Changed the name of SYSTEM:SERVER to SYSTEM:SERVE-EVENT and moved it into
  serve-event.lisp.

.../systems-work/code/lispinit.lisp, 07-Nov-89 17:26:47, Edit by Chiles.
  Added "SYS" nickname for "SYSTEM" package.
1 ram 1.1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the Spice 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 Spice Lisp, please contact
7     ;;; Scott Fahlman (FAHLMAN@CMUC).
8     ;;; **********************************************************************
9     ;;;
10     ;;; Initialization and low-level interrupt support for the Spice Lisp system.
11     ;;; Written by Skef Wholey and Rob MacLachlan.
12     ;;;
13     (in-package "LISP" :use '("SYSTEM" "DEBUG"))
14    
15     (in-package "XLIB")
16    
17     (in-package "LISP")
18    
19     (export '(most-positive-fixnum most-negative-fixnum sleep
20     ++ +++ ** *** // ///))
21    
22    
23 ram 1.4 (in-package "SYSTEM" :nicknames '("SYS"))
24 ram 1.1 (export '(add-port-death-handler remove-port-death-handler sap-int
25     int-sap sap-ref-8 sap-ref-16 sap-ref-32 without-gcing
26     *in-the-compiler* compiler-version *pornography-of-death*
27     *port-receive-rights-handlers* *port-ownership-rights-handlers*
28     without-interrupts with-reply-port map-port add-port-object
29     remove-port-object make-object-set object-set-operation
30     server-message *xwindow-table* map-xwindow add-xwindow-object
31     remove-xwindow-object server-event coerce-to-key-event
32     coerce-to-motion-event coerce-to-expose-event
33     coerece-to-exposecopy-event coerce-to-focuschange-event server
34     *nameserverport* *usertypescript* *userwindow* *typescriptport*
35     *task-self* *task-data* *task-notify* *file-input-handlers*
36     with-interrupts with-enabled-interrupts enable-interrupt
37 ram 1.4 ignore-interrupt default-interrupt))
38 ram 1.1
39     (in-package "EXTENSIONS")
40     (export '(quit *prompt* print-herald save-lisp gc-on gc-off
41     *before-save-initializations* *after-save-initializations*
42 ram 1.4 *editor-lisp-p* *clx-server-displays*))
43 ram 1.1
44     (in-package "LISP")
45    
46     ;;; These go here so that we can refer to them in top-level forms.
47    
48     (defvar *before-save-initializations* ()
49     "This is a list of functions which are called before creating a saved core
50     image. These functions are executed in the child process which has no ports,
51     so they cannot do anything that tries to talk to the outside world.")
52    
53     (defvar *after-save-initializations* ()
54     "This is a list of functions which are called when a saved core image starts
55     up. The system itself should be initialized at this point, but applications
56     might not be.")
57    
58     ;;; Make the error system enable interrupts.
59    
60     (defconstant most-positive-fixnum 134217727
61     "The fixnum closest in value to positive infinity.")
62    
63     (defconstant most-negative-fixnum -134217728
64     "The fixnum closest in value to negative infinity.")
65    
66    
67     ;;; Random information:
68    
69     (defvar compiler-version "???")
70 ram 1.3 (defvar *lisp-implementation-version* "3.0(?)")
71 ram 1.1
72     (defvar *in-the-compiler* ()
73     "Bound to T while running code inside the compiler. Macros may test this to
74     see where they are being expanded.")
75    
76     (defparameter %fasl-code-format 6)
77    
78    
79     ;;;; Global ports:
80    
81     (defvar *task-self* 1
82     "Port that refers to the current task.")
83    
84     (defvar *task-data* 2
85     "Port used to receive data for the current task.")
86    
87     (defvar *nameserverport* ()
88     "Port to the name server.")
89    
90    
91     ;;; GC stuff.
92    
93     (defvar *gc-inhibit* nil) ; Inhibits GC's.
94    
95     (defvar *already-maybe-gcing* nil) ; Inhibits recursive GC's.
96    
97     (defvar *need-to-collect-garbage* nil
98     "*Need-to-collect-garbage* is set to T when GC is disabled, but the system
99     needs to do a GC. When GC is enabled again, the GC is done then.")
100    
101    
102     ;;; Software interrupt stuff.
103    
104     (defvar *in-server* NIL
105     "*In-server* is set to T when the SIGMSG interrupt has been enabled
106     in Server.")
107    
108     (defvar server-unique-object (cons 1 2))
109    
110 ram 1.4 (defconstant lockout-interrupts (logior (mach:sigmask :sigint)
111     (mach:sigmask :sigquit)
112     (mach:sigmask :sigfpe)
113     (mach:sigmask :sigsys)
114     (mach:sigmask :sigpipe)
115     (mach:sigmask :sigalrm)
116     (mach:sigmask :sigurg)
117     (mach:sigmask :sigstop)
118     (mach:sigmask :sigtstp)
119     (mach:sigmask :sigcont)
120     (mach:sigmask :sigchld)
121     (mach:sigmask :sigttin)
122     (mach:sigmask :sigttou)
123     (mach:sigmask :sigio)
124     (mach:sigmask :sigxcpu)
125     (mach:sigmask :sigxfsz)
126     (mach:sigmask :sigvtalrm)
127     (mach:sigmask :sigprof)
128     (mach:sigmask :sigwinch)
129     (mach:sigmask :sigmsg)
130     (mach:sigmask :sigemsg)))
131 ram 1.1
132     (defconstant interrupt-stack-size 4096
133     "Size of stack for Unix interrupts.")
134    
135     (defvar software-interrupt-stack NIL
136     "Address of the stack used by Mach to send signals to Lisp.")
137    
138     (defvar %sp-interrupts-inhibited nil
139     "True if emergency message interrupts should be inhibited, false otherwise.")
140    
141     (defvar *software-interrupt-vector*
142     (make-array mach::maximum-interrupts)
143     "A vector that associates Lisp functions with Unix interrupts.")
144    
145     (defun enable-interrupt (interrupt function &optional character)
146     "Enable one Unix interrupt and associate a Lisp function with it.
147     Interrupt should be the number of the interrupt to enable. Function
148     should be a funcallable object that will be called with three
149     arguments: the signal code, a subcode, and the context of the
150     interrupt. The optional character should be an ascii character or
151     an integer that causes the interrupt from the keyboard. This argument
152     is only used for SIGINT, SIGQUIT, and SIGTSTP interrupts and is ignored
153     for any others. Returns the old function associated with the interrupt
154     and the character that generates it if the interrupt is one of SIGINT,
155     SIGQUIT, SIGTSTP and character was specified."
156     (unless (< 0 interrupt mach::maximum-interrupts)
157     (error "Interrupt number ~D is not between 1 and ~D."
158     mach::maximum-interrupts))
159     (let ((old-fun (svref *software-interrupt-vector* interrupt))
160     (old-char ()))
161     (when (and character
162     (or (eq interrupt mach:sigint)
163     (eq interrupt mach:sigquit)
164     (eq interrupt mach:sigtstp)))
165     (when (characterp character)
166     (setq character (char-code character)))
167     (when (mach:unix-isatty 0)
168     (if (or (eq interrupt mach:sigint)
169     (eq interrupt mach:sigquit))
170     (mach:with-trap-arg-block mach:tchars tc
171     (multiple-value-bind
172     (val err)
173     (mach:unix-ioctl 0 mach:TIOCGETC
174     (alien-value-sap mach:tchars))
175     (if (null val)
176     (error "Failed to get tchars information, unix error ~S."
177     (mach:get-unix-error-msg err))))
178     (cond ((eq interrupt mach:sigint)
179     (setq old-char
180     (alien-access (mach::tchars-intrc (alien-value tc))))
181     (setf (alien-access (mach::tchars-intrc (alien-value tc)))
182     character))
183     (T
184     (setq old-char
185     (alien-access (mach::tchars-quitc (alien-value tc))))
186     (setf (alien-access (mach::tchars-quitc (alien-value tc)))
187     character)))
188     (multiple-value-bind
189     (val err)
190     (mach:unix-ioctl 0 mach:tiocsetc
191     (alien-value-sap mach:tchars))
192     (if (null val)
193     (error "Failed to set tchars information, unix error ~S."
194     (mach:get-unix-error-msg err)))))
195     (mach:with-trap-arg-block mach:ltchars tc
196     (multiple-value-bind
197     (val err)
198     (mach:unix-ioctl 0 mach:TIOCGLTC
199     (alien-value-sap mach:ltchars))
200     (if (null val)
201     (error "Failed to get ltchars information, unix error ~S."
202     (mach:get-unix-error-msg err))))
203     (setq old-char
204     (alien-access (mach::ltchars-suspc (alien-value tc))))
205     (setf (alien-access (mach::ltchars-suspc (alien-value tc)))
206     character)
207     (multiple-value-bind
208     (val err)
209     (mach:unix-ioctl 0 mach:TIOCSLTC
210     (alien-value-sap mach:ltchars))
211     (if (null val)
212     (error "Failed to set ltchars information, unix error ~S."
213     (mach:get-unix-error-msg err))))))))
214     (setf (svref *software-interrupt-vector* interrupt) function)
215     (if (null function)
216     (mach:unix-sigvec interrupt mach:sig_dfl 0 0)
217     (let ((diha (+ (ash clc::romp-data-base 16)
218     clc::software-interrupt-offset)))
219     (mach:unix-sigvec interrupt diha lockout-interrupts 1)))
220     (if old-char
221     (values old-fun old-char)
222     old-fun)))
223    
224     (defun ignore-interrupt (interrupt)
225     "The Unix interrupt handling mechanism is set up so that interrupt is
226     ignored."
227     (unless (< 0 interrupt mach::maximum-interrupts)
228     (error "Interrupt number ~D is not between 1 and 31."))
229     (let ((old-fun (svref *software-interrupt-vector* interrupt)))
230     (mach:unix-sigvec interrupt mach:sig_ign 0 0)
231     (setf (svref *software-interrupt-vector* interrupt) NIL)
232     old-fun))
233    
234     (defun default-interrupt (interrupt)
235     "The Unix interrupt handling mechanism is set up to do the default action
236     under mach. Lisp will not get control of the interrupt."
237     (unless (< 0 interrupt mach::maximum-interrupts)
238     (error "Interrupt number ~D is not between 1 and 31."))
239     (let ((old-fun (svref *software-interrupt-vector* interrupt)))
240     (mach:unix-sigvec interrupt mach:sig_dfl 0 0)
241     (setf (svref *software-interrupt-vector* interrupt) NIL)
242     old-fun))
243    
244    
245     ;;; %SP-Software-Interrupt-Handler is called by the miscops when a Unix
246     ;;; signal arrives. The three arguments correspond to the information
247     ;;; passed to a normal Unix signal handler, i.e.:
248     ;;; signal -- the Unix signal number.
249     ;;; code -- a code for those signals which can be caused by more
250     ;;; than one kind of event. This code specifies the sub-event.
251     ;;; scp -- a pointer to the context of the signal.
252    
253     ;;; Because of the way %sp-software-interrupt-handler returns, it doesn't
254     ;;; unwind the binding stack properly. The only variable affected by this
255     ;;; is software-interrupt-stack, so it must be handled specially.
256    
257     (defun %sp-software-interrupt-handler (signal code scp stack)
258     (declare (optimize (speed 3) (safety 0)))
259     (if (and %sp-interrupts-inhibited
260     (not (memq signal '(#.mach:sigill #.mach:sigbus #.mach:sigsegv))))
261     (progn
262     (let ((iin %sp-interrupts-inhibited))
263     (setq %sp-interrupts-inhibited
264     (nconc (if (consp iin) iin)
265     (list `(,signal ,code ,scp))))
266     (mach:unix-sigsetmask 0)))
267     (let* ((old-stack software-interrupt-stack)
268     (new-stack ())
269     (%sp-interrupts-inhibited T))
270     (unwind-protect
271     (progn
272     (when *in-server*
273     (mach:unix-sigvec mach:sigmsg mach::sig_dfl 0 0))
274     (multiple-value-bind (gr addr)
275     (mach:vm_allocate *task-self* 0
276     interrupt-stack-size t)
277     (gr-error 'mach:vm_allocate gr '%sp-software-interrupt-handler)
278     (setq software-interrupt-stack
279     (int-sap (+ addr interrupt-stack-size))))
280     (setq new-stack software-interrupt-stack)
281     (mach:unix-sigstack new-stack 0)
282     (mach:unix-sigsetmask 0)
283     (funcall (svref *software-interrupt-vector* signal)
284     signal code scp)
285     (mach:unix-sigsetmask lockout-interrupts))
286     (mach:vm_deallocate *task-self*
287     (- (sap-int new-stack)
288     interrupt-stack-size)
289     interrupt-stack-size)
290     (setq software-interrupt-stack old-stack)
291     (mach:unix-sigstack old-stack 0)
292     (when *in-server*
293     (let ((diha (+ (ash clc::romp-data-base 16)
294     clc::software-interrupt-offset)))
295     (mach:unix-sigvec mach:sigmsg diha lockout-interrupts 1)))
296     (mach:unix-sigsetmask 0))))
297     (%primitive break-return stack))
298    
299    
300     (defun ih-sigint (signal code scp)
301     (declare (ignore signal code scp))
302     (without-hemlock
303     (with-interrupts
304     (break "Software Interrupt" t))))
305    
306     (defun ih-sigquit (signal code scp)
307     (declare (ignore signal code scp))
308     (throw 'top-level-catcher nil))
309    
310     (defun ih-sigtstp (signal code scp)
311     (declare (ignore signal code scp))
312     (without-hemlock
313     ; (reset-keyboard 0)
314     (mach:unix-kill (mach:unix-getpid) mach:sigstop)))
315    
316     (defun ih-sigill (signal code scp)
317     (declare (ignore signal code))
318     (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
319     'mach:sigcontext)
320     mach:sigcontext T))
321     (error "Illegal instruction encountered at IAR ~X."
322     (alien-access (mach::sigcontext-iar (alien-value context))))))
323    
324     (defun ih-sigbus (signal code scp)
325     (declare (ignore signal code))
326     (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
327     'mach:sigcontext)
328     mach:sigcontext T))
329     (with-interrupts
330     (error "Bus error encountered at IAR ~X."
331     (alien-access (mach::sigcontext-iar (alien-value context)))))))
332    
333     (defun ih-sigsegv (signal code scp)
334     (declare (ignore signal code))
335     (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
336     'mach:sigcontext)
337     mach:sigcontext T))
338     (with-interrupts
339     (error "Segment violation encountered at IAR ~X."
340     (alien-access (mach::sigcontext-iar (alien-value context)))))))
341    
342     (defun ih-sigfpe (signal code scp)
343     (declare (ignore signal code))
344     (alien-bind ((context (make-alien-value scp 0 (record-size 'mach:sigcontext)
345     'mach:sigcontext)
346     mach:sigcontext T))
347     (with-interrupts
348     (error "Floating point exception encountered at IAR ~X."
349     (alien-access (mach::sigcontext-iar (alien-value context)))))))
350    
351     ;;; When we're in server then throw back to server. If we're not
352     ;;; in server then just ignore the sigmsg interrupt. We can't handle
353     ;;; it and we should never get it anyway. But of course we do -- it's
354     ;;; dealing with interrupts and there funny at best.
355     (defun ih-sigmsg (signal code scp)
356     (declare (ignore signal code scp))
357 ram 1.4 (mach:unix-sigsetmask (mach:sigmask :sigmsg))
358 ram 1.1 (default-interrupt mach:sigmsg)
359     (when *in-server*
360     (setq *in-server* nil)
361     (throw 'server-catch server-unique-object)))
362    
363     (defun ih-sigemsg (signal code scp)
364     (declare (ignore signal code scp))
365     (service-emergency-message-interrupt))
366    
367     (defun init-mach-signals ()
368     (declare (optimize (speed 3) (safety 0)))
369     (multiple-value-bind (gr addr)
370     (mach:vm_allocate *task-self* 0 interrupt-stack-size t)
371     (gr-error 'mach:vm_allocate gr 'enable-interrupt)
372     (setq software-interrupt-stack
373     (int-sap (+ addr interrupt-stack-size))))
374     (let ((iha (get 'clc::interrupt-handler '%loaded-address))
375     (diha (+ (ash clc::romp-data-base 16) clc::software-interrupt-offset)))
376     (%primitive pointer-system-set diha 0 iha))
377     (mach:unix-sigstack software-interrupt-stack 0)
378     (enable-interrupt mach:sigint #'ih-sigint)
379     (enable-interrupt mach:sigquit #'ih-sigquit)
380     (enable-interrupt mach:sigtstp #'ih-sigtstp)
381     (enable-interrupt mach:sigill #'ih-sigill)
382     (enable-interrupt mach:sigbus #'ih-sigbus)
383     (enable-interrupt mach:sigsegv #'ih-sigsegv)
384     (enable-interrupt mach:sigemsg #'ih-sigemsg)
385     (enable-interrupt mach:sigfpe #'ih-sigfpe)
386     ; (reset-keyboard 0)
387     )
388    
389    
390     ;;;; Reply port allocation.
391     ;;;
392     ;;; We maintain a global stack of reply ports which is shared among
393     ;;; all matchmaker interfaces, and could be used by other people as well.
394     ;;;
395     ;;; The stack is represented by a vector, and a pointer to the first
396     ;;; free port. The stack grows upward. There is always at least one
397     ;;; NIL entry in the stack after the last allocated port.
398     ;;;
399     (defvar *reply-port-stack* (make-array 16)) ; Vector of reply ports.
400     (defvar *reply-port-pointer* 0) ; Index of first free port.
401     (defvar *reply-port-depth* 0) ; Dynamic depth in With-Reply-Port forms.
402    
403     ;;; We use this as the reply port when allocating or deallocating reply
404     ;;; ports to get around potentially nasty interactions. Interrupts
405     ;;; are always off when we are doing this, so we don't have to have
406     ;;; more than one of these, or worry about unwinding.
407     (defvar *allocate-reply-port* (mach:mach-task_data))
408    
409     ;;; Reset-Reply-Port-Stack -- Internal
410     ;;;
411     ;;; This is a before-save initialization which Nil's out the reply
412     ;;; port stack and sets *allocate-reply-port* back to DataPort so that
413     ;;; things initialize right at OS-Init time.
414     ;;;
415     (defun reset-reply-port-stack ()
416     (setq *reply-port-pointer* 0 *reply-port-depth* 0)
417     (fill (the simple-vector *reply-port-stack*) nil)
418     (setq *allocate-reply-port* (mach:mach-task_data)))
419     (pushnew 'reset-reply-port-stack *before-save-initializations*)
420    
421     ;;; Allocate-New-Reply-Ports -- Internal
422     ;;;
423     ;;; If we run out of reply ports, we allocate another one, possibly
424     ;;; growing the stack.
425     ;;;
426     (defun allocate-new-reply-ports ()
427     (let* ((stack *reply-port-stack*)
428     (pointer *reply-port-pointer*)
429     (len (length stack)))
430     (declare (simple-vector stack) (fixnum len))
431     (when (eql pointer (1- len))
432     (let ((new (make-array (* len 2))))
433     (replace new stack :end1 len :end2 len)
434     (setq stack new *reply-port-stack* new)))
435     (setf (svref stack pointer) *allocate-reply-port*)
436     (let ((port (gr-call* mach:port_allocate (mach:mach-task_self))))
437     (gr-call mach:port_disable (mach:mach-task_self) port)
438     ;;
439     ;; Nil out the allocate reply port so it isn't used for mundane purposes.
440     (setf (svref stack pointer) nil)
441     (setf (svref stack (1- pointer)) port)
442     port)))
443    
444     ;;; Reallocate-Reply-Ports -- Internal
445     ;;;
446     ;;; This function is called when With-Reply-Port finds the stack pointer
447     ;;; to be other than what it expected when it finishes. Reallocates all
448     ;;; of the ports on the stack from Start to *reply-port-pointer*. We
449     ;;; stick the *allocate-reply-port* out at *reply-port-pointer*, and
450     ;;; bind *reply-port-depth*, so that the allocation functions are happy.
451     ;;;
452     (defun reallocate-reply-ports (start)
453     (let* ((pointer *reply-port-pointer*)
454     (*reply-port-depth* pointer)
455     (stack *reply-port-stack*)
456     (save-port (svref stack pointer)))
457     (when (> start pointer)
458     (error "More ports in use than allocated???"))
459     (setf (svref stack pointer) *allocate-reply-port*)
460     (do ((i start (1+ i)))
461     ((= i pointer)
462     (setf (svref stack pointer) save-port))
463     (let ((port (svref stack i)))
464     (gr-call mach:port_deallocate *task-self* port)
465     (setf (svref stack i)
466     (gr-call* mach:port_allocate *task-self*))))))
467    
468    
469     ;;;; Server stuff:
470     ;;;
471     ;;; There is a fair amount of stuff to support Matchmaker RPC servers
472     ;;; and asynchonous message service. RPC message service needs to be
473     ;;; centralized since a server must receive on all ports, and there is
474     ;;; no way for a particular server to know about all other servers
475     ;;; in the same lisp.
476     ;;;
477     ;;; The idea is that you receive the message, and then dispatch off
478     ;;; of the port received on and the message ID received. Ports correspond
479     ;;; to objects that the server manages. Message ID's correspond to the
480     ;;; operations on the objects. Objects are grouped into object sets, which
481     ;;; are sets of objects having the same operations defined.
482     ;;;
483     ;;; The same mechanism is used for handling asynchronous messages.
484     ;;;
485    
486     ;;; The current implementation uses standard eq[l] hashtables for both
487     ;;; levels of dispatching. Special purpose data structures would be more
488     ;;; efficient, but the ~1ms overhead will probably be lost in the noise.
489    
490     ;;;
491     ;;; Hashtable from ports to objects. Each entry is a cons (object . set).
492     ;;;
493     (defvar *port-table* (make-hash-table :test #'eql))
494    
495     ;;; Hashtable from windows to objects. Each entry is a cons (object . set).
496     ;;;
497     (defvar *xwindow-table* (make-hash-table :test #'eql))
498    
499    
500     (defstruct (object-set
501     (:constructor make-object-set
502     (name &optional
503     (default-handler #'default-default-handler)))
504     (:print-function
505     (lambda (s stream d)
506     (declare (ignore d))
507     (format stream "#<Object Set ~S>" (object-set-name s)))))
508     name ; Name, for descriptive purposes.
509     (table (make-hash-table :test #'eq)) ; Message-ID or xevent-type --> handler fun.
510     default-handler)
511    
512     (setf (documentation 'make-object-set 'function)
513     "Make an object set for use by a RPC/xevent server. Name is for
514     descriptive purposes only.")
515    
516    
517     ;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and
518     ;;; object set mapped to by a xwindow or port in *xwindow-table* or
519     ;;; *port-table*.
520     ;;;
521     (macrolet ((defmapper (name table)
522     `(defun ,(intern (concatenate 'simple-string
523     "MAP-" (symbol-name name)))
524     (,name)
525     ,(format nil "Return as multiple values the object and ~
526     object-set mapped to by ~A."
527     (string-downcase (symbol-name name)))
528     (let ((temp (gethash ,name ,table)))
529     (if temp
530     (values (car temp) (cdr temp))
531     (values nil nil))))))
532     (defmapper port *port-table*)
533     (defmapper xwindow *xwindow-table*))
534    
535    
536     ;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair
537     ;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*.
538     ;;;
539     (macrolet ((def-add-object (name table)
540     `(defun ,(intern (concatenate 'simple-string
541     "ADD-" (symbol-name name)
542     "-OBJECT"))
543     (,name object object-set)
544     ,(format nil "Add a new ~A/object/object-set association."
545     (string-downcase (symbol-name name)))
546     (check-type object-set object-set)
547     (setf (gethash ,name ,table) (cons object object-set))
548     object)))
549     (def-add-object port *port-table*)
550     (def-add-object xwindow *xwindow-table*))
551    
552    
553     ;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and
554     ;;; its associated object/object-set pair from *port-table* or *xwindow-table*.
555     ;;;
556     (macrolet ((def-remove-object (name table)
557     `(defun ,(intern (concatenate 'simple-string
558     "REMOVE-" (symbol-name name)
559     "-OBJECT"))
560     (,name)
561     ,(format nil
562     "Remove ~A and its associated object/object-set pair."
563     (string-downcase (symbol-name name)))
564     (remhash ,name ,table))))
565     (def-remove-object port *port-table*)
566     (def-remove-object xwindow *xwindow-table*))
567    
568    
569     ;;; Object-Set-Operation -- Public
570     ;;;
571     ;;; Look up the handler function for a given message ID.
572     ;;;
573     (defun object-set-operation (object-set message-id)
574     "Return the handler function in Object-Set for the operation specified by
575     Message-ID, if none, NIL is returned. The handler function is passed
576     the object. The received message is in server-Message."
577     (check-type object-set object-set)
578     (check-type message-id fixnum)
579     (values (gethash message-id (object-set-table object-set))))
580    
581     ;;; %Set-Object-Set-Operation -- Internal
582     ;;;
583     ;;; The setf inverse for Object-Set-Operation.
584     ;;;
585     (defun %set-object-set-operation (object-set message-id new-value)
586     (check-type object-set object-set)
587     (check-type message-id fixnum)
588     (setf (gethash message-id (object-set-table object-set)) new-value))
589     ;;;
590     (defsetf object-set-operation %set-object-set-operation
591     "Sets the handler function for an object set operation.")
592    
593     ;;;; Emergency Message Handling:
594     ;;;
595     ;;; We use the same mechanism for asynchronous messages as is used for
596     ;;; normal server messages. The only tricky part is that we don't want
597     ;;; some random server function being called when we really want to
598     ;;; receive an emergency message, so we can't receive on all ports.
599     ;;; Instead, we use MessagesWaiting to find the ports with emergency
600     ;;; messages.
601    
602     (defalien waiting-ports nil (long-words 128))
603    
604     ;;; Service-Emergency-Message-Interrupt -- Internal
605     ;;;
606     ;;; This is a lot like the server function, but we only receive on
607     ;;; ports with one emergency message. We only receive one message because
608     ;;; the handler function might have caused any other messages to be received.
609     ;;; When we re-enable interrupts, if any emergency messages are left, we
610     ;;; should be interrupted again.
611     ;;;
612     (defun service-emergency-message-interrupt ()
613     (grab-message-loop))
614    
615     ;;;
616     ;;; This object set is used for DataPort, which is the port various magical
617     ;;; message from the kernel are received on...
618     (defvar *kernel-messages* (make-object-set "Kernel Messages"))
619    
620     (compiler-let ((*alien-eval-when* '(compile eval)))
621     (defrecord port-death-msg
622     (msg mach:msg #.(record-size 'mach:msg))
623     (ex-port-tt pad (long-words 1))
624     (ex-port (signed-byte 32) (long-words 1)))
625    
626     (defoperator (server-message-port-death-msg port-death-msg)
627     ((msg server-message))
628     `(alien-index (alien-value ,msg) 0 (record-size 'port-death-msg)))
629     ); Compiler-Let
630    
631    
632     ;;; *Port-Death-Handlers* is an EQ hash table of lists of functions that are
633     ;;; called upon port death. If a port dies that is not in the table, we print
634     ;;; out a message on *Trace-Output* describing its death. If
635     ;;; *Pornography-Of-Death* is true, we don't even print that message.
636    
637     (defvar *port-death-handlers* (make-hash-table :test #'eql)
638     "Don't use this --- use Add-Port-Death-Handler instead.")
639    
640     ;;; Add-Port-Death-Handler, Remove-Port-Death-Handler -- Public
641     ;;;
642     (defun add-port-death-handler (port function)
643     "Make Function a handler for port death on Port. When the port dies,
644     Function is called with the port and an argument. See also
645     Remove-Port-Death-Handler."
646     (pushnew function (gethash port *port-death-handlers*))
647     nil)
648     ;;;
649     (defun remove-port-death-handler (port function)
650     "Undoes the effect of Add-Port-Death-Handler."
651     (setf (gethash port *port-death-handlers*)
652     (delete function (gethash port *port-death-handlers*)))
653     nil)
654    
655     (setf (object-set-operation *kernel-messages* mach:notify-port-deleted)
656     #'(lambda (obj)
657     (declare (ignore obj))
658     (let* ((ex-port (alien-access
659     (port-death-msg-ex-port
660     (server-message-port-death-msg server-message))))
661     (handlers (gethash ex-port *port-death-handlers*)))
662     (remhash ex-port *port-table*)
663     (remhash ex-port *port-death-handlers*)
664     (if (null handlers)
665     (handle-unclaimed-port-death ex-port)
666     (dolist (fun handlers) (funcall fun ex-port))))
667     mach:kern-success))
668    
669     (defvar *pornography-of-death* t
670     "If true, nothing is said about port deaths.")
671    
672     (defun handle-unclaimed-port-death (port)
673     (unless *pornography-of-death*
674     (format *trace-output* "~&[Port ~S just bit the dust.]~%" port)))
675    
676     ;;; Port receive and ownership rights messages are handled simlarly, but
677     ;;; by default we deallocate the port to make sure it's really dead. This
678     ;;; gets around problems with ports being exhausted because some servers
679     ;;; don't really nuke the port when the deallocate the object.
680     ;;;
681    
682     (defvar *port-receive-rights-handlers* (make-hash-table :test #'eql)
683     "This is a hashtable from ports to functions. The function is called with
684     the port as its argument when a port receive rights message for that port
685     is received from the kernel.")
686    
687     (defvar *port-ownership-rights-handlers* (make-hash-table :test #'eql)
688     "This is a hashtable from ports to functions. The function is called with
689     the port as its argument when a port ownership rights message for that port
690     is received from the kernel.")
691    
692     (setf (object-set-operation *kernel-messages* mach:notify-receive-rights)
693     #'(lambda (obj)
694     (declare (ignore obj))
695     (let ((ex-port (alien-access
696     (port-death-msg-ex-port
697     (server-message-port-death-msg server-message)))))
698     (funcall (gethash ex-port *port-receive-rights-handlers*
699     #'handle-unclaimed-port-rights)
700     ex-port))
701     mach:kern-success))
702    
703     (setf (object-set-operation *kernel-messages* mach:notify-ownership-rights)
704     #'(lambda (obj)
705     (declare (ignore obj))
706     (let ((ex-port (alien-access
707     (port-death-msg-ex-port
708     (server-message-port-death-msg server-message)))))
709     (funcall (gethash ex-port *port-ownership-rights-handlers*
710     #'handle-unclaimed-port-rights)
711     ex-port))
712     mach:kern-success))
713    
714     (defun handle-unclaimed-port-rights (port)
715     (unless *pornography-of-death*
716     (format *trace-output* "~&[Rights received for port ~D, deallocating it.]~%"
717     port))
718     (mach:port_deallocate *task-self* port)
719     (remhash port *port-receive-rights-handlers*)
720     (remhash port *port-ownership-rights-handlers*)
721     (remhash port *port-table*))
722    
723     (add-port-object *task-data* nil *kernel-messages*)
724    
725     ;;; Clear-Port-Tables -- Internal
726     ;;;
727     ;;; A before-save initialization which clears all of the port hashtables.
728     ;;;
729     (defun clear-port-tables ()
730     (clrhash *port-table*)
731     (clrhash *port-death-handlers*)
732     (clrhash *port-receive-rights-handlers*)
733     (clrhash *port-ownership-rights-handlers*))
734    
735     (pushnew 'clear-port-tables *before-save-initializations*)
736    
737    
738     ;;; %Initial-Function is called when a cold system starts up. First we zoom
739     ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
740     ;;; at "load time." Then we initialize the various subsystems and call the
741     ;;; read-eval-print loop. The top-level Read-Eval-Print loop is executed until
742     ;;; someone (most likely the Quit function) throws to the tag
743     ;;; %End-Of-The-World. We quit this way so that all outstanding cleanup forms
744     ;;; in Unwind-Protects will get executed.
745    
746     (proclaim '(special *lisp-initialization-functions*))
747    
748     (eval-when (compile)
749     (defmacro print-and-call (name)
750     `(progn
751     (%primitive print ',name)
752     (,name))))
753    
754     (defun %initial-function ()
755     "Gives the world a shove and hopes it spins."
756     (setq *already-maybe-gcing* t)
757 ram 1.2 (setf *gc-inhibit* t)
758 ram 1.1 (setf *need-to-collect-garbage* nil)
759     (%primitive print "In initial-function, and running.")
760    
761     ;; Many top-level forms call INFO, (SETF INFO).
762     (print-and-call c::globaldb-init)
763    
764     ;; Some of the random top-level forms call Make-Array, which calls Subtypep...
765     (print-and-call subtypep-init)
766    
767     (setq *lisp-initialization-functions*
768     (nreverse *lisp-initialization-functions*))
769     (%primitive print "Calling top-level forms.")
770     (dolist (fun *lisp-initialization-functions*)
771     (funcall fun))
772     (makunbound '*lisp-initialization-functions*) ; So it gets GC'ed.
773    
774     (print-and-call os-init)
775     (print-and-call filesys-init)
776     (print-and-call conditions::error-init)
777    
778     (print-and-call reader-init)
779     (print-and-call backq-init)
780     (print-and-call sharp-init)
781     ;; After the various reader subsystems have done their thing to the standard
782     ;; readtable, copy it to *readtable*.
783     (setq *readtable* (copy-readtable std-lisp-readtable))
784    
785     (print-and-call stream-init)
786     (print-and-call random-init)
787     (print-and-call format-init)
788     (print-and-call package-init)
789     (print-and-call pprint-init)
790    
791     (setq *already-maybe-gcing* nil)
792     (terpri)
793     (princ "CMU Common Lisp kernel core image ")
794     (princ (lisp-implementation-version))
795     (princ ".")
796     (terpri)
797     (princ "[You are in the LISP package.]")
798     (terpri)
799     (catch '%end-of-the-world
800     (loop
801     (%top-level)
802     (write-line "You're certainly a clever child.")))
803     (mach:unix-exit 0))
804    
805    
806     ;;;; Initialization functions:
807    
808     ;;; Reinit is called to reinitialize the world when a saved core image
809     ;;; is resumed.
810     (defvar *task-notify* NIL)
811    
812     (defun reinit ()
813     (without-interrupts
814     (setq *already-maybe-gcing* t)
815     (os-init)
816     (stream-reinit)
817     (setq *already-maybe-gcing* nil))
818     (setq *task-notify* (mach:mach-task_notify))
819     (mach:port_enable (mach:mach-task_self) *task-notify*)
820     (add-port-object *task-notify* nil *kernel-messages*)
821     (init-mach-signals))
822    
823    
824     ;;; OS-Init initializes our operating-system interface. It sets the values
825     ;;; of the global port variables to what they should be and calls the functions
826     ;;; that set up the argument blocks for the server interfaces.
827    
828     (defun os-init ()
829     (setq *task-self* (mach:mach-task_self))
830     (setq *task-data* (mach:mach-task_data)))
831    
832    
833     ;;; Setup-path-search-list returns a list of the directories that are
834     ;;; in the unix path environment variable. This is so that run-program
835     ;;; can be smarter about where to find a program to run.
836     (defun setup-path-search-list ()
837     (let ((path (cdr (assoc :path ext::*environment-list*))))
838     (when path
839     (do* ((i 0 (1+ p))
840     (p (position #\: path :start i)
841     (position #\: path :start i))
842     (pl ()))
843     ((null p)
844     (let ((s (subseq path i)))
845     (if (string= s "")
846     (push "default:" pl)
847     (push (concatenate 'simple-string s "/") pl)))
848     (nreverse pl))
849     (let ((s (subseq path i p)))
850     (if (string= s "")
851     (push "default:" pl)
852     (push (concatenate 'simple-string s "/") pl)))))))
853    
854    
855     ;;;; Miscellaneous external functions:
856    
857     (defun print-herald ()
858     (write-string "CMU Common Lisp ")
859     (write-line (lisp-implementation-version))
860     (write-string "Hemlock ") (write-string *hemlock-version*)
861     (write-string ", Compiler ") (write-line compiler-version)
862     (write-line "Send bug reports and questions to Gripe.")
863     (values))
864    
865     (defvar *editor-lisp-p* nil
866     "This is true if and only if the lisp was started with the -edit switch.")
867    
868     (defun save-lisp (core-file-name &key
869     (purify t)
870     (root-structures ())
871     (init-function
872     #'(lambda ()
873     (throw 'top-level-catcher nil)))
874     (load-init-file t)
875     (print-herald t)
876     (process-command-line t))
877     "Saves a Spice Lisp core image in the file of the specified name. The
878     following keywords are defined:
879    
880     :purify
881     If true, do a purifying GC which moves all dynamically allocated
882     objects into static space so that they stay pure. This takes somewhat
883     longer than the normal GC which is otherwise done, but GC's will done
884     less often and take less time in the resulting core file.
885    
886     :root-structures
887     This should be a list of the main entry points in any newly loaded
888     systems. This need not be supplied, but locality will be better if it
889     is. This is meaningless if :purify is Nil.
890    
891     :init-function
892     This is a function which is called when the created core file is
893     resumed. The default function simply aborts to the top level
894     read-eval-print loop. If the function returns it will be the value
895     of Save-Lisp.
896    
897     :load-init-file
898     If true, then look for an init.lisp or init.fasl file when the core
899     file is resumed.
900    
901     :print-herald
902     If true, print out the lisp system herald when starting."
903    
904     (if purify
905     (purify :root-structures root-structures)
906     (gc))
907     (unless (save core-file-name)
908     (setf (search-list "default:") (list (default-directory)))
909     (setf (search-list "path:") (setup-path-search-list))
910     (when process-command-line (ext::process-command-strings))
911     (setf *editor-lisp-p* nil)
912     (macrolet ((find-switch (name)
913     `(find ,name *command-line-switches*
914     :key #'cmd-switch-name
915     :test #'(lambda (x y)
916     (declare (simple-string x y))
917     (string-equal x y)))))
918     (when (and process-command-line (find-switch "edit"))
919     (setf *editor-lisp-p* t))
920     (when (and load-init-file
921     (not (and process-command-line (find-switch "noinit"))))
922     (let* ((cl-switch (find-switch "init"))
923     (name (or (and cl-switch
924     (or (cmd-switch-value cl-switch)
925     (car (cmd-switch-words cl-switch))
926     "init"))
927     "init")))
928     (load (merge-pathnames name (user-homedir-pathname))
929     :if-does-not-exist nil))))
930     (when print-herald
931     (print-herald))
932     (when process-command-line
933     (ext::invoke-switch-demons *command-line-switches*
934     *command-switch-demons*))
935     (funcall init-function)))
936    
937    
938     ;;; Quit gets us out, one way or another.
939    
940     (defun quit (&optional recklessly-p)
941     "Terminates the current Lisp. Things are cleaned up unless Recklessly-P is
942     non-Nil."
943     ; (reset-keyboard 0)
944     (dolist (x (if (boundp 'extensions::temporary-foreign-files)
945     extensions::temporary-foreign-files))
946     (mach:unix-unlink x))
947     (if recklessly-p
948     (mach:unix-exit 0)
949     (throw '%end-of-the-world nil)))
950    
951    
952    
953     (defalien sleep-msg mach:msg (record-size 'mach:msg))
954     (setf (alien-access (mach:msg-simplemsg sleep-msg)) T)
955     (setf (alien-access (mach:msg-msgtype sleep-msg)) 0)
956     (setf (alien-access (mach:msg-msgsize sleep-msg))
957     (/ (record-size 'mach:msg) 8))
958    
959     ;;; Currently there is a bug in the Mach timeout code that if the timeout
960     ;;; period is too short the receive never returns.
961    
962     (defun sleep (n)
963     "This function causes execution to be suspended for N seconds. N may
964     be any non-negative, non-complex number."
965     (with-reply-port (sleep-port)
966     (let ((m (round (* 1000 n))))
967     (cond ((minusp m)
968     (error "Argument to Sleep, ~S, is a negative number." n))
969     ((zerop m))
970     (t
971     (setf (alien-access (mach:msg-localport sleep-msg)) sleep-port)
972     (let ((gr (mach:msg-receive sleep-msg mach:rcv-timeout m)))
973     (unless (eql gr mach:rcv-timed-out)
974     (gr-error 'mach:receive gr)))))))
975     nil)
976    
977    
978     ;;;; TOP-LEVEL loop.
979    
980     (defvar / nil
981     "Holds a list of all the values returned by the most recent top-level EVAL.")
982     (defvar // nil "Gets the previous value of / when a new value is computed.")
983     (defvar /// nil "Gets the previous value of // when a new value is computed.")
984     (defvar * nil "Holds the value of the most recent top-level EVAL.")
985     (defvar ** nil "Gets the previous value of * when a new value is computed.")
986     (defvar *** nil "Gets the previous value of ** when a new value is computed.")
987     (defvar + nil "Holds the value of the most recent top-level READ.")
988     (defvar ++ nil "Gets the previous value of + when a new value is read.")
989     (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
990     (defvar - nil "Holds the form curently being evaluated.")
991 ram 1.3 (defvar *prompt* "* "
992     "The top-level prompt string. This also may be a function of no arguments
993     that returns a simple-string.")
994 ram 1.1 (defvar *in-top-level-catcher* nil
995     "True if we are within the Top-Level-Catcher. This is used by interrupt
996     handlers to see whether it is o.k. to throw.")
997    
998 ram 1.3 (defun interactive-eval (form)
999     "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
1000     +, ///, //, /, and -."
1001     (setf +++ ++
1002     ++ +
1003     + -
1004     - form)
1005     (let ((results (multiple-value-list (eval form))))
1006     (setf /// //
1007     // /
1008     / results
1009     *** **
1010     ** *
1011     * (car results)))
1012     (unless (boundp '*)
1013     ;; The bogon returned an unbound marker.
1014     (setf * nil)
1015     (cerror "Go on with * set to NIL."
1016     "EVAL returned an unbound marker."))
1017     (values-list /))
1018    
1019     (defconstant eofs-before-quit 10)
1020    
1021 ram 1.1 (defun %top-level ()
1022     "Top-level READ-EVAL-PRINT loop. Do not call this."
1023 ram 1.3 (let ((* nil) (** nil) (*** nil)
1024 ram 1.1 (- nil) (+ nil) (++ nil) (+++ nil)
1025 ram 1.3 (/// nil) (// nil) (/ nil)
1026     (magic-eof-cookie (cons :eof nil))
1027     (number-of-eofs 0))
1028 ram 1.1 (loop
1029     (with-simple-restart (abort "Return to Top-Level.")
1030     (catch 'top-level-catcher
1031     (let ((*in-top-level-catcher* t))
1032     (loop
1033 ram 1.3 (fresh-line)
1034     (princ (if (functionp *prompt*)
1035     (funcall *prompt*)
1036     *prompt*))
1037     (force-output)
1038     (let ((form (read *standard-input* nil magic-eof-cookie)))
1039     (cond ((not (eq form magic-eof-cookie))
1040     (let ((results
1041     (multiple-value-list (interactive-eval form))))
1042     (dolist (result results)
1043     (fresh-line)
1044     (prin1 result)))
1045     (setf number-of-eofs 0))
1046     ((eql (incf number-of-eofs) 1)
1047     (let ((stream (make-synonym-stream '*terminal-io*)))
1048     (setf *standard-input* stream)
1049     (setf *standard-output* stream)
1050     (format t "~&Received EOF on *standard-input*, ~
1051     switching to *terminal-io*.~%")))
1052     ((> number-of-eofs eofs-before-quit)
1053     (format t "~&Received more than ~D EOFs; Aborting.~%"
1054     eofs-before-quit)
1055     (quit))
1056     (t
1057     (format t "~&Received EOF.~%")))))))))))
1058 ram 1.1
1059    
1060 ram 1.3
1061 ram 1.1 ;;; %Halt -- Interface
1062     ;;;
1063     ;;; A convenient way to get into the assembly level debugger.
1064     ;;;
1065     (defun %halt ()
1066     (%primitive halt))

  ViewVC Help
Powered by ViewVC 1.1.5