diff --git a/code/lispinit.lisp b/code/lispinit.lisp index bee999fdc21c913236d02260548a5c9eb4d8058d..91c9dcd19d63e11ee522d14c47948e88f8e65759 100644 --- a/code/lispinit.lisp +++ b/code/lispinit.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.32 1992/03/08 18:30:32 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/lispinit.lisp,v 1.33 1992/04/12 00:24:12 wlott Exp $") ;;; ;;; ********************************************************************** ;;; @@ -19,25 +19,13 @@ (in-package "LISP" :use '("SYSTEM" "DEBUG")) (export '(most-positive-fixnum most-negative-fixnum sleep - ++ +++ ** *** // ///)) - + ++ +++ ** *** // ///)) (in-package "SYSTEM" :nicknames '("SYS")) -(export '(without-gcing - *in-the-compiler* compiler-version *pornography-of-death* - *port-receive-rights-handlers* *port-ownership-rights-handlers* - without-interrupts with-reply-port map-port add-port-object - remove-port-object make-object-set object-set-operation - server-message *xwindow-table* map-xwindow add-xwindow-object - remove-xwindow-object server-event coerce-to-key-event - coerce-to-motion-event coerce-to-expose-event - coerece-to-exposecopy-event coerce-to-focuschange-event server - *task-self* *task-data* *task-notify* with-interrupts - with-enabled-interrupts enable-interrupt ignore-interrupt - default-interrupt scrub-control-stack)) +(export '(compiler-version scrub-control-stack)) (in-package "EXTENSIONS") -(export '(quit *prompt* save-lisp gc-on gc-off *clx-server-displays*)) +(export '(quit *prompt*)) (in-package "LISP") @@ -54,10 +42,6 @@ (defvar *lisp-implementation-version* "4.0(?)") -(defvar *in-the-compiler* nil - "Bound to T while running code inside the compiler. Macros may test this to - see where they are being expanded.") - ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs... (proclaim '(special *gc-inhibit* *already-maybe-gcing* @@ -78,388 +62,6 @@ (defvar *free-interrupt-context-index*) - -;;;; Global ports: - -(defvar *task-self* nil - "Port that refers to the current task.") - -(defvar *task-data* nil - "Port used to receive data for the current task.") - - - -;;;; Reply port allocation. -;;; -;;; We maintain a global stack of reply ports which is shared among -;;; all matchmaker interfaces, and could be used by other people as well. -;;; - -#| More stuff that will probably be drastically different. - -;;; The stack is represented by a vector, and a pointer to the first -;;; free port. The stack grows upward. There is always at least one -;;; NIL entry in the stack after the last allocated port. -;;; -(defvar *reply-port-stack* (make-array 16)) ; Vector of reply ports. -(defvar *reply-port-pointer* 0) ; Index of first free port. -(defvar *reply-port-depth* 0) ; Dynamic depth in With-Reply-Port forms. - -;;; We use this as the reply port when allocating or deallocating reply -;;; ports to get around potentially nasty interactions. Interrupts -;;; are always off when we are doing this, so we don't have to have -;;; more than one of these, or worry about unwinding. -(defvar *allocate-reply-port* (mach:mach-task_data)) - -;;; Reset-Reply-Port-Stack -- Internal -;;; -;;; This is a before-save initialization which Nil's out the reply -;;; port stack and sets *allocate-reply-port* back to DataPort so that -;;; things initialize right at OS-Init time. -;;; -(defun reset-reply-port-stack () - (setf *reply-port-pointer* 0 *reply-port-depth* 0) - (fill (the simple-vector *reply-port-stack*) nil) - (setf *allocate-reply-port* (mach:mach-task_data))) -(pushnew 'reset-reply-port-stack *before-save-initializations*) - -;;; Allocate-New-Reply-Ports -- Internal -;;; -;;; If we run out of reply ports, we allocate another one, possibly -;;; growing the stack. -;;; -(defun allocate-new-reply-ports () - (let* ((stack *reply-port-stack*) - (pointer *reply-port-pointer*) - (len (length stack))) - (declare (simple-vector stack) (fixnum len)) - (when (eql pointer (1- len)) - (let ((new (make-array (* len 2)))) - (replace new stack :end1 len :end2 len) - (setf stack new *reply-port-stack* new))) - (setf (svref stack pointer) *allocate-reply-port*) - (let ((port (gr-call* mach:port_allocate (mach:mach-task_self)))) - (gr-call mach:port_disable (mach:mach-task_self) port) - ;; - ;; Nil out the allocate reply port so it isn't used for mundane purposes. - (setf (svref stack pointer) nil) - (setf (svref stack (1- pointer)) port) - port))) - -;;; Reallocate-Reply-Ports -- Internal -;;; -;;; This function is called when With-Reply-Port finds the stack pointer -;;; to be other than what it expected when it finishes. Reallocates all -;;; of the ports on the stack from Start to *reply-port-pointer*. We -;;; stick the *allocate-reply-port* out at *reply-port-pointer*, and -;;; bind *reply-port-depth*, so that the allocation functions are happy. -;;; -(defun reallocate-reply-ports (start) - (let* ((pointer *reply-port-pointer*) - (*reply-port-depth* pointer) - (stack *reply-port-stack*) - (save-port (svref stack pointer))) - (when (> start pointer) - (error "More ports in use than allocated???")) - (setf (svref stack pointer) *allocate-reply-port*) - (do ((i start (1+ i))) - ((= i pointer) - (setf (svref stack pointer) save-port)) - (let ((port (svref stack i))) - (gr-call mach:port_deallocate *task-self* port) - (setf (svref stack i) - (gr-call* mach:port_allocate *task-self*)))))) -|# - - -;;;; Server stuff: -;;; -;;; There is a fair amount of stuff to support Matchmaker RPC servers -;;; and asynchonous message service. RPC message service needs to be -;;; centralized since a server must receive on all ports, and there is -;;; no way for a particular server to know about all other servers -;;; in the same lisp. -;;; -;;; The idea is that you receive the message, and then dispatch off -;;; of the port received on and the message ID received. Ports correspond -;;; to objects that the server manages. Message ID's correspond to the -;;; operations on the objects. Objects are grouped into object sets, which -;;; are sets of objects having the same operations defined. -;;; -;;; The same mechanism is used for handling asynchronous messages. -;;; - -;;; The current implementation uses standard eq[l] hashtables for both -;;; levels of dispatching. Special purpose data structures would be more -;;; efficient, but the ~1ms overhead will probably be lost in the noise. - -;;; -;;; Hashtable from ports to objects. Each entry is a cons (object . set). -;;; -(defvar *port-table* (make-hash-table :test #'eql)) - -;;; Hashtable from windows to objects. Each entry is a cons (object . set). -;;; -(defvar *xwindow-table* (make-hash-table :test #'eql)) - - -(defstruct (object-set - (:constructor make-object-set - (name &optional - (default-handler #'default-default-handler))) - (:print-function - (lambda (s stream d) - (declare (ignore d)) - (format stream "#<Object Set ~S>" (object-set-name s))))) - name ; Name, for descriptive purposes. - (table (make-hash-table :test #'eq)) ; Message-ID or xevent-type --> handler fun. - default-handler) - -(setf (documentation 'make-object-set 'function) - "Make an object set for use by a RPC/xevent server. Name is for - descriptive purposes only.") - -;;; Default-Default-Handler -- Internal -;;; -;;; If no such operation defined, signal an error. -;;; -(defun default-default-handler (object) - #+nil - (alien-bind ((msg (server-message-msg server-message))) - (error "No operation for ID ~D on ~S in ~S." - (alien-access (mach:msg-id (alien-value msg))) object - (car (gethash (alien-access (mach:msg-localport (alien-value msg))) - *port-table*)))) - (error "You lose, object: ~S" object)) - - -;;; MAP-XWINDOW and MAP-PORT return as multiple values the object and -;;; object set mapped to by a xwindow or port in *xwindow-table* or -;;; *port-table*. -;;; -(macrolet ((defmapper (name table) - `(defun ,(intern (concatenate 'simple-string - "MAP-" (symbol-name name))) - (,name) - ,(format nil "Return as multiple values the object and ~ - object-set mapped to by ~A." - (string-downcase (symbol-name name))) - (let ((temp (gethash ,name ,table))) - (if temp - (values (car temp) (cdr temp)) - (values nil nil)))))) - (defmapper port *port-table*) - (defmapper xwindow *xwindow-table*)) - - -;;; ADD-PORT-OBJECT and ADD-XWINDOW-OBJECT store an object/object-set pair -;;; mapped to by a port or xwindow in either *port-table* or *xwindow-table*. -;;; -(macrolet ((def-add-object (name table) - `(defun ,(intern (concatenate 'simple-string - "ADD-" (symbol-name name) - "-OBJECT")) - (,name object object-set) - ,(format nil "Add a new ~A/object/object-set association." - (string-downcase (symbol-name name))) - (check-type object-set object-set) - (setf (gethash ,name ,table) (cons object object-set)) - object))) - (def-add-object port *port-table*) - (def-add-object xwindow *xwindow-table*)) - - -;;; REMOVE-PORT-OBJECT and REMOVE-XWINDOW-OBJECT remove a port or xwindow and -;;; its associated object/object-set pair from *port-table* or *xwindow-table*. -;;; -(macrolet ((def-remove-object (name table) - `(defun ,(intern (concatenate 'simple-string - "REMOVE-" (symbol-name name) - "-OBJECT")) - (,name) - ,(format nil - "Remove ~A and its associated object/object-set pair." - (string-downcase (symbol-name name))) - (remhash ,name ,table)))) - (def-remove-object port *port-table*) - (def-remove-object xwindow *xwindow-table*)) - - -;;; Object-Set-Operation -- Public -;;; -;;; Look up the handler function for a given message ID. -;;; -(defun object-set-operation (object-set message-id) - "Return the handler function in Object-Set for the operation specified by - Message-ID, if none, NIL is returned. The handler function is passed - the object. The received message is in server-Message." - (check-type object-set object-set) - (check-type message-id fixnum) - (values (gethash message-id (object-set-table object-set)))) - -;;; %Set-Object-Set-Operation -- Internal -;;; -;;; The setf inverse for Object-Set-Operation. -;;; -(defun %set-object-set-operation (object-set message-id new-value) - (check-type object-set object-set) - (check-type message-id fixnum) - (setf (gethash message-id (object-set-table object-set)) new-value)) -;;; -(defsetf object-set-operation %set-object-set-operation - "Sets the handler function for an object set operation.") - - - -;;;; Emergency Message Handling: -;;; -;;; We use the same mechanism for asynchronous messages as is used for -;;; normal server messages. The only tricky part is that we don't want -;;; some random server function being called when we really want to -;;; receive an emergency message, so we can't receive on all ports. -;;; Instead, we use MessagesWaiting to find the ports with emergency -;;; messages. - -#| still more noise that will be different. - -(defalien waiting-ports nil (long-words 128)) - -;;; Service-Emergency-Message-Interrupt -- Internal -;;; -;;; This is a lot like the server function, but we only receive on -;;; ports with one emergency message. We only receive one message because -;;; the handler function might have caused any other messages to be received. -;;; When we re-enable interrupts, if any emergency messages are left, we -;;; should be interrupted again. -;;; -(defun service-emergency-message-interrupt () - (grab-message-loop)) - -;;; -;;; This object set is used for DataPort, which is the port various magical -;;; message from the kernel are received on... -(defvar *kernel-messages* (make-object-set "Kernel Messages")) - -(compiler-let ((*alien-eval-when* '(compile eval))) -(defrecord port-death-msg - (msg mach:msg #.(record-size 'mach:msg)) - (ex-port-tt pad (long-words 1)) - (ex-port (signed-byte 32) (long-words 1))) - -(defoperator (server-message-port-death-msg port-death-msg) - ((msg server-message)) - `(alien-index (alien-value ,msg) 0 (record-size 'port-death-msg))) -); Compiler-Let - - -;;; *Port-Death-Handlers* is an EQ hash table of lists of functions that are -;;; called upon port death. If a port dies that is not in the table, we print -;;; out a message on *Trace-Output* describing its death. If -;;; *Pornography-Of-Death* is true, we don't even print that message. - -(defvar *port-death-handlers* (make-hash-table :test #'eql) - "Don't use this --- use Add-Port-Death-Handler instead.") - -;;; Add-Port-Death-Handler, Remove-Port-Death-Handler -- Public -;;; -(defun add-port-death-handler (port function) - "Make Function a handler for port death on Port. When the port dies, - Function is called with the port and an argument. See also - Remove-Port-Death-Handler." - (pushnew function (gethash port *port-death-handlers*)) - nil) -;;; -(defun remove-port-death-handler (port function) - "Undoes the effect of Add-Port-Death-Handler." - (setf (gethash port *port-death-handlers*) - (delete function (gethash port *port-death-handlers*))) - nil) - -(setf (object-set-operation *kernel-messages* mach:notify-port-deleted) - #'(lambda (obj) - (declare (ignore obj)) - (let* ((ex-port (alien-access - (port-death-msg-ex-port - (server-message-port-death-msg server-message)))) - (handlers (gethash ex-port *port-death-handlers*))) - (remhash ex-port *port-table*) - (remhash ex-port *port-death-handlers*) - (if (null handlers) - (handle-unclaimed-port-death ex-port) - (dolist (fun handlers) (funcall fun ex-port)))) - mach:kern-success)) - -(defvar *pornography-of-death* t - "If true, nothing is said about port deaths.") - -(defun handle-unclaimed-port-death (port) - (unless *pornography-of-death* - (format *trace-output* "~&[Port ~S just bit the dust.]~%" port))) - -;;; Port receive and ownership rights messages are handled simlarly, but -;;; by default we deallocate the port to make sure it's really dead. This -;;; gets around problems with ports being exhausted because some servers -;;; don't really nuke the port when the deallocate the object. -;;; - -(defvar *port-receive-rights-handlers* (make-hash-table :test #'eql) - "This is a hashtable from ports to functions. The function is called with - the port as its argument when a port receive rights message for that port - is received from the kernel.") - -(defvar *port-ownership-rights-handlers* (make-hash-table :test #'eql) - "This is a hashtable from ports to functions. The function is called with - the port as its argument when a port ownership rights message for that port - is received from the kernel.") - -(setf (object-set-operation *kernel-messages* mach:notify-receive-rights) - #'(lambda (obj) - (declare (ignore obj)) - (let ((ex-port (alien-access - (port-death-msg-ex-port - (server-message-port-death-msg server-message))))) - (funcall (gethash ex-port *port-receive-rights-handlers* - #'handle-unclaimed-port-rights) - ex-port)) - mach:kern-success)) - -(setf (object-set-operation *kernel-messages* mach:notify-ownership-rights) - #'(lambda (obj) - (declare (ignore obj)) - (let ((ex-port (alien-access - (port-death-msg-ex-port - (server-message-port-death-msg server-message))))) - (funcall (gethash ex-port *port-ownership-rights-handlers* - #'handle-unclaimed-port-rights) - ex-port)) - mach:kern-success)) - -(defun handle-unclaimed-port-rights (port) - (unless *pornography-of-death* - (format *trace-output* "~&[Rights received for port ~D, deallocating it.]~%" - port)) - (mach:port_deallocate *task-self* port) - (remhash port *port-receive-rights-handlers*) - (remhash port *port-ownership-rights-handlers*) - (remhash port *port-table*)) - -(add-port-object *task-data* nil *kernel-messages*) - -;;; Clear-Port-Tables -- Internal -;;; -;;; A before-save initialization which clears all of the port hashtables. -;;; -(defun clear-port-tables () - (clrhash *port-table*) - (clrhash *port-death-handlers*) - (clrhash *port-receive-rights-handlers*) - (clrhash *port-ownership-rights-handlers*)) - -(pushnew 'clear-port-tables *before-save-initializations*) - -|# - - ;;; %Initial-Function is called when a cold system starts up. First we zoom ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen @@ -570,24 +172,17 @@ ;;;; Initialization functions: -;;; Reinit is called to reinitialize the world when a saved core image -;;; is resumed. -(defvar *task-notify* NIL) - (defun reinit () (without-interrupts - (setf *already-maybe-gcing* t) - (os-init) - (stream-reinit) - (kernel::signal-init) - (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t) - (setf *already-maybe-gcing* nil)) - (set-floating-point-modes :traps '(:overflow :underflow :invalid - :divide-by-zero)) - #+nil - (mach:port_enable (mach:mach-task_self) *task-notify*) - #+nil - (add-port-object *task-notify* nil *kernel-messages*)) + (without-gcing + (os-init) + (stream-reinit) + (kernel::signal-init) + (gc-init) + (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t) + (set-floating-point-modes :traps + '(:overflow :underflow :invalid + :divide-by-zero)))))