X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fgenesis.lisp;h=95be9b3c88b11e9b3914d05cbcb6c55583692875;hb=ae09f8fd7765f6cab6ad317a13e27ff22ab0c11e;hp=51ccf01074e9f58c232a0889f8b718ef33855d78;hpb=40b949acce1ac108b62d52d13eb2a09454f8db33;p=sbcl.git diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 51ccf01..95be9b3 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -280,7 +280,7 @@ (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 @@ -400,21 +400,31 @@ ;;; (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) @@ -422,6 +432,8 @@ (<= 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) @@ -430,8 +442,7 @@ (- 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)) @@ -529,16 +540,17 @@ (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)) @@ -546,18 +558,11 @@ (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)) @@ -1632,37 +1637,38 @@ core and return a descriptor to it." ;;; 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*)))) + (maphash + (lambda (code-object-address fixup-offsets) + (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))) + *load-time-code-fixups*)) ;;; 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 @@ -1728,32 +1734,44 @@ core and return a descriptor to it." (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 @@ -1809,6 +1827,11 @@ core and return a descriptor to it." (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) @@ -1830,11 +1853,17 @@ core and return a descriptor to it." ;; (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 @@ -1846,10 +1875,9 @@ core and return a descriptor to it." ;; 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 () @@ -2304,7 +2332,7 @@ core and return a descriptor to it." *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*) @@ -3193,7 +3221,7 @@ initially undefined function references:~2%") 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) @@ -3261,7 +3289,7 @@ initially undefined function references:~2%") ;; 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")