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