genesis.lisp

开源跨平台Lisp编译器

  ;; structure slots don't have a terribly firm idea of their names.
  ;; At least here if we change LAYOUT's package of definition, we
  ;; only have to change one thing...
  (let* ((name (find-symbol (symbol-name slot-name) "SB!KERNEL"))
         (layout (find-layout 'layout))
         (dd (layout-info layout))
         (slots (dd-slots dd))
         (dsd (find name slots :key #'dsd-name)))
    (aver dsd)
    (dsd-index dsd)))

(defun cold-set-layout-slot (cold-layout slot-name value)
  (write-wordindexed
   cold-layout
   (+ sb!vm:instance-slots-offset (target-layout-index slot-name))
   value))

;;; Return a list of names created from the cold layout INHERITS data
;;; in X.
(defun listify-cold-inherits (x)
  (let ((len (descriptor-fixnum (read-wordindexed x
                                                  sb!vm:vector-length-slot))))
    (collect ((res))
      (dotimes (index len)
        (let* ((des (read-wordindexed x (+ sb!vm:vector-data-offset index)))
               (found (gethash (descriptor-bits des) *cold-layout-names*)))
          (if found
            (res found)
            (error "unknown descriptor at index ~S (bits = ~8,'0X)"
                   index
                   (descriptor-bits des)))))
      (res))))

(declaim (ftype (function (symbol descriptor descriptor descriptor descriptor)
                          descriptor)
                make-cold-layout))
(defun make-cold-layout (name length inherits depthoid nuntagged)
  (let ((result (allocate-boxed-object *dynamic*
                                       ;; KLUDGE: Why 1+? -- WHN 19990901
                                       ;; header word? -- CSR 20051204
                                       (1+ target-layout-length)
                                       sb!vm:instance-pointer-lowtag)))
    (write-memory result
                  (make-other-immediate-descriptor
                   target-layout-length sb!vm:instance-header-widetag))

    ;; KLUDGE: The offsets into LAYOUT below should probably be pulled out
    ;; of the cross-compiler's tables at genesis time instead of inserted
    ;; by hand as bare numeric constants. -- WHN ca. 19990901

    ;; Set slot 0 = the layout of the layout.
    (write-wordindexed result sb!vm:instance-slots-offset *layout-layout*)

    ;; Set the CLOS hash value.
    ;;
    ;; Note: CMU CL didn't set these in genesis, but instead arranged
    ;; for them to be set at cold init time. That resulted in slightly
    ;; kludgy-looking code, but there were at least two things to be
    ;; said for it:
    ;;   1. It put the hash values under the control of the target Lisp's
    ;;      RANDOM function, so that CLOS behavior would be nearly
    ;;      deterministic (instead of depending on the implementation of
    ;;      RANDOM in the cross-compilation host, and the state of its
    ;;      RNG when genesis begins).
    ;;   2. It automatically ensured that all hash values in the target Lisp
    ;;      were part of the same sequence, so that we didn't have to worry
    ;;      about the possibility of the first hash value set in genesis
    ;;      being precisely equal to the some hash value set in cold init time
    ;;      (because the target Lisp RNG has advanced to precisely the same
    ;;      state that the host Lisp RNG was in earlier).
    ;; Point 1 should not be an issue in practice because of the way we do our
    ;; build procedure in two steps, so that the SBCL that we end up with has
    ;; been created by another SBCL (whose RNG is under our control).
    ;; Point 2 is more of an issue. If ANSI had provided a way to feed
    ;; entropy into an RNG, we would have no problem: we'd just feed
    ;; some specialized genesis-time-only pattern into the RNG state
    ;; before using it. However, they didn't, so we have a slight
    ;; problem. We address it by generating the hash values using a
    ;; different algorithm than we use in ordinary operation.
    (let (;; The expression here is pretty arbitrary, we just want
          ;; to make sure that it's not something which is (1)
          ;; evenly distributed and (2) not foreordained to arise in
          ;; the target Lisp's (RANDOM-LAYOUT-CLOS-HASH) sequence
          ;; and show up as the CLOS-HASH value of some other
          ;; LAYOUT.
          (hash-value
           (1+ (mod (logxor (logand   (random-layout-clos-hash) 15253)
                            (logandc2 (random-layout-clos-hash) 15253)
                            1)
                    (1- sb!kernel:layout-clos-hash-limit)))))
      (cold-set-layout-slot result 'clos-hash
                            (make-fixnum-descriptor hash-value)))

    ;; Set other slot values.
    ;;
    ;; leave CLASSOID uninitialized for now
    (cold-set-layout-slot result 'invalid *nil-descriptor*)
    (cold-set-layout-slot result 'inherits inherits)
    (cold-set-layout-slot result 'depthoid depthoid)
    (cold-set-layout-slot result 'length length)
    (cold-set-layout-slot result 'info *nil-descriptor*)
    (cold-set-layout-slot result 'pure *nil-descriptor*)
    (cold-set-layout-slot result 'n-untagged-slots nuntagged)
    (cold-set-layout-slot result 'for-std-class-p *nil-descriptor*)

    (setf (gethash name *cold-layouts*)
          (list result
                name
                (descriptor-fixnum length)
                (listify-cold-inherits inherits)
                (descriptor-fixnum depthoid)
                (descriptor-fixnum nuntagged)))
    (setf (gethash (descriptor-bits result) *cold-layout-names*) name)

    result))

(defun initialize-layouts ()

  (clrhash *cold-layouts*)

  ;; We initially create the layout of LAYOUT itself with NIL as the LAYOUT and
  ;; #() as INHERITS,
  (setq *layout-layout* *nil-descriptor*)
  (let ((xlayout-layout (find-layout 'layout)))
    (aver (= 0 (layout-n-untagged-slots xlayout-layout)))
    (setq *layout-layout*
          (make-cold-layout 'layout
                            (number-to-core target-layout-length)
                            (vector-in-core)
                            (number-to-core (layout-depthoid xlayout-layout))
                            (number-to-core 0)))
  (write-wordindexed
   *layout-layout* sb!vm:instance-slots-offset *layout-layout*)

  ;; Then we create the layouts that we'll need to make a correct INHERITS
  ;; vector for the layout of LAYOUT itself..
  ;;
  ;; FIXME: The various LENGTH and DEPTHOID numbers should be taken from
  ;; the compiler's tables, not set by hand.
  (let* ((t-layout
          (make-cold-layout 't
                            (number-to-core 0)
                            (vector-in-core)
                            (number-to-core 0)
                            (number-to-core 0)))
         (so-layout
          (make-cold-layout 'structure-object
                            (number-to-core 1)
                            (vector-in-core t-layout)
                            (number-to-core 1)
                            (number-to-core 0)))
         (bso-layout
          (make-cold-layout 'structure!object
                            (number-to-core 1)
                            (vector-in-core t-layout so-layout)
                            (number-to-core 2)
                            (number-to-core 0)))
         (layout-inherits (vector-in-core t-layout
                                          so-layout
                                          bso-layout)))

    ;; ..and return to backpatch the layout of LAYOUT.
    (setf (fourth (gethash 'layout *cold-layouts*))
          (listify-cold-inherits layout-inherits))
    (cold-set-layout-slot *layout-layout* 'inherits layout-inherits))))

;;;; interning symbols in the cold image

;;; In order to avoid having to know about the package format, we
;;; build a data structure in *COLD-PACKAGE-SYMBOLS* that holds all
;;; interned symbols along with info about their packages. The data
;;; structure is a list of sublists, where the sublists have the
;;; following format:
;;;   (<make-package-arglist>
;;;    <internal-symbols>
;;;    <external-symbols>
;;;    <imported-internal-symbols>
;;;    <imported-external-symbols>
;;;    <shadowing-symbols>
;;;    <package-documentation>)
;;;
;;; KLUDGE: It would be nice to implement the sublists as instances of
;;; a DEFSTRUCT (:TYPE LIST). (They'd still be lists, but at least we'd be
;;; using mnemonically-named operators to access them, instead of trying
;;; to remember what THIRD and FIFTH mean, and hoping that we never
;;; need to change the list layout..) -- WHN 19990825

;;; an alist from packages to lists of that package's symbols to be dumped
(defvar *cold-package-symbols*)
(declaim (type list *cold-package-symbols*))

;;; a map from descriptors to symbols, so that we can back up. The key
;;; is the address in the target core.
(defvar *cold-symbols*)
(declaim (type hash-table *cold-symbols*))

;;; sanity check for a symbol we're about to create on the target
;;;
;;; Make sure that the symbol has an appropriate package. In
;;; particular, catch the so-easy-to-make error of typing something
;;; like SB-KERNEL:%BYTE-BLT in cold sources when what you really
;;; need is SB!KERNEL:%BYTE-BLT.
(defun package-ok-for-target-symbol-p (package)
  (let ((package-name (package-name package)))
    (or
     ;; Cold interning things in these standard packages is OK. (Cold
     ;; interning things in the other standard package, CL-USER, isn't
     ;; OK. We just use CL-USER to expose symbols whose homes are in
     ;; other packages. Thus, trying to cold intern a symbol whose
     ;; home package is CL-USER probably means that a coding error has
     ;; been made somewhere.)
     (find package-name '("COMMON-LISP" "KEYWORD") :test #'string=)
     ;; Cold interning something in one of our target-code packages,
     ;; which are ever-so-rigorously-and-elegantly distinguished by
     ;; this prefix on their names, is OK too.
     (string= package-name "SB!" :end1 3 :end2 3)
     ;; This one is OK too, since it ends up being COMMON-LISP on the
     ;; target.
     (string= package-name "SB-XC")
     ;; Anything else looks bad. (maybe COMMON-LISP-USER? maybe an extension
     ;; package in the xc host? something we can't think of
     ;; a valid reason to cold intern, anyway...)
     )))

;;; like SYMBOL-PACKAGE, but safe for symbols which end up on the target
;;;
;;; Most host symbols we dump onto the target are created by SBCL
;;; itself, so that as long as we avoid gratuitously
;;; cross-compilation-unfriendly hacks, it just happens that their
;;; SYMBOL-PACKAGE in the host system corresponds to their
;;; SYMBOL-PACKAGE in the target system. However, that's not the case
;;; in the COMMON-LISP package, where we don't get to create the
;;; symbols but instead have to use the ones that the xc host created.
;;; In particular, while ANSI specifies which symbols are exported
;;; from COMMON-LISP, it doesn't specify that their home packages are
;;; COMMON-LISP, so the xc host can keep them in random packages which
;;; don't exist on the target (e.g. CLISP keeping some CL-exported
;;; symbols in the CLOS package).
(defun symbol-package-for-target-symbol (symbol)
  ;; We want to catch weird symbols like CLISP's
  ;; CL:FIND-METHOD=CLOS::FIND-METHOD, but we don't want to get
  ;; sidetracked by ordinary symbols like :CHARACTER which happen to
  ;; have the same SYMBOL-NAME as exports from COMMON-LISP.
  (multiple-value-bind (cl-symbol cl-status)
      (find-symbol (symbol-name symbol) *cl-package*)
    (if (and (eq symbol cl-symbol)
             (eq cl-status :external))
        ;; special case, to work around possible xc host weirdness
        ;; in COMMON-LISP package
        *cl-package*
        ;; ordinary case
        (let ((result (symbol-package symbol)))
          (unless (package-ok-for-target-symbol-p result)
            (bug "~A in bad package for target: ~A" symbol result))
          result))))

;;; Return a handle on an interned symbol. If necessary allocate the
;;; symbol and record which package the symbol was referenced in. When
;;; we allocate the 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-for-target-symbol symbol)))

  (aver (package-ok-for-target-symbol-p package))

  ;; Anything on the cross-compilation host which refers to the target
  ;; machinery through the host SB-XC package should be translated to
  ;; something on the target which refers to the same machinery
  ;; through the target COMMON-LISP package.
  (let ((p (find-package "SB-XC")))
    (when (eq package p)
      (setf package *cl-package*))
    (when (eq (symbol-package symbol) p)
      (setf symbol (intern (symbol-name symbol) *cl-package*))))

  (let (;; Information about each cold-interned symbol is stored
        ;; in COLD-INTERN-INFO.
        ;;   (CAR COLD-INTERN-INFO) = descriptor of symbol
        ;;   (CDR COLD-INTERN-INFO) = list of packages, other than symbol's
        ;;                            own package, referring to symbol
        ;; (*COLD-PACKAGE-SYMBOLS* and *COLD-SYMBOLS* store basically the
        ;; same information, but with the mapping running the opposite way.)
        (cold-intern-info (get symbol 'cold-intern-info)))
    (unless cold-intern-info
      (cond ((eq (symbol-package-for-target-symbol symbol) package)