`(simple-array (unsigned-byte 8) (,+smallvec-length+)))
(defun make-smallvec ()
- (make-array +smallvec-length+ :element-type '(unsigned-byte 8)))
+ (make-array +smallvec-length+ :element-type '(unsigned-byte 8)
+ :initial-element 0))
;;; a big vector, implemented as a vector of SMALLVECs
;;;
(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))
+ (gspace nil :type (or gspace (eql :load-time-value) 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
;;; (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))
+ (or (descriptor-gspace des)
+
+ ;; gspace wasn't set, now we have to search for it.
+ (let ((lowtag (descriptor-lowtag des))
+ (high (descriptor-high des))
+ (low (descriptor-low des)))
+
+ ;; Non-pointer objects don't have a gspace.
+ (unless (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))
+ (error "don't even know how to look for a GSPACE for ~S" des))
+
(dolist (gspace (list *dynamic* *static* *read-only*)
- (error "couldn't find a GSPACE for ~S" des))
+ (error "couldn't find a GSPACE for ~S" des))
+ ;; Bounds-check the descriptor against the allocated area
+ ;; within each gspace.
+ ;;
+ ;; Most of the faffing around in here involving ash and
+ ;; various computed shift counts is due to the high/low
+ ;; split representation of the descriptor bits and an
+ ;; apparent disinclination to create intermediate values
+ ;; larger than a target fixnum.
+ ;;
;; 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)
(<= high (ash (+ (gspace-word-address gspace)
(gspace-free-word-index gspace))
(- sb!vm:word-shift descriptor-low-bits))))
+ ;; Update the descriptor with the correct gspace and the
+ ;; offset within the gspace and return the gspace.
(setf (descriptor-gspace des) gspace)
(setf (descriptor-word-offset des)
(+ (ash (- high (ash (gspace-word-address gspace)
(- 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)))))
+ (return gspace))))))
(defun make-random-descriptor (value)
(make-descriptor (logand (ash value (- descriptor-low-bits))
;;; purposes.
(defvar *current-reversed-cold-toplevels*)
+;;; the head of a list of DEBUG-SOURCEs which need to be patched when
+;;; the cold core starts up
+(defvar *current-debug-sources*)
+
;;; 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)
(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))
+;;; value, instead of the object-and-offset we use here.)
+(declaim (ftype (function (descriptor sb!vm:word descriptor) (values))
note-load-time-value-reference))
-(defun note-load-time-value-reference (address marker)
+(defun note-load-time-value-reference (address offset 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*)))
+ (cold-cons address
+ (cold-cons (number-to-core offset)
+ (cold-cons
+ (number-to-core (descriptor-word-offset marker))
+ *nil-descriptor*))))
*current-reversed-cold-toplevels*)
(values))
(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))
+ (if (eql (descriptor-gspace value) :load-time-value)
+ (note-load-time-value-reference address
+ (- (ash index sb!vm:word-shift)
+ (logand (descriptor-bits address)
+ sb!vm:lowtag-mask))
value)
(let* ((bytes (gspace-bytes (descriptor-intuit-gspace address)))
(byte-index (ash (+ index (descriptor-word-offset address))
;; Set slot 0 = the layout of the layout.
(write-wordindexed result sb!vm:instance-slots-offset *layout-layout*)
- ;; Set the CLOS hash value.
+ ;; Don't set the CLOS hash value: done in cold-init instead.
;;
- ;; 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
*cl-package*
;; ordinary case
(let ((result (symbol-package symbol)))
- (aver (package-ok-for-target-symbol-p result))
+ (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
;;; 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*))
+ (let ((layouts nil)
+ (result *nil-descriptor*))
(maphash (lambda (key stuff)
- (cold-push (cold-cons (cold-intern key)
- (first stuff))
- result))
+ (push (cons key (first stuff)) layouts))
*cold-layouts*)
- result))
+ (flet ((sorter (x y)
+ (let ((xpn (package-name (symbol-package-for-target-symbol x)))
+ (ypn (package-name (symbol-package-for-target-symbol y))))
+ (cond
+ ((string= x y) (string< xpn ypn))
+ (t (string< x y))))))
+ (setq layouts (sort layouts #'sorter :key #'car)))
+ (dolist (layout layouts result)
+ (cold-push (cold-cons (cold-intern (car layout)) (cdr layout))
+ result))))
;;; Establish initial values for magic 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)))
+ (documentation (base-string-to-core
+ ;; KLUDGE: NIL punned as 0-length string.
+ (unless
+ ;; don't propagate the arbitrary
+ ;; docstring from host packages into
+ ;; the core
+ (or (eql cold-package *cl-package*)
+ (eql cold-package *keyword-package*))
+ (documentation cold-package t))))
(internal-count 0)
(external-count 0)
(internal *nil-descriptor*)
(cold-set '*!initial-fdefn-objects* (list-all-fdefn-objects))
(cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*)
+ (cold-set '*!initial-debug-sources* *current-debug-sources*)
#!+(or x86 x86-64)
(progn
sym nil offset desired))))))
(defun list-all-fdefn-objects ()
- (let ((result *nil-descriptor*))
+ (let ((fdefns nil)
+ (result *nil-descriptor*))
(maphash (lambda (key value)
- (declare (ignore key))
- (cold-push value result))
+ (push (cons key value) fdefns))
*cold-fdefn-objects*)
- result))
+ (flet ((sorter (x y)
+ (let* ((xbn (fun-name-block-name x))
+ (ybn (fun-name-block-name y))
+ (xbnpn (package-name (symbol-package-for-target-symbol xbn)))
+ (ybnpn (package-name (symbol-package-for-target-symbol ybn))))
+ (cond
+ ((eql xbn ybn) (consp x))
+ ((string= xbn ybn) (string< xbnpn ybnpn))
+ (t (string< xbn ybn))))))
+ (setq fdefns (sort fdefns #'sorter :key #'car)))
+ (dolist (fdefn fdefns result)
+ (cold-push (cdr fdefn) result))))
\f
;;;; fixups and related stuff
;;; The x86 port needs to store code fixups along with code objects if
;;; they are to be moved, so fixups for code objects in the dynamic
;;; heap need to be noted.
-#!+(or x86 x86-64)
+#!+x86
(defvar *load-time-code-fixups*)
-#!+(or x86 x86-64)
-(defun note-load-time-code-fixup (code-object offset value kind)
+#!+x86
+(defun note-load-time-code-fixup (code-object offset)
;; If CODE-OBJECT might be moved
(when (= (gspace-identifier (descriptor-intuit-gspace code-object))
dynamic-core-space-id)
- ;; FIXME: pushed thing should be a structure, not just a list
- (push (list code-object offset value kind) *load-time-code-fixups*))
+ (push offset (gethash (descriptor-bits code-object)
+ *load-time-code-fixups*
+ nil)))
(values))
-#!+(or x86 x86-64)
+#!+x86
(defun output-load-time-code-fixups ()
- (dolist (fixups *load-time-code-fixups*)
- (let ((code-object (first fixups))
- (offset (second fixups))
- (value (third fixups))
- (kind (fourth fixups)))
- (cold-push (cold-cons
- (cold-intern :load-time-code-fixup)
- (cold-cons
- code-object
- (cold-cons
- (number-to-core offset)
- (cold-cons
- (number-to-core value)
- (cold-cons
- (cold-intern kind)
- *nil-descriptor*)))))
- *current-reversed-cold-toplevels*))))
+ (let ((fixup-infos nil))
+ (maphash
+ (lambda (code-object-address fixup-offsets)
+ (push (cons code-object-address fixup-offsets) fixup-infos))
+ *load-time-code-fixups*)
+ (setq fixup-infos (sort fixup-infos #'< :key #'car))
+ (dolist (fixup-info fixup-infos)
+ (let ((code-object-address (car fixup-info))
+ (fixup-offsets (cdr fixup-info)))
+ (let ((fixup-vector
+ (allocate-vector-object
+ *dynamic* sb!vm:n-word-bits (length fixup-offsets)
+ sb!vm:simple-array-unsigned-byte-32-widetag)))
+ (do ((index sb!vm:vector-data-offset (1+ index))
+ (fixups fixup-offsets (cdr fixups)))
+ ((null fixups))
+ (write-wordindexed fixup-vector index
+ (make-random-descriptor (car fixups))))
+ ;; KLUDGE: The fixup vector is stored as the first constant,
+ ;; not as a separately-named slot.
+ (write-wordindexed (make-random-descriptor code-object-address)
+ sb!vm:code-constants-offset
+ fixup-vector))))))
;;; Given a pointer to a code object and an offset relative to the
;;; tail of the code object's header, return an offset relative to the
(ecase kind
(:load
(setf (bvref-32 gspace-bytes gspace-byte-offset)
- (logior (ash (ldb (byte 11 0) value) 1)
- (logand (bvref-32 gspace-bytes gspace-byte-offset)
- #xffffc000))))
+ (logior (mask-field (byte 18 14)
+ (bvref-32 gspace-bytes gspace-byte-offset))
+ (if (< value 0)
+ (1+ (ash (ldb (byte 13 0) value) 1))
+ (ash (ldb (byte 13 0) value) 1)))))
+ (:load11u
+ (setf (bvref-32 gspace-bytes gspace-byte-offset)
+ (logior (mask-field (byte 18 14)
+ (bvref-32 gspace-bytes gspace-byte-offset))
+ (if (< value 0)
+ (1+ (ash (ldb (byte 10 0) value) 1))
+ (ash (ldb (byte 11 0) value) 1)))))
(:load-short
(let ((low-bits (ldb (byte 11 0) value)))
- (assert (<= 0 low-bits (1- (ash 1 4))))
- (setf (bvref-32 gspace-bytes gspace-byte-offset)
- (logior (ash low-bits 17)
- (logand (bvref-32 gspace-bytes gspace-byte-offset)
- #xffe0ffff)))))
+ (assert (<= 0 low-bits (1- (ash 1 4)))))
+ (setf (bvref-32 gspace-bytes gspace-byte-offset)
+ (logior (ash (dpb (ldb (byte 4 0) value)
+ (byte 4 1)
+ (ldb (byte 1 4) value)) 17)
+ (logand (bvref-32 gspace-bytes gspace-byte-offset)
+ #xffe0ffff))))
(:hi
(setf (bvref-32 gspace-bytes gspace-byte-offset)
- (logior (ash (ldb (byte 5 13) value) 16)
+ (logior (mask-field (byte 11 21)
+ (bvref-32 gspace-bytes gspace-byte-offset))
+ (ash (ldb (byte 5 13) value) 16)
(ash (ldb (byte 2 18) value) 14)
(ash (ldb (byte 2 11) value) 12)
(ash (ldb (byte 11 20) value) 1)
- (ldb (byte 1 31) value)
- (logand (bvref-32 gspace-bytes gspace-byte-offset)
- #xffe00000))))
+ (ldb (byte 1 31) value))))
(:branch
(let ((bits (ldb (byte 9 2) value)))
(assert (zerop (ldb (byte 2 0) value)))
(setf (bvref-32 gspace-bytes gspace-byte-offset)
(logior (ash bits 3)
- (logand (bvref-32 gspace-bytes gspace-byte-offset)
- #xffe0e002)))))))
+ (mask-field (byte 1 1) (bvref-32 gspace-bytes gspace-byte-offset))
+ (mask-field (byte 3 13) (bvref-32 gspace-bytes gspace-byte-offset))
+ (mask-field (byte 11 21) (bvref-32 gspace-bytes gspace-byte-offset))))))))
(:mips
(ecase kind
(:jump
(byte 10 0)
(bvref-32 gspace-bytes gspace-byte-offset))))))
((:x86 :x86-64)
+ ;; XXX: Note that un-fixed-up is read via bvref-word, which is
+ ;; 64 bits wide on x86-64, but the fixed-up value is written
+ ;; via bvref-32. This would make more sense if we supported
+ ;; :absolute64 fixups, but apparently the cross-compiler
+ ;; doesn't dump them.
(let* ((un-fixed-up (bvref-word gspace-bytes
gspace-byte-offset))
(code-object-start-addr (logandc2 (descriptor-bits code-object)
;; (not beyond it). It would be good to add an
;; explanation of why that's true, or an assertion that
;; it's really true, or both.
+ ;;
+ ;; One possible explanation is that all absolute fixups
+ ;; point either within the code object, within the
+ ;; runtime, within read-only or static-space, or within
+ ;; the linkage-table space. In all x86 configurations,
+ ;; these areas are prior to the start of dynamic space,
+ ;; where all the code-objects are loaded.
+ #!+x86
(unless (< fixed-up code-object-start-addr)
(note-load-time-code-fixup code-object
- after-header
- value
- kind))))
+ after-header))))
(:relative ; (used for arguments to X86 relative CALL instruction)
(let ((fixed-up (- (+ value un-fixed-up)
gspace-byte-address
;; object, which is to say all relative fixups, since
;; relative addressing within a code object never needs
;; a fixup.
+ #!+x86
(note-load-time-code-fixup code-object
- after-header
- value
- kind))))))))
+ after-header))))))))
(values))
(defun resolve-assembler-fixups ()
;;; create *STATIC-FOREIGN-SYMBOLS*, which the code in
;;; target-load.lisp refers to.
(defun foreign-symbols-to-core ()
- (let ((result *nil-descriptor*))
+ (let ((symbols nil)
+ (result *nil-descriptor*))
(maphash (lambda (symbol value)
- (cold-push (cold-cons (base-string-to-core symbol)
- (number-to-core value))
- result))
+ (push (cons symbol value) symbols))
*cold-foreign-symbol-table*)
+ (setq symbols (sort symbols #'string< :key #'car))
+ (dolist (symbol symbols)
+ (cold-push (cold-cons (base-string-to-core (car symbol))
+ (number-to-core (cdr symbol)))
+ result))
(cold-set (cold-intern 'sb!kernel:*!initial-foreign-symbols*) result))
(let ((result *nil-descriptor*))
- (dolist (rtn *cold-assembler-routines*)
+ (dolist (rtn (sort (copy-list *cold-assembler-routines*) #'string< :key #'car))
(cold-push (cold-cons (cold-intern (car rtn))
(number-to-core (cdr rtn)))
result))
(write-wordindexed result sb!vm:array-data-slot data-vector)
(write-wordindexed result sb!vm:array-displacement-slot *nil-descriptor*)
(write-wordindexed result sb!vm:array-displaced-p-slot *nil-descriptor*)
+ (write-wordindexed result sb!vm:array-displaced-from-slot *nil-descriptor*)
(let ((total-elements 1))
(dotimes (axis rank)
(let ((dim (pop-stack)))
*nil-descriptor*)))
*current-reversed-cold-toplevels*)
(setf *load-time-value-counter* (1+ counter))
- (make-descriptor 0 0 nil counter)))
+ (make-descriptor 0 0 :load-time-value counter)))
(defun finalize-load-time-value-noise ()
(cold-set (cold-intern '*!load-time-values*)
(setf (gethash warm-name *cold-fset-warm-names*) t))
(static-fset cold-name fn)))
+(define-cold-fop (fop-note-debug-source :pushp nil)
+ (let ((debug-source (pop-stack)))
+ (cold-push debug-source *current-debug-sources*)))
+
(define-cold-fop (fop-fdefinition)
(cold-fdefinition-object (pop-stack)))
(do-cold-fixup code-object offset value kind)
code-object))
\f
+;;;; sanity checking space layouts
+
+(defun check-spaces ()
+ ;;; Co-opt type machinery to check for intersections...
+ (let (types)
+ (flet ((check (start end space)
+ (unless (< start end)
+ (error "Bogus space: ~A" space))
+ (let ((type (specifier-type `(integer ,start ,end))))
+ (dolist (other types)
+ (unless (eq *empty-type* (type-intersection (cdr other) type))
+ (error "Space overlap: ~A with ~A" space (car other))))
+ (push (cons space type) types))))
+ (check sb!vm:read-only-space-start sb!vm:read-only-space-end :read-only)
+ (check sb!vm:static-space-start sb!vm:static-space-end :static)
+ #!+gencgc
+ (check sb!vm:dynamic-space-start sb!vm:dynamic-space-end :dynamic)
+ #!-gencgc
+ (progn
+ (check sb!vm:dynamic-0-space-start sb!vm:dynamic-0-space-end :dynamic-0)
+ (check sb!vm:dynamic-1-space-start sb!vm:dynamic-1-space-end :dynamic-1))
+ #!+linkage-table
+ (check sb!vm:linkage-table-space-start sb!vm:linkage-table-space-end :linkage-table))))
+\f
;;;; emitting C header file
(defun tailwise-equal (string tail)
(when (constantp symbol)
(let ((name (symbol-name symbol)))
(labels ( ;; shared machinery
- (record (string priority)
+ (record (string priority suffix)
(push (list string
priority
(symbol-value symbol)
+ suffix
(documentation symbol 'variable))
constants))
;; machinery for old-style CMU CL Lisp-to-C
'simple-string
prefix
(delete #\- (string-capitalize string)))
- priority))
+ priority
+ ""))
(maybe-record-with-munged-name (tail prefix priority)
(when (tailwise-equal name tail)
(record-with-munged-name prefix
(length tail)))
priority)))
;; machinery for new-style SBCL Lisp-to-C naming
- (record-with-translated-name (priority)
- (record (c-name name) priority))
- (maybe-record-with-translated-name (suffixes priority)
+ (record-with-translated-name (priority large)
+ (record (c-name name) priority (if large "LU" "")))
+ (maybe-record-with-translated-name (suffixes priority &key large)
(when (some (lambda (suffix)
(tailwise-equal name suffix))
suffixes)
- (record-with-translated-name priority))))
-
+ (record-with-translated-name priority large))))
(maybe-record-with-translated-name '("-LOWTAG") 0)
- (maybe-record-with-translated-name '("-WIDETAG") 1)
+ (maybe-record-with-translated-name '("-WIDETAG" "-SHIFT") 1)
(maybe-record-with-munged-name "-FLAG" "flag_" 2)
(maybe-record-with-munged-name "-TRAP" "trap_" 3)
(maybe-record-with-munged-name "-SUBTYPE" "subtype_" 4)
(maybe-record-with-munged-name "-SC-NUMBER" "sc_" 5)
- (maybe-record-with-translated-name '("-START" "-END" "-SIZE") 6)
- (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 7)
- (maybe-record-with-translated-name '("-CORE-SPACE-ID") 8))))))
+ (maybe-record-with-translated-name '("-SIZE") 6)
+ (maybe-record-with-translated-name '("-START" "-END" "-PAGE-BYTES") 7 :large t)
+ (maybe-record-with-translated-name '("-CORE-ENTRY-TYPE-CODE") 8)
+ (maybe-record-with-translated-name '("-CORE-SPACE-ID") 9))))))
;; KLUDGE: these constants are sort of important, but there's no
;; pleasing way to inform the code above about them. So we fake
;; it for now. nikodemus on #lisp (2004-08-09) suggested simply
(push (list (c-symbol-name c)
-1 ; invent a new priority
(symbol-value c)
+ ""
nil)
constants))
;; One more symbol that doesn't fit into the code above.
(push (list (c-symbol-name c)
9
(symbol-value c)
+ "LU"
nil)
constants))
-
(setf constants
(sort constants
(lambda (const1 const2)
(if (= (second const1) (second const2))
- (< (third const1) (third const2))
+ (if (= (third const1) (third const2))
+ (string< (first const1) (first const2))
+ (< (third const1) (third const2)))
(< (second const1) (second const2))))))
(let ((prev-priority (second (car constants))))
(dolist (const constants)
- (destructuring-bind (name priority value doc) const
+ (destructuring-bind (name priority value suffix doc) const
(unless (= prev-priority priority)
(terpri)
(setf prev-priority priority))
- (format t "#define ~A " name)
- (format t
- ;; KLUDGE: We're dumping two different kinds of
- ;; values here, (1) small codes and (2) machine
- ;; addresses. The small codes can be dumped as bare
- ;; integer values. The large machine addresses might
- ;; cause problems if they're large and represented
- ;; as (signed) C integers, so we want to force them
- ;; to be unsigned by appending an U to the
- ;; literal. We can't dump all the values using the
- ;; literal-U syntax, since the assembler doesn't
- ;; support that syntax and some of the small
- ;; constants can be used in assembler files.
- (let ( ;; cutoff for treatment as a small code
- (cutoff (expt 2 16)))
- (cond ((minusp value)
- (error "stub: negative values unsupported"))
- ((< value cutoff)
- "~D")
- (t
- "~DU")))
- value)
- (format t " /* 0x~X */~@[ /* ~A */~]~%" value doc))))
+ (when (minusp value)
+ (error "stub: negative values unsupported"))
+ (format t "#define ~A ~A~A /* 0x~X ~@[ -- ~A ~]*/~%" name value suffix value doc))))
(terpri))
;; writing information about internal errors
;; I'm not really sure why this is in SB!C, since it seems
;; conceptually like something that belongs to SB!VM. In any case,
;; it's needed C-side.
- (format t "#define BACKEND_PAGE_SIZE ~DU~%" sb!c:*backend-page-size*)
+ (format t "#define BACKEND_PAGE_BYTES ~DLU~%" sb!c:*backend-page-bytes*)
(terpri)
(force-output *core-file*)
(file-position *core-file*
(round-up (file-position *core-file*)
- sb!c:*backend-page-size*)))
+ sb!c:*backend-page-bytes*)))
(defun output-gspace (gspace)
(force-output *core-file*)
(let* ((posn (file-position *core-file*))
(bytes (* (gspace-free-word-index gspace) sb!vm:n-word-bytes))
- (pages (ceiling bytes sb!c:*backend-page-size*))
- (total-bytes (* pages sb!c:*backend-page-size*)))
+ (pages (ceiling bytes sb!c:*backend-page-bytes*))
+ (total-bytes (* pages sb!c:*backend-page-bytes*)))
(file-position *core-file*
- (* sb!c:*backend-page-size* (1+ *data-page*)))
+ (* sb!c:*backend-page-bytes* (1+ *data-page*)))
(format t
"writing ~S byte~:P [~S page~:P] from ~S~%"
total-bytes
(write-word (gspace-free-word-index gspace))
(write-word *data-page*)
(multiple-value-bind (floor rem)
- (floor (gspace-byte-address gspace) sb!c:*backend-page-size*)
+ (floor (gspace-byte-address gspace) sb!c:*backend-page-bytes*)
(aver (zerop rem))
(write-word floor))
(write-word pages)
(do-all-symbols (sym)
(remprop sym 'cold-intern-info))
+ (check-spaces)
+
(let* ((*foreign-symbol-placeholder-value* (if core-file-name nil 0))
(*load-time-value-counter* 0)
(*cold-fdefn-objects* (make-hash-table :test 'equal))
#!-gencgc sb!vm:dynamic-0-space-start))
(*nil-descriptor* (make-nil-descriptor))
(*current-reversed-cold-toplevels* *nil-descriptor*)
+ (*current-debug-sources* *nil-descriptor*)
(*unbound-marker* (make-other-immediate-descriptor
0
sb!vm:unbound-marker-widetag))
*cold-assembler-fixups*
*cold-assembler-routines*
- #!+(or x86 x86-64) *load-time-code-fixups*)
+ #!+x86 (*load-time-code-fixups* (make-hash-table)))
;; Prepare for cold load.
(initialize-non-nil-symbols)
;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
(resolve-assembler-fixups)
- #!+(or x86 x86-64) (output-load-time-code-fixups)
+ #!+x86 (output-load-time-code-fixups)
(foreign-symbols-to-core)
(finish-symbols)
(/show "back from FINISH-SYMBOLS")
projects / sbcl.git / blobdiff