genesis.lisp

开源跨平台Lisp编译器

  ;;
  ;; KLUDGE: Judging from the comments in genesis.lisp of the CMU CL
  ;; old-rt compiler, this split dates back from a very early version
  ;; of genesis where 32-bit integers were represented as conses of
  ;; two 16-bit integers. In any system with nice (UNSIGNED-BYTE 32)
  ;; structure slots, like CMU CL >= 17 or any version of SBCL, there
  ;; seems to be no reason to persist in this. -- WHN 19990917
  high
  low)
(def!method print-object ((des descriptor) stream)
  (let ((lowtag (descriptor-lowtag des)))
    (print-unreadable-object (des stream :type t)
      (cond ((or (= lowtag sb!vm:even-fixnum-lowtag)
                 (= lowtag sb!vm:odd-fixnum-lowtag))
             (let ((unsigned (logior (ash (descriptor-high des)
                                          (1+ (- descriptor-low-bits
                                                 sb!vm:n-lowtag-bits)))
                                     (ash (descriptor-low des)
                                          (- 1 sb!vm:n-lowtag-bits)))))
               (format stream
                       "for fixnum: ~W"
                       (if (> unsigned #x1FFFFFFF)
                           (- unsigned #x40000000)
                           unsigned))))
            ((or (= lowtag sb!vm:other-immediate-0-lowtag)
                 (= lowtag sb!vm:other-immediate-1-lowtag)
                 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
                 (= lowtag sb!vm:other-immediate-2-lowtag)
                 #!+#.(cl:if (cl:= 64 sb!vm:n-word-bits) '(and) '(or))
                 (= lowtag sb!vm:other-immediate-3-lowtag))
             (format stream
                     "for other immediate: #X~X, type #b~8,'0B"
                     (ash (descriptor-bits des) (- sb!vm:n-widetag-bits))
                     (logand (descriptor-low des) sb!vm:widetag-mask)))
            (t
             (format stream
                     "for pointer: #X~X, lowtag #b~3,'0B, ~A"
                     (logior (ash (descriptor-high des) descriptor-low-bits)
                             (logandc2 (descriptor-low des) sb!vm:lowtag-mask))
                     lowtag
                     (let ((gspace (descriptor-gspace des)))
                       (if gspace
                           (gspace-name gspace)
                           "unknown"))))))))

;;; Return a descriptor for a block of LENGTH bytes out of GSPACE. The
;;; free word index is boosted as necessary, and if additional memory
;;; is needed, we grow the GSPACE. The descriptor returned is a
;;; pointer of type LOWTAG.
(defun allocate-cold-descriptor (gspace length lowtag)
  (let* ((bytes (round-up length (ash 1 sb!vm:n-lowtag-bits)))
         (old-free-word-index (gspace-free-word-index gspace))
         (new-free-word-index (+ old-free-word-index
                                 (ash bytes (- sb!vm:word-shift)))))
    ;; Grow GSPACE as necessary until it's big enough to handle
    ;; NEW-FREE-WORD-INDEX.
    (do ()
        ((>= (bvlength (gspace-bytes gspace))
             (* new-free-word-index sb!vm:n-word-bytes)))
      (expand-bigvec (gspace-bytes gspace)))
    ;; Now that GSPACE is big enough, we can meaningfully grab a chunk of it.
    (setf (gspace-free-word-index gspace) new-free-word-index)
    (let ((ptr (+ (gspace-word-address gspace) old-free-word-index)))
      (make-descriptor (ash ptr (- sb!vm:word-shift descriptor-low-bits))
                       (logior (ash (logand ptr
                                            (1- (ash 1
                                                     (- descriptor-low-bits
                                                        sb!vm:word-shift))))
                                    sb!vm:word-shift)
                               lowtag)
                       gspace
                       old-free-word-index))))

(defun descriptor-lowtag (des)
  #!+sb-doc
  "the lowtag bits for DES"
  (logand (descriptor-low des) sb!vm:lowtag-mask))

(defun descriptor-bits (des)
  (logior (ash (descriptor-high des) descriptor-low-bits)
          (descriptor-low des)))

(defun descriptor-fixnum (des)
  (let ((bits (descriptor-bits des)))
    (if (logbitp (1- sb!vm:n-word-bits) bits)
        ;; KLUDGE: The (- SB!VM:N-WORD-BITS 2) term here looks right to
        ;; me, and it works, but in CMU CL it was (1- SB!VM:N-WORD-BITS),
        ;; and although that doesn't make sense for me, or work for me,
        ;; it's hard to see how it could have been wrong, since CMU CL
        ;; genesis worked. It would be nice to understand how this came
        ;; to be.. -- WHN 19990901
        (logior (ash bits (- 1 sb!vm:n-lowtag-bits))
                (ash -1 (1+ sb!vm:n-positive-fixnum-bits)))
        (ash bits (- 1 sb!vm:n-lowtag-bits)))))

(defun descriptor-word-sized-integer (des)
  ;; Extract an (unsigned-byte 32), from either its fixnum or bignum
  ;; representation.
  (let ((lowtag (descriptor-lowtag des)))
    (if (or (= lowtag sb!vm:even-fixnum-lowtag)
            (= lowtag sb!vm:odd-fixnum-lowtag))
        (make-random-descriptor (descriptor-fixnum des))
        (read-wordindexed des 1))))

;;; common idioms
(defun descriptor-bytes (des)
  (gspace-bytes (descriptor-intuit-gspace des)))
(defun descriptor-byte-offset (des)
  (ash (descriptor-word-offset des) sb!vm:word-shift))

;;; If DESCRIPTOR-GSPACE is already set, just return that. Otherwise,
;;; figure out a GSPACE which corresponds to DES, set it into
;;; (DESCRIPTOR-GSPACE DES), set a consistent value into
;;; (DESCRIPTOR-WORD-OFFSET DES), and return the GSPACE.
(declaim (ftype (function (descriptor) gspace) descriptor-intuit-gspace))
(defun descriptor-intuit-gspace (des)
  (if (descriptor-gspace des)
    (descriptor-gspace des)
    ;; KLUDGE: It's not completely clear to me what's going on here;
    ;; this is a literal translation from of some rather mysterious
    ;; code from CMU CL's DESCRIPTOR-SAP function. Some explanation
    ;; would be nice. -- WHN 19990817
    (let ((lowtag (descriptor-lowtag des))
          (high (descriptor-high des))
          (low (descriptor-low des)))
      (if (or (eql lowtag sb!vm:fun-pointer-lowtag)
              (eql lowtag sb!vm:instance-pointer-lowtag)
              (eql lowtag sb!vm:list-pointer-lowtag)
              (eql lowtag sb!vm:other-pointer-lowtag))
        (dolist (gspace (list *dynamic* *static* *read-only*)
                        (error "couldn't find a GSPACE for ~S" des))
          ;; This code relies on the fact that GSPACEs are aligned
          ;; such that the descriptor-low-bits low bits are zero.
          (when (and (>= high (ash (gspace-word-address gspace)
                                   (- sb!vm:word-shift descriptor-low-bits)))
                     (<= high (ash (+ (gspace-word-address gspace)
                                      (gspace-free-word-index gspace))
                                   (- sb!vm:word-shift descriptor-low-bits))))
            (setf (descriptor-gspace des) gspace)
            (setf (descriptor-word-offset des)
                  (+ (ash (- high (ash (gspace-word-address gspace)
                                       (- sb!vm:word-shift
                                          descriptor-low-bits)))
                          (- descriptor-low-bits sb!vm:word-shift))
                     (ash (logandc2 low sb!vm:lowtag-mask)
                          (- sb!vm:word-shift))))
            (return gspace)))
        (error "don't even know how to look for a GSPACE for ~S" des)))))

(defun make-random-descriptor (value)
  (make-descriptor (logand (ash value (- descriptor-low-bits))
                           (1- (ash 1
                                    (- sb!vm:n-word-bits
                                       descriptor-low-bits))))
                   (logand value (1- (ash 1 descriptor-low-bits)))))

(defun make-fixnum-descriptor (num)
  (when (>= (integer-length num)
            (1+ (- sb!vm:n-word-bits sb!vm:n-lowtag-bits)))
    (error "~W is too big for a fixnum." num))
  (make-random-descriptor (ash num (1- sb!vm:n-lowtag-bits))))

(defun make-other-immediate-descriptor (data type)
  (make-descriptor (ash data (- sb!vm:n-widetag-bits descriptor-low-bits))
                   (logior (logand (ash data (- descriptor-low-bits
                                                sb!vm:n-widetag-bits))
                                   (1- (ash 1 descriptor-low-bits)))
                           type)))

(defun make-character-descriptor (data)
  (make-other-immediate-descriptor data sb!vm:character-widetag))

(defun descriptor-beyond (des offset type)
  (let* ((low (logior (+ (logandc2 (descriptor-low des) sb!vm:lowtag-mask)
                         offset)
                      type))
         (high (+ (descriptor-high des)
                  (ash low (- descriptor-low-bits)))))
    (make-descriptor high (logand low (1- (ash 1 descriptor-low-bits))))))

;;;; miscellaneous variables and other noise

;;; a numeric value to be returned for undefined foreign symbols, or NIL if
;;; undefined foreign symbols are to be treated as an error.
;;; (In the first pass of GENESIS, needed to create a header file before
;;; the C runtime can be built, various foreign symbols will necessarily
;;; be undefined, but we don't need actual values for them anyway, and
;;; we can just use 0 or some other placeholder. In the second pass of
;;; GENESIS, all foreign symbols should be defined, so any undefined
;;; foreign symbol is a problem.)
;;;
;;; KLUDGE: It would probably be cleaner to rewrite GENESIS so that it
;;; never tries to look up foreign symbols in the first place unless
;;; it's actually creating a core file (as in the second pass) instead
;;; of using this hack to allow it to go through the motions without
;;; causing an error. -- WHN 20000825
(defvar *foreign-symbol-placeholder-value*)

;;; a handle on the trap object
(defvar *unbound-marker*)
;; was:  (make-other-immediate-descriptor 0 sb!vm:unbound-marker-widetag)

;;; a handle on the NIL object
(defvar *nil-descriptor*)

;;; the head of a list of TOPLEVEL-THINGs describing stuff to be done
;;; when the target Lisp starts up
;;;
;;; Each TOPLEVEL-THING can be a function to be executed or a fixup or
;;; loadtime value, represented by (CONS KEYWORD ..). The FILENAME
;;; tells which fasl file each list element came from, for debugging
;;; purposes.
(defvar *current-reversed-cold-toplevels*)

;;; the name of the object file currently being cold loaded (as a string, not a
;;; pathname), or NIL if we're not currently cold loading any object file
(defvar *cold-load-filename* nil)
(declaim (type (or string null) *cold-load-filename*))

;;;; miscellaneous stuff to read and write the core memory

;;; FIXME: should be DEFINE-MODIFY-MACRO
(defmacro cold-push (thing list)
  #!+sb-doc
  "Push THING onto the given cold-load LIST."
  `(setq ,list (cold-cons ,thing ,list)))

(declaim (ftype (function (descriptor sb!vm:word) descriptor) read-wordindexed))
(defun read-wordindexed (address index)
  #!+sb-doc
  "Return the value which is displaced by INDEX words from ADDRESS."
  (let* ((gspace (descriptor-intuit-gspace address))
         (bytes (gspace-bytes gspace))
         (byte-index (ash (+ index (descriptor-word-offset address))
                          sb!vm:word-shift))
         (value (bvref-word bytes byte-index)))
    (make-random-descriptor value)))

(declaim (ftype (function (descriptor) descriptor) read-memory))
(defun read-memory (address)
  #!+sb-doc
  "Return the value at ADDRESS."
  (read-wordindexed address 0))

;;; (Note: In CMU CL, this function expected a SAP-typed ADDRESS
;;; value, instead of the SAP-INT we use here.)
(declaim (ftype (function (sb!vm:word descriptor) (values))
                note-load-time-value-reference))
(defun note-load-time-value-reference (address marker)
  (cold-push (cold-cons
              (cold-intern :load-time-value-fixup)
              (cold-cons (sap-int-to-core address)
                         (cold-cons
                          (number-to-core (descriptor-word-offset marker))
                          *nil-descriptor*)))
             *current-reversed-cold-toplevels*)
  (values))

(declaim (ftype (function (descriptor sb!vm:word descriptor)) write-wordindexed))
(defun write-wordindexed (address index value)
  #!+sb-doc
  "Write VALUE displaced INDEX words from ADDRESS."
  ;; KLUDGE: There is an algorithm (used in DESCRIPTOR-INTUIT-GSPACE)
  ;; for calculating the value of the GSPACE slot from scratch. It
  ;; doesn't work for all values, only some of them, but mightn't it
  ;; be reasonable to see whether it works on VALUE before we give up
  ;; because (DESCRIPTOR-GSPACE VALUE) isn't set? (Or failing that,
  ;; perhaps write a comment somewhere explaining why it's not a good
  ;; idea?) -- WHN 19990817
  (if (and (null (descriptor-gspace value))
           (not (null (descriptor-word-offset value))))
    (note-load-time-value-reference (+ (logandc2 (descriptor-bits address)
                                                 sb!vm:lowtag-mask)
                                       (ash index sb!vm:word-shift))
                                    value)
    (let* ((bytes (gspace-bytes (descriptor-intuit-gspace address)))
           (byte-index (ash (+ index (descriptor-word-offset address))
                               sb!vm:word-shift)))
      (setf (bvref-word bytes byte-index)
            (descriptor-bits value)))))

(declaim (ftype (function (descriptor descriptor)) write-memory))
(defun write-memory (address value)
  #!+sb-doc
  "Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)."
  (write-wordindexed address 0 value))