(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))
(read-wordindexed address 0))
;;; (Note: In CMU CL, this function expected a SAP-typed ADDRESS
-;;; value, instead of the SAP-INT we use here.)
+;;; 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 offset marker)
(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))))
+ (if (eql (descriptor-gspace value) :load-time-value)
(note-load-time-value-reference address
(- (ash index sb!vm:word-shift)
(logand (descriptor-bits address)
(lambda (code-object-address fixup-offsets)
(let ((fixup-vector
(allocate-vector-object
- *dynamic* sb-vm:n-word-bits (length fixup-offsets)
+ *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)))
*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*)
(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)
projects / sbcl.git / blobdiff