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

Contents of /src/code/lispinit.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5