Skip to content
Snippets Groups Projects
Commit a332872f authored by wlott's avatar wlott
Browse files

Initial revision

parent 2624da01
No related branches found
No related tags found
No related merge requests found
;;; -*- Package: Lisp -*-
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/gengc-genesis.lisp,v 1.1 1993/05/07 07:25:58 wlott Exp $")
;;;
;;; **********************************************************************
;;;
;;; Core image builder for CMU Common Lisp.
;;;
;;; Written by Skef Wholey. Package hackery courtesy of Rob MacLachlan.
;;;
;;; Completely Rewritten by William Lott for MIPS port.
;;;
(in-package "LISP")
(defmacro round-up (num size)
"Rounds number up to be an integral multiple of size."
(let ((size-var (gensym)))
`(let ((,size-var ,size))
(* ,size-var (ceiling ,num ,size-var)))))
;;;; Addresses
(deftype address ()
`(unsigned-byte ,vm:word-bits))
(defconstant null-address 0)
;;;; Block allocator.
(defconstant block-shift 16)
(defconstant block-bytes (ash 1 block-shift))
(defconstant block-words (truncate block-bytes vm:word-bytes))
(defparameter *heap-start* #x01000000)
(defvar *heap-free-pointer*)
(defvar *allocations*)
(defun allocate-blocks (n)
(declare (type index n)
(values address system-area-pointer))
(let* ((free-ptr *heap-free-pointer*)
(bytes (* n block-bytes))
(sap (system:allocate-system-memory bytes)))
(setf *heap-free-pointer* (+ free-ptr bytes))
(push (cons sap bytes) *allocations*)
(values free-ptr sap)))
(defun free-allocations ()
(dolist (allocation *allocations*)
(system:deallocate-system-memory (car allocation) (cdr allocation))))
(defmacro with-allocation-pool (&body body)
`(let ((*heap-free-pointer* *heap-start*)
(*allocations* nil))
(unwind-protect
(progn
,@body)
(free-allocations))))
(defvar *block-owners*)
(defun set-address-owner (address blocks owner)
(let* ((start (truncate (- address *heap-start*) block-bytes))
(end (+ start blocks))
(owners *block-owners*)
(length (length owners)))
(when (< length end)
(do ((new-length length (ash new-length 2)))
((<= end new-length)
(setf owners
(adjust-array owners new-length :initial-element nil))
(setf *block-owners* owners))))
(do ((index start (1+ index)))
((= index end))
(assert (null (aref owners index)))
(setf (aref owners index) owner))))
(defun address-owner (address)
(declare (type address address))
(let ((index (truncate (- address *heap-start*) block-bytes))
(owners *block-owners*))
(if (and (<= 0 index) (< index (length owners)))
(aref owners index)
nil)))
;;;; Generation representation.
(defconstant gen-default-policy 0)
(defconstant gen-tenure-policy 1)
(defstruct (generation
(:constructor %make-generation (num policy))
(:print-function %print-generation))
;;
;; The generation number for this generation. 0 is the youngest.
(num 0 :type index)
;;
;; The policy number for this generation.
(policy 0 :type index)
;;
;; List of all the steps allocated for this generation.
(steps nil :type list)
;;
;; Hash table holding all addresses that (might) hold pointers to younger
;; generations.
(remset (make-hash-table :test #'eql)
:type hash-table))
(defun %print-generation (gen stream depth)
(declare (ignore depth))
(print-unreadable-object (gen stream :type t)
(format stream "~D" (generation-num gen))))
(defun make-generation (num policy)
(%make-generation num policy))
(defun make-generations (&rest policies)
(loop
for policy in policies
for num from 0
collect (make-generation num policy)))
(defun add-remset-entry (generation address)
(declare (type generation generation) (type address address))
(setf (gethash address (generation-remset generation)) t))
;;;; Step representation.
;;; Initially there are two generations, one for static stuff and one for
;;; dynamic stuff. Each generation has only one step.
(defvar *static*)
(defvar *dynamic*)
(defstruct (block
(:print-function %print-block))
;;
;; The step this block belongs to.
(step (required-argument) :type step)
;;
;; The address this block starts at.
(base 0 :type address)
;;
;; Pointer to the memory actually backing this block.
(sap (required-argument) :type system-area-pointer)
;;
;; Offset (in bytes) into the block were the next allocation goes.
(free 0 :type index)
;;
;; Number of words remaining in this block.
(remaining block-words :type index)
;;
;; The next block allocated to this step.
(next nil :type (or null block)))
(defun %print-block (block stream depth)
(declare (ignore depth))
(print-unreadable-object (block stream :type t)
(format stream "at #x~8,'0X" (block-base block))))
(defconstant step-default-policy 0)
(defconstant step-tenure-policy 1)
(defstruct (step
(:constructor %make-step (num policy gen))
(:print-function %print-step))
;;
;; The number for this step.
(num 0 :type index)
;;
;; The policy number for this step.
(policy 0 :type index)
;;
;; The generation this step is part of.
(gen (required-argument) :type generation)
;;
;; Chain of blocks allocated to this step.
(block nil :type (or null block))
;;
;; Address of the first and last large object in this step.
(first-LO null-address :type address)
(last-LO null-address :type address)
;;
;; SAP pointing to the region_header for the last large object in this step.
(last-LO-sap nil :type (or null system-area-pointer)))
(defun %print-step (step stream depth)
(declare (ignore depth))
(print-unreadable-object (step stream :type t)
(format stream "~D" (step-num step))))
(defun make-step (num policy gen)
(let ((step (%make-step num policy gen)))
(push step (generation-steps gen))
step))
(defun alloc-small-object (words step)
(let ((padded (logandc2 (1+ words) 1))
(block (step-block step)))
(assert (<= padded block-words))
(when (or (null block) (< (block-remaining block) padded))
(multiple-value-bind
(addr sap)
(allocate-blocks 1)
(setf block (make-block :step step :base addr :sap sap :next block))
(set-address-owner addr 1 block)
(setf (step-block step) block)))
(let ((offset (block-free block)))
(setf (block-free block) (+ offset (* padded vm:word-bytes)))
(decf (block-remaining block) padded)
(values (+ (block-base block) offset)
(sap+ (block-sap block) offset)))))
;;;; Large object stuff
(defstruct (cluster
(:print-function %print-cluster))
;;
;; Number of blocks in this cluster.
(blocks 0 :type index)
;;
;; Address of the start of this cluster.
(base (required-argument) :type address)
;;
;; Pointer to the memory backing this cluster.
(sap (required-argument) :type system-area-pointer)
;;
;; Address of the first header in this cluster.
(first (required-argument) :type address)
;;
;; Offset (in bytes) into the cluster were the next allocation goes.
(free 0 :type index)
;;
;; Number of words remaining in this cluster.
(remaining 0 :type index)
;;
;; The next cluster in the chain of clusters.
(next nil :type (or null cluster)))
(defun %print-cluster (cluster stream depth)
(declare (ignore depth))
(print-unreadable-object (cluster stream :type t)
(format stream "of ~D blocks at #x~8,'0X"
(cluster-blocks cluster)
(cluster-base cluster))))
(defvar *current-los-cluster*)
;;; LOS-OBJECT-WORD-OVERHEAD -- number of words extra we have to pre-pend
;;; to each large object.
;;;
(defconstant los-object-word-overhead 6)
;;; LOS-HEADER-mumble-OFFSET -- byte offset of the various slots in the
;;; large-object header.
;;;
(defconstant los-header-longs-offset 0)
(defconstant los-header-step-offset 4)
(defconstant los-header-prev-offset 8)
(defconstant los-header-next-offset 12)
;;; LOS-OBJECT-MINIMUM-SIZE -- minimum number of words that a large object
;;; can be. Objects smaller then this must be padded out to this. Includes
;;; the los-object-word-overhead.
;;;
(defconstant los-object-minimum-size 128)
;;; LOS-REGION-ALIGNMENT -- word alignment for regions (object + overhead) in
;;; the large object store.
;;;
(defconstant los-region-alignment 2)
;;; MIN-CLUSTER-BLOCKS -- minimum number of blocks to allocate per cluster.
;;;
(defconstant min-cluster-blocks 4)
;;; LOS-CLUSTER-BYTE-OVERHEAD -- number of bytes needs for the cluster
;;; header.
;;;
(defconstant los-cluster-byte-overhead (* vm:word-bytes 3))
;;; LOS-CHUNK-BYTES -- number of bytes per los chunk.
;;;
(defconstant los-chunk-bytes (ash 1 9))
;;; LOS-CHUNK-BYTE-OVERHEAD -- number of bytes overhead needed in the
;;; cluster per chuck.
;;;
(defconstant los-chunk-byte-overhead 1)
;;; CLUSTER-START-ALIGNMENT -- Alignment restriction for the first object
;;; in the cluster. Must be at least the largest page size for any system.
;;;
(defconstant cluster-start-alignment (ash 1 13))
(defun alloc-large-object (words step)
(declare (type index words)
(values address system-area-pointer))
(let ((padded (max (round-up (+ los-object-word-overhead words)
los-region-alignment)
los-object-minimum-size))
(cluster *current-los-cluster*))
(when (or (null cluster) (> padded (cluster-remaining cluster)))
;; Figure out how many blocks to actually allocate.
(iterate repeat
((blocks (max (ceiling padded block-words) min-cluster-blocks)))
(let* ((bytes (* blocks block-bytes))
(chunks (ceiling bytes los-chunk-bytes))
(overhead (round-up (+ los-cluster-byte-overhead
(* chunks los-chunk-byte-overhead))
cluster-start-alignment)))
(if (> (- bytes overhead) (* padded vm:word-bytes))
(multiple-value-bind
(addr sap)
(allocate-blocks blocks)
(setf cluster
(make-cluster :blocks blocks :base addr :sap sap
:first (+ addr overhead)
:free overhead
:remaining
(truncate (- bytes overhead) vm:word-bytes)
:next cluster))
(set-address-owner addr blocks cluster)
(setf *current-los-cluster* cluster))
(repeat (1+ blocks))))))
(let* ((offset (cluster-free cluster))
(addr (+ (cluster-base cluster) offset))
(sap (sap+ (cluster-sap cluster) offset)))
(setf (cluster-free cluster) (+ offset (* padded vm:word-bytes)))
(decf (cluster-remaining cluster) padded)
;; Fill in the length.
(setf (sap-ref-32 sap los-header-longs-offset)
(maybe-byte-swap padded))
;; Fill in the step with some random non-zero value.
(setf (sap-ref-32 sap los-header-step-offset)
(maybe-byte-swap 1))
;; Grab the previous large object in this step.
(let ((last (step-last-LO-sap step)))
(cond (last
;; Set our prev link to point to him.
(setf (sap-ref-32 sap los-header-prev-offset)
(maybe-byte-swap (step-last-LO step)))
;; And his next link to point to us.
(setf (sap-ref-32 last los-header-next-offset)
(maybe-byte-swap addr)))
(t
;; Set out prev link to NULL.
(setf (sap-ref-32 sap los-header-prev-offset)
(maybe-byte-swap null-address))
;; And record the fact that we are the first.
(setf (step-first-LO step) addr))))
;; Set our next link to NULL.
(setf (sap-ref-32 sap los-header-next-offset)
(maybe-byte-swap null-address))
;; Record us as the last LO in this step.
(setf (step-last-LO step) addr)
(setf (step-last-LO-sap step) sap)
;; Return pointers just past the header.
(values (+ addr (* los-object-word-overhead vm:word-bytes))
(sap+ sap (* los-object-word-overhead vm:word-bytes))))))
;;;; Descriptors.
(defstruct (descriptor
(:constructor make-random-descriptor (bits))
(:constructor make-pointer-descriptor (bits %sap step))
(:print-function %print-descriptor))
;;
;; The actual bits of this descriptor.
(bits (required-argument) :type address)
;;
;; A sap pointing to the memory backing this object if it is heap allocated,
;; or :LOAD-TIME-COOKIE if references to this descriptor need to be fixed
;; up a load time. NIL until known.
(%sap nil :type (or null system-area-pointer (member :load-time-cookie)))
;;
;; The step this object is part of, NIL if unknown or immediate.
(step nil :type (or null step)))
(defun %print-descriptor (des stream depth)
(declare (ignore depth))
(let ((bits (descriptor-bits des))
(sap (descriptor-%sap des)))
(if (eq sap :load-time-cookie)
(print-unreadable-object (des stream)
(format stream "load-time-cookie ~D" bits))
(if (logbitp 0 bits)
(print-unreadable-object (des stream)
(format stream "pointer: #x~8,'0X" bits))
(if (logbitp 1 bits)
(print-unreadable-object (des stream)
(format stream "other immediate: #x~X, type #b~8,'0B"
(ash bits (- vm:type-bits))
(logand bits vm:type-mask)))
(print-unreadable-object (des stream)
(format stream "fixnum: ~D"
(let ((unsigned (ash bits -2)))
(if (logbitp 29 unsigned)
(logior (ash -1 30) unsigned)
unsigned)))))))))
(defun descriptor-sap (des)
(declare (type descriptor des))
(let ((sap (descriptor-%sap des)))
(case sap
((nil)
(let* ((addr (logandc2 (descriptor-bits des) vm:lowtag-mask))
(owner (address-owner addr)))
(multiple-value-bind
(base base-sap step)
(etypecase owner
(block
(values (block-base owner)
(block-sap owner)
(block-step owner)))
(cluster
(values (cluster-base owner)
(cluster-sap owner)
nil)))
(setf (descriptor-step des) step)
(setf (descriptor-%sap des)
(sap+ base-sap (- addr base))))))
(:load-time-cookie
(error "Values computed at load time cannot be used as addresses: ~S"
des))
(t
sap))))
(defun allocate-descriptor (step words lowtag force-large)
(declare (type step step)
(type index words)
(type (unsigned-byte #.vm:lowtag-bits) lowtag)
(type (member t nil) force-large))
(multiple-value-bind
(addr sap)
(if (or force-large (>= words vm:large-object-cutoff))
(alloc-large-object words step)
(alloc-small-object words step))
(make-pointer-descriptor (logior addr lowtag) sap step)))
(declaim (inline descriptor-lowtag))
(defun descriptor-lowtag (des)
"Return the lowtag bits for DES."
(logand (descriptor-bits des) vm:lowtag-mask))
(defun make-fixnum-descriptor (num)
(when (>= (integer-length num)
(1+ (- vm:word-bits vm:lowtag-bits)))
(error "~D is too big for a fixnum." num))
(make-random-descriptor (ash num (1- vm:lowtag-bits))))
(defun make-other-immediate-descriptor (data type)
(make-random-descriptor (logior (ash data vm:type-bits) type)))
(defun make-character-descriptor (data)
(make-other-immediate-descriptor data vm:base-char-type))
(defun descriptor-beyond (des offset type)
(make-pointer-descriptor
(logior (+ (logandc2 (descriptor-bits des) vm:lowtag-mask) offset) type)
(sap+ (descriptor-sap des) offset)
(descriptor-step des)))
;;;; Random variables and other noise.
(defparameter unbound-marker
(make-other-immediate-descriptor 0 vm:unbound-marker-type)
"Handle on the trap object.")
(defvar *nil-descriptor* nil
"Handle on Nil.")
(defvar *current-init-functions-cons* nil
"Head of list of functions to be called when the Lisp starts up.")
(defvar *in-cold-load* nil
"Used by normal loader.")
;;;; Stuff to read and write the core memory.
(defun maybe-byte-swap (word)
(declare (type (unsigned-byte 32) word))
(assert (= vm:word-bits 32))
(assert (= vm:byte-bits 8))
(if (eq (c:backend-byte-order c:*native-backend*)
(c:backend-byte-order c:*backend*))
word
(logior (ash (ldb (byte 8 0) word) 24)
(ash (ldb (byte 8 8) word) 16)
(ash (ldb (byte 8 16) word) 8)
(ldb (byte 8 24) word))))
(defun maybe-byte-swap-short (short)
(declare (type (unsigned-byte 16) short))
(assert (= vm:word-bits 32))
(assert (= vm:byte-bits 8))
(if (eq (c:backend-byte-order c:*native-backend*)
(c:backend-byte-order c:*backend*))
short
(logior (ash (ldb (byte 8 0) short) 8)
(ldb (byte 8 8) short))))
(defun write-bits (address index bits)
(declare (type descriptor address)
(type index index)
(type (unsigned-byte #.vm:word-bits) bits))
(setf (sap-ref-32 (descriptor-sap address) (ash index vm:word-shift))
(maybe-byte-swap bits)))
(defun write-descriptor (address index value &key (remember :slot))
"Write VALUE (a descriptor) INDEX words from ADDRESS (also a descriptor)."
(declare (type descriptor address value)
(type index index)
(type (member :nothing :slot :object) remember))
(if (eq (descriptor-%sap value) :load-time-cookie)
(note-load-time-value-reference
(int-sap (+ (logandc2 (descriptor-bits address) vm:lowtag-mask)
(ash index vm:word-shift)))
value)
(let ((bits (descriptor-bits value)))
(write-bits address index bits)
(unless (eq remember :nothing)
(when (logbitp 0 bits)
(let ((from-step (descriptor-step address))
(to-step (descriptor-step value)))
(unless from-step
(error "Don't know the step for ~S" address))
(unless to-step
(error "Don't know the step for ~S" value))
(let* ((from-gen (step-gen from-step))
(from-gen-num (generation-num from-gen))
(to-gen-num (generation-num (step-gen to-step))))
(when (> from-gen-num to-gen-num)
(add-remset-entry from-gen
(ecase remember
(:slot
(+ (logandc2 (descriptor-bits address)
vm:lowtag-mask)
(ash index vm:word-shift)))
(:object
(descriptor-bits address))))))))))))
(defun read-bits (address index)
(declare (type descriptor address)
(type index index)
(values (unsigned-byte #.vm:word-bits)))
(maybe-byte-swap (sap-ref-32 (descriptor-sap address)
(ash index vm:word-shift))))
(defun read-descriptor (address index)
"Return the value (as a descriptor) INDEX words from ADDRESS (a descriptor)."
(declare (type descriptor address)
(type index index)
(values descriptor))
(make-random-descriptor (read-bits address index)))
;;;; Allocating primitive objects.
;;; There are two common kinds of objects that we have special allocators
;;; for:
;;;
;;; Simple objects:
;;; A header word with the type and the length, plus the data.
;;;
;;; Vector objects:
;;; A header word with the type, a word for the length, plus the data.
;;;
(defun allocate-simple-object (step words lowtag header-type)
(declare (type step step)
(type index words)
(type (unsigned-byte #.vm:lowtag-bits) lowtag)
(type (or (unsigned-byte #.vm:type-bits) null) header-type)
(values descriptor))
(let ((des (allocate-descriptor step words lowtag nil)))
(when header-type
(write-descriptor des 0
(make-other-immediate-descriptor
(1- words) header-type)))
des))
(defun allocate-vector-object (step element-size length header-type)
(declare (type step step)
(type index element-size length)
(type (unsigned-byte #.vm:type-bits) header-type)
(values descriptor))
(let* ((words (+ (ceiling (* length element-size) vm:word-bits) 2))
(des (allocate-descriptor step words vm:other-pointer-type nil)))
(write-descriptor des 0 (make-other-immediate-descriptor 0 header-type))
(write-descriptor des vm:vector-length-slot
(make-fixnum-descriptor length))
des))
;;;; Routines to move simple objects into the core.
(defun string-to-core (string)
(declare (type string string)
(values descriptor))
(let* ((len (length string))
(des (allocate-vector-object *dynamic* vm:byte-bits (1+ len)
vm:simple-string-type)))
;; Note: We allocate an extra byte and tweek the length back to make sure
;; there will be a null at the end of the string to aid in call-out to
;; C.
(write-descriptor des vm:vector-length-slot (make-fixnum-descriptor len))
(copy-to-system-area string (* vm:vector-data-offset vm:word-bits)
(descriptor-sap des)
(* vm:vector-data-offset vm:word-bits)
(* (1+ len) vm:byte-bits))
des))
(defun bignum-to-core (n)
(declare (type integer n)
(values descriptor))
(let* ((words (ceiling (1+ (integer-length n)) vm:word-bits))
(handle (allocate-simple-object *dynamic* (1+ words)
vm:other-pointer-type
vm:bignum-type)))
(declare (fixnum words))
(do ((index 1 (1+ index))
(remainder n (ash remainder (- vm:word-bits))))
((> index words)
(unless (zerop (integer-length remainder))
(warn "Wrote ~D words of ~D, but ~D was left over"
words n remainder)))
(write-bits handle index (ldb (byte vm:word-bits 0) remainder)))
handle))
(defun number-pair-to-core (first second type)
(declare (type descriptor first second)
(type (unsigned-byte #.vm:type-bits) type)
(values descriptor))
(let ((des (allocate-simple-object *dynamic* 2 vm:other-pointer-type type)))
(write-descriptor des 1 first)
(write-descriptor des 2 second)
des))
(defun float-to-core (num)
(declare (type float num)
(values descriptor))
(etypecase num
(single-float
(let ((des (allocate-simple-object *dynamic* vm:single-float-size
vm:other-pointer-type
vm:single-float-type)))
(write-bits des vm:single-float-value-slot (single-float-bits num))
des))
(double-float
(let ((des (allocate-simple-object *dynamic* vm:double-float-size
vm:other-pointer-type
vm:double-float-type))
(high-bits (double-float-high-bits num))
(low-bits (double-float-low-bits num)))
(ecase (c:backend-byte-order c:*backend*)
(:little-endian
(write-bits des vm:double-float-value-slot low-bits)
(write-bits des (1+ vm:double-float-value-slot) high-bits))
(:big-endian
(write-bits des vm:double-float-value-slot high-bits)
(write-bits des (1+ vm:double-float-value-slot) low-bits)))
des))))
(defun number-to-core (number)
(declare (type number number)
(values descriptor))
(etypecase number
(integer
(if (< (integer-length number) 30)
(make-fixnum-descriptor number)
(bignum-to-core number)))
(ratio
(number-pair-to-core (number-to-core (numerator number))
(number-to-core (denominator number))
vm:ratio-type))
(complex
(number-pair-to-core (number-to-core (realpart number))
(number-to-core (imagpart number))
vm:complex-type))
(float
(float-to-core number))))
(defun sap-to-core (sap)
(declare (type system-area-pointer sap)
(values descriptor))
(let ((des (allocate-simple-object *dynamic* vm:sap-size
vm:other-pointer-type vm:sap-type)))
(write-bits des vm:sap-pointer-slot (sap-int sap))
des))
(defun cold-cons (car cdr)
(declare (type descriptor car cdr)
(values descriptor))
(let ((dest (allocate-simple-object *dynamic* 2 vm:list-pointer-type nil)))
(write-descriptor dest 0 car)
(write-descriptor dest 1 cdr)
dest))
(defmacro cold-push (thing list)
"Generates code to push the THING onto the given cold load LIST."
`(setq ,list (cold-cons ,thing ,list)))
;;; COLD-VECTOR -- Internal
;;;
;;; Make a simple-vector that holds the specified Objects and return its
;;; decriptor.
;;;
(defun cold-vector (&rest objects)
(let* ((size (length objects))
(result (allocate-vector-object *dynamic* vm:word-bits size
vm:simple-vector-type)))
(dotimes (index size)
(write-descriptor result (+ index vm:vector-data-offset) (pop objects)))
result))
;;;; Symbol magic.
;;; Cold-Make-Symbol allocates a symbol and fills its print name cell and
;;; property list cell.
(defvar *cold-symbol-allocation-step* nil)
(defun cold-make-symbol (name)
(declare (simple-string name)
(values descriptor))
(let ((symbol (allocate-simple-object
(or *cold-symbol-allocation-step* *dynamic*) vm:symbol-size
vm:other-pointer-type vm:symbol-header-type)))
(write-descriptor symbol vm:symbol-value-slot unbound-marker)
(write-descriptor symbol vm:symbol-plist-slot *nil-descriptor*)
(write-descriptor symbol vm:symbol-name-slot (string-to-core name))
(write-descriptor symbol vm:symbol-package-slot *nil-descriptor*)
symbol))
(defun cold-setq (symbol value)
(declare (type descriptor symbol value))
(write-descriptor symbol vm:symbol-value-slot value))
;;;; Interning.
;;; In order to avoid having to know about the package format, we
;;; build a data structure which we stick in *cold-packages* that
;;; holds all interned symbols along with info about their packages.
;;; The data structure is a list of lists in the following format:
;;; (<make-package-arglist>
;;; <internal-symbols>
;;; <external-symbols>
;;; <imported-internal-symbols>
;;; <imported-external-symbols>
;;; <shadowing-symbols>)
;;;
;;; Package manipulation forms are dumped magically by the compiler
;;; so that we can eval them at Genesis time. An eval-for-effect fop
;;; is used, surrounded by fops that switch the fop table to the hot
;;; fop table and back.
;;;
;;; An alist from packages to the list of symbols in that package to be
;;; dumped.
(defvar *cold-packages*)
;;; This holds a hash table mapping from descriptors to symbols, so we can
;;; back up. The key is the *address* in the target core.
;;;
(defvar *cold-symbols*)
;;; Cold-Intern -- Internal
;;;
;;; Return a handle on an interned symbol. If necessary allocate
;;; the symbol and record which package the symbol was referenced in.
;;; When we allocatethe symbol, make sure we record a reference to
;;; the symbol in the home package so that the package gets set.
;;;
(defun cold-intern (symbol &optional (package (symbol-package symbol)))
(declare (type symbol symbol)
(type (or package null) package)
(values descriptor))
(let ((cold-info (get symbol 'cold-info)))
(unless cold-info
(cond ((eq (symbol-package symbol) package)
(let ((handle (cold-make-symbol (symbol-name symbol))))
(setf (gethash (descriptor-bits handle) *cold-symbols*) symbol)
(when (eq package *keyword-package*)
(cold-setq handle handle))
(setq cold-info
(setf (get symbol 'cold-info) (cons handle nil)))))
(t
(cold-intern symbol)
(setq cold-info (get symbol 'cold-info)))))
(unless (or (null package)
(member package (cdr cold-info) :test #'eq))
(push package (cdr cold-info))
(push symbol (cdr (or (assoc package *cold-packages* :test #'eq)
(car (push (list package) *cold-packages*))))))
(car cold-info)))
;;; Initialize-Symbols -- Internal
;;;
;;; Since the initial symbols must be allocated before we can intern
;;; anything else, we intern those here. We also set the values of T and Nil.
;;;
(defun initialize-symbols ()
"Initilizes the cold load symbol-hacking data structures."
(do-all-symbols (sym)
(remprop sym 'cold-info))
(setq *cold-packages* nil)
(let ((*cold-symbol-allocation-step* *static*))
;; Special case NIL.
(let* ((des (allocate-simple-object *static* (+ vm:symbol-size 2) 0 nil))
(nil-des
(make-pointer-descriptor (+ (descriptor-bits des)
vm:word-bytes
vm:other-pointer-type)
nil
*static*)))
(setf *nil-descriptor* nil-des)
(write-descriptor nil-des 0
(make-other-immediate-descriptor
0 vm:symbol-header-type))
(write-descriptor nil-des vm:symbol-value-slot *nil-descriptor*)
(write-descriptor nil-des (1+ vm:symbol-value-slot) *nil-descriptor*)
(write-descriptor nil-des vm:symbol-plist-slot *nil-descriptor*)
(write-descriptor nil-des vm:symbol-name-slot (string-to-core "NIL"))
(write-descriptor nil-des vm:symbol-package-slot *nil-descriptor*)
(setf (get nil 'cold-info) (cons *nil-descriptor* nil))
(cold-intern nil))
;; Intern the others.
(dolist (symbol vm:static-symbols)
(let ((des (cold-intern symbol)))
(unless (= (- (descriptor-bits des) (descriptor-bits *nil-descriptor*))
(vm:static-symbol-offset symbol))
(warn "Offset from ~S to ~S is ~D, not ~D"
symbol
nil
(- (descriptor-bits des) (descriptor-bits *nil-descriptor*))
(vm:static-symbol-offset symbol)))))
;; Establish the value of T.
(let ((t-symbol (cold-intern t)))
(cold-setq t-symbol t-symbol))))
;;; Finish-Symbols -- Internal
;;;
;;; Establish initial values for magic symbols.
;;;
;;; Scan over all the symbols referenced in each package in *cold-packages*
;;; making the apropriate entry in the *initial-symbols* data structure to
;;; intern the thing.
;;;
(defun finish-symbols ()
(macrolet ((frob (symbol)
`(cold-setq (cold-intern ',symbol)
(cold-fdefinition-object (cold-intern ',symbol)))))
(frob kernel::internal-error)
(frob mach::handle-exception)
(frob di::handle-breakpoint)
(frob di::handle-function-end-breakpoint)
(frob lisp::fdefinition-object)
(frob apply))
(macrolet ((frob (symbol value)
`(cold-setq (cold-intern ',symbol) ,value)))
(frob *initial-layouts* (list-all-layouts))
(frob *initial-symbols* (list-initial-symbols))
(frob *initial-fdefn-objects* (list-all-fdefn-objects))
(frob *lisp-initialization-functions* *current-init-functions-cons*)
(frob kernel::*saved-state-chain* *nil-descriptor*))
nil)
(defun list-initial-symbols ()
(let ((res *nil-descriptor*))
(dolist (cpkg *cold-packages*)
(let* ((pkg (car cpkg))
(shadows (package-shadowing-symbols pkg)))
(let ((internal *nil-descriptor*)
(external *nil-descriptor*)
(imported-internal *nil-descriptor*)
(imported-external *nil-descriptor*)
(shadowing *nil-descriptor*))
(dolist (sym (cdr cpkg))
(let ((handle (car (get sym 'cold-info))))
(multiple-value-bind (found where)
(find-symbol (symbol-name sym) pkg)
(unless (and where (eq found sym))
(error "Symbol ~S is not available in ~S." sym pkg))
(when (memq sym shadows)
(cold-push handle shadowing))
(case where
(:internal
(if (eq (symbol-package sym) pkg)
(cold-push handle internal)
(cold-push handle imported-internal)))
(:external
(if (eq (symbol-package sym) pkg)
(cold-push handle external)
(cold-push handle imported-external)))))))
(let ((r *nil-descriptor*))
(cold-push shadowing r)
(cold-push imported-external r)
(cold-push imported-internal r)
(cold-push external r)
(cold-push internal r)
(cold-push (make-make-package-args pkg) r)
(cold-push r res)))))
res))
;;; Make-Make-Package-Args -- Internal
;;;
;;; Make a cold list that can be used as the arglist to make-package to
;;; make a similar package.
;;;
(defun make-make-package-args (package)
(let* ((use *nil-descriptor*)
(nicknames *nil-descriptor*)
(res *nil-descriptor*))
(dolist (u (package-use-list package))
(when (assoc u *cold-packages*)
(cold-push (string-to-core (package-name u)) use)))
(dolist (n (package-nicknames package))
(cold-push (string-to-core n) nicknames))
(cold-push (number-to-core (truncate (internal-symbol-count package) 0.8))
res)
(cold-push (cold-intern :internal-symbols) res)
(cold-push (number-to-core (truncate (external-symbol-count package) 0.8))
res)
(cold-push (cold-intern :external-symbols) res)
(cold-push nicknames res)
(cold-push (cold-intern :nicknames) res)
(cold-push use res)
(cold-push (cold-intern :use) res)
(cold-push (string-to-core (package-name package)) res)
res))
;;;; Fdefinition objects.
(defvar *fdefn-objects*)
(defvar *fdefn-space* nil)
(defun extract-fdefn-name (des)
(ecase (descriptor-lowtag des)
(#.vm:list-pointer-type
(if (= (descriptor-bits des) (descriptor-bits *nil-descriptor*))
nil
(cons (extract-fdefn-name (read-descriptor des vm:cons-car-slot))
(extract-fdefn-name (read-descriptor des vm:cons-cdr-slot)))))
(#.vm:other-pointer-type
(or (gethash (descriptor-bits des) *cold-symbols*)
(descriptor-bits des)))))
(defun cold-fdefinition-object (name &optional leave-fn-raw)
(let ((hash (extract-fdefn-name name)))
(or (gethash hash *fdefn-objects*)
(let ((fdefn (allocate-simple-object
(or *fdefn-space* *dynamic*)
vm:fdefn-size vm:other-pointer-type vm:fdefn-type)))
(setf (gethash hash *fdefn-objects*) fdefn)
(write-descriptor fdefn vm:fdefn-name-slot name)
(unless leave-fn-raw
(write-descriptor fdefn vm:fdefn-function-slot *nil-descriptor*)
(write-descriptor
fdefn vm:fdefn-raw-addr-slot
(make-random-descriptor
(ecase (c:backend-fasl-file-implementation
c:*backend*)
((#.c:pmax-fasl-file-implementation
#.c:rt-fasl-file-implementation
#.c:rt-afpa-fasl-file-implementation
#.c:x86-fasl-file-implementation
#.c:hppa-fasl-file-implementation)
(lookup-foreign-symbol "undefined_tramp"))
(#.c:sparc-fasl-file-implementation
(lookup-foreign-symbol "_undefined_tramp"))))))
fdefn))))
(defun cold-fset (name defn)
(assert (= (logand (read-bits defn 0) vm:type-mask) vm:function-header-type))
(let ((fdefn (cold-fdefinition-object name t)))
(write-descriptor fdefn vm:fdefn-function-slot defn
:remember :object)
(write-bits fdefn vm:fdefn-raw-addr-slot
(read-bits defn vm:function-entry-point-slot))
fdefn))
(defun initialize-static-fns ()
(let ((*fdefn-space* *static*))
(dolist (sym vm:static-functions)
(let* ((fdefn (cold-fdefinition-object (cold-intern sym)))
(offset (- (+ (- (descriptor-bits fdefn) vm:other-pointer-type)
(* vm:fdefn-raw-addr-slot vm:word-bytes))
(descriptor-bits *nil-descriptor*)))
(desired (vm:static-function-offset sym)))
(unless (= offset desired)
(warn "Offset from FDEFN ~S to ~S is ~D, not ~D"
sym nil offset desired))))))
(defun list-all-fdefn-objects ()
(let ((result *nil-descriptor*))
(maphash #'(lambda (key value)
(declare (ignore key))
(cold-push value result))
*fdefn-objects*)
result))
;;;; Layouts & type system pre-initialization:
;;;
;;; Since we want to be able to dump structure constants and predicates with
;;; reference layouts, we need to create layouts at cold-load time. We use the
;;; name to intern layouts by, and dump a list of all cold layouts in
;;; *INITIAL-LAYOUTS* so that type-system initialization can find them. The
;;; only thing that's tricky is initializing layout's layout, which must point
;;; to itself.
;;; Table mapping from class names to descriptors for their layouts.
;;;
(defvar *cold-layouts* (make-hash-table :test #'equal))
;;; The descriptor for layout's layout, which we need when making layouts.
;;;
(defvar *layout-layout*)
(defparameter target-layout-length 16)
(defun make-cold-layout (name length inherits depth)
(let ((result (allocate-simple-object *dynamic* (1+ target-layout-length)
vm:instance-pointer-type
vm:instance-header-type)))
(write-descriptor result vm:instance-slots-offset *layout-layout*)
(let ((base (+ vm:instance-slots-offset
kernel:layout-hash-length
1)))
;0 class uninitialized
(write-descriptor result (+ base 1) *nil-descriptor*); invalid
(write-descriptor result (+ base 2) inherits)
(write-descriptor result (+ base 3) depth)
(write-descriptor result (+ base 4) length)
(write-descriptor result (+ base 5) *nil-descriptor*); info
(write-descriptor result (+ base 6) *nil-descriptor*)); pure
(setf (gethash name *cold-layouts*) result)
result))
;;; INITIALIZE-LAYOUTS -- Internal
;;;
;;; Clear the layout table and set *layout-layout*. We initially create
;;; LAYOUT with NIL as the LAYOUT and INHERITS, then back-patch with itself and
;;; the correct INHERITS vector (which includes T, INSTANCE and
;;; STRUCTURE-OBJECT).
;;;
(defun initialize-layouts ()
(clrhash *cold-layouts*)
(setq *layout-layout* *nil-descriptor*)
(setq *layout-layout*
(make-cold-layout 'layout (number-to-core target-layout-length)
*nil-descriptor* (number-to-core 3)))
(write-descriptor *layout-layout* vm:instance-slots-offset *layout-layout*)
(let* ((t-layout
(make-cold-layout 't (number-to-core 0)
(cold-vector) (number-to-core 0)))
(inst-layout
(make-cold-layout 'instance (number-to-core 0)
(cold-vector t-layout) (number-to-core 1)))
(so-layout
(make-cold-layout 'structure-object (number-to-core 1)
(cold-vector t-layout inst-layout)
(number-to-core 2))))
(write-descriptor *layout-layout*
(+ vm:instance-slots-offset layout-hash-length 1 2)
(cold-vector t-layout inst-layout so-layout))))
;;; LIST-ALL-LAYOUTS -- Internal
;;;
;;; Return a cold alist that we're going to store in *INITIAL-LAYOUTS*.
;;;
(defun list-all-layouts ()
(let ((result *nil-descriptor*))
(maphash #'(lambda (key value)
(cold-push (cold-cons (cold-intern key) value) result))
*cold-layouts*)
result))
;;;; Reading FASL files.
(defvar *cold-fop-functions* (replace (make-array 256) fop-functions)
"FOP functions for cold loading.")
(defvar *normal-fop-functions*)
;;; Define-Cold-FOP -- Internal
;;;
;;; Like Define-FOP in load, but looks up the code, and stores into
;;; the *cold-fop-functions* vector.
;;;
(defmacro define-cold-fop ((name &optional (pushp t)) &rest forms)
(let ((fname (concat-pnames 'cold- name))
(code (get name 'fop-code)))
`(progn
(defun ,fname ()
,@(if (eq pushp :nope)
forms
`((with-fop-stack ,pushp ,@forms))))
,@(if code
`((setf (svref *cold-fop-functions* ,code) #',fname))
(warn "~S is not a defined FOP." name)))))
;;; Clone-Cold-FOP -- Internal
;;;
;;; Clone a couple of cold fops.
;;;
(defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms)
`(progn
(macrolet ((clone-arg () '(read-arg 4)))
(define-cold-fop (,name ,pushp) ,@forms))
(macrolet ((clone-arg () '(read-arg 1)))
(define-cold-fop (,small-name ,pushp) ,@forms))))
;;; Not-Cold-Fop -- Internal
;;;
;;; Define a fop to be undefined in cold load.
;;;
(defmacro not-cold-fop (name)
`(define-cold-fop (,name)
(error "~S is not supported in cold load." ',name)))
;;;; Random cold fops...
(define-cold-fop (fop-misc-trap) unbound-marker)
(define-cold-fop (fop-character)
(make-character-descriptor (read-arg 3)))
(define-cold-fop (fop-short-character)
(make-character-descriptor (read-arg 1)))
(define-cold-fop (fop-empty-list) *nil-descriptor*)
(define-cold-fop (fop-truth) (cold-intern t))
(define-cold-fop (fop-normal-load :nope)
(setq fop-functions *normal-fop-functions*))
(define-fop (fop-maybe-cold-load 82 :nope)
(when *in-cold-load*
(setq fop-functions *cold-fop-functions*)))
(define-cold-fop (fop-maybe-cold-load :nope))
(clone-cold-fop (fop-struct)
(fop-small-struct)
(let* ((size (clone-arg))
(result (allocate-simple-object *dynamic* (1+ size)
vm:instance-pointer-type
vm:instance-header-type)))
(do ((index (1- size) (1- index)))
((minusp index))
(declare (fixnum index))
(write-descriptor result (+ index vm:instance-slots-offset)
(pop-stack)))
result))
(define-cold-fop (fop-layout)
(let ((length (pop-stack))
(depth (pop-stack))
(inherits (pop-stack))
(name (pop-stack)))
(or (gethash name *cold-layouts*)
(make-cold-layout name length inherits depth))))
;;; Loading symbols...
;;; Cold-Load-Symbol loads a symbol N characters long from the File and interns
;;; that symbol in the given Package.
;;;
(defun cold-load-symbol (size package)
(let ((string (make-string size)))
(read-n-bytes *fasl-file* string 0 size)
(cold-intern (intern string package) package)))
(clone-cold-fop (fop-symbol-save)
(fop-small-symbol-save)
(push-table (cold-load-symbol (clone-arg) *package*)))
(macrolet ((frob (name pname-len package-len)
`(define-cold-fop (,name)
(let ((index (read-arg ,package-len)))
(push-table
(cold-load-symbol (read-arg ,pname-len)
(svref *current-fop-table* index)))))))
(frob fop-symbol-in-package-save 4 4)
(frob fop-small-symbol-in-package-save 1 4)
(frob fop-symbol-in-byte-package-save 4 1)
(frob fop-small-symbol-in-byte-package-save 1 1))
(clone-cold-fop (fop-lisp-symbol-save)
(fop-lisp-small-symbol-save)
(push-table (cold-load-symbol (clone-arg) *lisp-package*)))
(clone-cold-fop (fop-keyword-symbol-save)
(fop-keyword-small-symbol-save)
(push-table (cold-load-symbol (clone-arg) *keyword-package*)))
(clone-cold-fop (fop-uninterned-symbol-save)
(fop-uninterned-small-symbol-save)
(let* ((size (clone-arg))
(name (make-string size)))
(read-n-bytes *fasl-file* name 0 size)
(let ((symbol (cold-make-symbol name)))
(push-table symbol))))
;;; Loading lists...
;;; 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.
(defmacro cold-stack-list (length last)
`(do* ((index ,length (1- index))
(result ,last (cold-cons (pop-stack) result)))
((= index 0) result)
(declare (fixnum index))))
(define-cold-fop (fop-list)
(cold-stack-list (read-arg 1) *nil-descriptor*))
(define-cold-fop (fop-list*)
(cold-stack-list (read-arg 1) (pop-stack)))
(define-cold-fop (fop-list-1)
(cold-stack-list 1 *nil-descriptor*))
(define-cold-fop (fop-list-2)
(cold-stack-list 2 *nil-descriptor*))
(define-cold-fop (fop-list-3)
(cold-stack-list 3 *nil-descriptor*))
(define-cold-fop (fop-list-4)
(cold-stack-list 4 *nil-descriptor*))
(define-cold-fop (fop-list-5)
(cold-stack-list 5 *nil-descriptor*))
(define-cold-fop (fop-list-6)
(cold-stack-list 6 *nil-descriptor*))
(define-cold-fop (fop-list-7)
(cold-stack-list 7 *nil-descriptor*))
(define-cold-fop (fop-list-8)
(cold-stack-list 8 *nil-descriptor*))
(define-cold-fop (fop-list*-1)
(cold-stack-list 1 (pop-stack)))
(define-cold-fop (fop-list*-2)
(cold-stack-list 2 (pop-stack)))
(define-cold-fop (fop-list*-3)
(cold-stack-list 3 (pop-stack)))
(define-cold-fop (fop-list*-4)
(cold-stack-list 4 (pop-stack)))
(define-cold-fop (fop-list*-5)
(cold-stack-list 5 (pop-stack)))
(define-cold-fop (fop-list*-6)
(cold-stack-list 6 (pop-stack)))
(define-cold-fop (fop-list*-7)
(cold-stack-list 7 (pop-stack)))
(define-cold-fop (fop-list*-8)
(cold-stack-list 8 (pop-stack)))
;;; Loading vectors...
(clone-cold-fop (fop-string)
(fop-small-string)
(let* ((len (clone-arg))
(string (make-string len)))
(read-n-bytes *fasl-file* string 0 len)
(string-to-core string)))
(clone-cold-fop (fop-vector)
(fop-small-vector)
(let* ((size (clone-arg))
(result (allocate-vector-object *dynamic* vm:word-bits size
vm:simple-vector-type)))
(do ((index (1- size) (1- index)))
((minusp index))
(declare (fixnum index))
(write-descriptor result (+ index vm:vector-data-offset) (pop-stack)))
result))
(clone-cold-fop (fop-uniform-vector)
(fop-small-uniform-vector)
(let* ((size (clone-arg))
(datum (pop-stack))
(result (allocate-vector-object *dynamic* vm:word-bits size
vm:simple-vector-type)))
(do ((index (1- size) (1- index)))
((minusp index))
(declare (fixnum index))
(write-descriptor result (+ index vm:vector-data-offset) datum))
result))
(define-cold-fop (fop-uniform-int-vector)
(let* ((len (read-arg 4))
(size (read-arg 1))
(type (case size
(1 vm:simple-bit-vector-type)
(2 vm:simple-array-unsigned-byte-2-type)
(4 vm:simple-array-unsigned-byte-4-type)
(8 vm:simple-array-unsigned-byte-8-type)
(16 vm:simple-array-unsigned-byte-16-type)
(32 vm:simple-array-unsigned-byte-32-type)
(t (error "Losing element size: ~D." size))))
(value (case size
((1 2 4 8)
(read-arg 1))
(16
(read-arg 2))
(32
(read-arg 4))))
(result (allocate-vector-object *dynamic* size len type)))
(do ((bits size (* bits 2))
(word value (logior word (ash word bits))))
((= size vm:word-bits)
(dotimes (index (ceiling (* len size) vm:word-bits))
(write-bits result (+ index vm:vector-data-offset) word))))
result))
(define-cold-fop (fop-int-vector)
(let* ((len (read-arg 4))
(size (read-arg 1))
(type (case size
(1 vm:simple-bit-vector-type)
(2 vm:simple-array-unsigned-byte-2-type)
(4 vm:simple-array-unsigned-byte-4-type)
(8 vm:simple-array-unsigned-byte-8-type)
(16 vm:simple-array-unsigned-byte-16-type)
(32 vm:simple-array-unsigned-byte-32-type)
(t (error "Losing element size: ~D." size))))
(result (allocate-vector-object *dynamic* size len type)))
(unless (zerop len)
(read-n-bytes *fasl-file*
(descriptor-sap result)
(ash vm:vector-data-offset vm:word-shift)
(ceiling (* len size) vm:byte-bits)))
result))
(define-cold-fop (fop-single-float-vector)
(let* ((len (read-arg 4))
(result (allocate-vector-object *dynamic* vm:word-bits len
vm:simple-array-single-float-type)))
(unless (zerop len)
(read-n-bytes *fasl-file*
(descriptor-sap result)
(ash vm:vector-data-offset vm:word-shift)
(* len vm:word-bytes)))
result))
(define-cold-fop (fop-double-float-vector)
(let* ((len (read-arg 4))
(result (allocate-vector-object *dynamic* (* vm:word-bits 2) len
vm:simple-array-double-float-type)))
(unless (zerop len)
(read-n-bytes *fasl-file*
(descriptor-sap result)
(ash vm:vector-data-offset vm:word-shift)
(* len vm:word-bytes 2)))
result))
(define-cold-fop (fop-array)
(let* ((rank (read-arg 4))
(data-vector (pop-stack))
(result (allocate-simple-object *dynamic*
(+ vm:array-dimensions-offset rank)
vm:other-pointer-type
vm:simple-array-type)))
(write-descriptor result vm:array-fill-pointer-slot *nil-descriptor*)
(write-descriptor result vm:array-data-slot data-vector)
(write-descriptor result vm:array-displacement-slot *nil-descriptor*)
(write-descriptor result vm:array-displaced-p-slot *nil-descriptor*)
(let ((total-elements 1))
(dotimes (axis rank)
(let* ((dim (pop-stack))
(bits (descriptor-bits dim)))
(unless (zerop (ldb (byte 2 0) bits))
(error "Non-fixnum dimension? (~S)" dim))
(setf total-elements (* total-elements (ash bits -2)))
(write-descriptor result (+ vm:array-dimensions-offset axis) dim)))
(write-descriptor result vm:array-elements-slot
(make-fixnum-descriptor total-elements)))
result))
;;; Loading numbers.
(defmacro cold-number (fop)
`(define-cold-fop (,fop :nope)
(,fop)
(with-fop-stack t
(number-to-core (pop-stack)))))
(cold-number fop-single-float)
(cold-number fop-double-float)
(cold-number fop-integer)
(cold-number fop-small-integer)
(cold-number fop-word-integer)
(cold-number fop-byte-integer)
(define-cold-fop (fop-ratio)
(let ((den (pop-stack)))
(number-pair-to-core (pop-stack) den vm:ratio-type)))
(define-cold-fop (fop-complex)
(let ((im (pop-stack)))
(number-pair-to-core (pop-stack) im vm:complex-type)))
;;; Calling (or not calling).
(not-cold-fop fop-eval)
(not-cold-fop fop-eval-for-effect)
(defvar *load-time-value-counter*)
(define-cold-fop (fop-funcall)
(unless (= (read-arg 1) 0)
(error "Can't FOP-FUNCALL random stuff in cold load."))
(let ((counter *load-time-value-counter*))
(cold-push (cold-cons
(cold-intern :load-time-value)
(cold-cons
(pop-stack)
(cold-cons
(number-to-core counter)
*nil-descriptor*)))
*current-init-functions-cons*)
(setf *load-time-value-counter* (1+ counter))
(make-pointer-descriptor counter :load-time-cookie nil)))
(defun note-load-time-value-reference (address marker)
(cold-push (cold-cons
(cold-intern :load-time-value-fixup)
(cold-cons
(sap-to-core address)
(cold-cons
(number-to-core (descriptor-bits marker))
*nil-descriptor*)))
*current-init-functions-cons*))
(defun finalize-load-time-value-noise ()
(cold-setq (cold-intern 'lisp::*load-time-values*)
(allocate-vector-object *dynamic* vm:word-bits
*load-time-value-counter*
vm:simple-vector-type)))
(define-cold-fop (fop-funcall-for-effect nil)
(if (= (read-arg 1) 0)
(cold-push (pop-stack) *current-init-functions-cons*)
(error "Can't FOP-FUNCALL random stuff in cold load.")))
;;;; Fixing up circularities.
(define-cold-fop (fop-rplaca nil)
(let ((obj (svref *current-fop-table* (read-arg 4)))
(idx (read-arg 4)))
(write-descriptor (cold-nthcdr idx obj) 0 (pop-stack))))
(define-cold-fop (fop-rplacd nil)
(let ((obj (svref *current-fop-table* (read-arg 4)))
(idx (read-arg 4)))
(write-descriptor (cold-nthcdr idx obj) 1 (pop-stack))))
(define-cold-fop (fop-svset nil)
(let ((obj (svref *current-fop-table* (read-arg 4)))
(idx (read-arg 4)))
(write-descriptor obj (+ idx vm:vector-data-offset) (pop-stack))))
(define-cold-fop (fop-structset nil)
(let ((obj (svref *current-fop-table* (read-arg 4)))
(idx (read-arg 4)))
(write-descriptor obj (+ idx vm:instance-slots-offset) (pop-stack))))
(define-cold-fop (fop-nthcdr t)
(cold-nthcdr (read-arg 4) (pop-stack)))
(defun cold-nthcdr (index obj)
(iterate repeat ((result obj) (index index))
(cond ((plusp index)
(repeat (read-descriptor result 1) (1- index)))
(t
(setf (descriptor-step result) (descriptor-step obj))
result))))
;;; Loading code objects and functions.
(define-cold-fop (fop-fset nil)
(let ((fn (pop-stack))
(name (pop-stack)))
(cold-fset name fn)))
(define-cold-fop (fop-fdefinition)
(cold-fdefinition-object (pop-stack)))
(define-cold-fop (fop-sanctify-for-execution)
(pop-stack))
(defun cold-verify-code-format ()
(unless *current-code-format*
(error "Can't load code until after FOP-CODE-FORMAT."))
(let ((implementation (car *current-code-format*))
(version (cdr *current-code-format*)))
(unless (= implementation (c:backend-fasl-file-implementation c:*backend*))
(error
"~A was compiled for a ~A, but we are trying to build a core for a ~A"
*Fasl-file*
(or (elt c:fasl-file-implementations implementation)
"unknown machine")
(or (elt c:fasl-file-implementations
(c:backend-fasl-file-implementation c:*backend*))
"unknown machine")))
(unless (= version (c:backend-fasl-file-version c:*backend*))
(error
"~A was compiled for a fasl-file version ~A, but we need version ~A"
*Fasl-file* version (c:backend-fasl-file-version c:*backend*)))))
(defmacro define-cold-code-fop (name nconst size)
`(define-cold-fop (,name)
(cold-verify-code-format)
(let* ((nconst ,nconst)
(inst-words ,size)
(header-size
;; Note: we round the number of constants up to assure that
;; the code vector will be properly aligned.
(round-up (+ vm:code-debug-info-slot nconst) 2))
(des (allocate-descriptor *dynamic*
(+ header-size inst-words)
vm:other-pointer-type
t)))
(write-descriptor des 0
(make-other-immediate-descriptor header-size
vm:code-header-type))
(write-descriptor des vm:code-code-size-slot
(make-fixnum-descriptor inst-words))
(write-descriptor des vm:code-entry-points-slot *nil-descriptor*)
(do ((index (1- (+ nconst vm:code-debug-info-slot)) (1- index)))
((< index vm:code-debug-info-slot))
(write-descriptor des index (pop-stack)))
(read-n-bytes *fasl-file*
(descriptor-sap des)
(ash header-size vm:word-shift)
(ash inst-words vm:word-shift))
des)))
(define-cold-code-fop fop-code (read-arg 4) (read-arg 4))
(define-cold-code-fop fop-small-code (read-arg 1) (read-arg 2))
(clone-cold-fop (fop-alter-code nil)
(fop-byte-alter-code)
(let ((slot (clone-arg))
(value (pop-stack))
(code (pop-stack)))
(write-descriptor code slot value)))
(defun calc-offset (code-object after-header)
(+ after-header
(ash (ash (read-bits code-object 0) (- vm:type-bits)) vm:word-shift)))
(define-cold-fop (fop-function-entry)
(let* ((type (pop-stack))
(arglist (pop-stack))
(name (pop-stack))
(code-object (pop-stack))
(offset (calc-offset code-object (read-arg 4)))
(fn (descriptor-beyond code-object offset vm:function-pointer-type))
(next (read-descriptor code-object vm:code-entry-points-slot)))
(unless (zerop (logand offset vm:lowtag-mask))
(warn "Unaligned function entry: ~S at #x~X" name offset))
(write-descriptor code-object vm:code-entry-points-slot fn)
(write-descriptor fn 0
(make-other-immediate-descriptor
(ash offset (- vm:word-shift))
vm:function-header-type))
(write-bits fn vm:function-entry-point-slot
(if (= (c:backend-fasl-file-implementation c:*backend*)
c:sparc-fasl-file-implementation)
(descriptor-bits fn)
(+ (logandc2 (descriptor-bits fn) vm:lowtag-mask)
(ash vm:function-code-offset vm:word-shift))))
(write-descriptor fn vm:function-next-slot next :remember :nothing)
(write-descriptor fn vm:function-name-slot name)
(write-descriptor fn vm:function-arglist-slot arglist)
(write-descriptor fn vm:function-type-slot type)
fn))
(define-cold-fop (fop-foreign-fixup)
(let* ((kind (pop-stack))
(code-object (pop-stack))
(len (read-arg 1))
(sym (make-string len)))
(read-n-bytes *fasl-file* sym 0 len)
(let ((offset (calc-offset code-object (read-arg 4))))
(do-cold-fixup code-object offset (lookup-foreign-symbol sym) kind))
code-object))
(define-cold-fop (fop-assembler-code)
(cold-verify-code-format)
(let* ((length (read-arg 4))
(header-size
;; Note: we round the number of constants up to assure that
;; the code vector will be properly aligned.
(round-up vm:code-constants-offset 2))
(des (allocate-descriptor *static*
(+ header-size length)
vm:other-pointer-type
t)))
(write-descriptor des 0
(make-other-immediate-descriptor header-size
vm:code-header-type))
(write-descriptor des vm:code-code-size-slot
(make-fixnum-descriptor length))
(write-descriptor des vm:code-entry-points-slot *nil-descriptor*)
(write-descriptor des vm:code-debug-info-slot *nil-descriptor*)
(read-n-bytes *fasl-file*
(descriptor-sap des)
(ash header-size vm:word-shift)
(ash length vm:word-shift))
des))
(define-cold-fop (fop-assembler-routine)
(let* ((routine (pop-stack))
(des (pop-stack))
(offset (calc-offset des (read-arg 4))))
(record-cold-assembler-routine
routine
(+ (logandc2 (descriptor-bits des) vm:lowtag-mask) offset))
des))
(define-cold-fop (fop-assembler-fixup)
(let* ((routine (pop-stack))
(kind (pop-stack))
(code-object (pop-stack))
(offset (calc-offset code-object (read-arg 4))))
(record-cold-assembler-fixup routine code-object offset kind)
code-object))
(define-cold-fop (fop-code-object-fixup)
(let* ((kind (pop-stack))
(code-object (pop-stack))
(offset (calc-offset code-object (read-arg 4))))
(do-cold-fixup code-object offset
(descriptor-bits code-object)
kind)
code-object))
;;; 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* ((*normal-fop-functions* fop-functions)
(fop-functions *cold-fop-functions*)
(*in-cold-load* t))
(with-open-file (file (merge-pathnames
filename
(make-pathname
:type (c:backend-fasl-file-type c:*backend*)))
:element-type '(unsigned-byte 8))
(load file :verbose nil))))
;;;; Fixups and related stuff.
(defvar *cold-foreign-symbol-table*)
(defun load-foreign-symbol-table (filename)
(with-open-file (file filename)
(let* ((version-line (read-line file))
(last-space (position #\Space version-line :from-end t))
(version (parse-integer version-line :start (1+ last-space))))
(loop
(let ((line (read-line file nil nil)))
(unless line
(return))
(multiple-value-bind
(value name)
(if (string= "0x" line :end2 2)
(values (parse-integer line :start 2 :end 10 :radix 16)
(subseq line 13))
(values (parse-integer line :end 8 :radix 16)
(subseq line 11)))
(multiple-value-bind
(old-value found)
(gethash name *cold-foreign-symbol-table*)
(when found
(warn "Redefining ~S from #x~X to #x~X" name old-value value)))
(setf (gethash name *cold-foreign-symbol-table*) value))))
version)))
(defun lookup-foreign-symbol (name)
(multiple-value-bind
(value found)
(gethash name *cold-foreign-symbol-table* 0)
(unless found
(warn "Undefined foreign symbol: ~S" name))
value))
(defvar *cold-assembler-routines*)
(defvar *cold-assembler-fixups*)
(defun record-cold-assembler-routine (name address)
(push (cons name address)
*cold-assembler-routines*))
(defun record-cold-assembler-fixup
(routine code-object offset &optional (kind :both))
(push (list routine code-object offset kind)
*cold-assembler-fixups*))
(defun lookup-assembler-reference (symbol)
(let ((value (cdr (assoc symbol *cold-assembler-routines*))))
(unless value (warn "Assembler routine ~S not defined." symbol))
value))
(defun resolve-assembler-fixups ()
(dolist (fixup *cold-assembler-fixups*)
(let* ((routine (car fixup))
(value (lookup-assembler-reference routine)))
(when value
(do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))))
(defun do-cold-fixup (code-object offset value kind)
(let ((sap (sap+ (descriptor-sap code-object) offset)))
(ecase (c:backend-fasl-file-implementation c:*backend*)
(#.c:pmax-fasl-file-implementation
(ecase kind
(:jump
(assert (zerop (ash value -26)))
(setf (ldb (byte 26 0) (sap-ref-32 sap 0))
(ash value -2)))
(:lui
(setf (sap-ref-16 sap 0)
(+ (ash value -16)
(if (logbitp 15 value) 1 0))))
(:addi
(setf (sap-ref-16 sap 0)
(ldb (byte 16 0) value)))))
(#.c:sparc-fasl-file-implementation
(let ((inst (maybe-byte-swap (sap-ref-32 sap 0))))
(ecase kind
(:call
(error "Can't deal with call fixups yet."))
(:sethi
(setf inst
(dpb (ldb (byte 22 10) value)
(byte 22 0)
inst)))
(:add
(setf inst
(dpb (ldb (byte 10 0) value)
(byte 10 0)
inst))))
(setf (sap-ref-32 sap 0)
(maybe-byte-swap inst))))
((#.c:rt-fasl-file-implementation
#.c:rt-afpa-fasl-file-implementation)
(ecase kind
(:cal
(setf (sap-ref-16 sap 2)
(maybe-byte-swap-short
(ldb (byte 16 0) value))))
(:cau
(let ((high (ldb (byte 16 16) value)))
(setf (sap-ref-16 sap 2)
(maybe-byte-swap-short
(if (logbitp 15 value) (1+ high) high)))))
(:ba
(unless (zerop (ash value -24))
(warn "#x~8,'0X out of range for branch-absolute." value))
(let ((inst (maybe-byte-swap-short (sap-ref-16 sap 0))))
(setf (sap-ref-16 sap 0)
(maybe-byte-swap-short
(dpb (ldb (byte 8 16) value)
(byte 8 0)
inst))))
(setf (sap-ref-16 sap 2)
(maybe-byte-swap-short (ldb (byte 16 0) value))))))
(#.c:x86-fasl-file-implementation
(let* ((disp (logior (sap-ref-8 sap 0)
(ash (sap-ref-8 sap 1) 8)
(ash (sap-ref-8 sap 2) 16)
(ash (sap-ref-8 sap 3) 24)))
(bits (descriptor-bits code-object))
(value (ecase kind
(:absolute (+ value disp))
(:relative (- (+ value disp vm:other-pointer-type)
bits offset 4)))))
(setf (sap-ref-8 sap 0) (ldb (byte 8 0) value))
(setf (sap-ref-8 sap 1) (ldb (byte 8 8) value))
(setf (sap-ref-8 sap 2) (ldb (byte 8 16) value))
(setf (sap-ref-8 sap 3) (ldb (byte 8 24) value))))
(#.c:hppa-fasl-file-implementation
(let ((inst (maybe-byte-swap (sap-ref-32 sap 0))))
(setf (sap-ref-32 sap 0)
(maybe-byte-swap
(ecase kind
(:load
(logior (ash (ldb (byte 11 0) value) 1)
(logand inst #xffffc000)))
(:load-short
(let ((low-bits (ldb (byte 11 0) value)))
(assert (<= 0 low-bits (1- (ash 1 4))))
(logior (ash low-bits 17)
(logand inst #xffe0ffff))))
(:hi
(logior (ash (ldb (byte 5 13) value) 16)
(ash (ldb (byte 2 18) value) 14)
(ash (ldb (byte 2 11) value) 12)
(ash (ldb (byte 11 20) value) 1)
(ldb (byte 1 31) value)
(logand inst #xffe00000)))
(:branch
(let ((bits (ldb (byte 9 2) value)))
(assert (zerop (ldb (byte 2 0) value)))
(logior (ash bits 3)
(logand inst #xffe0e002)))))))))))
(undefined-value))
(defun linkage-info-to-core ()
(let ((result *nil-descriptor*))
(maphash #'(lambda (symbol value)
(cold-push (cold-cons (string-to-core symbol)
(number-to-core value))
result))
*cold-foreign-symbol-table*)
(cold-setq (cold-intern '*initial-foreign-symbols*) result))
(let ((result *nil-descriptor*))
(dolist (rtn *cold-assembler-routines*)
(cold-push (cold-cons (cold-intern (car rtn))
(number-to-core (cdr rtn)))
result))
(cold-setq (cold-intern '*initial-assembler-routines*) result)))
;;;; Emit C Header.
(defun tail-comp (string tail)
(and (>= (length string) (length tail))
(string= string tail :start1 (- (length string) (length tail)))))
(defun head-comp (string head)
(and (>= (length string) (length head))
(string= string head :end1 (length head))))
(defun emit-c-header-aux ()
(format t "/*~% * Machine generated header file. Do not edit.~% */~2%")
(format t "#ifndef _INTERNALS_H_~%#define _INTERNALS_H_~2%")
(let ((constants nil))
(do-external-symbols (symbol (find-package "VM"))
(when (constantp symbol)
(let ((name (symbol-name symbol)))
(labels
((record (prefix string priority)
(push (list (concatenate
'simple-string
prefix
(delete #\- (string-capitalize string)))
priority
(symbol-value symbol)
(documentation symbol 'variable))
constants))
(test-tail (tail prefix priority)
(when (tail-comp name tail)
(record prefix
(subseq name 0
(- (length name)
(length tail)))
priority)))
(test-head (head prefix priority)
(when (head-comp name head)
(record prefix
(subseq name (length head))
priority))))
(test-tail "-TYPE" "type_" 0)
(test-tail "-TRAP" "trap_" 2)
(test-head "TRACE-TABLE-" "tracetab_" 4)
(test-tail "-SC-NUMBER" "sc_" 5)))))
(setf constants
(sort constants
#'(lambda (const1 const2)
(if (= (second const1) (second const2))
(< (third const1) (third const2))
(< (second const1) (second const2))))))
(let ((prev-priority (second (car constants))))
(dolist (const constants)
(unless (= prev-priority (second const))
(terpri)
(setf prev-priority (second const)))
(format t "#define ~A ~D~@[ /* ~A */~]~%"
(first const) (third const) (fourth const))))
(terpri)
(format t "#define ERRORS { \\~%")
(loop
for info across (c:backend-internal-errors c:*backend*)
do (format t " ~S, \\~%" (cdr info)))
(format t " NULL \\~%}~%")
(terpri))
(let ((structs (sort (copy-list vm:*primitive-objects*) #'string<
:key #'(lambda (obj)
(symbol-name
(vm:primitive-object-name obj))))))
(format t "#ifndef LANGUAGE_ASSEMBLY~2%")
(format t "#define LISPOBJ(x) ((lispobj)x)~2%")
(dolist (obj structs)
(format t "struct ~A {~%"
(nsubstitute #\_ #\-
(string-downcase
(string (vm:primitive-object-name obj)))))
(when (vm:primitive-object-header obj)
(format t " lispobj header;~%"))
(dolist (slot (vm:primitive-object-slots obj))
(format t " ~A ~A~@[[0]~];~%"
(getf (vm:slot-options slot) :c-type "lispobj")
(nsubstitute #\_ #\-
(string-downcase (string (vm:slot-name slot))))
(vm:slot-rest-p slot)))
(format t "};~2%"))
(format t "#else /* LANGUAGE_ASSEMBLY */~2%")
(format t "#define LISPOBJ(thing) thing~2%")
(dolist (obj structs)
(let ((name (vm:primitive-object-name obj))
(lowtag (or (eval (vm:primitive-object-lowtag obj)) 0)))
(dolist (slot (vm:primitive-object-slots obj))
(format t "#define ~A_~A_OFFSET ~D~%"
(substitute #\_ #\- (string name))
(substitute #\_ #\- (string (vm:slot-name slot)))
(- (* (vm:slot-offset slot) vm:word-bytes) lowtag)))
(terpri)))
(format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
(dolist (symbol (cons nil vm:static-symbols))
(format t "#define ~A LISPOBJ(0x~X)~%"
(nsubstitute #\_ #\-
(remove-if #'(lambda (char)
(member char '(#\% #\*)))
(symbol-name symbol)))
(if (boundp '*static*)
;; We actually ran Genesis, use the real value.
(descriptor-bits (cold-intern symbol))
;; We didn't run Genesis, so guess at the address.
(+ *heap-start*
vm:word-bytes
vm:other-pointer-type
(if symbol (vm:static-symbol-offset symbol) 0)))))
(format t "~%#endif~%"))
;;; FILES-DIFFER --- internal
;;;
;;; Return T iff the two files differ.
;;;
(defun files-differ (name1 name2)
(with-open-file (file1 name1)
(with-open-file (file2 name2)
(or (not (= (file-length file1)
(file-length file2)))
(do ((line1 "foo" (read-line file1 nil nil))
(line2 "foo" (read-line file2 nil nil)))
((and (null line1) (null line2)) nil)
(when (or (null line1)
(null line2)
(string/= line1 line2))
(return t)))))))
(defun emit-c-header (name)
(let* ((new-name (concatenate 'string (namestring name) ".NEW"))
(unix-newname (unix-namestring new-name nil)))
(with-open-file
(*standard-output* new-name
:direction :output
:if-exists :supersede)
(emit-c-header-aux))
(cond ((not (probe-file name))
(unix:unix-chmod unix-newname #o444)
(rename-file new-name name))
((files-differ name new-name)
(rename-file name
(concatenate 'simple-string
(namestring name)
".OLD"))
(unix:unix-chmod unix-newname #o444)
(rename-file new-name name)
(warn "The C header file has changed.~%Be sure to ~
re-compile the startup code."))
(t
(unix:unix-unlink unix-newname))))
(undefined-value))
;;;; The actual genesis function.
(defvar *genesis-core-name* "lisp.core")
(defvar *genesis-map-name* nil)
(defvar *genesis-c-header-name* t)
(defvar *genesis-symbol-table* nil)
(defun genesis (file-list &key
(symbol-table *genesis-symbol-table*)
(core-name *genesis-core-name*)
(map-name *genesis-map-name*)
(header-name *genesis-c-header-name*))
"Builds a kernel Lisp image from the .FASL files specified in the given
File-List and writes it to a file named by Core-Name."
(unless symbol-table
(error "Can't genesis without a symbol-table."))
(format t "~&Building ~S for the ~A~%"
core-name (c:backend-version c:*backend*))
(with-allocation-pool
(let* ((*block-owners* (make-array 16 :initial-element nil))
(generations
(make-generations gen-default-policy gen-tenure-policy))
(*static* (make-step 1 step-tenure-policy (second generations)))
(*dynamic* (make-step 0 step-default-policy (first generations)))
(*current-los-cluster* nil)
(*current-init-functions-cons* nil)
(*cold-packages* nil)
(*cold-symbols* (make-hash-table :test #'equal))
(*fdefn-objects* (make-hash-table :test #'equal))
(*load-time-value-counter* 0)
(*cold-foreign-symbol-table* (make-hash-table :test #'equal))
(*cold-assembler-routines* nil)
(*cold-assembler-fixups* nil)
(version (load-foreign-symbol-table symbol-table))
(initial-function nil))
(initialize-symbols)
(initialize-layouts)
(setf *current-init-functions-cons* *nil-descriptor*)
(initialize-static-fns)
(dolist (file (if (listp file-list)
file-list
(list file-list)))
(let ((file (truename
(merge-pathnames file
(make-pathname
:type
(c:backend-fasl-file-type
c:*backend*))))))
(write-line (namestring file))
(cold-load file))
(maybe-gc))
(let ((initial-fdefn
(cold-fdefinition-object (cold-intern 'lisp::%initial-function))))
(setf initial-function
(read-bits initial-fdefn vm:fdefn-function-slot)))
(resolve-assembler-fixups)
(linkage-info-to-core)
(finish-symbols)
(finalize-load-time-value-noise)
(when map-name
(with-open-file
(*standard-output* (if (eq map-name t)
(make-pathname
:type "map"
:defaults core-name)
(merge-pathnames
map-name
(make-pathname :type "map"
:defaults core-name)))
:direction :output
:if-exists :supersede)
(write-map-file)))
(when header-name
(emit-c-header
(merge-pathnames (if (eq header-name t)
"internals.h"
(merge-pathnames
header-name
(make-pathname :type "h")))
core-name)))
(write-initial-core-file core-name version generations
initial-function))))
(defun write-map-file ()
(let ((*print-pretty* nil)
(*print-case* :upcase))
(format t "Assembler routines defined in core image:~2%")
(dolist (routine (sort (copy-list *cold-assembler-routines*) #'<
:key #'cdr))
(format t "#x~8,'0X: ~S~%" (cdr routine) (car routine)))
(let ((funs nil) (undefs nil))
(maphash #'(lambda (name fdefn)
(let ((fun-bits (read-bits fdefn vm:fdefn-function-slot)))
(if (= fun-bits (descriptor-bits *nil-descriptor*))
(push name undefs)
(push (list* name
fun-bits
(read-bits fdefn vm:fdefn-raw-addr-slot))
funs))))
*fdefn-objects*)
(format t "~%~|~%Initially defined functions:~2%")
(dolist (info (sort funs #'< :key #'cddr))
(format t "#x~8,'0X: ~S #x~8,'0X~%"
(cddr info) (car info) (cadr info)))
(format t "~%~|~%Undefined function references:~2%")
(labels ((key (name)
(etypecase name
(symbol (symbol-name name))
(integer (prin1-to-string name))
(list (key (second name))))))
(dolist (fun (sort undefs #'string< :key #'key))
(format t "~S~%" fun)))
(format t "~%~|~%Layout names:~2%")
(collect ((stuff))
(maphash #'(lambda (name desc)
(stuff (cons (descriptor-bits desc) name)))
*cold-layouts*)
(dolist (x (sort (stuff) #'< :key #'car))
(format t "#x~8,'0X: ~S~%" (car x) (cdr x))))))
(undefined-value))
;;;; Core file writing magic.
(defstruct (range
(:print-function %print-range))
;;
(address (required-argument) :type address)
;;
bytes
;;
pieces
;;
next)
(defun %print-range (range stream depth)
(declare (ignore depth))
(print-unreadable-object (range stream :type t)
(format stream "#x~8,'0X...#x~8,'0X"
(range-address range)
(+ (range-address range) (range-bytes range)))))
(defconstant max-gap (ash 1 14))
(defun compute-ranges (generations)
(let ((ranges nil)
(page-size (c:backend-page-size c:*backend*)))
(flet
((write-range (sap addr bytes)
(let* ((start-offset (rem addr page-size))
(addr (- addr start-offset))
(sap (sap+ sap (- start-offset)))
(pages (ceiling (+ bytes start-offset) page-size))
(bytes (* pages page-size)))
(iterate repeat ((prev nil) (range ranges))
(flet ((insert (next)
(if prev
(setf (range-next prev) next)
(setf ranges next))))
(if range
(if (< addr (range-address range))
(insert (make-range :address addr :bytes bytes
:pieces (list (cons sap bytes))
:next range))
(repeat range (range-next range)))
(insert (make-range :address addr :bytes bytes
:pieces
(list (cons sap bytes))))))))))
(dolist (gen generations)
(dolist (step (generation-steps gen))
(do ((block (step-block step) (block-next block)))
((null block))
(write-range (block-sap block)
(block-base block)
(block-free block)))))
(do ((cluster *current-los-cluster* (cluster-next cluster)))
((null cluster))
(let* ((first (cluster-first cluster))
(base (cluster-base cluster))
(offset (- first base)))
(write-range (sap+ (cluster-sap cluster) offset)
first
(- (cluster-free cluster) offset)))))
(when ranges
(iterate repeat ((prev ranges) (next (range-next ranges)))
(when next
(let* ((prev-length (range-bytes prev))
(prev-end (+ (range-address prev) prev-length))
(next-start (range-address next))
(gap (- next-start prev-end)))
(if (< gap max-gap)
(let ((next-next (range-next next)))
(setf (range-pieces prev)
(append (range-pieces prev)
(cons (cons (int-sap 0) gap)
(range-pieces next))))
(setf (range-next prev) next-next)
(setf (range-bytes prev)
(+ prev-length gap (range-bytes next)))
(repeat prev next-next))
(repeat next (range-next next)))))))
ranges))
(defconstant max-header-size (ash 1 12))
(defvar *header-buffer*)
(defvar *header-fill-pointer*)
(defun write-long (num)
(let ((fill-pointer *header-fill-pointer*))
(setf (sap-ref-32 *header-buffer* fill-pointer) (maybe-byte-swap num))
(setf *header-fill-pointer* (+ fill-pointer 4))))
(defun write-magic-number (version)
(write-long (logior (ash (char-code #\C) 24)
(ash (char-code #\O) 16)
(ash (char-code #\R) 8)
(char-code #\E)))
(write-long version))
(defun write-chunks (chunks)
(do ((range chunks (range-next range)))
((null range))
(write-long (range-address range))
(write-long (range-bytes range))
(write-long 0))
(write-long 0))
(defun really-do-writing (chunk-info-start chunks file)
(let ((header-length (round-up *header-fill-pointer*
(c:backend-page-size c:*backend*))))
(do ((range chunks (range-next range))
(index (+ chunk-info-start 8) (+ index 12))
(file-offset header-length (+ file-offset (range-bytes range))))
((null range))
(setf (sap-ref-32 *header-buffer* index) (maybe-byte-swap file-offset))
(format t "Writing ~:D bytes from #x~8,'0X...~%"
(range-bytes range)
(range-address range))
(do ((file-offset file-offset (+ file-offset (cdar pieces)))
(pieces (range-pieces range) (cdr pieces)))
((null pieces))
(let* ((piece (car pieces))
(sap (car piece)))
(unless (zerop (sap-int sap))
(file-position file file-offset)
(system:output-raw-bytes file sap 0 (cdr piece))))))
(file-position file 0)
(system:output-raw-bytes file *header-buffer* 0 header-length))
nil)
(defun write-clusters ()
(do ((cluster *current-los-cluster* (cluster-next cluster)))
((null cluster))
(let ((base (cluster-base cluster)))
(write-long base)
(write-long (cluster-blocks cluster))
(write-long (cluster-first cluster))
(write-long (+ base (cluster-free cluster)))))
(write-long 0))
(defun write-generations (generations)
(write-long (length generations))
(dolist (gen generations)
(write-long (generation-policy gen))
(let ((steps (generation-steps gen)))
(write-long (length steps))
(dolist (step steps)
(write-long 0) ; step pointer
(write-long (step-num step)) ; step number
(write-long (step-num step)) ; promotion step
(write-long 0) ; max blocks
(write-long (step-policy step))
(do ((block (step-block step) (block-next block)))
((null block))
(let ((base (block-base block)))
(write-long base)
(write-long (+ base (block-free block)))))
(write-long 0)
(let* ((block (step-block step))
(base (block-base block)))
(write-long (+ base (block-free block)))
(write-long (+ base block-bytes)))
(write-long (step-first-LO step))
(write-long (step-last-LO step))))
(maphash #'(lambda (address ignore)
(declare (ignore ignore))
(write-long address))
(generation-remset gen))
(write-long 0)))
(defun write-initial-core-file (name version generations initial-function)
(format t "[Building Initial Core File (version ~D) in file ~S: ~%"
version (namestring name))
(force-output)
(let ((*header-buffer* (nth-value 1 (allocate-blocks 1)))
(*header-fill-pointer* 0))
(with-open-file (file name
:direction :output
:element-type '(unsigned-byte 8)
:if-exists :rename-and-delete)
(write-magic-number version)
(let* ((chunks-start *header-fill-pointer*)
(chunks (compute-ranges generations)))
(write-chunks chunks)
(write-clusters)
(write-generations generations)
(write-long initial-function)
(really-do-writing chunks-start chunks file))))
(format t "done]~%")
(force-output))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment