;;; -*- Lisp -*-
;;;
;;; Core image builder for Spice Lisp.
;;; Written by Skef Wholey.
;;;
;;; We gobble up SFASL files, building a virtual memory image in a collection
;;; of blocks in system table space. When we're done and wish to write out the
;;; file, we allocate a block large enough to hold the contents of the memory
;;; image, and twiddle the page map to map the parts of the image consecutively
;;; into this large block, which we then write out as a file.
;;;
(defun get-valid-hunk (size)
(let ((addr (%sp-make-misc (validate-memory 0 (ash size 1) -1))))
(values addr addr)))
;;; Memory accessing.
;;; The virtual address space is divided into 64 pieces.
(defvar number-of-spaces 64 "Number of pointer-type spaces.")
;;; The initial size of spaces will be 512K words. If we need more than this,
;;; the following constant will have to be changed.
(defvar space-size 524288 "Number of 16-bit words in each space.")
;;; Each space is represented as a structure containing the address of its
;;; data in system space and the number of words used so far in it.
(defstruct (space (:print-function print-a-space))
address
real-address
free-pointer)
(defun print-a-space (space stream depth)
depth
(write-string "#<SPACE, address = " stream)
(prin1 (%sp-make-fixnum (space-address space)) stream)
(write-char #\> stream))
;;; The type codes:
(defvar bit-vector-ltype 1)
(defvar integer-vector-ltype 2)
(defvar string-ltype 3)
(defvar bignum-ltype 4)
(defvar long-float-ltype 5)
(defvar complex-ltype 6)
(defvar ratio-ltype 7)
(defvar general-vector-ltype 8)
(defvar function-ltype 9)
(defvar array-ltype 10)
(defvar symbol-ltype 11)
(defvar list-ltype 12)
(defvar +-fixnum-ltype 16)
(defvar --fixnum-ltype 17)
(defvar fixnum-4bit-ltype 8)
(defvar +-short-float-ltype 18)
(defvar --short-float-ltype 19)
(defvar character-ltype 20)
(defvar values-marker-ltype 21)
(defvar call-header-ltype 22)
(defvar catch-header-ltype 23)
(defvar catch-all-ltype 24)
(defvar gc-forward-ltype 25)
;;; The subspace codes:
(defvar dynamic-space 0)
(defvar static-space 2)
(defvar read-only-space 3)
;;; Macros to construct space numbers from a type and subspace.
(defmacro dynamic (type)
`(logior (ash ,type 2) dynamic-space))
(defmacro static (type)
`(logior (ash ,type 2) static-space))
(defmacro read-only (type)
`(logior (ash ,type 2) read-only-space))
;;; Used-Spaces is a list of the spaces we allocate stuff for.
(defparameter used-spaces
(list (dynamic bit-vector-ltype)
(dynamic integer-vector-ltype)
(dynamic string-ltype)
(static string-ltype)
(dynamic bignum-ltype)
(dynamic long-float-ltype)
(dynamic complex-ltype)
(dynamic ratio-ltype)
(dynamic general-vector-ltype)
(dynamic function-ltype)
(dynamic array-ltype)
(static symbol-ltype)
(dynamic list-ltype)))
;;; Memory is a vector of these spaces. If a space is non-existent or is not
;;; used in cold load, NIL will be stored in the corresponding location instead
;;; of a space structure.
(defvar memory (make-array number-of-spaces))
(defvar *genesis-memory-initialized* nil)
(defun initialize-memory ()
(unless *genesis-memory-initialized*
(setq *genesis-memory-initialized* t)
(do ((spaces used-spaces (cdr spaces)))
((null spaces))
(multiple-value-bind (hunk addr)
(get-valid-hunk space-size)
(setf (svref memory (car spaces))
(make-space :address hunk
:real-address addr
:free-pointer (cons (ash (car spaces) 9) 0)))))))
(defun initialize-spaces ()
(do ((spaces used-spaces (cdr spaces)))
((null spaces))
(setf (space-free-pointer (svref memory (car spaces)))
(cons (ash (car spaces) 9) 0))))
;;; Since Spice Lisp objects are 32-bits wide, and Spice Lisp integers are only
;;; 28-bits wide, we use the following scheme to represent the 32-bit objects
;;; in the image being built. In the core image builder, we can have a handle
;;; on a 32-bit object, which is a cons of two 16-bit numbers, the high order
;;; word in the CAR, and the low order word in the CDR. We provide some macros
;;; to manipulate these handles.
(defmacro handle-on (high low)
`(cons ,high ,low))
(defun handle-beyond (handle offset)
(let ((new (+ (cdr handle) offset)))
(if (> new 65535)
(cons (+ (car handle) (ash new -16)) (logand new 65535))
(cons (car handle) new))))
(defun bump-handle (handle offset)
(let ((new (+ (cdr handle) offset)))
(if (> new 65535)
(setf (car handle) (+ (car handle) (ash new -16))
(cdr handle) (logand new 65535))
(setf (cdr handle) new))))
(defun copy-handle (handle)
(cons (car handle) (cdr handle)))
(defun handle< (han1 han2)
(or (< (car han1) (car han2))
(and (= (car han1) (car han2))
(< (cdr han1) (cdr han2)))))
(defun handle-offset (handle)
(logior (ash (logand (car handle) 511) 16) (cdr handle)))
(defmacro build-object (type bits)
`(let ((bits ,bits))
(handle-on (logior (ash ,type 11) (ldb (byte 11 16) bits))
(logand bits 65535))))
(defmacro build-object* (type bits)
`(let ((bits ,bits))
(handle-on (logior (ash ,type 12) (ldb (byte 12 16) bits))
(logand bits 65535))))
(defmacro build-sub-object (type subtype bits)
`(let ((bits ,bits))
(handle-on (logior (ash ,type 11)
(logior (ash ,subtype 8) (ldb (byte 8 16) bits)))
(logand bits 65535))))
(defvar trap-handle (handle-on #x+0000 0000) "Handle on the trap object.")
(defvar nil-handle (handle-on #x+5C00 0000) "Handle on Nil.")
;;; Write-Memory writes the Object (identified by a handle) into the given
;;; Address (also a handle).
(defun write-memory (address object)
(let ((high (car address))
(low (cdr address)))
(if (ldb-test (byte 1 15) high)
(error "Address ~S,,~S is not a pointer address." high low)
(let* ((space-number (ldb (byte 6 9) high))
(offset (handle-offset address))
(space (svref memory space-number)))
(if space
(if (handle< address (space-free-pointer space))
(let ((saddress (space-address space)))
(%primitive 16bit-system-set saddress offset (cdr object))
(%primitive 16bit-system-set saddress (+ offset 1) (car object)))
(error "No object at ~S,,~S has been allocated." high low))
(error "The space for address ~S,,~S does not exist."
high low))))))
;;; Read-Memory returns a handle to an object read from the given Address.
(defun read-memory (address)
(let ((high (car address))
(low (cdr address)))
(if (ldb-test (byte 1 15) high)
(error "Address ~S,,~S is not a pointer address." high low)
(let* ((space-number (ldb (byte 6 9) high))
(offset (handle-offset address))
(space (svref memory space-number)))
(if space
(if (handle< address (space-free-pointer space))
(let ((saddress (space-address space)))
(handle-on (%primitive 16bit-system-ref saddress (1+ offset))
(%primitive 16bit-system-ref saddress offset)))
(error "No object at ~S,,~S has been allocated." high low))
(error "The space for address ~S,,~S does not exist."
high low))))))
;;; Write-Indexed is used to write into g-vector-like things.
(defun write-indexed (address index value)
(write-memory (handle-beyond address (+ (ash index 1) 2)) value))
;;; Allocating primitive objects.
;;; Allocate-Boxed-Object returns a handle to an object allocated in the
;;; space of the given Space-Number with the given Length. No header words are
;;; initialized, and the Length should include the length of the header. The
;;; free pointer for the Space is incremented and quadword alligned.
(defun allocate-boxed-object (space-number length)
(let ((space (svref memory space-number)))
(if space
(let* ((start (space-free-pointer space))
(result (copy-handle start)))
(bump-handle start (+ (ash length 1) (if (oddp length) 2 0)))
result)
(error "Space ~S does not exist." space-number))))
;;; Allocate-Unboxed-Object returns a handle to an object allocated in the
;;; space of the given Space-Number with the given Byte-Size and Length in
;;; bytes of that size. The 2 unboxed object header words are initialized
;;; with the optional Subtype code.
(defun allocate-unboxed-object (space-number byte-size size subtype)
(let ((space (svref memory space-number)))
(if space
(let* ((start (space-free-pointer space))
(result (copy-handle start))
(length (+ 2 (ceiling size (/ 32 byte-size)))))
(bump-handle start (+ (ash length 1) (if (oddp length) 2 0)))
(write-memory result
(build-sub-object +-fixnum-ltype subtype length))
(write-memory (handle-beyond result 2)
(build-object (ash (access-type byte-size) 1) size))
result)
(error "Space ~S does not exist." space-number))))
;;; Access-Type returns the I-Vector access type for a given Byte-Size.
(defun access-type (byte-size)
(let ((access-type (cdr (assoc byte-size '((1 . 0) (2 . 1) (4 . 2)
(8 . 3) (16 . 4))))))
(if access-type access-type
(error "Invalid I-Vector byte size, ~S." byte-size))))
;;; I-Vector-To-Core copies the contents of the given unboxed thing into
;;; the virtual memory image in the space with the give Space-Number, returning
;;; a handle to the new object.
(defun i-vector-to-core (space-number byte-size size subtype thing)
(let* ((dest (allocate-unboxed-object space-number byte-size size subtype))
(byte-count (ash (ceiling size (/ 16 byte-size)) 1))
(offset (handle-offset dest))
(dest-byte-addr (+ offset offset 8)))
(%sp-byte-blt thing 0
(space-address (svref memory space-number))
dest-byte-addr (+ dest-byte-addr byte-count))
dest))
;;; Number-To-Core copies the given number to the virutal memory image,
;;; returning a handle to it.
(defun number-to-core (thing)
(typecase thing
(fixnum (handle-on (logior #x+8000 (%sp-logldb 12 16 thing))
(logand thing 65535)))
(bignum (i-vector-to-core (dynamic bignum-ltype) 8
(%sp-get-vector-length thing) 0 thing))
(long-float (write-line "Bogus long-float ignored.")
trap-handle)
; (long-float (error "Can't hack long-floats in cold load!"))
(ratio (let ((dest (allocate-boxed-object (read-only ratio-ltype) 2)))
(write-memory dest (number-to-core (numerator thing)))
(write-memory (handle-beyond dest 2)
(number-to-core (numerator thing)))
dest))
(short-float (let ((thing (%sp-make-fixnum thing)))
(handle-on (logior #x+9000 (%sp-logldb 12 16 thing))
(logand thing 65535))))
(t (error "~S isn't a cold-loadable number at all!" thing))))
;;; Allocate-G-Vector allocates a G-Vector of the given Length and writes
;;; the header word.
(defun allocate-g-vector (space-number length &optional (subtype 0))
(let* ((length (+ length 1))
(dest (allocate-boxed-object space-number length)))
(write-memory dest (build-sub-object +-fixnum-ltype subtype length))
dest))
;;; Allocate-Cons allocates a cons and fills it with the given stuff.
(defun allocate-cons (space-number car cdr)
(let ((dest (allocate-boxed-object space-number 2)))
(write-memory dest car)
(write-memory (handle-beyond dest 2) cdr)
dest))
;;; Allocate-Symbol allocates a symbol and fills its print name cell and
;;; property list cell.
(defun allocate-symbol (name)
(declare (simple-string name))
(let ((dest (allocate-boxed-object (static symbol-ltype) 6)))
(write-memory (handle-beyond dest 4) nil-handle)
(write-memory (handle-beyond dest 6)
(i-vector-to-core (static string-ltype) 8 (length name) 0 name))
dest))
;;; Interning.
;;; We build two lists: a list of Lisp package symbols and a list of Keyword
;;; package symbols. When the lisp process first comes to life, it must
;;; intern all of the symbols in these lists. This way, the cold loader
;;; doesn't need to know about package format and hash table format and all
;;; that awful stuff. Since the initial symbols are allocated before we can
;;; intern anything, we intern those here. We also set the values of T and
;;; Nil.
(defvar initial-symbols '(nil t %sp-internal-apply %sp-internal-error
%sp-software-interrupt-handler
%sp-internal-throw-tag
%initial-function
*initial-lisp-symbols*
*initial-keyword-symbols*
*lisp-initialization-functions*)
"Symbols that must be allocated first in Lisp.")
(defvar coldly-interned-symbols ()
"List of symbols that have been interned in the core image.")
(defvar current-lisp-symbols-cons nil-handle
"Head of the list of symbols that want to be in the Lisp package.")
(defvar current-keyword-symbols-cons nil-handle
"Head of the list of symbols that want to be in the Keyword package.")
(defvar current-init-functions-cons nil-handle
"Head of list of functions to be called when the Lisp starts up.")
(defmacro cold-push (thing list)
"Generates code to push the Thing onto the given cold load List."
`(setq ,list (allocate-cons (dynamic list-ltype) ,thing ,list)))
(defun initialize-symbols ()
"Initilizes the cold load symbol-hacking data structures."
(setq current-lisp-symbols-cons nil-handle)
(setq current-keyword-symbols-cons nil-handle)
(setq current-init-functions-cons nil-handle)
(dolist (symbol initial-symbols)
(setf (get symbol 'handle) (allocate-symbol (symbol-name symbol))))
(write-memory (get 'nil 'handle) nil-handle)
(write-memory (get 't 'handle) (get 't 'handle))
(dolist (symbol initial-symbols)
(push symbol coldly-interned-symbols)
(cold-push (get symbol 'handle) current-lisp-symbols-cons)))
;;; Finish Symbol sets the values of *Initial-Lisp-Symbols* and
;;; *Initial-Keyword-Symbols*, which are used to intern everything when
;;; the Lisp is fired up.
(defun finish-symbols ()
(write-memory (get '*initial-lisp-symbols* 'handle)
current-lisp-symbols-cons)
(write-memory (get '*initial-keyword-symbols* 'handle)
current-keyword-symbols-cons)
(write-memory (get '*lisp-initialization-functions* 'handle)
current-init-functions-cons))
;;; Cold-Intern records the address of the symbol for our use, and puts
;;; it in either the Lisp symbols list or the Keyword symbols list for
;;; the use of the Lisp that we're building.
(defun cold-intern (name)
(or (get name 'handle)
(let ((symbol (allocate-symbol (symbol-name name))))
(push name coldly-interned-symbols)
(setf (get name 'handle) symbol)
(cond ((eq (symbol-package name) *lisp-package*)
(cold-push (get name 'handle) current-lisp-symbols-cons))
((eq (symbol-package name) *keyword-package*)
(cold-push (get name 'handle) current-keyword-symbols-cons))
(t
(error "Can't cold load symbols not in Lisp or Keyword.")))
symbol)))
;;; The Bugout table.
(defconstant escape-routines
'((%Sp-BitAnd-Escape 0)
(%Sp-BitXor-Escape 1)
(%Sp-BitOr-Escape 2)
(%Sp-Negate-Escape 3)
(%Sp-Abs-Escape 4)
(%Sp-Sfloat-Escape 6)
(%Sp-Lfloat-Escape 7)
(%Sp-Equal-Escape 8)
(%Sp-GreaterThan-Escape 9)
(%Sp-LessThan-Escape 10)
(%Sp-AddOne-Escape 11)
(%Sp-SubtractOne-Escape 12)
(%Sp-Add-Escape 13)
(%Sp-Subtract-Escape 14)
(%Sp-Trunc-Escape 15)
(%Sp-Multiply-Escape 16)
(%Sp-Divide-Escape 17)
(%Sp-Ldb-Escape 18)
(%Sp-MaskField-Escape 19)
(%Sp-Dpb-Escape 20)
(%Sp-DepositField-Escape 21)
(%Sp-Ash-Escape 22)
(%Sp-IntegerLength-Escape 23)
(%Sp-Assoc-Escape 24)
(%Sp-Member-Escape 25)
(%Sp-Byte-BLT-Escape 26)))
;;; The escape routine (or ``bugout'') table is initialized by
;;; Write-Initial-Core-File. It begins at address #X20000.
;;; Reading SFASL files.
(declare (special fop-functions))
(defvar cold-fop-functions (make-vector 256) "FOP functions for cold loading.")
(defmacro fop-fun (&rest forms)
`#'(lambda () ,@forms))
(defun define-cold-fop (op name arglen function)
(declare (fixnum op))
"Like Define-Fop, but for cold load."
name arglen
(setf (svref cold-fop-functions op) function))
(defun initialize-cold-fops ()
(define-cold-fop 0 'fop-nop 0
(fop-fun))
(define-cold-fop 1 'fop-pop 0
(fop-fun (push-table (pop-stack))))
(define-cold-fop 2 'fop-push 4
(fop-fun (push-stack (svref *current-fop-table* load-operand))))
(define-cold-fop 3 'fop-byte-push 1
(fop-fun (push-stack (svref *current-fop-table* load-operand))))
(define-cold-fop 4 'fop-empty-list 0
(fop-fun (push-stack (get 'nil 'handle))))
(define-cold-fop 5 'fop-truth 0
(fop-fun (push-stack (get 't 'handle))))
(define-cold-fop 6 'fop-symbol-save 4
(fop-fun (push-stack (cold-load-symbol *package*))
(push-table (top-stack))))
(define-cold-fop 7 'fop-small-symbol-save 1
(fop-fun (push-stack (cold-load-symbol *package*))
(push-table (top-stack))))
(define-cold-fop 8 'fop-symbol-in-package-save 4
(fop-fun (push-stack (cold-load-symbol
(prog1 (svref *current-fop-table* load-operand)
(setq load-operand (load-u-integer 4)))))
(push-table (top-stack))))
(define-cold-fop 9 'fop-small-symbol-in-package-save 4
(fop-fun (push-stack (cold-load-symbol
(prog1 (svref *current-fop-table* load-operand)
(setq load-operand (load-u-integer 1)))))
(push-table (top-stack))))
(define-cold-fop 10 'fop-symbol-in-byte-package-save 1
(fop-fun (push-stack (cold-load-symbol
(prog1 (svref *current-fop-table* load-operand)
(setq load-operand (load-u-integer 4)))))
(push-table (top-stack))))
(define-cold-fop 11 'fop-small-symbol-in-byte-package-save 1
(fop-fun (push-stack (cold-load-symbol
(prog1 (svref *current-fop-table* load-operand)
(setq load-operand (load-u-integer 1)))))
(push-table (top-stack))))
(define-cold-fop 12 'fop-uninterned-symbol-save 4
(fop-fun (push-stack (cold-load-uninterned-symbol))
(push-table (top-stack))))
(define-cold-fop 13 'fop-uninterned-small-symbol-save 1
(fop-fun (push-stack (cold-load-uninterned-symbol))
(push-table (top-stack))))
(define-cold-fop 14 'fop-package 0
(fop-fun (push-stack (package (pop-stack)))))
(define-cold-fop 15 'fop-list 1
(fop-fun (push-stack (cold-stack-list load-operand nil-handle))))
(define-cold-fop 16 'fop-list* 1
(fop-fun (push-stack (cold-stack-list load-operand (pop-stack)))))
(define-cold-fop 17 'fop-list-1 0
(fop-fun (push-stack (cold-stack-list 1 nil-handle))))
(define-cold-fop 18 'fop-list-2 0
(fop-fun (push-stack (cold-stack-list 2 nil-handle))))
(define-cold-fop 19 'fop-list-3 0
(fop-fun (push-stack (cold-stack-list 3 nil-handle))))
(define-cold-fop 20 'fop-list-4 0
(fop-fun (push-stack (cold-stack-list 4 nil-handle))))
(define-cold-fop 21 'fop-list-5 0
(fop-fun (push-stack (cold-stack-list 5 nil-handle))))
(define-cold-fop 22 'fop-list-6 0
(fop-fun (push-stack (cold-stack-list 6 nil-handle))))
(define-cold-fop 23 'fop-list-7 0
(fop-fun (push-stack (cold-stack-list 7 nil-handle))))
(define-cold-fop 24 'fop-list-8 0
(fop-fun (push-stack (cold-stack-list 8 nil-handle))))
(define-cold-fop 25 'fop-list*-1 0
(fop-fun (push-stack (cold-stack-list 1 (pop-stack)))))
(define-cold-fop 26 'fop-list*-2 0
(fop-fun (push-stack (cold-stack-list 2 (pop-stack)))))
(define-cold-fop 27 'fop-list*-3 0
(fop-fun (push-stack (cold-stack-list 3 (pop-stack)))))
(define-cold-fop 28 'fop-list*-4 0
(fop-fun (push-stack (cold-stack-list 4 (pop-stack)))))
(define-cold-fop 29 'fop-list*-5 0
(fop-fun (push-stack (cold-stack-list 5 (pop-stack)))))
(define-cold-fop 30 'fop-list*-6 0
(fop-fun (push-stack (cold-stack-list 6 (pop-stack)))))
(define-cold-fop 31 'fop-list*-7 0
(fop-fun (push-stack (cold-stack-list 7 (pop-stack)))))
(define-cold-fop 32 'fop-list*-8 0
(fop-fun (push-stack (cold-stack-list 8 (pop-stack)))))
(define-cold-fop 33 'fop-integer 4
(fop-fun (push-stack (number-to-core (load-s-integer load-operand)))))
(define-cold-fop 34 'fop-small-integer 1
(fop-fun (push-stack (number-to-core (load-s-integer load-operand)))))
(define-cold-fop 35 'fop-word-integer 0
(fop-fun (push-stack (number-to-core (load-s-integer 4)))))
(define-cold-fop 36 'fop-byte-integer 0
(fop-fun (push-stack (build-object* fixnum-4bit-ltype
(load-s-integer 1)))))
(define-cold-fop 37 'fop-string 4
(fop-fun (push-stack
(let ((string (load-string)))
(declare (simple-string string))
(i-vector-to-core (dynamic string-ltype) 8 (length string) 0
string)))))
(define-cold-fop 38 'fop-small-string 1
(fop-fun (push-stack
(let ((string (load-string)))
(declare (simple-string string))
(i-vector-to-core (dynamic string-ltype) 8 (length string) 0
string)))))
(define-cold-fop 39 'fop-vector 4
(fop-fun (push-stack (cold-stack-vector))))
(define-cold-fop 40 'fop-small-vector 1
(fop-fun (push-stack (cold-stack-vector))))
(define-cold-fop 41 'fop-uniform-vector 4
(fop-fun (push-stack (cold-stack-uniform-vector))))
(define-cold-fop 42 'fop-small-uniform-vector 1
(fop-fun (push-stack (cold-stack-uniform-vector))))
(define-cold-fop 43 'fop-int-vector 4
(fop-fun (push-stack (cold-stack-int-vector))))
(define-cold-fop 44 'fop-uniform-int-vector 4
(fop-fun (push-stack (cold-stack-uniform-int-vector))))
(define-cold-fop 45 'fop-float 0
(fop-fun (push-stack (number-to-core (load-float)))))
(define-cold-fop 52 'fop-alter 1
(fop-fun (error "FOP-ALTER is out of style.")))
;; We have to make *keyword-package* be evaluable. Stick real package object
;; in table when we eval it.
(define-cold-fop 53 'fop-eval 0
(fop-fun (if (not (equal (pop-stack) (get '*keyword-package* 'handle)))
(error "Can't FOP-EVAL in cold load."))
(push-stack *keyword-package*)))
(define-cold-fop 54 'fop-eval-for-effect 0
(fop-fun (error "Can't FOP-EVAL in cold load.")))
(define-cold-fop 55 'fop-funcall 1
(fop-fun (error "Can't FOP-FUNCALL in cold load.")))
(define-cold-fop 56 'fop-funcall-for-effect 1
(fop-fun (if (= load-operand 0)
(cold-push (pop-stack) current-init-functions-cons)
(error "Can't FOP-FUNCALL random stuff in cold load."))))
(define-cold-fop 57 'fop-code-format 1
(fop-fun (setq current-code-format load-operand)))
(define-cold-fop 58 'fop-code 4
(fop-fun (if (= current-code-format %fasl-code-format)
(push-stack (cold-load-function
load-operand (load-u-integer 4)))
(error "~S: Bad code format for this implementation"
current-code-format))))
(define-cold-fop 59 'fop-small-code 1
(fop-fun (if (eql current-code-format %fasl-code-format)
(push-stack (cold-load-function
load-operand (load-u-integer 2)))
(error "~S: Bad code format for this implementation"
current-code-format))))
(define-cold-fop 60 'fop-static-heap 0
(fop-fun (setq current-space static-space)))
(define-cold-fop 61 'fop-dynamic-heap 0
(fop-fun (setq current-space dynamic-space)))
(define-cold-fop 62 'fop-verify-table-size 4
(fop-fun (if (/= *current-fop-table-index* load-operand)
(error "~S: Fasl table of improper size. Bug!"))))
(define-cold-fop 63 'fop-verify-empty-stack 0
(fop-fun (if (/= *fop-stack-index* *fop-stack-index-on-entry*)
(error "Fasl stack not empty. Bug!"))))
(define-cold-fop 64 'fop-end-group 0
(fop-fun))
(define-cold-fop 65 'fop-pop-for-effect 0
(fop-fun (pop-stack)))
(define-cold-fop 66 'fop-misc-trap 0
(fop-fun (push-stack trap-handle)))
(define-cold-fop 67 'fop-read-only-heap 0
(fop-fun (setq current-space read-only-space)))
(define-cold-fop 68 'fop-character 3
(fop-fun (push-stack (build-object character-ltype load-operand))))
(define-cold-fop 69 'fop-short-character 1
(fop-fun (push-stack (build-object character-ltype load-operand))))
(define-cold-fop 70 'fop-ratio 0
(fop-fun (push-stack
(number-to-core
(let ((den (pop-stack)))
(%primitive make-ratio (pop-stack) den))))))
(define-cold-fop 71 'fop-complex 0
(fop-fun (error "Complex numbers not supported in this implementation.")))
(define-cold-fop 72 'fop-some-vax-foo 0
(fop-fun (error "This FOP makes no sense on a Perq!")))
(define-cold-fop 73 'fop-some-vax-foo 0
(fop-fun (error "This FOP makes no sense on a Perq!")))
(define-cold-fop 74 'fop-fset 0
(fop-fun (let ((function (pop-stack)))
(write-memory (handle-beyond (pop-stack) 2)
function))))
(define-cold-fop 75 'fop-lisp-symbol-save 4
(fop-fun (push-stack (cold-load-symbol *lisp-package*))
(push-table (top-stack))))
(define-cold-fop 76 'fop-lisp-small-symbol-save 1
(fop-fun (push-stack (cold-load-symbol *lisp-package*))
(push-table (top-stack))))
(define-cold-fop 77 'fop-keyword-symbol-save 4
(fop-fun (push-stack (cold-load-symbol *keyword-package*))
(push-table (top-stack))))
(define-cold-fop 78 'fop-keyword-small-symbol-save 1
(fop-fun (push-stack (cold-load-symbol *keyword-package*))
(push-table (top-stack))))
(do ((index 79 (1+ index)))
((= index 255))
(define-cold-fop index 'losing-fop 0
`(lambda () (error "~S: Losing FaslOP!" ,index))))
(define-cold-fop 255 'fop-end-header 0
(fop-fun)))
(initialize-cold-fops)
;;; Cold-Load-Symbol loads a symbol N characters long from the File and interns
;;; that symbol in the given Package.
(defun cold-load-symbol (package)
(cold-intern (intern (load-string) package)))
(defun cold-load-uninterned-symbol ()
(let ((symbol (allocate-symbol (load-string))))
(write-memory (handle-beyond symbol 8) nil-handle)
symbol))
;;; Cold-Stack-List makes a list of the top Length things on the Fop-Stack.
;;; The last cdr of the list is set to Last. We make the list in read-only
;;; space.
(defun cold-stack-list (length last)
(declare (fixnum length))
(do* ((index length (1- index))
(result last (allocate-cons (dynamic list-ltype) (pop-stack) result)))
((= index 0) result)
(declare (fixnum index))))
;;; Cold-Stack-Vector makes a vector of the top Load-operand things on the
;;; Fop-Stack.
(defun cold-stack-vector ()
(do ((index (1- load-operand) (1- index))
(result (allocate-g-vector (dynamic general-vector-ltype) load-operand)))
((< index 0) result)
(declare (fixnum index))
(declare (simple-vector result))
(write-indexed result index (pop-stack))))
;;; Cold-Stack-Uniform-Vector fills a vector N long with the top of the
;;; Fop-Stack.
(defun cold-stack-uniform-vector ()
(error "I didn't think anyone ever used this!"))
;;; Cold-Stack-Int-Vector is hairy...@@@@
(defun cold-stack-int-vector ()
())
;;; Cold-Stack-Uniform-Int-Vector is less hairy...@@@@
(defun cold-stack-uniform-int-vector ()
())
;;; Cold-Load-Function loads a function object. Box-Num objects are popped off
;;; the stack for the boxed storage section, then code-length bytes of code are
;;; read in.
(defun cold-load-function (box-num code-length)
(declare (fixnum box-num code-length))
(let ((function (allocate-g-vector (dynamic function-ltype) box-num)))
(do ((index (1- box-num) (1- index))) ;symbols and constants
((= index 4))
(write-indexed function index (pop-stack)))
(write-indexed function 4 (pop-stack)) ; arg vector
(write-indexed function 3 (pop-stack)) ; name of function
(write-indexed function 2 (pop-stack)) ; arg info
(write-indexed function 1 (pop-stack)) ; place for code
(write-indexed function 0 (pop-stack)) ; function info
(let ((code (%sp-alloc-u-vector code-length 3)))
(read-n-bytes fop-file code 0 code-length)
(write-indexed function 1
(i-vector-to-core (dynamic integer-vector-ltype) 8 code-length
1 code)))
function))
;;; Cold-Load loads stuff into the core image being built by rebinding
;;; the Fop-Functions table to a table of cold loading functions.
(defun cold-load (filename)
"Loads the file named by FileName into the cold load image being built."
(let ((fop-functions cold-fop-functions))
(load filename)))
;;; Writing the core file.
;;; We assume here that the directory will fit on one page, make the
;;; alloc table be the first data page, and make the escape routine table
;;; the second data page. So the length of the file is the length of all
;;; of the stuff in the used spaces plus 3 pages.
(defun write-initial-core-file (name)
(let ((data-pages 3)
(nonempty-spaces 0)
(word-length))
(do ((spaces used-spaces (cdr spaces)))
((null spaces))
(let ((free (handle-offset
(space-free-pointer (svref memory (car spaces))))))
(when (> free 0)
(incf nonempty-spaces)
(incf data-pages (1+ (ash free -8))))))
(setq word-length (ash data-pages 8))
(multiple-value-bind (hunk addr)
(get-valid-hunk word-length)
;; Write the CORE file password.
(%primitive 16bit-system-set hunk 0 #x+5245)
(%primitive 16bit-system-set hunk 1 #x+434F)
;; Write the directory header entry.
(%primitive 16bit-system-set hunk 2 3841)
(%primitive 16bit-system-set hunk 3 0)
(%primitive 16bit-system-set hunk 4 (+ 2 (* 3 (+ nonempty-spaces 2))))
(%primitive 16bit-system-set hunk 5 0)
;; First, an entry for the alloc table.
(%primitive 16bit-system-set hunk 6 0) ; Data page
(%primitive 16bit-system-set hunk 7 0)
(%primitive 16bit-system-set hunk 8 256) ; Process page
(%primitive 16bit-system-set hunk 9 0)
(%primitive 16bit-system-set hunk 10 1) ; Page count
(%primitive 16bit-system-set hunk 11 0)
;; Next, an entry for the escape routine table.
(%primitive 16bit-system-set hunk 12 1) ; Data page
(%primitive 16bit-system-set hunk 13 0)
(%primitive 16bit-system-set hunk 14 512); Process page
(%primitive 16bit-system-set hunk 15 0)
(%primitive 16bit-system-set hunk 16 1) ; Page count
(%primitive 16bit-system-set hunk 17 0)
;; Construct the alloc table, with both free and clean pointers.
(do ((space (ash %bit-vector-type 2) (1+ space)))
((> space (+ (ash %list-type 2) 3)))
(let ((alloc-index (+ 256 (ash space 2))))
(cond ((svref memory space)
(let ((free (handle-offset
(space-free-pointer (svref memory space)))))
(%primitive 16bit-system-set hunk alloc-index
(logand free 65535))
(%primitive 16bit-system-set hunk (+ alloc-index 1)
(logior (ash space 9) (ash free -16)))
(%primitive 16bit-system-set hunk (+ alloc-index 2) 0)
(%primitive 16bit-system-set hunk (+ alloc-index 3)
(ash space 9))))
(t
(%primitive 16bit-system-set hunk alloc-index 0)
(%primitive 16bit-system-set hunk (+ alloc-index 1)
(ash space 9))
(%primitive 16bit-system-set hunk (+ alloc-index 2) 0)
(%primitive 16bit-system-set hunk (+ alloc-index 3)
(ash space 9))))))
;; Now construct the escape routine table.
(dolist (routine escape-routines)
(let ((name (get (car routine) 'handle))
(number (+ 512 (ash (cadr routine) 1))))
(cond (name
(%primitive 16bit-system-set hunk number (cdr name))
(%primitive 16bit-system-set hunk (1+ number) (car name)))
(t
(format t "~&Warning: ~S is not defined in this core image."
(car routine))))))
;; Then, write entries for each space.
(do ((spaces used-spaces (cdr spaces))
(data-page 2)
(index 18))
((null spaces)
;; Finally, the end of header code.
(%primitive 16bit-system-set hunk index 3840)
(%primitive 16bit-system-set hunk (+ index 1) 0)
(%primitive 16bit-system-set hunk (+ index 2) 2)
(%primitive 16bit-system-set hunk (+ index 3) 0))
(let* ((space (car spaces))
(free (handle-offset
(space-free-pointer (svref memory space)))))
(if (> free 0)
(let ((process-page (ash space 1))
(page-count (1+ (ash free -8))))
;; Make the directory entry.
(%primitive 16bit-system-set hunk index data-page)
(%primitive 16bit-system-set hunk (+ index 1) 0)
(%primitive 16bit-system-set hunk (+ index 2) 0)
(%primitive 16bit-system-set hunk (+ index 3) process-page)
(%primitive 16bit-system-set hunk (+ index 4) page-count)
(%primitive 16bit-system-set hunk (+ index 5) 0)
(format t "~S pages from space ~S.~%" page-count space)
;; Move the words into the file.
(move-words (%sp-make-fixnum
(space-real-address (svref memory space)))
(+ (%sp-make-fixnum addr) (ash (1+ data-page) 8))
(ash page-count 8)
nil
nil
-1
())
(incf data-page page-count)
(incf index 6)))))
(format t "Writing ~A.~%(Type a space when the paging has stopped)~%"
name)
(get-event 2)
(sub-write-file name (%sp-make-fixnum addr) (ash word-length 1) 0)
(write-line "Done!")
t)))
;;; Cleanup.
(defun clean-up-genesis ()
(dolist (symbol coldly-interned-symbols)
(remprop symbol 'handle))
(setq coldly-interned-symbols nil))
;;; Top level.
(defun genesis (file-list core-name)
"Builds a kernel Lisp image from the .SFASL files specified in the given
File-List and writes it to a file named by Core-Name."
(fresh-line)
(clean-up-genesis)
(initialize-memory)
(initialize-spaces)
(initialize-symbols)
(dolist (file file-list)
(write-line file)
(cold-load file))
(finish-symbols)
(write-initial-core-file core-name))