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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5