genesis.lisp

开源跨平台Lisp编译器


;;;; allocating images of primitive objects in the cold core

;;; There are three kinds of blocks of memory in the type system:
;;; * Boxed objects (cons cells, structures, etc): These objects have no
;;;   header as all slots are descriptors.
;;; * Unboxed objects (bignums): There is a single header word that contains
;;;   the length.
;;; * Vector objects: There is a header word with the type, then a word for
;;;   the length, then the data.
(defun allocate-boxed-object (gspace length lowtag)
  #!+sb-doc
  "Allocate LENGTH words in GSPACE and return a new descriptor of type LOWTAG
  pointing to them."
  (allocate-cold-descriptor gspace (ash length sb!vm:word-shift) lowtag))
(defun allocate-unboxed-object (gspace element-bits length type)
  #!+sb-doc
  "Allocate LENGTH units of ELEMENT-BITS bits plus a header word in GSPACE and
  return an ``other-pointer'' descriptor to them. Initialize the header word
  with the resultant length and TYPE."
  (let* ((bytes (/ (* element-bits length) sb!vm:n-byte-bits))
         (des (allocate-cold-descriptor gspace
                                        (+ bytes sb!vm:n-word-bytes)
                                        sb!vm:other-pointer-lowtag)))
    (write-memory des
                  (make-other-immediate-descriptor (ash bytes
                                                        (- sb!vm:word-shift))
                                                   type))
    des))
(defun allocate-vector-object (gspace element-bits length type)
  #!+sb-doc
  "Allocate LENGTH units of ELEMENT-BITS size plus a header plus a length slot in
  GSPACE and return an ``other-pointer'' descriptor to them. Initialize the
  header word with TYPE and the length slot with LENGTH."
  ;; FIXME: Here and in ALLOCATE-UNBOXED-OBJECT, BYTES is calculated using
  ;; #'/ instead of #'CEILING, which seems wrong.
  (let* ((bytes (/ (* element-bits length) sb!vm:n-byte-bits))
         (des (allocate-cold-descriptor gspace
                                        (+ bytes (* 2 sb!vm:n-word-bytes))
                                        sb!vm:other-pointer-lowtag)))
    (write-memory des (make-other-immediate-descriptor 0 type))
    (write-wordindexed des
                       sb!vm:vector-length-slot
                       (make-fixnum-descriptor length))
    des))

;;;; copying simple objects into the cold core

(defun base-string-to-core (string &optional (gspace *dynamic*))
  #!+sb-doc
  "Copy STRING (which must only contain STANDARD-CHARs) into the cold
core and return a descriptor to it."
  ;; (Remember that the system convention for storage of strings leaves an
  ;; extra null byte at the end to aid in call-out to C.)
  (let* ((length (length string))
         (des (allocate-vector-object gspace
                                      sb!vm:n-byte-bits
                                      (1+ length)
                                      sb!vm:simple-base-string-widetag))
         (bytes (gspace-bytes gspace))
         (offset (+ (* sb!vm:vector-data-offset sb!vm:n-word-bytes)
                    (descriptor-byte-offset des))))
    (write-wordindexed des
                       sb!vm:vector-length-slot
                       (make-fixnum-descriptor length))
    (dotimes (i length)
      (setf (bvref bytes (+ offset i))
            (sb!xc:char-code (aref string i))))
    (setf (bvref bytes (+ offset length))
          0) ; null string-termination character for C
    des))

(defun bignum-to-core (n)
  #!+sb-doc
  "Copy a bignum to the cold core."
  (let* ((words (ceiling (1+ (integer-length n)) sb!vm:n-word-bits))
         (handle (allocate-unboxed-object *dynamic*
                                          sb!vm:n-word-bits
                                          words
                                          sb!vm:bignum-widetag)))
    (declare (fixnum words))
    (do ((index 1 (1+ index))
         (remainder n (ash remainder (- sb!vm:n-word-bits))))
        ((> index words)
         (unless (zerop (integer-length remainder))
           ;; FIXME: Shouldn't this be a fatal error?
           (warn "~W words of ~W were written, but ~W bits were left over."
                 words n remainder)))
      (let ((word (ldb (byte sb!vm:n-word-bits 0) remainder)))
        (write-wordindexed handle index
                           (make-descriptor (ash word (- descriptor-low-bits))
                                            (ldb (byte descriptor-low-bits 0)
                                                 word)))))
    handle))

(defun number-pair-to-core (first second type)
  #!+sb-doc
  "Makes a number pair of TYPE (ratio or complex) and fills it in."
  (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits 2 type)))
    (write-wordindexed des 1 first)
    (write-wordindexed des 2 second)
    des))

(defun write-double-float-bits (address index x)
  (let ((hi (double-float-high-bits x))
        (lo (double-float-low-bits x)))
    (ecase sb!vm::n-word-bits
      (32
       (let ((high-bits (make-random-descriptor hi))
             (low-bits (make-random-descriptor lo)))
         (ecase sb!c:*backend-byte-order*
           (:little-endian
            (write-wordindexed address index low-bits)
            (write-wordindexed address (1+ index) high-bits))
           (:big-endian
            (write-wordindexed address index high-bits)
            (write-wordindexed address (1+ index) low-bits)))))
      (64
       (let ((bits (make-random-descriptor
                    (ecase sb!c:*backend-byte-order*
                      (:little-endian (logior lo (ash hi 32)))
                      ;; Just guessing.
                      #+nil (:big-endian (logior (logand hi #xffffffff)
                                                 (ash lo 32)))))))
         (write-wordindexed address index bits))))
    address))

(defun float-to-core (x)
  (etypecase x
    (single-float
     ;; 64-bit platforms have immediate single-floats.
     #!+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
     (make-random-descriptor (logior (ash (single-float-bits x) 32)
                                     sb!vm::single-float-widetag))
     #!-#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
     (let ((des (allocate-unboxed-object *dynamic*
                                         sb!vm:n-word-bits
                                         (1- sb!vm:single-float-size)
                                         sb!vm:single-float-widetag)))
       (write-wordindexed des
                          sb!vm:single-float-value-slot
                          (make-random-descriptor (single-float-bits x)))
       des))
    (double-float
     (let ((des (allocate-unboxed-object *dynamic*
                                         sb!vm:n-word-bits
                                         (1- sb!vm:double-float-size)
                                         sb!vm:double-float-widetag)))
       (write-double-float-bits des sb!vm:double-float-value-slot x)))))

(defun complex-single-float-to-core (num)
  (declare (type (complex single-float) num))
  (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
                                      (1- sb!vm:complex-single-float-size)
                                      sb!vm:complex-single-float-widetag)))
    (write-wordindexed des sb!vm:complex-single-float-real-slot
                   (make-random-descriptor (single-float-bits (realpart num))))
    (write-wordindexed des sb!vm:complex-single-float-imag-slot
                   (make-random-descriptor (single-float-bits (imagpart num))))
    des))

(defun complex-double-float-to-core (num)
  (declare (type (complex double-float) num))
  (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits
                                      (1- sb!vm:complex-double-float-size)
                                      sb!vm:complex-double-float-widetag)))
    (write-double-float-bits des sb!vm:complex-double-float-real-slot
                             (realpart num))
    (write-double-float-bits des sb!vm:complex-double-float-imag-slot
                             (imagpart num))))

;;; Copy the given number to the core.
(defun number-to-core (number)
  (typecase number
    (integer (if (< (integer-length number)
                    (- (1+ sb!vm:n-word-bits) sb!vm:n-lowtag-bits))
                 (make-fixnum-descriptor number)
                 (bignum-to-core number)))
    (ratio (number-pair-to-core (number-to-core (numerator number))
                                (number-to-core (denominator number))
                                sb!vm:ratio-widetag))
    ((complex single-float) (complex-single-float-to-core number))
    ((complex double-float) (complex-double-float-to-core number))
    #!+long-float
    ((complex long-float)
     (error "~S isn't a cold-loadable number at all!" number))
    (complex (number-pair-to-core (number-to-core (realpart number))
                                  (number-to-core (imagpart number))
                                  sb!vm:complex-widetag))
    (float (float-to-core number))
    (t (error "~S isn't a cold-loadable number at all!" number))))

(declaim (ftype (function (sb!vm:word) descriptor) sap-int-to-core))
(defun sap-int-to-core (sap-int)
  (let ((des (allocate-unboxed-object *dynamic*
                                      sb!vm:n-word-bits
                                      (1- sb!vm:sap-size)
                                      sb!vm:sap-widetag)))
    (write-wordindexed des
                       sb!vm:sap-pointer-slot
                       (make-random-descriptor sap-int))
    des))

;;; Allocate a cons cell in GSPACE and fill it in with CAR and CDR.
(defun cold-cons (car cdr &optional (gspace *dynamic*))
  (let ((dest (allocate-boxed-object gspace 2 sb!vm:list-pointer-lowtag)))
    (write-memory dest car)
    (write-wordindexed dest 1 cdr)
    dest))

;;; Make a simple-vector on the target that holds the specified
;;; OBJECTS, and return its descriptor.
(defun vector-in-core (&rest objects)
  (let* ((size (length objects))
         (result (allocate-vector-object *dynamic* sb!vm:n-word-bits size
                                         sb!vm:simple-vector-widetag)))
    (dotimes (index size)
      (write-wordindexed result (+ index sb!vm:vector-data-offset)
                         (pop objects)))
    result))

;;;; symbol magic

;;; FIXME: This should be a &KEY argument of ALLOCATE-SYMBOL.
(defvar *cold-symbol-allocation-gspace* nil)

;;; Allocate (and initialize) a symbol.
(defun allocate-symbol (name)
  (declare (simple-string name))
  (let ((symbol (allocate-unboxed-object (or *cold-symbol-allocation-gspace*
                                             *dynamic*)
                                         sb!vm:n-word-bits
                                         (1- sb!vm:symbol-size)
                                         sb!vm:symbol-header-widetag)))
    (write-wordindexed symbol sb!vm:symbol-value-slot *unbound-marker*)
    (write-wordindexed symbol
                       sb!vm:symbol-hash-slot
                       (make-fixnum-descriptor 0))
    (write-wordindexed symbol sb!vm:symbol-plist-slot *nil-descriptor*)
    (write-wordindexed symbol sb!vm:symbol-name-slot
                       (base-string-to-core name *dynamic*))
    (write-wordindexed symbol sb!vm:symbol-package-slot *nil-descriptor*)
    symbol))

;;; Set the cold symbol value of SYMBOL-OR-SYMBOL-DES, which can be either a
;;; descriptor of a cold symbol or (in an abbreviation for the
;;; most common usage pattern) an ordinary symbol, which will be
;;; automatically cold-interned.
(declaim (ftype (function ((or descriptor symbol) descriptor)) cold-set))
(defun cold-set (symbol-or-symbol-des value)
  (let ((symbol-des (etypecase symbol-or-symbol-des
                      (descriptor symbol-or-symbol-des)
                      (symbol (cold-intern symbol-or-symbol-des)))))
    (write-wordindexed symbol-des sb!vm:symbol-value-slot value)))

;;;; layouts and 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 [sic --
;;; WHN 19990816] is initializing layout's layout, which must point to
;;; itself.

;;; a map from class names to lists of
;;;    `(,descriptor ,name ,length ,inherits ,depth)
;;; KLUDGE: It would be more understandable and maintainable to use
;;; DEFSTRUCT (:TYPE LIST) here. -- WHN 19990823
(defvar *cold-layouts* (make-hash-table :test 'equal))

;;; a map from DESCRIPTOR-BITS of cold layouts to the name, for inverting
;;; mapping
(defvar *cold-layout-names* (make-hash-table :test 'eql))

;;; FIXME: *COLD-LAYOUTS* and *COLD-LAYOUT-NAMES* should be
;;; initialized by binding in GENESIS.

;;; the descriptor for layout's layout (needed when making layouts)
(defvar *layout-layout*)

(defconstant target-layout-length
  (layout-length (find-layout 'layout)))

(defun target-layout-index (slot-name)
  ;; KLUDGE: this is a little bit sleazy, but the tricky thing is that