From a332872f8ede4b9a02bc09e47af02febb9740dfa Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Fri, 7 May 1993 07:25:58 +0000 Subject: [PATCH] Initial revision --- compiler/generic/gengc-genesis.lisp | 2341 +++++++++++++++++++++++++++ 1 file changed, 2341 insertions(+) create mode 100644 compiler/generic/gengc-genesis.lisp diff --git a/compiler/generic/gengc-genesis.lisp b/compiler/generic/gengc-genesis.lisp new file mode 100644 index 000000000..fa1df7d5b --- /dev/null +++ b/compiler/generic/gengc-genesis.lisp @@ -0,0 +1,2341 @@ +;;; -*- 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)) + -- GitLab