;;; **********************************************************************
;;; 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))
  )