genesis.lisp

开源跨平台Lisp编译器

             (let ((handle (allocate-symbol (symbol-name symbol))))
               (setf (gethash (descriptor-bits handle) *cold-symbols*) symbol)
               (when (eq package *keyword-package*)
                 (cold-set handle handle))
               (setq cold-intern-info
                     (setf (get symbol 'cold-intern-info) (cons handle nil)))))
            (t
             (cold-intern symbol)
             (setq cold-intern-info (get symbol 'cold-intern-info)))))
    (unless (or (null package)
                (member package (cdr cold-intern-info)))
      (push package (cdr cold-intern-info))
      (let* ((old-cps-entry (assoc package *cold-package-symbols*))
             (cps-entry (or old-cps-entry
                            (car (push (list package)
                                       *cold-package-symbols*)))))
        (unless old-cps-entry
          (/show "created *COLD-PACKAGE-SYMBOLS* entry for" package symbol))
        (push symbol (rest cps-entry))))
    (car cold-intern-info)))

;;; Construct and return a value for use as *NIL-DESCRIPTOR*.
(defun make-nil-descriptor ()
  (let* ((des (allocate-unboxed-object
               *static*
               sb!vm:n-word-bits
               sb!vm:symbol-size
               0))
         (result (make-descriptor (descriptor-high des)
                                  (+ (descriptor-low des)
                                     (* 2 sb!vm:n-word-bytes)
                                     (- sb!vm:list-pointer-lowtag
                                        sb!vm:other-pointer-lowtag)))))
    (write-wordindexed des
                       1
                       (make-other-immediate-descriptor
                        0
                        sb!vm:symbol-header-widetag))
    (write-wordindexed des
                       (+ 1 sb!vm:symbol-value-slot)
                       result)
    (write-wordindexed des
                       (+ 2 sb!vm:symbol-value-slot)
                       result)
    (write-wordindexed des
                       (+ 1 sb!vm:symbol-plist-slot)
                       result)
    (write-wordindexed des
                       (+ 1 sb!vm:symbol-name-slot)
                       ;; This is *DYNAMIC*, and DES is *STATIC*,
                       ;; because that's the way CMU CL did it; I'm
                       ;; not sure whether there's an underlying
                       ;; reason. -- WHN 1990826
                       (base-string-to-core "NIL" *dynamic*))
    (write-wordindexed des
                       (+ 1 sb!vm:symbol-package-slot)
                       result)
    (setf (get nil 'cold-intern-info)
          (cons result nil))
    (cold-intern nil)
    result))

;;; Since the initial symbols must be allocated before we can intern
;;; anything else, we intern those here. We also set the value of T.
(defun initialize-non-nil-symbols ()
  #!+sb-doc
  "Initialize the cold load symbol-hacking data structures."
  (let ((*cold-symbol-allocation-gspace* *static*))
    ;; Intern the others.
    (dolist (symbol sb!vm:*static-symbols*)
      (let* ((des (cold-intern symbol))
             (offset-wanted (sb!vm:static-symbol-offset symbol))
             (offset-found (- (descriptor-low des)
                              (descriptor-low *nil-descriptor*))))
        (unless (= offset-wanted offset-found)
          ;; FIXME: should be fatal
          (warn "Offset from ~S to ~S is ~W, not ~W"
                symbol
                nil
                offset-found
                offset-wanted))))
    ;; Establish the value of T.
    (let ((t-symbol (cold-intern t)))
      (cold-set t-symbol t-symbol))
    ;; Establish the value of *PSEUDO-ATOMIC-BITS* so that the
    ;; allocation sequences that expect it to be zero upon entrance
    ;; actually find it to be so.
    #!+(or x86-64 x86)
    (let ((p-a-a-symbol (cold-intern 'sb!kernel:*pseudo-atomic-bits*)))
      (cold-set p-a-a-symbol (make-fixnum-descriptor 0)))))

;;; a helper function for FINISH-SYMBOLS: Return a cold alist suitable
;;; to be stored in *!INITIAL-LAYOUTS*.
(defun cold-list-all-layouts ()
  (let ((result *nil-descriptor*))
    (maphash (lambda (key stuff)
               (cold-push (cold-cons (cold-intern key)
                                     (first stuff))
                          result))
             *cold-layouts*)
    result))

;;; Establish initial values for magic symbols.
;;;
;;; Scan over all the symbols referenced in each package in
;;; *COLD-PACKAGE-SYMBOLS* making that for each one there's an
;;; appropriate entry in the *!INITIAL-SYMBOLS* data structure to
;;; intern it.
(defun finish-symbols ()

  ;; I think the point of setting these functions into SYMBOL-VALUEs
  ;; here, instead of using SYMBOL-FUNCTION, is that in CMU CL
  ;; SYMBOL-FUNCTION reduces to FDEFINITION, which is a pretty
  ;; hairy operation (involving globaldb.lisp etc.) which we don't
  ;; want to invoke early in cold init. -- WHN 2001-12-05
  ;;
  ;; FIXME: So OK, that's a reasonable reason to do something weird like
  ;; this, but this is still a weird thing to do, and we should change
  ;; the names to highlight that something weird is going on. Perhaps
  ;; *MAYBE-GC-FUN*, *INTERNAL-ERROR-FUN*, *HANDLE-BREAKPOINT-FUN*,
  ;; and *HANDLE-FUN-END-BREAKPOINT-FUN*...
  (dolist (symbol sb!vm::*c-callable-static-symbols*)
    (cold-set symbol (cold-fdefinition-object (cold-intern symbol))))

  (cold-set 'sb!vm::*current-catch-block*          (make-fixnum-descriptor 0))
  (cold-set 'sb!vm::*current-unwind-protect-block* (make-fixnum-descriptor 0))

  (cold-set '*free-interrupt-context-index* (make-fixnum-descriptor 0))

  (cold-set '*!initial-layouts* (cold-list-all-layouts))

  (/show "dumping packages" (mapcar #'car *cold-package-symbols*))
  (let ((initial-symbols *nil-descriptor*))
    (dolist (cold-package-symbols-entry *cold-package-symbols*)
      (let* ((cold-package (car cold-package-symbols-entry))
             (symbols (cdr cold-package-symbols-entry))
             (shadows (package-shadowing-symbols cold-package))
             (documentation (base-string-to-core (documentation cold-package t)))
             (internal-count 0)
             (external-count 0)
             (internal *nil-descriptor*)
             (external *nil-descriptor*)
             (imported-internal *nil-descriptor*)
             (imported-external *nil-descriptor*)
             (shadowing *nil-descriptor*))
        (declare (type package cold-package)) ; i.e. not a target descriptor
        (/show "dumping" cold-package symbols)

        ;; FIXME: Add assertions here to make sure that inappropriate stuff
        ;; isn't being dumped:
        ;;   * the CL-USER package
        ;;   * the SB-COLD package
        ;;   * any internal symbols in the CL package
        ;;   * basically any package other than CL, KEYWORD, or the packages
        ;;     in package-data-list.lisp-expr
        ;; and that the structure of the KEYWORD package (e.g. whether
        ;; any symbols are internal to it) matches what we want in the
        ;; target SBCL.

        ;; FIXME: It seems possible that by looking at the contents of
        ;; packages in the target SBCL we could find which symbols in
        ;; package-data-lisp.lisp-expr are now obsolete. (If I
        ;; understand correctly, only symbols which actually have
        ;; definitions or which are otherwise referred to actually end
        ;; up in the target packages.)

        (dolist (symbol symbols)
          (let ((handle (car (get symbol 'cold-intern-info)))
                (imported-p (not (eq (symbol-package-for-target-symbol symbol)
                                     cold-package))))
            (multiple-value-bind (found where)
                (find-symbol (symbol-name symbol) cold-package)
              (unless (and where (eq found symbol))
                (error "The symbol ~S is not available in ~S."
                       symbol
                       cold-package))
              (when (memq symbol shadows)
                (cold-push handle shadowing))
              (case where
                (:internal (if imported-p
                               (cold-push handle imported-internal)
                               (progn
                                 (cold-push handle internal)
                                 (incf internal-count))))
                (:external (if imported-p
                               (cold-push handle imported-external)
                               (progn
                                 (cold-push handle external)
                                 (incf external-count))))))))
        (let ((r *nil-descriptor*))
          (cold-push documentation r)
          (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 cold-package
                                             internal-count
                                             external-count)
                     r)
          ;; FIXME: It would be more space-efficient to use vectors
          ;; instead of lists here, and space-efficiency here would be
          ;; nice, since it would reduce the peak memory usage in
          ;; genesis and cold init.
          (cold-push r initial-symbols))))
    (cold-set '*!initial-symbols* initial-symbols))

  (cold-set '*!initial-fdefn-objects* (list-all-fdefn-objects))

  (cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*)

  #!+(or x86 x86-64)
  (progn
    (cold-set 'sb!vm::*fp-constant-0d0* (number-to-core 0d0))
    (cold-set 'sb!vm::*fp-constant-1d0* (number-to-core 1d0))
    (cold-set 'sb!vm::*fp-constant-0f0* (number-to-core 0f0))
    (cold-set 'sb!vm::*fp-constant-1f0* (number-to-core 1f0))))

;;; Make a cold list that can be used as the arg list to MAKE-PACKAGE in
;;; order to make a package that is similar to PKG.
(defun make-make-package-args (pkg internal-count external-count)
  (let* ((use *nil-descriptor*)
         (cold-nicknames *nil-descriptor*)
         (res *nil-descriptor*))
    (dolist (u (package-use-list pkg))
      (when (assoc u *cold-package-symbols*)
        (cold-push (base-string-to-core (package-name u)) use)))
    (let* ((pkg-name (package-name pkg))
           ;; Make the package nickname lists for the standard packages
           ;; be the minimum specified by ANSI, regardless of what value
           ;; the cross-compilation host happens to use.
           (warm-nicknames (cond ((string= pkg-name "COMMON-LISP")
                                  '("CL"))
                                 ((string= pkg-name "COMMON-LISP-USER")
                                  '("CL-USER"))
                                 ((string= pkg-name "KEYWORD")
                                  '())
                                 ;; For packages other than the
                                 ;; standard packages, the nickname
                                 ;; list was specified by our package
                                 ;; setup code, not by properties of
                                 ;; what cross-compilation host we
                                 ;; happened to use, and we can just
                                 ;; propagate it into the target.
                                 (t
                                  (package-nicknames pkg)))))
      (dolist (warm-nickname warm-nicknames)
        (cold-push (base-string-to-core warm-nickname) cold-nicknames)))

    ;; INTERNAL-COUNT and EXTERNAL-COUNT are the number of symbols that
    ;; the package contains in the core. We arrange for the package
    ;; symbol tables to be created somewhat larger so that they don't
    ;; need to be rehashed so easily when additional symbols are
    ;; interned during the warm build.
    (cold-push (number-to-core (truncate internal-count 0.8)) res)
    (cold-push (cold-intern :internal-symbols) res)
    (cold-push (number-to-core (truncate external-count 0.8)) res)
    (cold-push (cold-intern :external-symbols) res)

    (cold-push cold-nicknames res)
    (cold-push (cold-intern :nicknames) res)

    (cold-push use res)
    (cold-push (cold-intern :use) res)

    (cold-push (base-string-to-core (package-name pkg)) res)
    res))

;;;; functions and fdefinition objects

;;; a hash table mapping from fdefinition names to descriptors of cold
;;; objects
;;;
;;; Note: Since fdefinition names can be lists like '(SETF FOO), and
;;; we want to have only one entry per name, this must be an 'EQUAL
;;; hash table, not the default 'EQL.
(defvar *cold-fdefn-objects*)

(defvar *cold-fdefn-gspace* nil)

;;; Given a cold representation of a symbol, return a warm
;;; representation.
(defun warm-symbol (des)
  ;; Note that COLD-INTERN is responsible for keeping the
  ;; *COLD-SYMBOLS* table up to date