genesis.lisp

开源跨平台Lisp编译器

;;;; "cold" core image builder: This is how we create a target Lisp
;;;; system from scratch, by converting from fasl files to an image
;;;; file in the cross-compilation host, without the help of the
;;;; target Lisp system.
;;;;
;;;; As explained by Rob MacLachlan on the CMU CL mailing list Wed, 06
;;;; Jan 1999 11:05:02 -0500, this cold load generator more or less
;;;; fakes up static function linking. I.e. it makes sure that all the
;;;; DEFUN-defined functions in the fasl files it reads are bound to the
;;;; corresponding symbols before execution starts. It doesn't do
;;;; anything to initialize variable values; instead it just arranges
;;;; for !COLD-INIT to be called at cold load time. !COLD-INIT is
;;;; responsible for explicitly initializing anything which has to be
;;;; initialized early before it transfers control to the ordinary
;;;; top level forms.
;;;;
;;;; (In CMU CL, and in SBCL as of 0.6.9 anyway, functions not defined
;;;; by DEFUN aren't set up specially by GENESIS. In particular,
;;;; structure slot accessors are not set up. Slot accessors are
;;;; available at cold init time because they're usually compiled
;;;; inline. They're not available as out-of-line functions until the
;;;; toplevel forms installing them have run.)

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!FASL")

;;; a magic number used to identify our core files
(defconstant core-magic
  (logior (ash (sb!xc:char-code #\S) 24)
          (ash (sb!xc:char-code #\B) 16)
          (ash (sb!xc:char-code #\C) 8)
          (sb!xc:char-code #\L)))

;;; the current version of SBCL core files
;;;
;;; FIXME: This is left over from CMU CL, and not well thought out.
;;; It's good to make sure that the runtime doesn't try to run core
;;; files from the wrong version, but a single number is not the ideal
;;; way to do this in high level data like this (as opposed to e.g. in
;;; IP packets), and in fact the CMU CL version number never ended up
;;; being incremented past 0. A better approach might be to use a
;;; string which is set from CVS data. (Though now as of sbcl-0.7.8 or
;;; so, we have another problem that the core incompatibility
;;; detection mechanisms are on such a hair trigger -- with even
;;; different builds from the same sources being considered
;;; incompatible -- that any coarser-grained versioning mechanisms
;;; like this are largely irrelevant as long as the hair-triggering
;;; persists.)
;;;
;;; 0: inherited from CMU CL
;;; 1: rearranged static symbols for sbcl-0.6.8
;;; 2: eliminated non-ANSI %DEFCONSTANT/%%DEFCONSTANT support,
;;;    deleted a slot from DEBUG-SOURCE structure
;;; 3: added build ID to cores to discourage sbcl/.core mismatch
;;; 4: added gc page table data
(defconstant sbcl-core-version-integer 4)

(defun round-up (number size)
  #!+sb-doc
  "Round NUMBER up to be an integral multiple of SIZE."
  (* size (ceiling number size)))

;;;; implementing the concept of "vector" in (almost) portable
;;;; Common Lisp
;;;;
;;;; "If you only need to do such simple things, it doesn't really
;;;; matter which language you use." -- _ANSI Common Lisp_, p. 1, Paul
;;;; Graham (evidently not considering the abstraction "vector" to be
;;;; such a simple thing:-)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant +smallvec-length+
    (expt 2 16)))

;;; an element of a BIGVEC -- a vector small enough that we have
;;; a good chance of it being portable to other Common Lisps
(deftype smallvec ()
  `(simple-array (unsigned-byte 8) (,+smallvec-length+)))

(defun make-smallvec ()
  (make-array +smallvec-length+ :element-type '(unsigned-byte 8)))

;;; a big vector, implemented as a vector of SMALLVECs
;;;
;;; KLUDGE: This implementation seems portable enough for our
;;; purposes, since realistically every modern implementation is
;;; likely to support vectors of at least 2^16 elements. But if you're
;;; masochistic enough to read this far into the contortions imposed
;;; on us by ANSI and the Lisp community, for daring to use the
;;; abstraction of a large linearly addressable memory space, which is
;;; after all only directly supported by the underlying hardware of at
;;; least 99% of the general-purpose computers in use today, then you
;;; may be titillated to hear that in fact this code isn't really
;;; portable, because as of sbcl-0.7.4 we need somewhat more than
;;; 16Mbytes to represent a core, and ANSI only guarantees that
;;; ARRAY-DIMENSION-LIMIT is not less than 1024. -- WHN 2002-06-13
(defstruct bigvec
  (outer-vector (vector (make-smallvec)) :type (vector smallvec)))

;;; analogous to SVREF, but into a BIGVEC
(defun bvref (bigvec index)
  (multiple-value-bind (outer-index inner-index)
      (floor index +smallvec-length+)
    (aref (the smallvec
            (svref (bigvec-outer-vector bigvec) outer-index))
          inner-index)))
(defun (setf bvref) (new-value bigvec index)
  (multiple-value-bind (outer-index inner-index)
      (floor index +smallvec-length+)
    (setf (aref (the smallvec
                  (svref (bigvec-outer-vector bigvec) outer-index))
                inner-index)
          new-value)))

;;; analogous to LENGTH, but for a BIGVEC
;;;
;;; the length of BIGVEC, measured in the number of BVREFable bytes it
;;; can hold
(defun bvlength (bigvec)
  (* (length (bigvec-outer-vector bigvec))
     +smallvec-length+))

;;; analogous to WRITE-SEQUENCE, but for a BIGVEC
(defun write-bigvec-as-sequence (bigvec stream &key (start 0) end)
  (loop for i of-type index from start below (or end (bvlength bigvec)) do
        (write-byte (bvref bigvec i)
                    stream)))

;;; analogous to READ-SEQUENCE-OR-DIE, but for a BIGVEC
(defun read-bigvec-as-sequence-or-die (bigvec stream &key (start 0) end)
  (loop for i of-type index from start below (or end (bvlength bigvec)) do
        (setf (bvref bigvec i)
              (read-byte stream))))

;;; Grow BIGVEC (exponentially, so that large increases in size have
;;; asymptotic logarithmic cost per byte).
(defun expand-bigvec (bigvec)
  (let* ((old-outer-vector (bigvec-outer-vector bigvec))
         (length-old-outer-vector (length old-outer-vector))
         (new-outer-vector (make-array (* 2 length-old-outer-vector))))
    (dotimes (i length-old-outer-vector)
      (setf (svref new-outer-vector i)
            (svref old-outer-vector i)))
    (loop for i from length-old-outer-vector below (length new-outer-vector) do
          (setf (svref new-outer-vector i)
                (make-smallvec)))
    (setf (bigvec-outer-vector bigvec)
          new-outer-vector))
  bigvec)

;;;; looking up bytes and multi-byte values in a BIGVEC (considering
;;;; it as an image of machine memory on the cross-compilation target)

;;; BVREF-32 and friends. These are like SAP-REF-n, except that
;;; instead of a SAP we use a BIGVEC.
(macrolet ((make-bvref-n
            (n)
            (let* ((name (intern (format nil "BVREF-~A" n)))
                   (number-octets (/ n 8))
                   (ash-list-le
                    (loop for i from 0 to (1- number-octets)
                          collect `(ash (bvref bigvec (+ byte-index ,i))
                                        ,(* i 8))))
                   (ash-list-be
                    (loop for i from 0 to (1- number-octets)
                          collect `(ash (bvref bigvec
                                               (+ byte-index
                                                  ,(- number-octets 1 i)))
                                        ,(* i 8))))
                   (setf-list-le
                    (loop for i from 0 to (1- number-octets)
                          append
                          `((bvref bigvec (+ byte-index ,i))
                            (ldb (byte 8 ,(* i 8)) new-value))))
                   (setf-list-be
                    (loop for i from 0 to (1- number-octets)
                          append
                          `((bvref bigvec (+ byte-index ,i))
                            (ldb (byte 8 ,(- n 8 (* i 8))) new-value)))))
              `(progn
                 (defun ,name (bigvec byte-index)
                   (logior ,@(ecase sb!c:*backend-byte-order*
                               (:little-endian ash-list-le)
                               (:big-endian ash-list-be))))
                 (defun (setf ,name) (new-value bigvec byte-index)
                   (setf ,@(ecase sb!c:*backend-byte-order*
                             (:little-endian setf-list-le)
                             (:big-endian setf-list-be))))))))
  (make-bvref-n 8)
  (make-bvref-n 16)
  (make-bvref-n 32)
  (make-bvref-n 64))

;; lispobj-sized word, whatever that may be
;; hopefully nobody ever wants a 128-bit SBCL...
#!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
(progn
(defun bvref-word (bytes index)
  (bvref-64 bytes index))
(defun (setf bvref-word) (new-val bytes index)
  (setf (bvref-64 bytes index) new-val)))

#!+#.(cl:if (cl:= 32 sb!vm:n-word-bits) '(and) '(or))
(progn
(defun bvref-word (bytes index)
  (bvref-32 bytes index))
(defun (setf bvref-word) (new-val bytes index)
  (setf (bvref-32 bytes index) new-val)))


;;;; representation of spaces in the core

;;; If there is more than one dynamic space in memory (i.e., if a
;;; copying GC is in use), then only the active dynamic space gets
;;; dumped to core.
(defvar *dynamic*)
(defconstant dynamic-core-space-id 1)

(defvar *static*)
(defconstant static-core-space-id 2)

(defvar *read-only*)
(defconstant read-only-core-space-id 3)

(defconstant descriptor-low-bits 16
  "the number of bits in the low half of the descriptor")
(defconstant target-space-alignment (ash 1 descriptor-low-bits)
  "the alignment requirement for spaces in the target.
  Must be at least (ASH 1 DESCRIPTOR-LOW-BITS)")

;;; a GENESIS-time representation of a memory space (e.g. read-only
;;; space, dynamic space, or static space)
(defstruct (gspace (:constructor %make-gspace)
                   (:copier nil))
  ;; name and identifier for this GSPACE
  (name (missing-arg) :type symbol :read-only t)
  (identifier (missing-arg) :type fixnum :read-only t)
  ;; the word address where the data will be loaded
  (word-address (missing-arg) :type unsigned-byte :read-only t)
  ;; the data themselves. (Note that in CMU CL this was a pair of
  ;; fields SAP and WORDS-ALLOCATED, but that wasn't very portable.)
  ;; (And then in SBCL this was a VECTOR, but turned out to be
  ;; unportable too, since ANSI doesn't think that arrays longer than
  ;; 1024 (!) should needed by portable CL code...)
  (bytes (make-bigvec) :read-only t)
  ;; the index of the next unwritten word (i.e. chunk of
  ;; SB!VM:N-WORD-BYTES bytes) in BYTES, or equivalently the number of
  ;; words actually written in BYTES. In order to convert to an actual
  ;; index into BYTES, thus must be multiplied by SB!VM:N-WORD-BYTES.
  (free-word-index 0))

(defun gspace-byte-address (gspace)
  (ash (gspace-word-address gspace) sb!vm:word-shift))

(def!method print-object ((gspace gspace) stream)
  (print-unreadable-object (gspace stream :type t)
    (format stream "~S" (gspace-name gspace))))

(defun make-gspace (name identifier byte-address)
  (unless (zerop (rem byte-address target-space-alignment))
    (error "The byte address #X~X is not aligned on a #X~X-byte boundary."
           byte-address
           target-space-alignment))
  (%make-gspace :name name
                :identifier identifier
                :word-address (ash byte-address (- sb!vm:word-shift))))

;;;; representation of descriptors

(defstruct (descriptor
            (:constructor make-descriptor
                          (high low &optional gspace word-offset))
            (:copier nil))
  ;; the GSPACE that this descriptor is allocated in, or NIL if not set yet.
  (gspace nil :type (or gspace null))
  ;; the offset in words from the start of GSPACE, or NIL if not set yet
  (word-offset nil :type (or sb!vm:word null))
  ;; the high and low halves of the descriptor