Skip to content
Snippets Groups Projects
Commit 6eeb55d6 authored by wlott's avatar wlott
Browse files

Moved lots of exports into the files that contain the thing being

exported.  Moved the object-set stuff into serve-event.lisp.
Added a call to GC-INIT to REINIT to facilitate making sure set-auto-gc-
trigger gets called.
parent f4b565a9
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (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 @@ ...@@ -19,25 +19,13 @@
(in-package "LISP" :use '("SYSTEM" "DEBUG")) (in-package "LISP" :use '("SYSTEM" "DEBUG"))
(export '(most-positive-fixnum most-negative-fixnum sleep (export '(most-positive-fixnum most-negative-fixnum sleep
++ +++ ** *** // ///)) ++ +++ ** *** // ///))
(in-package "SYSTEM" :nicknames '("SYS")) (in-package "SYSTEM" :nicknames '("SYS"))
(export '(without-gcing (export '(compiler-version scrub-control-stack))
*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))
(in-package "EXTENSIONS") (in-package "EXTENSIONS")
(export '(quit *prompt* save-lisp gc-on gc-off *clx-server-displays*)) (export '(quit *prompt*))
(in-package "LISP") (in-package "LISP")
...@@ -54,10 +42,6 @@ ...@@ -54,10 +42,6 @@
(defvar *lisp-implementation-version* "4.0(?)") (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... ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...
(proclaim '(special *gc-inhibit* *already-maybe-gcing* (proclaim '(special *gc-inhibit* *already-maybe-gcing*
...@@ -78,388 +62,6 @@ ...@@ -78,388 +62,6 @@
(defvar *free-interrupt-context-index*) (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 ;;; %Initial-Function is called when a cold system starts up. First we zoom
;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
...@@ -570,24 +172,17 @@ ...@@ -570,24 +172,17 @@
;;;; Initialization functions: ;;;; Initialization functions:
;;; Reinit is called to reinitialize the world when a saved core image
;;; is resumed.
(defvar *task-notify* NIL)
(defun reinit () (defun reinit ()
(without-interrupts (without-interrupts
(setf *already-maybe-gcing* t) (without-gcing
(os-init) (os-init)
(stream-reinit) (stream-reinit)
(kernel::signal-init) (kernel::signal-init)
(setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t) (gc-init)
(setf *already-maybe-gcing* nil)) (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
(set-floating-point-modes :traps '(:overflow :underflow :invalid (set-floating-point-modes :traps
:divide-by-zero)) '(:overflow :underflow :invalid
#+nil :divide-by-zero)))))
(mach:port_enable (mach:mach-task_self) *task-notify*)
#+nil
(add-port-object *task-notify* nil *kernel-messages*))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment