;;; -*- Mode: Lisp; Package: Lisp -*-
;;;
;;; **********************************************************************
;;; 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 routines to suspend a process and create a core file.
;;;
;;; Written by Daniel Aronson, Rob MacLachlan and Skef Wholey.
;;;
;;;**********************************************************************
;;; To see the format of Spice Lisp core files look at the document
;;; prva:<slisp.docs>core.mss.
;;;; Global state:
(defvar *next-word* ()
"The next word to be written in the core file, as word offset from
the beginning.")
(defvar *file-pointer* ()
"The system-area-pointer to the place where the core file is being assembled.")
(defvar *delayed-header-actions* ()
"A list of functions that are to be called after the process is mapped
into our adress space.")
(defvar *first-data-word* ()
"The word offset of the first data page in the file.")
(defvar *last-data-word* ()
"The word offset after the last data word.")
(defstruct dir-entry
process-page
file-page
count)
(defconstant page-word-size 256)
(defconstant page-byte-size 512)
;;; These constant are returned from the Fork call.
(defconstant is-parent 135)
(defconstant is-child 136)
;;; The DForm argument to sub-write-file.
(defconstant dform-32-bit 32)
;;; Constants for the lisp address space.
(defconstant alloc-table-start #x10000)
(defconstant alloc-table-size 512) ; (in bytes)
(defconstant bugout-table-start #x20000)
(defconstant bugout-table-size 512)
(defconstant binding-stack-pointer 8)
(defconstant binding-stack-start #x4000000)
(defconstant control-stack-pointer 2)
(defconstant control-stack-start #x2000000)
(defconstant warm-start-address 12320)
;;; Constants having to do with the core file format.
;; The core file password.
(defconstant core-file-password 1129271877)
;; Header entry types:
(defconstant end-entry-code 3840)
(defconstant dir-entry-code 3841)
(defconstant user-reg-entry-code 3843)
(defconstant validate-entry-code 3845)
(defconstant checksum-entry-code 3846)
;; The size in words of the checksum.
(defconstant checksum-size 8192)
;; The largest size that the header could possibly be, in pages.
(defconstant max-header-size 128)
;;; Stuff
;;; Get-Register -- Internal
;;;
;;; Reads a 32 bit register, Register, in the process with the
;;; specified child-kport.
;;;
(defmacro get-register (child-kport register)
`(logior (examine ,child-kport t ,register)
(ash (examine ,child-kport t (1+ ,register)) 16)))
;;; Sap+ -- Internal
;;;
;;; Return a new SAP that points Offset words form SAP.
;;;
(defmacro sap+ (sap offset)
`(%primitive make-immediate-type
(+ (%primitive make-immediate-type ,sap %+-fixnum-type)
,offset)
%misc-type))
;;; Put-Header -- Internal
;;;
;;; Writes a 32 bit Word at the current position in the core file,
;;; and increments.
;;;
(defun put-header (word)
(let ((index *next-word*))
(%primitive 16bit-system-set *file-pointer* index (logand word #xFFFF))
(%primitive 16bit-system-set *file-pointer* (1+ index) (ash word -16))
(setq *next-word* (+ index 2))))
;;; Put-Word -- Internal
;;;
;;; Write the specified word at the specified offset.
;;;
(defun put-word (word offset)
(%primitive 16bit-system-set *file-pointer* offset (logand word #xFFFF))
(%primitive 16bit-system-set *file-pointer* (1+ offset) (ash word -16)))
;;; Write-Header-Entry -- Internal
;;;
;;; Write out an entry in the header of the specified type. We leave
;;; space for the size, and then go back and change it to the amount of stuff
;;; actually written.
;;;
(defmacro write-header-entry ((type) &body body)
(let ((start-pos (gensym)))
`(let ((,start-pos *next-word*))
(put-header ,type)
(incf *next-word* 2)
(multiple-value-prog1
(progn ,@body)
(put-word (/ (- *next-word* ,start-pos) 2) (+ ,start-pos 2))))))
;;; Delayed-Write-Header-Entry -- Internal
;;;
;;; Set up a header entry with the specified Type and Size, but
;;; don't actually execute the body until the process-pages have
;;; already been mapped into our address space.
;;;
(defmacro delayed-write-header-entry ((type size) &body body)
(let ((start-pos (gensym))
(n-size (gensym)))
`(progn
(put-header ,type)
(let ((,n-size ,size))
(put-header (+ ,n-size 2))
(let ((,start-pos *next-word*))
(incf *next-word* (* ,n-size 2))
(push #'(lambda ()
(let ((*next-word* ,start-pos))
,@body))
*delayed-header-actions*))))))
;;; Save -- Public
;;;
;;; We fork off a copy of ourselves, which then suspends. The parent
;;; process then figures out what pages of the child want to be saved
;;; by looking at the alloc-table and micro state. The dir-list
;;; list is built to contain this information.
;;; We then scan through the entries to find out how much space we need,
;;; add in a fudge-factor to allow for the size of the header, and then
;;; allocate a piece of memory that big.
;;; After we have this in *file-pointer*, we write out the header,
;;; map the pages we want over, go back and compute the checksum,
;;; and write the file out.
;;; When the child restarts, it reinitializes stuff that wants
;;; reinitialized.
;;;
(defun save (pathname &key (checksum t))
"Save the current lisp core image in a core file. When it returns in
the current process, the number of bytes written is returned.
then the child is resumed, Nil will be returned. If checksum is
supplied and is Nil, then no checksum entry is generated."
(catch 'save
(let* ((namestring (predict-name pathname nil))
(child-kport (do-fork))
(dir-list (make-dir-list child-kport))
(valid-size (do ((l dir-list (cdr l))
(sum max-header-size
(+ sum (dir-entry-count (car l)))))
((null l)
(* sum page-byte-size))))
(address (validate-memory 0 valid-size -1))
(*file-pointer* (%primitive make-immediate-type address %misc-type))
(*next-word* 0)
(*first-data-word* 0)
(*delayed-header-actions* ()))
(write-core-file-header checksum child-kport dir-list)
(write-data-pages child-kport dir-list address)
(terminate child-kport)
(fresh-line)
(let ((*last-data-word* *next-word*))
(dolist (action (nreverse *delayed-header-actions*))
(funcall action))
(format t "Writing core file ~S.~%" namestring)
(let ((byte-size (* *next-word* 2)))
(sesame-error
(prog1
(sub-write-file namestring address byte-size dform-32-bit)
(invalidate-memory address valid-size))
namestring)
byte-size)))))
;;; Write-Core-File-Header -- Internal
;;;
;;; Write out the stuff in the core file header, given the dir-list.
;;; leave room for the checksum entry, and return the offset where
;;; it is to be written.
;;;
(defun write-core-file-header (checksum child-kport dir-list)
(put-header core-file-password)
(write-validate-entry)
(write-register-entry child-kport)
(when checksum
(write-checksum-entry))
(write-dir-list-entry dir-list)
(write-header-entry (end-entry-code)))
;;; WRITE-VALIDATE-ENTRY
;;; WRITE-VALIDATE-ENTRY writes the validate entry to the data area.
;;; The addresses and number of bytes to validate are as follows.
;;; #h00000100 #h1FFFF ; microcode tables
;;; #h02000000 #h20000 ; control stack
;;; #h04000000 #h20000 ; binding stack
;;; ---------- #h20000 ; Don't validate the Accent message area
;;; #h08000000 #h80000 ; Bit vector
;;; #h10000000 #h80000 ; I-Vector
;;; #h18000000 #h80000 ; String
;;; #h20000000 #h80000 ; Bignum
;;; #h28000000 #h80000 ; Long Float
;;; #h30000000 #h80000 ; Complex
;;; #h38000000 #h80000 ; Ratio
;;; #h40000000 #h80000 ; G-Vector
;;; #h48000000 #h80000 ; Function
;;; #h50000000 #h80000 ; Array
;;; #h58000000 #h80000 ; Symbol
;;; #h60000000 #h80000 ; Cons
;;; #h68000000 #h80000 ; Unused
;;; #h70000000 #h80000 ; Unused
;;; #h78000000 #h80000 ; Unused
;;;
(defun write-validate-entry ()
(write-header-entry (validate-entry-code)
(dolist (word '(#x000001 #x1FFFF
#x020000 #x20000
#x040000 #x20000
#x080000 #x80000
#x100000 #x80000
#x180000 #x80000
#x200000 #x80000
#x280000 #x80000
#x300000 #x80000
#x380000 #x80000
#x400000 #x80000
#x480000 #x80000
#x500000 #x80000
#x580000 #x80000
#x600000 #x80000
#x680000 #x80000
#x700000 #x80000
#x780000 #x80000))
(put-header word))))
;;; Write-Register-Entry -- Internal
;;;
;;; Write-Register-Entry dumps the user registers 0..64 and 96..111
;;; (the latter refers to trap-code..resaddr). We set resaddr to the
;;; Spice Lisp microcode Warm Start address.
;;;
(defun write-register-entry (child-kport)
(write-header-entry (user-reg-entry-code)
(put-header 0)
(dotimes (i 65)
(put-header (examine child-kport t i))))
(write-header-entry (user-reg-entry-code)
(put-header 96)
(dotimes (i 15)
(put-header (examine child-kport t (+ 96 i))))
(put-header warm-start-address)))
;;; Write-Dir-List-Entry -- Internal
;;;
;;; Write out the dir-list entry. This has to be delayed, since
;;; the associated file-pages are not known until after the header
;;; has been written.
;;;
(defun write-dir-list-entry (dir-list)
(delayed-write-header-entry (dir-entry-code (* (length dir-list) 3))
(dolist (entry dir-list)
(put-header (dir-entry-file-page entry))
(put-header (dir-entry-process-page entry))
(put-header (dir-entry-count entry)))))
;;; Write-Checksum-Entry -- Internal
;;;
;;; Compute the checksum of the data pages and bash it into the
;;; checksum entry.
;;;
(defun write-checksum-entry ()
(delayed-write-header-entry (checksum-entry-code (/ checksum-size 2))
(let ((cptr (sap+ *file-pointer* *next-word*))
(vptr (sap+ *file-pointer* *first-data-word*))
(words (- *last-data-word* *first-data-word*)))
(write-line "Computing checksum entry for data pages.")
(do* ((carry 0 (%primitive lsh check -13))
(cidx 0 (1+ cidx))
(vidx 0 (1+ vidx)) check)
((= vidx words))
(when (= cidx checksum-size)
(setq cidx 0))
(setq check (%primitive 16bit-system-ref cptr cidx))
(%primitive 16bit-system-set cptr cidx
(logxor (%primitive 16bit-system-ref vptr vidx)
(logior (%primitive lsh check 3) carry)))))))
;;; Make-Dir-List -- Internal
;;;
;;; Returns a list of all the dir-entries. The file-page slots
;;; are not filled in, since they cannot be determined until the header
;;; is written.
;;;
(defun make-dir-list (child-kport)
(list*
(make-dir-entry :process-page (ash alloc-table-start -8)
:count 1)
(make-dir-entry :process-page (ash bugout-table-start -8)
:count 1)
(append (make-stack-dir-list child-kport)
(make-alloc-table-dir-list child-kport))))
;;; Make-Stack-Dir-List -- Internal
;;;
;;; Look at the control and binding stack pointers to determine how
;;; much of each of those to write.
;;;
(defun make-stack-dir-list (child-kport)
(let ((bstack (get-register child-kport binding-stack-pointer))
(cstack (get-register child-kport control-stack-pointer)))
(list
(make-dir-entry :process-page (ash binding-stack-start -8)
:count (ceiling (- bstack binding-stack-start)
page-word-size))
(make-dir-entry :process-page (ash control-stack-start -8)
:count (ceiling (- cstack control-stack-start)
page-word-size)))))
;;; Make-Alloc-Table-Dir-List -- Internal
;;;
;;; Grovel the alloc-table, making dir-list entries for each space
;;; that is non-empty.
;;;
(defun make-alloc-table-dir-list (child-kport)
(multiple-value-bind (cnt data)
(read-process-memory child-kport alloc-table-start
alloc-table-size)
(declare (ignore cnt))
(let ((sap (%primitive make-immediate-type data %misc-type))
(res ()))
(do ((i 1 (1+ i)))
((= i 16))
(dotimes (j 4)
(let* ((address (+ (ash i 27) (ash j 25)))
(index (+ (ash i 4) (ash j 2)))
(free (logior (%primitive 16bit-system-ref sap index)
(ash (%primitive 16bit-system-ref sap (1+ index))
16)))
(pages (ceiling (- free address) page-word-size)))
(when (> pages 0)
(push (make-dir-entry :process-page (ash address -8)
:count pages)
res)))))
res)))
;;; Write-Data-Pages -- Internal
;;;
;;; Scan down the dir-list and copy the specified pages in the child
;;; process into the file area.
;;;
(defun write-data-pages (child-kport dir-list address)
(setq *next-word* (* (ceiling *next-word* page-word-size) page-word-size))
(setq *first-data-word* *next-word*)
(dolist (entry dir-list)
(let ((words (* (dir-entry-count entry) page-word-size))
(source (* (dir-entry-process-page entry) page-word-size)))
(setf (dir-entry-file-page entry)
(truncate (- *next-word* *first-data-word*) page-word-size))
(multiple-value-bind (cnt data)
(read-process-memory child-kport source (* words 2))
(declare (ignore cnt))
(move-words data (+ address *next-word*) words t nil -1 t))
(incf *next-word* words))))
;;; Do-Fork -- Internal
;;;
;;; Do-Fork does the actually forking and if the return code says that
;;; the process is the child process it suspends itself. When the Spice
;;; Lisp process is resumed the necessary init routines are called, and a
;;; throw is done to punt the Save routine.
;;;
(defun do-fork ()
(multiple-value-bind (code port) (fork)
(when (= code is-child)
;; We suspend ourselves in a low-down greasy way because we'll never
;; get the From-Suspend message due us.
(setf (to-suspend-msg-remote-port to-suspend) kernel-port)
(simple-send to-suspend)
(reinit)
(throw 'save nil))
port))