;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; Spice Lisp interface to the Accent Kernel.
;;;
;;; Written by Jim Large and Dan Aronson.
;;;
;;; **********************************************************************
;;; Standard Ports
;;; These global variables hold the port objects which are needed in the basic
;;; system. Null-port, kernel-port, and data-port are special ports which
;;; should be constants, but are too complex for a cold load.
;;;
;;; The other ports are passed to Lisp from the parent process in a message
;;; sent to data-port. That message is always the first message sent to a
;;; lisp process
;;;
;;; The values of all these ports are setup at init time by the function,
;;; kernel-init.
(defvar null-port () "A bit bucket for messages.")
(defvar kernel-port () "The handle of (right to manipulate) this process.")
(defvar data-port ()
"A port on which this process may always receive messages.")
(defvar *lisp-command* ()
"This string contains the lisp command given to Club")
(defvar *user-window* ()
"This process's initial window")
(defvar *user-typescript* ()
"This process's initial typescript")
(defvar *sesame-port* ()
"This process's initial file server connection.")
(defvar *env-mgr-port* ()
"This process's initial environment manager connection.")
(defvar *time-port* ()
"This process's initial time server connection.")
(defvar *process-manager-port* ()
"This process's initial process manager connection.")
(defvar *name-server-port* ()
"This process's initial name server connection.")
;;; Kernel-reply-port is the port we give in kernel calls for the reply.
(defvar kernel-reply-port ())
;;; Return Codes
;;;
;;; Accent defines a set of standard integer codes which are returned from
;;; many functions to indicate the success or failure of the call. Useful
;;; codes are defined here as constants.
(defconstant rc-timeout 102) ;the return code for timeout.
(defconstant rc-success 101) ;the return code for success.
;;; Primitive Kernel Calls
;;;
;;; Primitive kernel calls are invoked by the misc-op, %sp-kernel-trap, which
;;; takes two args; ARG-BLOCK, and TRAP-CODE. TRAP-CODE selects which kernel
;;; primitive is being called, and ARG-BLOCK is a u-vector which contains the
;;; args to the call.
;;;
;;; Each of the functions below is a lisp interface to a kernel primitive.
;;; Alien structures are used to store lispish arguments in the arg-block.
;;; Make-pointer-f returns a form which computes the Accent word address of the
;;; first data byte in a u-vector-like object. The form stores the address as
;;; two fixnums.
;;;
;;;
;;; U-VEC -- a form which yields the u-vecotr.
;;; LSW -- a setf place where the low 16 bits of the address are stored
;;; MSW -- high 16 bits.
(defmacro make-pointer-f (u-vec lsw msw)
`(let ((fixnum (+ (%sp-make-fixnum ,u-vec) 4)))
(setf ,lsw (logand fixnum 65535))
(setf ,msw (dpb (%sp-type ,u-vec)
(byte 5 11)
(%sp-lsh fixnum -16)))))
;;; Send
(defconstant trap-send 3) ;the trap code for sending messages
;;; The send-arg-block structure defines the argument block for the Send
;;; primitive. The default values are chosen to be appropriate for the
;;; simple-send case.
(def-alien-structure send-arg-block
(return-code unsigned-integer 0 2)
(msg-lsw unsigned-integer 2 4)
(msg-msw unsigned-integer 4 6)
(max-wait unsigned-integer 6 10 :default 0)
(option (selection 'wait 'dont-wait 'reply) 10 12 :default 'wait))
;;; Simple-send sends the message to the port specified in message's header.
;;; If the destination queue is full, simple-send will wait until the message
;;; can be sent. If the send is not successful, then simple-send will signal
;;; a fatal error.
;;;
;;; MESSAGE is an alien structure whose data vector contains the message to
;;; be sent.
;;;
;;; Simple-send-arg-block holds the arg block which is used by simple-send.
(defvar simple-send-arg-block ())
(defun simple-send (message)
"Sends message to port stored in message's header. Infinite wait."
;;store pointer to data into arg block.
(make-pointer-f (alien-structure-data message)
(send-arg-block-msg-lsw simple-send-arg-block)
(send-arg-block-msg-msw simple-send-arg-block))
(%sp-kernel-trap (alien-structure-data simple-send-arg-block) trap-send)
(if (/= (send-arg-block-return-code simple-send-arg-block)
rc-success)
(error "Send error, ~s."
(send-arg-block-return-code simple-send-arg-block)))
)
;;; Receive
(defconstant trap-receive 4) ;the trap code for receiving messages.
(def-alien-structure receive-arg-block
(return-code unsigned-integer 0 2)
(msg-lsw unsigned-integer 2 4)
(msg-msw unsigned-integer 4 6)
(max-wait unsigned-integer 6 10 :default 0)
(option (selection 'preview 'receive 'receive-wait)
10 12
:default 'receive)
(port-option (selection 'default-ports 'all-ports 'local-port)
12 14
:default 'local-port))
;;; Simple-receive receives a message from the port given in message's header.
;;; Simple-receive will wait until a message is available. If the receive
;;; is not successful, then simple-receive will signal a fatal error.
;;;
;;; MESSAGE is an alien structure whose data vector is an accent message. The
;;; data vector will be destructively modified by the incoming message.
;;;
;;; Simple-receive-arg-block holds the argument block used by simple-receive.
(defvar simple-receive-arg-block ())
(defun simple-receive (message &optional (timeout 0 timeout-p))
;;store pointer to data into arg block
(make-pointer-f (alien-structure-data message)
(receive-arg-block-msg-lsw simple-receive-arg-block)
(receive-arg-block-msg-msw simple-receive-arg-block))
(setf (receive-arg-block-max-wait simple-receive-arg-block) timeout)
(%sp-kernel-trap (alien-structure-data simple-receive-arg-block)
trap-receive)
(let ((rc (receive-arg-block-return-code simple-receive-arg-block)))
(if (/= rc rc-success)
(if (and timeout-p (= rc rc-timeout))
:timeout
(error "Receive error, ~s." rc))))
)
;;; Move-Words
(defconstant trap-move-words 15)
(defvar move-words-arg-block ())
(def-alien-structure move-words
(return-code unsigned-integer 0 2)
(source unsigned-integer 2 6)
(dest unsigned-integer 6 10)
(word-count unsigned-integer 10 14)
(delete (selection () t) 14 16)
(create (selection () t) 16 18)
(mask unsigned-integer 18 22)
(no-share (selection () t) 22 24))
;;; move-words moves data from one place in our address space to another.
;;; SOURCE -- the address of the data to be moved.
;;; DEST -- the address to move the data to.
;;; WORD-COUNT -- then number of 16 bit words to move.
;;; DELETE -- If T, invalidate the source pages after moving.
;;; CREATE -- If T, then DEST is ignored and the destination address is chosen
;;; by the kernel from our invalid memory.
;;; MASK -- Same as for validate-memory (below)
;;; NO-SHARE -- If (), then referencing the dest data becomes equivalent to
;;; referencing the source area.
;;;
;;; If source, dest, and word-count are multiples of the accent page size, then
;;; data are moved by tweaking the page map. It is an error for no-share to
;;; be (), delete to be T, or create to be T if source, dest, and word-count
;;; are not page multiples.
;;;
;;; Returns the actual address to which the data were moved.
(defun move-words (source dest word-count delete create mask no-share)
(setf (move-words-source move-words-arg-block) source)
(setf (move-words-dest move-words-arg-block) dest)
(setf (move-words-word-count move-words-arg-block) word-count)
(setf (move-words-delete move-words-arg-block) delete)
(setf (move-words-create move-words-arg-block) create)
(setf (move-words-mask move-words-arg-block) mask)
(setf (move-words-no-share move-words-arg-block) no-share)
(%sp-kernel-trap (alien-structure-data move-words-arg-block) trap-move-words)
(let ((return-code (move-words-return-code move-words-arg-block)))
(if (/= return-code rc-success)
(error "Move-Words error, ~s." return-code)))
(move-words-dest move-words-arg-block))
;;; Soft-Enable
(defconstant trap-soft-enable 21)
(defvar Soft-enable-arg-block ())
(def-alien-structure soft-enable
(normalp (selection () t) 2 4)
(enablep (selection () t) 4 6))
;;; Soft-enable controls the enabling of software interrupts. Interrupts can
;;; be caused by the receiving of messages.
;;;
;;; NORMALP -- If T, set the status for normal messages, if (), set the status
;;; for emergency messages.
;;; ENABLEP -- If T, enable interrupts. If (), disable interrupts.
(defun soft-enable (normalp enablep)
(setf (soft-enable-normalp soft-enable-arg-block) normalp)
(setf (soft-enable-enablep soft-enable-arg-block) enablep)
(%sp-kernel-trap (alien-structure-data soft-enable-arg-block)
trap-soft-enable)
T)
;;; Allocate-Port
(defvar to-allocate-port ()) ;holds the message sent to allocate-port
(def-alien-structure to-allocate-port
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 28)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant data-port)
(msg-remote-port port 14 18 :constant kernel-port)
(msg-id unsigned-integer 18 22 :constant 101)
(backlog-hack1 unsigned-integer 22 24 :constant 4097)
(backlog-hack2 unsigned-integer 24 26 :constant 4097)
(backlog unsigned-integer 26 28)
)
(defvar from-allocate-port ()) ; holds the message received from allocate-port
(def-alien-structure from-allocate-port
(msg-size unsigned-integer 2 6 :constant 36)
(msg-local-port port 10 14 :constant data-port)
(return-code unsigned-integer 26 28)
(new-port port 32 36)
)
;;; Allocate-port returns a new port object which belongs to this process.
;;; BACKLOG is the number of pending messages which may be queued for
;;; reception. if backlog=0, then a default value chosen by accent will
;;; be used.
(defun allocate-port (backlog)
(setf (to-allocate-port-backlog to-allocate-port) backlog)
(simple-send to-allocate-port)
(simple-receive from-allocate-port)
(let ((return-code (from-allocate-port-return-code from-allocate-port)))
(if (/= return-code rc-success)
(error "Allocate-port error ~s." return-code)))
(from-allocate-port-new-port from-allocate-port))
;;; Validate-Memory
(defvar to-validate-memory ())
(def-alien-structure to-validate-memory
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 46)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant kernel-reply-port)
(msg-remote-port port 14 18 :constant kernel-port)
(msg-id unsigned-integer 18 22 :constant 120)
(address-hack1 unsigned-integer 22 24 :constant 8194)
(address-hack2 unsigned-integer 24 26 :constant 4097)
(address unsigned-integer 26 30)
(count-hack1 unsigned-integer 30 32 :constant 8194)
(count-hack2 unsigned-integer 32 34 :constant 4097)
(count unsigned-integer 34 38)
(mask-hack1 unsigned-integer 38 40 :constant 8194)
(mask-hack2 unsigned-integer 40 42 :constant 4097)
(mask unsigned-integer 42 46))
(defvar from-validate-memory ())
(def-alien-structure from-validate-memory
(msg-size unsigned-integer 2 4 :constant 36)
(msg-local-port port 10 14 :constant kernel-reply-port)
(return-code unsigned-integer 26 28)
(address unsigned-integer 32 36)
)
;;; Validate-memory marks a given part of our address space as valid.
;;;
;;; ADDRESS -- The address of the first page to validate. If 0, accent will
;;; choose an address from our invalid pages.
;;; COUNT -- The number of 8 bit bytes to validate
;;; MASK -- If address = 0, then the address chosen by accent will be such
;;; that for each 0 bit in MASK, the corresponding bit in the
;;; chosen address will be zero.
;;;
;;; RETURNS the address actualy validated.
(defun validate-memory (address count mask)
(setf (to-validate-memory-address to-validate-memory) address)
(setf (to-validate-memory-count to-validate-memory) count)
(setf (to-validate-memory-mask to-validate-memory) mask)
(simple-send to-validate-memory)
(simple-receive from-validate-memory)
(let ((return-code (from-validate-memory-return-code from-validate-memory)))
(if (/= return-code rc-success)
(error "Validate-memory error ~s." return-code)))
(from-validate-memory-address from-validate-memory))
;;; Invalidate-Memory
(defvar to-invalidate-memory ())
(def-alien-structure to-invalidate-memory
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 38)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant kernel-reply-port)
(msg-remote-port port 14 18 :constant kernel-port)
(msg-id unsigned-integer 18 22 :constant 121)
(address-hack1 unsigned-integer 22 24 :constant 8194)
(address-hack2 unsigned-integer 24 26 :constant 4097)
(address unsigned-integer 26 30)
(count-hack1 unsigned-integer 30 32 :constant 8194)
(count-hack2 unsigned-integer 32 34 :constant 4097)
(count unsigned-integer 34 38)
)
(defvar from-invalidate-memory ())
(def-alien-structure from-invalidate-memory
(msg-size unsigned-integer 2 4 :constant 28)
(msg-local-port port 10 14 :constant kernel-reply-port)
(return-code unsigned-integer 26 28))
;;; Invalidate-memory is called to invalidate a chunk of our address space.
;;; ADDRESS is the address to invalidate.
;;; COUNT is the number of bytes to be invalidated.
;;;
;;; Currently, accent crashes if address is not a page boundary, and count
;;; is not a multiple of the page size.
(defun invalidate-memory (address count)
(setf (to-invalidate-memory-address to-invalidate-memory) address)
(setf (to-invalidate-memory-count to-invalidate-memory) count)
(simple-send to-invalidate-memory)
(simple-receive from-invalidate-memory)
(let ((return-code (from-invalidate-memory-return-code from-invalidate-memory)))
(if (/= return-code rc-success)
(error "invalidate-memory error ~s." return-code)))
)
;;; Terminate
;;; TERMINATE terminates the current process.
(defvar to-terminate)
(def-alien-structure to-terminate
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 30)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant'normal-message)
(msg-local-port port 10 14 :constant kernel-reply-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 107)
(t-hack1 unsigned-integer 22 24 :constant 8194)
(t-hack2 unsigned-integer 24 26 :constant 4097)
(reason unsigned-integer 26 30 :constant 0)
)
(defvar from-terminate)
(def-alien-structure from-terminate
(msg-size unsigned-integer 2 6 :constant 28)
(msg-local-port port 10 14 :constant kernel-reply-port)
(reply unsigned-integer 26 28 :direction read))
(defun terminate (&optional (process kernel-port))
(setf (to-terminate-msg-remote-port to-terminate) process)
(simple-send to-terminate)
(simple-receive from-terminate)
(from-terminate-reply from-terminate)
)
;;; The user call that terminates the current lisp process
(defun quit ()
(terminate))
;;; Available-VM
;;; Available-VM return the number of bytes of paging space available.
(defvar to-available-vm)
(def-alien-structure to-available-vm
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 22)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant kernel-reply-port)
(msg-remote-port port 14 18 :constant kernel-port)
(msg-id unsigned-integer 18 22 :constant 141)
)
(defvar from-available-vm)
(def-alien-structure from-available-vm
(msg-size unsigned-integer 2 6 :constant 36)
(msg-local-port port 10 14 :constant kernel-reply-port)
(reply unsigned-integer 26 28 :direction read)
(num-bytes unsigned-integer 32 36 :direction read)
)
(defun available-vm ()
(simple-send to-available-vm)
(simple-receive from-available-vm)
(from-available-vm-num-bytes from-available-vm)
)
;;; PORT-DEATH-MESSAGE
;;; When a port that this process has dies two emergency messages are
;;; queued up on its data port. The first is a receive-rights message,
;;; and the second is a port death message. PORT-DEATH-MESSAGE is a structure
;;; that both messages fit into.
(defvar port-death-message)
(def-alien-structure port-death-message
(msg-size unsigned-integer 2 6 :constant 30)
(msg-local-port port 10 14 :constant data-port)
(reason unsigned-integer 18 22 :direction read)
(port port 26 30 :direction read)
)
;;; Kernel-Init
;;; The structure, from-init-ports, is usedby kernel-init to hold the message
;;; from the parent process which contains our standard ports.
(def-alien-structure from-init-ports
(hdr-size unsigned-integer 2 6 :constant 148)
(hdr-local-port port 10 14 :constant data-port)
(window port 26 30 :direction read)
(sesame port 30 34 :direction read)
(env-mgr port 34 38 :direction read)
(ts-port port 38 42 :direction read)
(time-port port 42 46 :direction read)
(pm-port port 46 50 :direction read)
(ns-port port 50 54 :direction read)
(lisp-command perq-string 66 148 :direction read)
)
;;; Kernel-init is called at system init time before the init functions of any
;;; module that uses these definitions. Kernel-init sets the values of global
;;; variables which are used by kernel interface functions, and any functions
;;; which do message passing.
(defun kernel-init ()
"Initializes global variables used by the kernel interface functions."
;;create the "constant" ports
(setq null-port (make-port 0 0))
(setq kernel-port (make-port 1 0))
(setq data-port (make-port 2 0))
;;create the arg blocks used by kernel primitives
(setq simple-send-arg-block (make-send-arg-block))
(setq simple-receive-arg-block (make-receive-arg-block))
(setq move-words-arg-block (make-move-words))
(setq soft-enable-arg-block (make-soft-enable))
(setq to-allocate-port (make-to-allocate-port))
(setq from-allocate-port (make-from-allocate-port))
;;receive the other standard ports from the parent process.
(let ((init-message (make-from-init-ports)))
(simple-receive init-message)
(setq *user-window* (from-init-ports-window init-message))
(setq *sesame-port* (from-init-ports-sesame init-message))
(setq *env-mgr-port* (from-init-ports-env-mgr init-message))
(setq *user-typescript* (from-init-ports-ts-port init-message))
(setq *time-port* (from-init-ports-time-port init-message))
(setq *process-manager-port* (from-init-ports-pm-port init-message))
(setq *name-server-port* (from-init-ports-ns-port init-message))
(setq *lisp-command* (from-init-ports-lisp-command init-message))
)
;;initialize the kernel-reply-port. NOTE: the allocate-port call
;;must be done after the startup message is received.
(setq kernel-reply-port (allocate-port 0))
;;create the messages used by other kernel functions
(setq to-validate-memory (make-to-validate-memory))
(setq from-validate-memory (make-from-validate-memory))
(setq to-invalidate-memory (make-to-invalidate-memory))
(setq from-invalidate-memory (make-from-invalidate-memory))
(setq to-terminate (make-to-terminate))
(setq from-terminate (make-from-terminate))
(setq to-available-vm (make-to-available-vm))
(setq from-available-vm (make-from-available-vm))
(setq port-death-message (make-port-death-message))
)