;;; **********************************************************************
;;; 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 auxilary routines for creating a core file.
;;; 
;;; Written by Daniel Aronson.
;;;
;;; **********************************************************************


(declare (special data-port kernel-port null-port kernel-reply-port))
;;; fork

;;; this version of fork is a temporary hack.  it is intended to be
;;; used for now as a tool for the save command.  hence the father
;;; process passes no ports to the forked process.

(defvar to-fork)
(def-alien-structure to-fork
  (msg-simplep (selection () t) 0 2 :constant ())
  (msg-size unsigned-integer 2 6 :constant 54)
  (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 105)
  (t1-hack1 unsigned-integer 22 24 :constant 8198)	
  (t1-hack2 unsigned-integer 24 26 :constant 4097)
  (his-kernel-port port 26 30 :constant null-port)
  (t2-hack1 unsigned-integer 30 32 :constant 8198)
  (t2-hack2 unsigned-integer 32 34 :constant 4097)
  (his-data-port port 34 38 :constant null-port)
  (t3-hack1 unsigned-integer 38 40 :constant 0)
  (t3-hack2 unsigned-integer 40 42 :constant 8192)
  (t-name unsigned-integer 42 44 :constant 6)
  (t-size unsigned-integer 44 46 :constant 32)
  (num-ports unsigned-integer 46 50 :constant 0)

 ;; ports is supposed to be a pointer to a list of ports that the
 ;;parent passes the child.  we can set this to nil (0) since we are
 ;;passing no ports.

  (ports unsigned-integer 50 54 :constant 0)
  )


(defvar from-fork)
(def-alien-structure from-fork
  (msg-size unsigned-integer 2 6 :constant 60)		
  (msg-local-port port 10 14 :constant data-port)
  (reply-code unsigned-integer 26 28 :direction read)
  (his-kernel-port port 32 36 :direction read))

(defun fork ()
  (simple-send to-fork)
  (simple-receive from-fork)
  (values (from-fork-reply-code from-fork)
	  (from-fork-his-kernel-port from-fork))
  )



;;; suspend

(defvar to-suspend)
(def-alien-structure to-suspend
  (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)
  (msg-id unsigned-integer 18 22 :constant 110)
  )


(defvar from-suspend)
(def-alien-structure from-suspend
  (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)
  )

;;; Suspend suspends a the process associated with PORT


(defun suspend (port)
  (setf (to-suspend-msg-remote-port to-suspend) port)
  (simple-send to-suspend)
  (simple-receive from-suspend)
  (from-suspend-reply from-suspend)
  )

;;; Examine
(defvar to-examine)
(def-alien-structure to-examine
  (msg-simplep (selection () t) 0 2 :constant t)
  (msg-size unsigned-integer 2 6 :constant 34)
  (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 112)
  (t1-hack1 unsigned-integer 22 24 :constant 4096)
  (t1-hack2 unsigned-integer 24 26 :constant 4097)
  (reg-or-stack (selection () t) 26 28)
  (t2-hack1 unsigned-integer 28 30 :constant 4097)
  (t2-hack2 unsigned-integer 30 32 :constant 4097)
  (index unsigned-integer 32 34)
  )


(defvar from-examine)
(def-alien-structure from-examine
  (msg-size unsigned-integer 2 6 :constant 34)
  (msg-local-port port 10 14 :constant kernel-reply-port)
  (return-code unsigned-integer 26 28 :direction read)
  (value unsigned-integer 32 34 :direction read)
  )



;;; Examine takes three parameters--
;;;    PORT - The KernelPort of the process to be examined.
;;;    REG-OR-STACK - () - E-Stack
;;;                    T - registers
;;;    INDEX - The register or e-stack entry to examine

;;; The value is returned.

(defun examine (port reg-or-stack index)
  "examine the e-stack or registers of the process associated with port.
  if reg-or-stack is TRUE then the registers are examined, else the e-stack is
  examined ."
  (setf (to-examine-msg-remote-port to-examine) port)
  (setf (to-examine-reg-or-stack to-examine) reg-or-stack)
  (setf (to-examine-index to-examine) index)
  (simple-send to-examine)
  (simple-receive from-examine)
  (from-examine-value from-examine)
  )

;;; Read-Process-Memory

(defvar to-read-process-memory)
(def-alien-structure to-read-process-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)
  (msg-id unsigned-integer 18 22 :constant 123)
  (t1-hack1 unsigned-integer 22 24 :constant 8194)
  (t1-hack2 unsigned-integer 24 26 :constant 4097)
  (address unsigned-integer 26 30)
  (t2-hack1 unsigned-integer 30 32 :constant 8194)
  (t2-hack2 unsigned-integer 32 34 :constant 4097)
  (num-bytes unsigned-integer 34 38)
  )


(defvar from-read-process-memory)
(def-alien-structure from-read-process-memory
  (msg-size unsigned-integer 2 6 :constant 44)
  (msg-local-port port 10 14 :constant kernel-reply-port)
  (return-code unsigned-integer 26 28 :direction read)
  (data-cnt unsigned-integer 36 40 :direction read)
  (data unsigned-integer 40 44 :direction read)
  )

(defun read-process-memory (port address num-bytes)
  (setf (to-read-process-memory-msg-remote-port
	 to-read-process-memory) port)
  (setf (to-read-process-memory-address
	 to-read-process-memory) address)
  (setf (to-read-process-memory-num-bytes
	 to-read-process-memory) num-bytes)
  (simple-send to-read-process-memory)
  (simple-receive from-read-process-memory)
  (values (from-read-process-memory-data-cnt from-read-process-memory)
	  (from-read-process-memory-data from-read-process-memory))
  )

;;; Here we initialize some non-fixnums for SAVE, which is cold-loaded,
;;; and set up the alien structures that we'll need.

(defun save-aux-init ()
  (setq to-fork (make-to-fork))
  (setq from-fork (make-from-fork :alien-data-length 60))
  (setq to-suspend (make-to-suspend))
  (setq from-suspend (make-from-suspend))
  (setq to-examine (make-to-examine))
  (setq from-examine (make-from-examine))
  (setq to-read-process-memory (make-to-read-process-memory))
  (setq from-read-process-memory (make-from-read-process-memory))
  )