;;; -*- Mode:LISP; Package:K-COLD; Compile-In-Roots:(K-GLOBAL); Readtable:CL; Base:10 -*-

;;;; Cold Loader

;;; Builds a Cold Load

(defvar *cold-data-size* (ash 15. 10.) ;15 clusters
  "Size of cold load data space in words")

(defvar *cold-data* (make-array (ash *cold-data-size* 2)
				     :element-type '(unsigned-byte 16.)))

(defvar *cold-code-size* (ash 32. 10.)  ;32 clusters
  "Size of cold load code space in words")

(defvar *cold-code* (make-array (ash *cold-code-size* 2)
				     :element-type '(unsigned-byte 16.)))

(defconstant cold-code-start 0)

(defvar *cold-code-pointer* cold-code-start)
(defvar *cold-loaded-functions* '())
(defvar *cold-eval-list* '())

(defmacro cold-data-read (address)
  `(let ((.address. (ash ,address 1)))
     (logior (aref *cold-data* .address.)
	     (ash (aref *cold-data* (1+ .address.))
		  16.))))

(defmacro cold-data-write (address data)
  `(let ((.address. (ash ,address 1))
	 (.data. ,data))
     (setf (aref *cold-data* .address.)      (logand .data. #xFFFF))
     (setf (aref *cold-data* (1+ .address.)) (ash .data. -16.))))


(defun cold-code-read (code-address)
  (let ((address (ash code-address 2)))
    (logior (aref *cold-code* address)
	    (ash (aref *cold-code* (+ address 1)) 16.)
	    (ash (aref *cold-code* (+ address 2)) 32.)
	    (ash (aref *cold-code* (+ address 3)) 48.))))

(defun cold-code-write (code-address data)
  (let ((address (ash code-address 2)))
    (setf (aref *cold-code* address)       (ldb (byte 16. 0) data))
    (setf (aref *cold-code* (+ 1 address)) (ldb (byte 16. 16.) data))
    (setf (aref *cold-code* (+ 2 address)) (ldb (byte 16. 32.) data))
    (setf (aref *cold-code* (+ 3 address)) (ldb (byte 16. 48.) data))))



;;;; Cold Load Initial Code

(defvar *file-being-cold-loaded* nil "Pathname of the file being cold loaded.")
(defvar *cold-files-loaded* '())
(defvar *cold-functions-loaded* '())

(defun cold-loader-forget-everything ()
 ;called manually by user.
  (setq *cold-code-pointer* cold-code-start)
  (setq *cold-loaded-functions* nil)
  (setq *cold-eval-list* nil)
  (setq *cold-functions-loaded* nil)
  (setq *cold-files-loaded* nil)
  (dotimes (c (si:array-length *cold-data*))
    (setf (aref *cold-data* c) 0))
  (dotimes (c (si:array-length *cold-code*))
    (setf (aref *cold-code* c) 0))
  (user#:reset-cold-warm-hot-files))		; $$$ Put in correct package. <07-Nov-88 wkf>


(defun same-file-except-for-version (file1 file2)
  (eq (zl:send file1 :generic-pathname)
      (zl:send file2 :generic-pathname)))

(defun cold-file-needs-loading? (file)
  (let ((entry (assoc file *cold-files-loaded*)))
    (or (null entry)
	(< (cdr entry)
	   (file-write-date file)))))

;;; $$$ Changed function and argument name. <08-Nov-88 wkf>
(defun file-needs-compiling-p (file binary-real-pathname)
  (or (null binary-real-pathname)
      (< (file-write-date binary-real-pathname)
	 (file-write-date file))
      (not (= (fs:file-version-number file)
	      (fs:file-version-number binary-real-pathname)))))

;;||| --wkf 10/5/88
fs:(defun file-version-number (pathname)
  (send (send (pathname pathname) :truename) :version))

(defun record-cold-file-loaded (pathname)
  (setq *cold-files-loaded*
	(cons (cons pathname
		    (file-write-date pathname))
	      (delete pathname *cold-files-loaded*
		      :key #'car
		      :test #'same-file-except-for-version))))


  
(defun make-cold-function-entry (compiled-function-structure source-file code)
  (list compiled-function-structure source-file code))

(defun cold-function-entry-structure (entry)
  (first entry))

(defsetf cold-function-entry-structure (entry) (new-value)
  `(setf (first ,entry) ,new-value))

(defun cold-function-entry-source-file (entry)
  (second entry))

(defsetf cold-function-entry-source-file (entry) (new-value)
  `(setf (second ,entry) ,new-value))

(defun cold-function-entry-code (entry)
  (third entry))

(defsetf cold-function-entry-code (entry) (new-value)
  `(setf (third ,entry) ,new-value))
	 
(defun enter-compiled-function (structure source-file code)
  (let ((entry (assoc structure *cold-functions-loaded*
		      :test #'(lambda (s1 s2) (eq (nc::ncompiled-function-name s1)
						  (nc::ncompiled-function-name s2))))))
    (if (null entry)
	(setq *cold-functions-loaded*
	      (append *cold-functions-loaded* (list (make-cold-function-entry structure source-file code))))
	(progn (setf (cold-function-entry-structure entry) structure)
	       (setf (cold-function-entry-source-file entry) source-file)
	       (setf (cold-function-entry-code        entry) code)))))


(defun find-named-function (name)
  (find name *cold-loaded-functions* :key #'nc::ncompiled-function-name))

(defun cold-disassemble (fcn)
  (format t "~&From cold load array in LAMBDA:")
  (if (symbolp fcn) (setq fcn (nc::get-ncompiled-function fcn)))
  (let ((sa (nc::ncompiled-function-starting-address fcn)))
    (let ((*print-base* 16.))
      (format t "~&~x:" sa)
      (do ((addr sa (1+ addr))
	   (n (nc::ncompiled-function-length fcn) (1- n)))
	  ((zerop n))
	(format t "~&  ~a" (nc::dis (cold-code-read addr))))))
  fcn)
	
(zl:defsubst cold-read-byte (stream)
  (read-byte stream))

(zl:defsubst cold-peek-byte (stream)
  (or (zl:tyipeek nil stream nil)
      (zl::ferror nil "Unexpected EOF in ~s" stream)))

(defun cold-read-instruction (stream)
  (let ((i
	  (logior 
	    (ash (cold-read-byte stream)  0.)
	    (ash (cold-read-byte stream)  8.)
	    
	    (ash (cold-read-byte stream) 16.)
	    (ash (cold-read-byte stream) 24.)


	    (ash (cold-read-byte stream) 32.)
	    (ash (cold-read-byte stream) 40.)

	    (ash (cold-read-byte stream) 48.)
	    (ash (cold-read-byte stream) 56.))))
;    (format t "~%~s" (nc::dis i))
    i))


(defun create-cold-compiled-function (name local-refs refs entry-points immediates length code)
  (let ((fcn (nc::make-ncompiled-function
	       :name name
	       :starting-address nil
	       :entry-points entry-points
	       :local-refs local-refs
	       :refs refs
	       :immediates immediates
	       :length length
	       :code code)))
    (push fcn *cold-loaded-functions*)
    (if (symbolp name)
	(setf (nc::nsymbol-function name) fcn))
    fcn))

(defun cold-read-opcode (stream)
  (cold-read-byte stream))

(defun cold-peek-opcode (stream)
  (cold-peek-byte stream))

(defvar *cold-load-warning-stream* t)

(defun cold-fasload (filename &key (package *package*))
  (let ((path (fs:merge-pathname-defaults filename nil "KFASL")))
    (let ((*file-being-cold-loaded* (zl:send path :generic-pathname)))
      (with-open-file (stream path)
	(do ()
	    ((= (cold-peek-opcode stream)
		;fasdump:$$fasl-op-end-of-file)
		k2:$$fasl-op-end-of-file)
	     (cold-read-opcode stream)
	     stream)
	  (cold-read-object stream))))))

(defvar *cold-fasl-op-handler-table* (make-array 256.))

(defmacro define-cold-fasl-op-handler (name opcode lambda-list &body body)
  `(PROGN
     (DEFUN ,name ,lambda-list
       ,@body)
     (SETF (AREF *COLD-FASL-OP-HANDLER-TABLE* ,opcode) #',name)))

(defmacro format-if-needed (stream ctl-string &rest args)
  `(when ,stream
     (format ,stream ,ctl-string . ,args)))
 

(defun cold-read-object (stream)
  (let* ((op (cold-read-opcode stream))
	 (handler (aref *cold-fasl-op-handler-table* op)))
    (if handler
	(funcall handler stream)
      (error "Unknown fasl op: ~a" op))))

(define-cold-fasl-op-handler cold-read-fixnum
			     ;fasdump:$$fasl-op-fixnum     doesn't exist
			     k2:$$fasl-op-fixnum
			     (stream)
  (let ((low-bits    (cold-read-byte stream))
	(medium-bits (cold-read-byte stream))
	(high-bits   (cold-read-byte stream)))
    (let ((result
	    (dpb high-bits
		 (byte 8. 16.)
		 (dpb medium-bits
		      (byte 8. 8.)
		      low-bits))))
      (if (ldb-test (byte 1. 23.) result)
	  (- result (expt 2. 24.))
	  result))))

(define-cold-fasl-op-handler cold-read-string
			     ;fasdump:$$fasl-op-string    doesn't exist
			     k2:$$fasl-op-string
			     (stream)
  (let ((length (cold-read-fixnum stream)))
    (let ((string (make-string length)))
      (dotimes (i length)
	(setf (aref string i) (cold-read-byte stream)))
      string)))

(define-cold-fasl-op-handler cold-read-string-character
			     k2:$$fasl-op-string-character
			     (stream)
  (int-char (cold-read-byte stream)))

(define-cold-fasl-op-handler cold-read-symbol
			     ;fasdump:$$fasl-op-symbol
			     k2:$$fasl-op-symbol
			     (stream)
  (let ((pname (cold-read-object stream))
	(pack (cold-read-object stream)))	;caution, the variable PACKAGE is forwarded to
    (intern pname (find-package pack *package*))))

(define-cold-fasl-op-handler cold-read-compiled-function
			     ;fasdump:$$fasl-op-compiled-function
			     k2:$$fasl-op-compiled-function
                             (stream)
  (let ((name         (cold-read-object stream))
	(local-refs   (cold-read-local-refs stream))
	(refs         (cold-read-refs stream))
	(entry-points (cold-read-entry-points stream))
	(code         (cold-load-code stream))
	(immediates   (cold-read-immediates stream)))
    (create-cold-compiled-function name local-refs refs entry-points immediates (length code) code)))

(define-cold-fasl-op-handler cold-read-list
			     ;fasdump:$$fasl-op-list
			     k2:$$fasl-op-list
			     (stream)
  (let ((length (cold-read-fixnum stream)))
    (let ((l '()))
      (let ((tail l))
	(dotimes (i length)
	  (let ((cons (cons (cold-read-object stream)
				    nil)))
	    (if tail
	      (rplacd tail cons)
	      (setq l cons))
	    (setq tail cons))))
      l)))

(define-cold-fasl-op-handler cold-read-cons
			     ;fasdump:$$fasl-op-cons
			     k2:$$fasl-op-cons
			     (stream)
  (let ((car (cold-read-object stream))
	(cdr (cold-read-object stream)))
    (cons car cdr)))

(define-cold-fasl-op-handler cold-read-nil
			     k2:$$fasl-op-nil
			     (stream)
  stream
  nil)

(define-cold-fasl-op-handler cold-read-simple-vector
			     k2:$$fasl-op-simple-vector
			     (stream)
  (let ((length (cold-read-fixnum stream)))
    (let ((vector (make-array (list length))))
      (dotimes (i length)
	(setf (svref vector i) (cold-read-object stream)))
      vector)))

(define-cold-fasl-op-handler cold-read-eval
			     k2:$$fasl-op-eval
			     (stream)
  (let ((form (cold-read-object stream)))
    ;(format-if-needed *cold-load-warning-stream* "~%Cold eval ~s" form)
    (let ((*print-level* 3))
      (format-if-needed *cold-load-warning-stream* "~&Pushing ~S onto *cold-eval-list*" form))
    (push form *cold-eval-list*)))


(define-cold-fasl-op-handler cold-read-defafun
			     k2:$$fasl-op-defafun
			     (stream)
  (let ((name (cold-read-object stream))
	(function (cold-read-object stream)))
     name
    (enter-compiled-function 
      function
      *file-being-cold-loaded*
      (nc::ncompiled-function-code function))))

(define-cold-fasl-op-handler cold-read-defmacro
			     k2:$$fasl-op-defmacro
			     (stream)
  (let ((name (cold-read-object stream))
	(function (cold-read-object stream)))
    name
    function
    (format-if-needed *cold-load-warning-stream* "~%Ignoring macro ~s" name)))

(define-cold-fasl-op-handler cold-read-defun
			     k2:$$fasl-op-defun
			     (stream)
  (let ((name (cold-read-object stream))
	(function (cold-read-object stream)))
    name
    (enter-compiled-function
      function
      *file-being-cold-loaded*
      (nc::ncompiled-function-code function))))

(define-cold-fasl-op-handler cold-read-defconstant
			     k2:$$fasl-op-defconstant
			     (stream)
  (let ((name (cold-read-object stream))
	(value (cold-read-object stream)))
    value
    (format-if-needed *cold-load-warning-stream* "~%Pushing DEFCONSTANT ~s onto *cold-eval-list*" name)
    (push `(SETQ ,name ,value) *cold-eval-list*)
    (push `(SYMBOL:%PUT ',name 'LI::CONSTANT T) *cold-eval-list*)
    (push `(SYMBOL:%PUT ',name 'LI::SPECIAL T)  *cold-eval-list*)))

(define-cold-fasl-op-handler cold-read-in-package
			     k2:$$fasl-op-in-package
  (stream)
  (let ((pkg (cold-read-object stream)))
    (format-if-needed *cold-load-warning-stream* "~%Ignoring IN-PACKAGE ~s" pkg)))

(define-cold-fasl-op-handler cold-read-defsubst
			     k2:$$fasl-op-defsubst
  (stream)
  (let ((name     (cold-read-object stream))
	(source   (cold-read-object stream))
	(function (cold-read-object stream)))
    name
    source
    (enter-compiled-function
      function
      *file-being-cold-loaded*
      (nc::ncompiled-function-code function))))

(define-cold-fasl-op-handler cold-read-bignum
			     k2:$$fasl-op-bignum
			     (stream)
  (let ((size (cold-read-fixnum stream)))
    (do ((count 0  (1+ count))
	 (number 0 (dpb (cold-read-byte stream) (byte 8. (* count 8.)) number)))
	((= count (* size 4.))
	 (if (ldb-test (byte 1. (1- (* count 8.))) number)
	     (- number (expt 2. (* count 8.)))
	   number)))))

;;; floats

(define-cold-fasl-op-handler cold-do-short-float
			     k2:$$fasl-op-short-float
			     (stream)
  (let ((bits0-7   (cold-read-byte stream))
	(bits8-15  (cold-read-byte stream))
	(bits16-23 (cold-read-byte stream))
	(bits24-31 (cold-read-byte stream)))
    `(short-float ,bits24-31 ,bits16-23 ,bits8-15 ,bits0-7)))


(define-cold-fasl-op-handler cold-do-single-float
			     k2:$$fasl-op-single-float
			     (stream)
  (let ((bits0-7   (cold-read-byte stream))
	(bits8-15  (cold-read-byte stream))
	(bits16-23 (cold-read-byte stream))
	(bits24-31 (cold-read-byte stream)))
    `(single-float ,bits24-31 ,bits16-23 ,bits8-15 ,bits0-7)))

(define-cold-fasl-op-handler cold-do-double-float
			     k2:$$fasl-op-double-float
			     (stream)
  (let ((bits0-7   (cold-read-byte stream))
	(bits8-15  (cold-read-byte stream))
	(bits16-23 (cold-read-byte stream))
	(bits24-31 (cold-read-byte stream))
	(bits32-39 (cold-read-byte stream))
	(bits40-47 (cold-read-byte stream))
	(bits48-55 (cold-read-byte stream))
	(bits56-63 (cold-read-byte stream))
	)
    `(double-float ,bits56-63 ,bits48-55 ,bits40-47 ,bits32-39 ,bits24-31 ,bits16-23 ,bits8-15 ,bits0-7)))



(define-cold-fasl-op-handler cold-do-defparameter
			     k2:$$fasl-op-defparameter
  (stream)
  (let ((symbol (cold-read-object stream))
	(value (cold-read-object stream))
	(documentation (cold-read-object stream)))
      (format-if-needed *cold-load-warning-stream* "~%Ignoring defparameter ~s ~s ~s" symbol documentation value))
    )



(define-cold-fasl-op-handler cold-do-defvar		;installed 1/5/88 by RG.  Just tries to ignore it, pretty much.
			     k2:$$fasl-op-defvar
  (stream)
  (let ((symbol (cold-read-object stream)))
    (let ((value (cold-read-someones-value stream symbol))
	  (documentation (cold-read-object stream)))
      (format-if-needed *cold-load-warning-stream* "~%Ignoring defvar ~s ~s ~s" symbol documentation value))
    ))
	

(defun cold-read-someones-value (stream someone)
  (let ((opcode (cold-read-opcode stream)))
    (cond ((= opcode k2:$$fasl-op-unbound)
	   ;(cons:make-pointer $$dtp-unbound someone)
	   `(unbound ,someone))
	  (t (let ((handler (aref *cold-fasl-op-handler-table* opcode)))
	       (if handler
		   (funcall handler stream)
		 (error "Unknown fasl op: ~a" opcode)))))))

(defun cold-read-local-refs (stream)
  (let* ((n (cold-read-fixnum stream))
	 (len (+ n n))
	 (refs (make-array len)))
      (do ((i 0 (+ i 2)))
	  ((>= i len))
	(setf (svref refs i)      (cold-read-fixnum stream))
	(setf (svref refs (1+ i)) (cold-read-fixnum stream)))
      refs))

(defun cold-read-refs (stream)
  (let* ((n (cold-read-fixnum stream))
	 (len (+ n n n))
	 (refs (make-array len)))
      (do ((i 0 (+ i 3)))
	  ((>= i len))
	(setf (svref refs i)       (cold-read-fixnum stream))   ;ref offset
	(setf (svref refs (+ i 1)) (cold-read-object stream))   ;function called
	(setf (svref refs (+ i 2)) (cold-read-fixnum stream)))  ;number of args
      refs))

(defun cold-read-entry-points (stream)
  (let* ((n (cold-read-fixnum stream))
	 (len (+ n n))
	 (entries (make-array len)))
      (do ((i 0 (+ i 2)))
	  ((>= i len))
	(setf (svref entries i)      (cold-read-fixnum stream))    ;number of args
	(setf (svref entries (1+ i)) (cold-read-fixnum stream)))   ;entry point offset
      entries))

(defun cold-read-immediates (stream)
  (let ((len (ash (cold-read-fixnum stream) 1)))
    (let ((immediates (make-array len)))
      (do ((i 0 (+ i 2)))
	  ((>= i len))
	(setf (svref immediates i)     (cold-read-fixnum stream))
	(setf (svref immediates (1+ i)) (cold-read-object stream)))
      immediates)))

(defun cold-load-code (stream)
  (let ((size-in-instructions (cold-read-fixnum stream)))
    (do ((count size-in-instructions (1- count))
	 (instructions '() (cons (cold-read-instruction stream) instructions)))
	((zerop count) (reverse instructions)))))

;(define-cold-fasl-op-handler NC::FASL-OP/EVAL (stream)
;  (let ((form (cold-read stream)))
;    (case (car form)
;      ;((in-package export) (eval form))
;      ((defconstant))
;      (t (format-if-needed *cold-load-warning-stream* "~&~s wants to be evaluated" form)))))
			

(defun cold-link-local-refs (cfun starting-address)
  (let* ((local-refs (nc::ncompiled-function-local-refs cfun))
	 (length (length local-refs)))
    (do ((i 0 (+ i 2)))
	((>= i length))
      (let ((iaddr (+ starting-address (aref local-refs i)))
	    (toffset (aref local-refs (1+ i))))
	(cold-code-write iaddr
			 (if (not (minusp toffset))
			     (dpb (+ starting-address toffset)
				  hw:%%i-branch-address
				  (cold-code-read iaddr))
			   ;; negative offset means pc ref (imm32)
			   (dpb vinc:$$dtp-code vinc:%%data-type
				(logior (- starting-address toffset)
					(logand #xFFFFFFFFFF000000
						(cold-code-read iaddr))))))))))

(defun get-entry-point (fcn nargs callee)
  (let ((entry-points (nc::ncompiled-function-entry-points fcn)))
    (let ((length (length entry-points)))
      (do ((i 0 (+ i 2)))
	  ((>= i length)
	   (format t "~&~s calling ~s with wrong number of args: ~d"
		   callee
		   (nc::ncompiled-function-name fcn)
		   nargs)
	   0)
	(let ((ep-nargs (aref entry-points i)))
	  (when (or (= ep-nargs nargs)
		    (and (minusp ep-nargs)
			 (>= nargs (1- (- ep-nargs)))))
	    (return (aref entry-points (1+ i)))))))))


(defun cold-link-refs (cfun starting-address)
  (let* ((refs (nc::ncompiled-function-refs cfun))
	 (length (length refs)))
    (do ((i 0 (+ i 3)))
	((>= i length))
      (let* ((reffun (find-named-function (aref refs (+ i 1))))
	     (reffunx (or reffun (find-named-function 'K2:UNDEFINED-FUNCTION)))
	     (entry-pt (get-entry-point reffunx
					(if reffun (aref refs (+ i 2)) 0)
					cfun))
	     (ref-addr (+ starting-address (aref refs i))))
	(cold-code-write
	  ref-addr
	  (logior (logand #xFFFFFFFFFF000000
			  (cold-code-read ref-addr))
		  (+ (nc::ncompiled-function-starting-address reffunx)
		     entry-pt)))
	(unless reffun
	  (format-if-needed *cold-load-warning-stream* "~&~S is undefined in ~s"
		  (aref refs (+ i 1))
		  (nc::ncompiled-function-name cfun)))))))

(defun cold-link (cfun)
  "Relocate and resolve references of FUNCTION"
  (let ((starting-address (nc::ncompiled-function-starting-address cfun)))
    (cold-link-local-refs cfun starting-address)
    (cold-link-refs cfun starting-address)
    ;; Do immediates
    (unless (zerop (length (nc::ncompiled-function-immediates cfun)))
	(format-if-needed *cold-load-warning-stream* "~&Immediates used in ~s: ~s"
		(nc::ncompiled-function-name cfun)
		(nc::ncompiled-function-immediates cfun)))
    ))


(defun link-cold-loaded-functions ()
  (dolist (f *cold-loaded-functions*)
    (cold-link f)))



(defun cold-load-functions ()
  (setq *cold-code-pointer* cold-code-start)
  (setq *cold-loaded-functions* '())
  (dolist (function *cold-functions-loaded*)
    (let* ((descriptor (first function))
	   (code       (third function))
	   (next-block (dpb 0 (byte 12. 0.) (+ *cold-code-pointer* (dpb 1. (byte 1. 12.) 0.))))
	   (size-in-instructions (1+ (nc::ncompiled-function-length descriptor))))
      (when (> (+ size-in-instructions *cold-code-pointer*) next-block)
	(setq *cold-code-pointer* next-block))

      ;;; This prevents the trap code from being shifted upward in memory (no FEF pointer).
      (when (>= *cold-code-pointer* 64.)
	(cold-code-write *cold-code-pointer* #x7fffffff00000000) ;Mark the function header
	(incf *cold-code-pointer*))

      (setf (nc::ncompiled-function-starting-address descriptor) *cold-code-pointer*)
      (dolist (instruction code)
	(cold-code-write *cold-code-pointer* instruction)
	(incf *cold-code-pointer*))
      (push descriptor *cold-loaded-functions*))))

(defun cold-load-file (file compile-type load-type)
  (let ((kfasl-real-pathname (zl:probef (fs:merge-pathname-defaults file nil "KFASL" :newest))))
    (when (or (and (eq compile-type :compile)
		   (file-needs-compiling-p file kfasl-real-pathname))	; $$$ Changed function name. <08-Nov-88 wkf>
	      (eq compile-type :recompile))
      (let ((si#:*package* (si#:find-package 'user)))
	(compiler:::nlisp:compile-file file)))
    (setq kfasl-real-pathname (zl:probef (fs:merge-pathname-defaults file nil "KFASL" :newest))) 
    (when (or (and (eq load-type :load)
		   (cold-file-needs-loading? kfasl-real-pathname))
	      ;; $$$ Added :no-load to support recompilation without a FALCON present <09-Nov-88 JIM>
	      (eq load-type :no-load)
	      (eq load-type :reload))
      (forget-functions-in-file kfasl-real-pathname)
      (cold-fasload kfasl-real-pathname)
      (record-cold-file-loaded kfasl-real-pathname)
      (let ((si#:*package* (si#:find-package 'user)))
	(load (zl:send kfasl-real-pathname :new-pathname :type "KENV" :version :newest))))))

(defun cold-load-files (files compile-type load-type &aux (nc:*debug-stream* t))
  (internal-cold-load-files files compile-type load-type)
  (cold-load-functions)
  (link-cold-loaded-functions))

(defun internal-cold-load-files (files compile-type load-type)
  (dolist (file files)
    (cold-load-file file compile-type load-type)))

(defun forget-functions-in-file (file)
  (let ((this-file (zl:send file :generic-pathname)))
    (setq *cold-functions-loaded*
	  (remove-if #'(lambda (source-file)
			 (eq source-file this-file))
		   *cold-functions-loaded*
		   :key #'cold-function-entry-source-file))))

(defun fasd-cold-function-info (stream &key (warning-stream t))
  (unless warning-stream
	  (format t "~& you're not going to see the countdown .."))
  (let ((count (length cold:*cold-loaded-functions*)))
    (fasdump:fasd-fixnum-internal count stream)
    (dolist (fcn cold:*cold-loaded-functions*)
      (let ((name (nc::ncompiled-function-name fcn)))
	(when warning-stream
	  (format warning-stream "~&~3d  ~A" (setq count (1- count)) name))
	(fasdump:fasd-cold-compiled-function-info
	  name
	  (nc::ncompiled-function-local-refs fcn)
	  (nc::ncompiled-function-refs fcn)
	  (nc::ncompiled-function-immediates fcn)
	  (nc::ncompiled-function-entry-points fcn)
	  (nc::ncompiled-function-length fcn)
	  (nc::ncompiled-function-starting-address fcn)
	  stream)))))



;;;; Cold Load Initial Data

(defmacro dpb-multiple (&rest fields)
  (labels ((expander (fields)
	     (cond ((null fields) (error "Even number of arguments to ~s" 'dpb-multiple))
		   ((null (rest fields)) (first fields))
		   (t `(DPB
			 ,(first fields) ,(second fields)
			 ,(expander (rest (rest fields))))))))
    (expander fields)))

(defun cluster->address (cluster)
  (dpb cluster vinc::%%cluster-number 0))


;;; Physical locations of the initial data.

;;; NIL is at virtual address 0

;;; The Boot vector is an art-32b whose data begins at *boot-vector-origin*
;;; in the middle of cluster 0.   The cold load builder
;;; will place a header of the appropriate type before it.
(defparameter *boot-vector-origin*                             42.)	;absolute.

;;; The physical cluster table will go in quantum 1.
;;; It takes up half of a quantum.
;;; In the second half of the quantum, we put
;;; the quantum map and the region bits.  Each of
;;; these takes up a quarter of the quantum.

;;; Cluster addresses
;(defparameter *initial-map-data-physical-location*              (cluster->address 2.))	;64 clusters

(defparameter *quantum-map-physical-location*                    4.)
(defparameter *quantum-map-clusters*                             4.)

(defparameter *region-bits-physical-location*                    8.)
(defparameter *region-bits-clusters*                             4.)

(defparameter *initial-physical-cluster-data-physical-location* (cluster->address 12.))	;1 cluster

(defparameter *initial-gc-ram-data-physical-location*           (cluster->address 13.))	;1 cluster  --decommitted

(defparameter *initial-transporter-ram-data-physical-location*  14.)

;;; Virtual addresses of nifty things.

;;; Quantum 0.
;;; Cluster 1.
(defparameter *temporary-map-entry-location*            (ash 1. (byte-position vinc::%%cluster-number)))


;;; Quantum 1.
;;; Clusters 0. 7.
(defparameter *physical-cluster-table-location*        (* 1 (ash 1 (byte-position vinc::%%quantum-number))))

;;; Clusters 8. 11.
(defparameter *quantum-map-virtual-location*            (+ *physical-cluster-table-location*
							  (ash 1. (1- (byte-position vinc::%%quantum-number)))))
;;; Clusters 12. 15.
(defparameter *region-bits-virtual-location*            (+ *quantum-map-virtual-location*
							  (ash 1 (- (byte-position vinc::%%quantum-number) 2))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Initial map cluster data
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;(defun load-initial-map-data ()

;  ;; Make everything volatility 0.
;  (dotimes (i map::*number-of-map-entries*)
;    (cold-data-write
;      (+ i *initial-map-data-physical-location*)
;      (dpb-multiple
;	0.                     hw:%%map-volatility
;	map::$$cluster-fresh map::%%map-fresh-cluster
;        0.)))

;  ;; Cluster 0 is volatility 1.
;  (cold-data-write
;     *initial-map-data-physical-location*
;    (dpb-multiple
;      1.                         hw:%%map-volatility
;      map::$$cluster-not-fresh map::%%map-fresh-cluster
;      0.)))

;;; We will move this comment down later.
;(defparameter *boot-quanta*
;	     (list
;	       (list 0. *null-paging-device* 0)
;	       (list 1. *null-paging-device* 1)))

;(defun load-boot-quantum-map ()
;  (do ((devices (reverse *quantum-devices*) (if devices (rest devices) nil))
;       (devnum  0                 (1+ devnum)))
;      ((or (null devices) (= devnum 16.))
;       (when devices
;	 (error "Too many quantum devices")))
;    (setf (aref *quantum-device-vector* devnum)
;	  (if devices
;	      (first devices)
;	      *null-paging-device*
;	      )))

;  ;; Zero all quanta.
;  (dotimes (i vinc:*number-of-quanta*)
;    (cold-data-write
;      (+ i (cluster->address *quantum-map-physical-location*))
;      0.))

;  ;; Write initial quanta.
;  (dolist (q *boot-quanta*)
;    (cold-data-write
;      (+ (first q) (cluster->address *quantum-map-physical-location*))
;      (vinc::dpb-multiple-unboxed
;	(find-position-in-list (second q) *quantum-devices*)
;	                               quantum-map::%%quantum-map-device
;	(third  q)                     quantum-map::%%quantum-map-region-origin
;	quantum-map::$$quantum-mapped  quantum-map::%%Quantum-map-status
;	0.))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Initial physical cluster data
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun get-initial-physical-cluster-data ()
   ;ea element a 4 list (<physical-cluster> <virtual-address> <map-status> <cluster-count>)
	(list 

	  ;; Map in the wired instructions.
	  (list (vinc:cluster-number *cold-data-size*)
                (vinc:cluster->address hw:*first-instruction-cluster*)
		pcd::$$init-map-wired-read-only
		(1+ (vinc:cluster-number (ash *cold-code-pointer* 2))))

	  (list *quantum-map-physical-location*
		*quantum-map-virtual-location*
		pcd::$$init-map-wired
		*quantum-map-clusters*)

	  (list *region-bits-physical-location*
		*region-bits-virtual-location*
		pcd::$$init-map-wired
		*region-bits-clusters*)

	  ;; Shared memory cluster
	  (list 2. (cluster->address 2.) pcd::$$init-map-wired 1.)

	  ;; This must be last, since entry for cluster 0 terminates list.  It maps NIL.
	  (list 0.
		0.
		pcd::$$init-map-wired
		1.)))
	   

;;;; This function fakes up the initial physical cluster data.
(defun load-initial-physical-cluster-data ()
  (let ((pointer (1- *initial-physical-cluster-data-physical-location*)))
    (dolist (record (get-initial-physical-cluster-data))
      (cold-data-write (incf pointer) (first  record))
      (cold-data-write (incf pointer) (vinc:cluster-number (second record)))
      (cold-data-write (incf pointer) (third  record))
      (cold-data-write (incf pointer) (fourth record)))))

;(defun get-boot-gc-ram-data ()
;  (list
;    ;; quantum, volatility, oldspace
;    ;; Resident symbols
;    (list 0. 0. hw:$$not-oldspace)
;    ;; Paging tables
;    (list 1. 0. hw:$$not-oldspace)))

;(defun load-boot-gc-ram-data ()
;  (dotimes (i gc-ram::*number-of-gc-ram-entries*)
;    (cold-data-write
;      (+ i *initial-gc-ram-data-physical-location*)
;      (dpb-multiple
;	0.                hw:%%gc-ram-quantum-volatility
;	hw:$$not-oldspace hw:%%gc-ram-quantum-oldspace
;	0.)))
;  (dolist (record (get-boot-gc-ram-data))
;    (cold-data-write
;      (+ (first record) *initial-gc-ram-data-physical-location*)
;      (dpb-multiple
;	(second record) hw:%%gc-ram-quantum-volatility
;	(third  record) hw:%%gc-ram-quantum-oldspace
;	0.))))

;;; This function has a corresponding reader in "TRANSPORTER-RAM"
(defun modify-boot-transporter-ram-data (mode type datatype vma-boxed md-boxed modifier)
  (let ((address (+ (cluster->address *initial-transporter-ram-data-physical-location*)
		    (dpb-multiple
		      datatype   (byte (byte-size hw:%%transporter-ram-md-byte) 0.)
		      type       (byte (byte-size hw:%%memory-status-transport-type)
				       (byte-size hw:%%transporter-ram-md-byte))
		      mode       (byte (byte-size hw:%%memory-control-transporter-mode)
				       (+ (byte-size hw:%%memory-status-transport-type)
					  (byte-size hw:%%transporter-ram-md-byte)))
		      0.)))
	(byte-offset (byte 4. (dpb-multiple
				vma-boxed (byte 1. 2.)
				md-boxed  (byte 1. 3.)
				0))))
    (let ((data-there (cold-data-read address)))
      (let ((new-data (funcall modifier (ldb byte-offset data-there))))
	
      (cold-data-write address
		       (dpb new-data byte-offset data-there))))))

(defun expand-data-modifier (bit-list)
  (labels ((convert-to-ones (bit)
	     (if (null bit) 1 bit))
	   (convert-to-zeros (bit)
	     (if (null bit) 0 bit))
	   (compact-bits (bit-list)
	     (compact-iter bit-list 0))
	   (compact-iter (bit-list answer)
	     (if (null bit-list)
		 answer
		 (compact-iter (rest bit-list)
			       (+ (ash answer 1.) (first bit-list)))))
	   )
    (let ((and-pattern (compact-bits (mapcar #'convert-to-ones bit-list)))
	  (ior-pattern (compact-bits (mapcar #'convert-to-zeros bit-list))))
      #'(lambda (data-there)
	  (logior ior-pattern
		  (logand and-pattern
			  data-there))))))

(defconstant no-trans vinc::$$transport-type-no-transport)
(defconstant trans    vinc::$$transport-type-transport)
(defconstant vis-evcp vinc::$$transport-type-visible-evcp)
(defconstant write    vinc::$$transport-type-write)

(defconstant normal   vinc::$$transporter-mode-normal)

(defun load-boot-transporter-ram-data (data-list)
  (flet ((val (x) (if (eq x '*) '* (eval x))))
    (dolist (data-element data-list)
      (let ((vma-boxed (val (first  data-element)))
	    (md-boxed  (val (second data-element)))
	    (datatype  (val (third  data-element)))
	    (mstat     (val (fourth data-element)))
	    (mctl      (val (fifth  data-element)))
	    (modifier  (expand-data-modifier (nthcdr 5 data-element))))
	(dotimes (vmab 2.)
	  (when (lisp::or (eq '* vma-boxed) (= vma-boxed vmab))
	    (dotimes (mdb 2.)
	      (when (lisp::or (eq '* md-boxed) (= mdb md-boxed))
		(dotimes (dtp 64.)
		  (when (lisp::or (eq '* datatype) (= dtp datatype))
		    (dotimes (type 4.)
		      (when (lisp::or (eq '* mstat) (= type mstat))
			(dotimes (mode 4.)
			  (when (lisp::or (eq '* mctl) (= mctl mode))
			    (modify-boot-transporter-ram-data
			      mode type dtp vmab mdb modifier)))))))))))))))

;;; Format of transporter ram data:
;;; (vma-boxed md-boxed datatype mstat mctl box-error trap-if-not-old trap-if-old trappable-pointer)

(defparameter *transporter-ram-initial-data*
  '(;; Anything weird we trap on. 
    (* *   *                 *        *      1 1 1 1) 
    ;; Don't trap on unboxed-write if no gc-write-test, no trap on unboxed read if "no-transport"
    (0 0   *                 no-trans normal 0 0 0 0)
    ;; Don't trap on unboxed-write if no gc-write-test, trap on unboxed read if not "no-transport"
    (0 0   *                 vis-evcp normal 0 1 1 0)
    ;; NIL is not treated like a pointer in the transporter ram.
    (* 1   vinc:$$dtp-nil    no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-nil    trans    normal 0 0 0 0)
    (* 1   vinc:$$dtp-nil    vis-evcp normal 1 0 0 1)
    (* 1   vinc:$$dtp-nil    write    normal 0 0 0 0)

    ;; FIXNUMS 
    (* 1   vinc:$$dtp-fixnum no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-fixnum trans    normal 0 0 0 0)
    (* 1   vinc:$$dtp-fixnum vis-evcp normal 1 0 0 1)
    (* 1   vinc:$$dtp-fixnum write    normal 0 0 0 0)

    ;; CHARACTERS same as fixnums
    (* 1   vinc:$$dtp-character no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-character trans    normal 0 0 0 0)
    (* 1   vinc:$$dtp-character vis-evcp normal 1 0 0 1)
    (* 1   vinc:$$dtp-character write    normal 0 0 0 0)

    ;; ARRAY HEADER SINGLE not a pointer, but don't bash
    (* 1   vinc:$$dtp-array-header-single no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-array-header-single trans    normal 0 0 0 0)
    (* 1   vinc:$$dtp-array-header-single vis-evcp normal 1 0 0 1)
    (* 1   vinc:$$dtp-array-header-single write    normal 0 0 0 0) ;Compiler-bug writes temps to stack

    ;; ARRAY HEADER MULTIPLE not a pointer, but don't bash
    (* 1   vinc:$$dtp-array-header-multiple no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-array-header-multiple trans    normal 0 0 0 0)
    (* 1   vinc:$$dtp-array-header-multiple vis-evcp normal 1 0 0 1)
    (* 1   vinc:$$dtp-array-header-multiple write    normal 0 0 0 0) ;Compiler-bug writes temps to stack

    ;; ARRAY HEADER EXTENSION not a pointer, but don't bash
    (* 1   vinc:$$dtp-array-header-extension no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-array-header-extension trans    normal 0 0 0 0)
    (* 1   vinc:$$dtp-array-header-extension vis-evcp normal 1 0 0 1)
    (* 1   vinc:$$dtp-array-header-extension write    normal 0 0 0 0) ;Compiler-bug writes temps to stack

    ;; STRUCTURE HEADER not a pointer, but don't bash
    (* 1   vinc:$$dtp-structure-header no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-structure-header trans    normal 0 0 0 0)
    (* 1   vinc:$$dtp-structure-header vis-evcp normal 1 0 0 1)
    (* 1   vinc:$$dtp-structure-header write    normal 0 0 0 0) ;Compiler-bug writes temps to stack

    ;; HASH-TABLE HEADER not a pointer, but don't bash
    (* 1   vinc:$$dtp-hash-table-header no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-hash-table-header trans    normal 0 0 0 0)
    (* 1   vinc:$$dtp-hash-table-header vis-evcp normal 1 0 0 1)
    (* 1   vinc:$$dtp-hash-table-header write    normal 0 0 0 0) ;Compiler-bug writes temps to stack

    ;; UNBOXED STRUCTURE HEADER not a pointer, but don't bash
    (* 1   vinc:$$dtp-unboxed-header no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-unboxed-header trans    normal 0 0 0 0)
    (* 1   vinc:$$dtp-unboxed-header vis-evcp normal 1 0 0 1)
    (* 1   vinc:$$dtp-unboxed-header write    normal 0 0 0 0) ;Compiler-bug writes temps to stack

    ;; ARRAY
    (* 1   vinc:$$dtp-array  no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-array  trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-array  vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-array  write    normal 0 0 1 1)

    ;; STRUCTURE
    (* 1   vinc:$$dtp-structure  no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-structure  trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-structure  vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-structure  write    normal 0 0 1 1)

    ;; HASH-TABLE
    (* 1   vinc:$$dtp-hash-table  no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-hash-table  trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-hash-table  vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-hash-table  write    normal 0 0 1 1)

    ;; CONS
    (* 1   vinc:$$dtp-cons   no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-cons   trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-cons   vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-cons   write    normal 0 0 1 1)

    ;; SYMBOL HEADER pointer, but don't bash
    (* 1   vinc:$$dtp-symbol-header no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-symbol-header trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-symbol-header vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-symbol-header write    normal 0 0 0 0) ;Compiler-bug writes temps to stack

    ;; SYMBOL
    (* 1   vinc:$$dtp-symbol   no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-symbol   trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-symbol   vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-symbol   write    normal 0 0 1 1)

    ;; BIGNUM
    (* 1   vinc:$$dtp-bignum   no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-bignum   trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-bignum   vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-bignum   write    normal 0 0 1 1)

    ;; RATIONAL
    (* 1   vinc:$$dtp-rational   no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-rational   trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-rational   vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-rational   write    normal 0 0 1 1)

    ;; SHORT-FLOAT
    (* 1   vinc:$$dtp-short-float   no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-short-float   trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-short-float   vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-short-float   write    normal 0 0 1 1)

    ;; SINGLE-FLOAT
    (* 1   vinc:$$dtp-single-float   no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-single-float   trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-single-float   vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-single-float   write    normal 0 0 1 1)

    ;; DOUBLE-FLOAT
    (* 1   vinc:$$dtp-double-float   no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-double-float   trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-double-float   vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-double-float   write    normal 0 0 1 1)

    ;; COMPLEX
    (* 1   vinc:$$dtp-complex   no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-complex   trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-complex   vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-complex   write    normal 0 0 1 1)

    ;; UNBOUND
    (* 1   vinc:$$dtp-unbound  no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-unbound  trans    normal 0 1 1 1)
    (* 1   vinc:$$dtp-unbound  vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-unbound  write    normal 0 0 1 1)

    ;; I'm not sure this is quite right

    ;; BODY-FORWARD
    (* 1   vinc:$$dtp-body-forward  no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-body-forward  trans    normal 0 1 1 1)
    (* 1   vinc:$$dtp-body-forward  vis-evcp normal 1 1 1 1)
    (* 1   vinc:$$dtp-body-forward  write    normal 0 0 1 1)

    ;; HEADER-FORWARD
    (* 1   vinc:$$dtp-header-forward  no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-header-forward  trans    normal 0 1 1 1)
    (* 1   vinc:$$dtp-header-forward  vis-evcp normal 1 1 1 1)
    (* 1   vinc:$$dtp-header-forward  write    normal 0 0 1 1)

    ;; COMPILED-FUNCTION
    (* 1   vinc:$$dtp-compiled-function  no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-compiled-function  trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-compiled-function  vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-compiled-function  write    normal 0 0 1 1)

    ;; CODE
    (* 1   vinc:$$dtp-code  no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-code  trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-code  vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-code  write    normal 0 0 1 1)

    ;; LOCATIVE
    (* 1   vinc:$$dtp-locative  no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-locative  trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-locative  vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-locative  write    normal 0 0 1 1)

    ;; UNBOXED-LOCATIVE
    (* 1   vinc:$$dtp-unboxed-locative  no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-unboxed-locative  trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-unboxed-locative  vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-unboxed-locative  write    normal 0 0 1 1)

    ;; LEXICAL-CLOSURE
    (* 1   vinc:$$dtp-lexical-closure  no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-lexical-closure  trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-lexical-closure  vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-lexical-closure  write    normal 0 0 1 1)

    ;; INTERPRETER-CLOSURE
    (* 1   vinc:$$dtp-interpreter-closure  no-trans normal 1 1 1 1)
    (* 1   vinc:$$dtp-interpreter-closure  trans    normal 0 0 1 1)
    (* 1   vinc:$$dtp-interpreter-closure  vis-evcp normal 1 0 1 1)
    (* 1   vinc:$$dtp-interpreter-closure  write    normal 0 0 1 1)

  ;; DYNAMIC-CLOSURE
    (* 1 vinc:$$dtp-dynamic-closure  no-trans normal 1 1 1 1)
    (* 1 vinc:$$dtp-dynamic-closure  trans    normal 0 0 1 1)
    (* 1 vinc:$$dtp-dynamic-closure  vis-evcp normal 1 0 1 1)
    (* 1 vinc:$$dtp-dynamic-closure  write    normal 0 0 1 1)

  ;; SELECT-METHOD
    (* 1 vinc:$$dtp-select-method  no-trans normal 1 1 1 1)
    (* 1 vinc:$$dtp-select-method  trans    normal 0 0 1 1)
    (* 1 vinc:$$dtp-select-method  vis-evcp normal 1 0 1 1)
    (* 1 vinc:$$dtp-select-method  write    normal 0 0 1 1)

  ;; UNRECONCILED (always trap)
    (* 1 vinc:$$dtp-unreconciled  no-trans normal 1 1 1 1)
    (* 1 vinc:$$dtp-unreconciled  trans    normal 1 1 1 1)
    (* 1 vinc:$$dtp-unreconciled  vis-evcp normal 1 1 1 1)
    (* 1 vinc:$$dtp-unreconciled  write    normal 1 1 1 1)

  ;; SELF-REF-POINTER
    (* 1 vinc:$$dtp-self-ref-pointer  no-trans normal 1 1 1 1)
    (* 1 vinc:$$dtp-self-ref-pointer  trans    normal 0 1 1 1)
    (* 1 vinc:$$dtp-self-ref-pointer  vis-evcp normal 0 0 0 0)
    (* 1 vinc:$$dtp-self-ref-pointer  write    normal 0 0 0 0)

    ))


(defun cold-transporter-ram-data ()
  (load-boot-transporter-ram-data *transporter-ram-initial-data*))

;;(defun load-boot-transporter-ram-data ()
;;  ;; All unused entries trap.
;;  (dotimes (mode transporter-ram::*number-of-transporter-modes*)
;;    (dotimes (type transporter-ram::*number-of-transport-types*)
;;      (dotimes (md-byte transporter-ram::*number-of-transporter-md-byte-values*)
;;	(let ((transporter-data 0.))
;;	  (dotimes (vma-boxed 2.)
;;	    (dotimes (md-boxed 2.)
;;	      (setq transporter-data
;;		    (sim:k-dpb
;;		      (sim:k-ldb
;;			(sim:k-dpb
;;			  hw::$$trappable-pointer    sim::%%k-transporter-ram-trappable-pointer
;;			  (sim:k-dpb
;;			    hw::$$trap-if-oldspace     sim::%%k-transporter-ram-trap-if-oldspace
;;			    (sim:k-dpb
;;			      hw::$$trap-if-not-oldspace sim::%%k-transporter-ram-trap-if-not-oldspace
;;			      (sim:k-dpb
;;				hw::$$box-error            sim::%%k-transporter-ram-box-error
;;				0))))
;;			(byte 4. 4.)
;;			0.)
;;		      (byte 4. (* 4. (+ (* vma-boxed 2) md-boxed)))
;;		      transporter-data))))
;;	  (cold-data-write
;;	    (+ (cluster->address *initial-transporter-ram-data-physical-location*)
;;	       (sim:k-dpb
;;		 md-byte (byte (byte-size sim::%%k-transporter-md-byte) 0.)
;;		 (sim:k-dpb
;;		   type    (byte (byte-size sim::%%k-memory-status-transport-ram-bits)
;;				 (byte-size sim::%%k-transporter-md-byte))
;;		   (sim:k-dpb
;;		     mode    (byte (byte-size sim::%%k-memory-control-transporter-mode)
;;				   (+ (byte-size sim::%%k-memory-status-transport-ram-bits)
;;				      (byte-size sim::%%k-transporter-md-byte)))
;;		     0.))
;;		 transporter-data)))))

;;  ;; Normal mode, all unboxed never traps.
;;  (let ((mode      vinc::$$transport-mode-normal)
;;	(vma-boxed $$unboxed)
;;	(md-boxed  $$unboxed))
;;    (dotimes (type *number-of-transport-types*)
;;      (dotimes (md-byte *number-of-transporter-md-byte-values*)
;;	(let* ((location
;;		 (+ (cluster->address *initial-transporter-ram-data-physical-location*)
;;		    (vinc::dpb-multiple-unboxed
;;		      md-byte (byte (byte-size %%k-transporter-md-byte) 0.)
;;		      type    (byte (byte-size %%k-memory-status-transport-type)
;;				    (byte-size %%k-transporter-md-byte))
;;		      mode    (byte (byte-size %%k-memory-control-transporter-mode)
;;				    (+ (byte-size %%k-memory-status-transport-type)
;;				       (byte-size %%k-transporter-md-byte)))
;;		      0.)))
;;	       (transporter-data (cold-data-write location)))
;;	  (setq transporter-data
;;		(%dpb
;;		  (%ldb
;;		    (vinc::dpb-multiple-unboxed
;;		      $$non-trappable-pointer     %%k-transporter-ram-trappable-pointer
;;		      $$dont-trap-if-oldspace     %%k-transporter-ram-trap-if-oldspace
;;		      $$dont-trap-if-not-oldspace %%k-transporter-ram-trap-if-not-oldspace
;;		      $$no-box-error              %%k-transporter-ram-box-error
;;		      0.)
;;		    (byte 4. 4.)
;;		    0.)
;;		  (byte 4. (* 4. (+ (* vma-boxed 2) md-boxed)))
;;		  transporter-data))
;;	  (cold-data-write location transporter-data)))))

;;  ;; Normal mode, type no-transport, never trans trap.
;;  (let ((mode vinc::$$transport-mode-normal)
;;	(type vinc::$$transport-type-no-transport))
;;    (dotimes (md-byte *number-of-transporter-md-byte-values*)
;;      (let* ((location
;;	       (+ (cluster->address *initial-transporter-ram-data-physical-location*)
;;		  (vinc::dpb-multiple-unboxed
;;		    md-byte (byte (byte-size %%k-transporter-md-byte) 0.)
;;		    type    (byte (byte-size %%k-memory-status-transport-type)
;;				  (byte-size %%k-transporter-md-byte))
;;		    mode    (byte (byte-size %%k-memory-control-transporter-mode)
;;				  (+ (byte-size %%k-memory-status-transport-type)
;;				     (byte-size %%k-transporter-md-byte)))
;;		    0.)))
;;	     (transporter-data (cold-data-read location)))
;;	(dotimes (vma-boxed 2.)
;;	  (dotimes (md-boxed 2.)
;;	    (setq transporter-data
;;		  (%dpb
;;		    (%ldb
;;		      (vinc::dpb-multiple-unboxed
;;			$$dont-trap-if-oldspace     %%k-transporter-ram-trap-if-oldspace
;;			$$dont-trap-if-not-oldspace %%k-transporter-ram-trap-if-not-oldspace
;;			$$no-box-error              %%k-transporter-ram-box-error
;;			(%ldb transporter-data (byte 4. (* 4. (+ (* vma-boxed 2) md-boxed))) 0.))
;;		      (byte 4. 4.)
;;		      0.)
;;		    (byte 4. (* 4. (+ (* vma-boxed 2) md-boxed)))
;;		    transporter-data))))
;;	(cold-data-write location transporter-data)))))



;(defun init-boot-vector-macro ()
;  (do ((tail (get-boot-vector-entries) (rest tail))
;       (count 0 (1+ count))
;       (code '() (cons `(SETQ ,(first (first tail)) (BOOT::READ-BOOT-VECTOR ,count)) code)))
;      ((null tail) `(PROGN ,@(reverse code)))))

;(defun initialize-from-boot-vector ()
;  (eval (init-boot-vector-macro)))		;GAK! CHOKE! ARGH!


(defparameter *quantum-devices* '(*null-paging-device*))

(defparameter *boot-quanta*
	     (list
	       ;; nil, t, and boot vector
	       (list 0.    '*null-paging-device* 1)
	       ;; quantum map, region bits, and pcd
	       (list 1.    '*null-paging-device* 1)
	       ;; code
	       (list 2048. '*null-paging-device* 4.))) ;(ceiling *cold-code-size* vinc:*qs-in-quantum*))))

(defun build-cold-quantum-map ()
;;; Don't know where the device vector will be yet.
;  (do ((devices (reverse *quantum-devices*) (if devices (rest devices) nil))
;       (devnum  0                 (1+ devnum)))
;      ((or (null devices) (= devnum 16.))
;       (when devices
;	 (ferror nil "Too many quantum devices")))
;    (setf (aref *quantum-device-vector* devnum)
;	  (if devices
;	      (first devices)
;	      *null-paging-device*
;	      )))

  ;; Zero all quanta.
  (dotimes (i vinc:*number-of-quanta*)
    (cold-data-write
      (+ i (cluster->address *quantum-map-physical-location*))
      0.))

  ;; Write initial quanta.
  (dolist (q *boot-quanta*)
    (dotimes (number (third q))
      (cold-data-write
	(+ (first q) (cluster->address *quantum-map-physical-location*) number)
	(dpb-multiple
	  (zl::find-position-in-list (second q) *quantum-devices*)
	                                 quantum-map::%%quantum-map-device
	  (first  q)                     quantum-map::%%quantum-map-region-origin
	  quantum-map::$$quantum-mapped  quantum-map::%%quantum-map-status
	  0.)))))

;;;;;;;;;;;;;;;;;
;;;; Region bits
;;;;;;;;;;;;;;;;;

(defun get-boot-regions ()
	(list
  ;ea element (<start-quantum> <length> <region-bits>)
	  ;; Resident symbols
	  (list 0.				;quantum 0
		1.				;one quantum long
		(region-bits:encode-region-bits
		  region-bits:$$region-fixed
		  region-bits:$$region-copy-space
		  region-bits:$$region-space-structure
		  region-bits:$$region-read-write
		  region-bits:$$scavenge-enabled
		  region-bits:$$region-internal-memory
		  0.))				;swapin quantum 0

	  ;; Paging tables
	  (list 1.				;quantum 1
		1.				;one quantum long
		(region-bits:encode-region-bits
		  region-bits:$$region-fixed
		  region-bits:$$region-copy-space
		  region-bits:$$region-space-unboxed
		  region-bits:$$region-read-write
		  region-bits:$$scavenge-disabled
		  region-bits:$$region-internal-memory
		  0.))				;swapin quantum 0
	  (list 2048.
		4. ;(ceiling *cold-code-size* vinc:*qs-in-quantum*)
		(region-bits:encode-region-bits
		  region-bits:$$region-fixed
		  region-bits:$$region-copy-space
		  region-bits:$$region-space-code
		  region-bits:$$region-read-only
		  region-bits:$$scavenge-enabled
		  region-bits:$$region-internal-memory
		  16.))
	  ))

(defun load-boot-region-bits ()
  ;; Zero all the region bits.
  (let ((zapped
	  (region-bits:encode-region-bits
	    region-bits:$$region-fixed
	    region-bits:$$region-copy-space
	    region-bits:$$region-space-free
	    region-bits:$$region-read-only
	    region-bits:$$scavenge-disabled
	    region-bits:$$region-internal-memory
	    0.)))
  (dotimes (i region-bits:*number-of-regions*)
    (cold-data-write (+ i (cluster->address *region-bits-physical-location*))
		     zapped
		     ))

  (dolist (record (get-boot-regions))
    (let ((quantum-start      (first  record))
	  (quantum-count      (second record)))
      (do ((quantum     quantum-start (1+ quantum))
	   (count       quantum-count (1- count))
	   (region-bits (third  record) (dpb region-bits:$$region-space-invalid
					     region-bits::%%region-bits-space-type
					     region-bits)))

	  ((zerop count))
	(cold-data-write (+ quantum (cluster->address *region-bits-physical-location*))
	  region-bits))))))


;;;;;;;;;;;;;;;;;
;;;; Region data
;;;;;;;;;;;;;;;;;



;(defun create-region-data-for-cold-load ()
;  (let ((region-data (region-bits:make-region
;		       (ceiling (* region-bits:*number-of-regions* 4.) vinc:*qs-in-quantum*)
;		       (region-bits:parameters->region-bits
;			 region-bits:$$region-space-fixed
;			 region-bits:$$scavenge-disabled
;			 region-bits:$$region-read-write 
;			 15.)			;Swapin entire thing.
;		       0.)))			;volatility 0.

;    (setq region-data::*region-free-pointer*      (quantum->address region-data))
;    (setq region-data::*region-allocation-status* (+ region-data::*region-free-pointer*
;						     region-bits:*number-of-regions*))
;    (setq region-data::*region-end*               (+ region-data::*region-allocation-status*
;						     region-bits:*number-of-regions*))
;    (setq region-data::*region-gc-pointer*        (+ region-data::*region-end*
;						     region-bits:*number-of-regions*))

;    ;; Bash data for initial regions.  Do this right someday.
;    (setf (region-data:region-free-pointer      0) (hw:dpb 1. vinc::%%quantum-number  0.))
;    (setf (region-data:region-allocation-status 0) 0)
;    (setf (region-data:region-end               0) (hw:dpb 1. vinc::%%quantum-number  0.))
;    (setf (region-data:region-gc-pointer        0) (hw:dpb 1. vinc::%%quantum-number  0.))

;    (setf (region-data:region-free-pointer      1) (hw:dpb 2. vinc::%%quantum-number  0.))
;    (setf (region-data:region-allocation-status 1) 0)
;    (setf (region-data:region-end               1) (hw:dpb 2. vinc::%%quantum-number  0.))
;    (setf (region-data:region-gc-pointer        1) (hw:dpb 2. vinc::%%quantum-number  0.))

;    ;; We ourselves is full.
;    (setf (region-data:region-free-pointer region-data)
;	  (+ region-data::*region-gc-pointer* region-bits:*number-of-regions*))
;    (setf (region-data:region-allocation-status region-data) 0)
;    (setf (region-data:region-end region-data)
;	  (+ region-data::*region-gc-pointer* region-bits:*number-of-regions*))
;    (setf (region-data:region-gc-pointer region-data)
;	  (+ region-data::*region-gc-pointer* region-bits:*number-of-regions*))
    
;    region-data
;    ))

;(defun create-area-data-for-cold-load (region-data-region)
;  (let* ((qs-needed (+ mem:*number-of-regions*	;Region list thread
;		       mem:*number-of-areas*	;Area region data
;		       mem:*number-of-areas*	;Area region bits
;		       mem:*number-of-areas*	;Area region size
;		       ))
;	 (quanta-needed (ceiling qs-needed vinc:*qs-in-quantum*))
;	 (region-bits (region-bits:parameters->region-bits
;			region-bits:$$region-space-fixed
;			region-bits:$$scavenge-disabled
;			region-bits:$$region-read-write
;			(max 15. (1- (* quanta-needed vinc:*clusters-in-quantum*)))))
;	 (region (region-data:make-region quanta-needed region-bits 1)))
    
;    (setq memlow:*region-list-thread* (region-data::region-free-pointer region))
;    (region-data::advance-free-pointer region mem:*number-of-regions*)

;    (setq memlow:*area-region-data* (region-data::region-free-pointer region))
;    (region-data::advance-free-pointer region mem:*number-of-areas*)

;    (setq memlow::*area-region-bits* (region-data::region-free-pointer region))
;    (region-data::advance-free-pointer region mem:*number-of-areas*)

;    (setq memlow::*area-region-size* (region-data::region-free-pointer region))
;    (region-data::advance-free-pointer region mem:*number-of-areas*)

;    (setf (region-data::region-gc-pointer region) (region-data::region-free-pointer region))

;    ;;; Zero out the area tables
;    (dotimes (area mem:*number-of-areas*)
;      (setf (area-data::area-region-data area)
;	    (hw:dpb area-data::$$area-free area-data::%%area-data-area-status 0.)))

;    ;;; Setup RESIDENT SYMBOL AREA
;    (setf (area-data::area-region-data   0.)
;	  (vinc::dpb-multiple-boxed
;	    area-data::$$area-fixed area-data::%%area-data-area-status
;	    0.                      area-data::%%area-data-region-thread
;	    0.))
;    (setf (area-data::region-list-thread 0.)
;	  (hw:dpb-boxed area-data::$$thread-ends area-data::%%region-list-thread-end-flag 0.))
;    (setf (area-data::area-region-size   0.) 0.)
;    (setf (area-data::area-region-bits   0.)
;	  (vinc::dpb-multiple-boxed
;	    (region-bits::parameters->region-bits
;	      region-bits::$$region-space-fixed
;	      region-bits::$$scavenge-enabled
;	      region-bits::$$region-read-only
;	      0.)))

;    ;;; Setup PAGING TABLE AREA
;    (setf (area-data::area-region-data   1.)
;	  (vinc::dpb-multiple-boxed
;	    area-data::$$area-fixed area-data::%%area-data-area-status
;	    1.                      area-data::%%area-data-region-thread
;	    0.))
;    (setf (area-data::region-list-thread 1.)
;	  (hw:dpb-boxed area-data::$$thread-ends area-data::%%region-list-thread-end-flag 1.))
;    (setf (area-data::area-region-size   1.) 0.)
;    (setf (area-data::area-region-bits   1.)
;	  (vinc::dpb-multiple-boxed
;	    (region-bits::parameters->region-bits
;	      region-bits::$$region-space-fixed
;	      region-bits::$$scavenge-enabled
;	      region-bits::$$region-read-only
;	      0.)))

;    ;;; Setup MEMORY MANAGEMENT AREA
;    (setf (area-data::area-region-data   2.)
;	  (vinc::dpb-multiple-boxed
;	    area-data::$$area-fixed area-data::%%area-data-area-status
;	    region-data-region      area-data::%%area-data-region-thread
;	    0.))
;    (setf (area-data::region-list-thread region-data-region)
;	  (hw:dpb-boxed area-data::$$thread-continues area-data::%%region-list-thread-end-flag region))
;    (setf (area-data::region-list-thread region)
;	  (hw:dpb-boxed area-data::$$thread-ends area-data::%%region-list-thread-end-flag region-data-region))
;    (setf (area-data::area-region-size 2.) 0.)
;    (setf (area-data::area-region-bits 2.) region-bits)))


(defun cold-load-data ()	;called after cold-files have been loaded.  Download and start after this!
;  (load-initial-map-data)
;  (load-boot-gc-ram-data)
  (cold-transporter-ram-data)
  (load-initial-physical-cluster-data)
  (build-cold-quantum-map)
  (load-boot-region-bits)
; ...
  )

;(defun make-cold-load-but-dont-load-the-files (initial-function)
;  (link-cold-loaded-functions)
;  (cold-load-data)
;  (cold-data-write (+ boot::**boot-vector-origin** boot::**initial-code-physical-location-bv-offset**)
;		   *cold-data-size*)
;  (cold-data-write (+ boot::**boot-vector-origin** boot::**initial-code-size-in-clusters-bv-offset**)
;		   (1+ (ldb vinc::%%cluster-number (ash *cold-code-pointer* 2))))
;  (cold-data-write (+ boot::**boot-vector-origin** boot::**initial-code-entry-point-bv-offset**)
;		   (nc::ncompiled-function-starting-address (find-named-function initial-function)))
;  (cold-data-write (+ boot::**boot-vector-origin** boot::*initial-gc-ram-data-physical-location*)
;		   *initial-gc-ram-data-physical-location*)
;  (cold-data-write (+ boot::**boot-vector-origin** boot::*initial-transporter-ram-data-physical-location*)
;		   (cluster->address *initial-transporter-ram-data-physical-location*))
;  (user::dump-illop-codes))


(defun cold-write-boot-vector (offset data)
  (cold-data-write (+ boot::**boot-vector-origin** offset) data))

(defun cold-read-boot-vector (offset)
  (cold-data-read (+  boot::**boot-vector-origin** offset)))

(defun cold-print-boot-vector (&optional (stream t))
 ;this prints it from the cold data arrays
  (format stream "~&initial-code-physical-location (~S bv offset): ~S"
	  boot::**initial-code-physical-location-bv-offset**
	  (cold-read-boot-vector boot::**initial-code-physical-location-bv-offset**))
  (format stream "~&initial-code-size-in-clusters (~S bv offset): ~S"
	  boot::**initial-code-size-in-clusters-bv-offset**
	  (cold-read-boot-vector boot::**initial-code-size-in-clusters-bv-offset**))
  (format stream "~&initial-code-entry-point (~S bv offset): ~S"
	  boot::**initial-code-entry-point-bv-offset**
	  (cold-read-boot-vector boot::**initial-code-entry-point-bv-offset**))
  (format stream "~&initial-gc-ram-data-physical-location*: ~S"
	  (cold-read-boot-vector *initial-gc-ram-data-physical-location*))
  (format stream "~&initial-transporter-ram-data-physical-location*: ~S"
	  (cold-read-boot-vector *initial-transporter-ram-data-physical-location*))
  (format stream "~&cold-load-flag: ~S"
	  (cold-read-boot-vector boot::*cold-load-flag*)))

(defun print-boot-vector (&optional (stream t))
 ;this prints it from the real machine
  (format stream "~&initial-code-physical-location (~S bv offset): ~x"
	  boot::**initial-code-physical-location-bv-offset**
	  (read-boot-vector boot::**initial-code-physical-location-bv-offset**))
  (format stream "~&initial-code-size-in-clusters (~S bv offset): ~x"
	  boot::**initial-code-size-in-clusters-bv-offset**
	  (read-boot-vector boot::**initial-code-size-in-clusters-bv-offset**))
  (format stream "~&initial-code-entry-point (~S bv offset): ~x"
	  boot::**initial-code-entry-point-bv-offset**
	  (read-boot-vector boot::**initial-code-entry-point-bv-offset**))
  (format stream "~&initial-gc-ram-data-physical-location*: ~x"
	  (read-boot-vector *initial-gc-ram-data-physical-location*))
  (format stream "~&initial-transporter-ram-data-physical-location*: ~x"
	  (read-boot-vector *initial-transporter-ram-data-physical-location*))
  (format stream "~&cold-load-flag: ~x"
	  (read-boot-vector boot::*cold-load-flag*))
  (format stream "~&lowlevel-root-region: ~x"
	  (read-boot-vector boot::*bv-lowlevel-root-region*))
  (format stream "~&debug-root-cluster: ~x"
	  (read-boot-vector boot::*bv-debug-root-cluster*))
  (format stream "~&communication-root-cluster: ~x"
	  (read-boot-vector boot::*bv-communication-root-cluster*))
  (format stream "~&*all-packages*: ~x"
	  (read-boot-vector #x35))		;boot::*bv-all-packages*
  )

(defun read-boot-vector (offset)
  (lam:k-mem-read-word-address (+ boot::**boot-vector-origin** offset)))
  

(defun make-cold-load (&key (files user#:*cold-files*) (initial-function 'boot:cold-boot-function)
		            (compile-type :compile)    (load-type :load) (format-stream t))
  "COMPILE-TYPE is :COMPILE or :RECOMPILE or NIL
LOAD-TYPE is :LOAD or :RELOAD or NIL"
  (let ((*cold-load-warning-stream* format-stream))
    (cold-load-files files compile-type load-type)
    (cold-load-data))
  (cold-write-boot-vector boot::**initial-code-physical-location-bv-offset**		;winds up in 43.
			  *cold-data-size*)		;this much taken by data, code starts after this!
  (cold-write-boot-vector boot::**initial-code-size-in-clusters-bv-offset**
			  (1+ (ldb vinc::%%cluster-number (ash *cold-code-pointer* 2))))
  (cold-write-boot-vector  boot::**initial-code-entry-point-bv-offset**
			   (nc::ncompiled-function-starting-address (find-named-function initial-function)))
;  (cold-write-boot-vector  boot::*initial-gc-ram-data-physical-location*
;			   *initial-gc-ram-data-physical-location*)
  (cold-write-boot-vector boot::*initial-transporter-ram-data-physical-location*
			  (cluster->address *initial-transporter-ram-data-physical-location*))
  (cold-write-boot-vector boot::*cold-load-flag* (dpb vinc:$$dtp-fixnum vinc:%%data-type 1))
  (setq *mega-boot-cold-load-already-done* t))