From: Alastair Bridgewater Date: Tue, 3 Feb 2009 04:11:05 +0000 (+0000) Subject: 1.0.25.1: x86-64 code fixup recording for gc / slash-and-burn X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=3d87bae55ccdbab2c9ed117b8399013adfd8bbf2;p=sbcl.git 1.0.25.1: x86-64 code fixup recording for gc / slash-and-burn x86-64 code segments do not have absolute references to within themselves, nor do they have relative references to without themselves, making them relocatable without patching. The GC has long since been updated to reflect this, but the fixup recording code originally part of the x86 port had been retained. * Removed x86-64 code-object fixup recording code everywhere. * Added some commentary to x86iod fixup handling in genesis. --- diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 2b26328..5252ea3 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -200,7 +200,7 @@ (setf (sap-ref-word (second toplevel-thing) 0) (get-lisp-obj-address (svref *!load-time-values* (third toplevel-thing))))) - #!+(and (or x86 x86-64) gencgc) + #!+(and x86 gencgc) (:load-time-code-fixup (sb!vm::!envector-load-time-code-fixup (second toplevel-thing) (third toplevel-thing) diff --git a/src/code/x86-64-vm.lisp b/src/code/x86-64-vm.lisp index a5a025b..e263853 100644 --- a/src/code/x86-64-vm.lisp +++ b/src/code/x86-64-vm.lisp @@ -63,133 +63,33 @@ ;;;; :CODE-OBJECT fixups -;;; a counter to measure the storage overhead of these fixups -(defvar *num-fixups* 0) -;;; FIXME: When the system runs, it'd be interesting to see what this is. - -(declaim (inline adjust-fixup-array)) -(defun adjust-fixup-array (array size) - (let ((new (make-array size :element-type '(unsigned-byte 64)))) - (replace new array) - new)) - ;;; This gets called by LOAD to resolve newly positioned objects ;;; with things (like code instructions) that have to refer to them. -;;; -;;; Add a fixup offset to the vector of fixup offsets for the given -;;; code object. (defun fixup-code-object (code offset fixup kind) (declare (type index offset)) - (flet ((add-fixup (code offset) - ;; (We check for and ignore fixups for code objects in the - ;; read-only and static spaces. (In the old CMU CL code - ;; this check was conditional on *ENABLE-DYNAMIC-SPACE-CODE*, - ;; but in SBCL relocatable dynamic space code is always in - ;; use, so we always do the check.) - (incf *num-fixups*) - (let ((fixups (code-header-ref code code-constants-offset))) - (cond ((typep fixups '(simple-array (unsigned-byte 64) (*))) - (let ((new-fixups - (adjust-fixup-array fixups (1+ (length fixups))))) - (setf (aref new-fixups (length fixups)) offset) - (setf (code-header-ref code code-constants-offset) - new-fixups))) - (t - (unless (or (eq (widetag-of fixups) - unbound-marker-widetag) - (zerop fixups)) - (format t "** Init. code FU = ~S~%" fixups)) ; FIXME - (setf (code-header-ref code code-constants-offset) - (make-array - 1 - :element-type '(unsigned-byte 64) - :initial-element offset))))))) - (sb!sys:without-gcing - (let* ((sap (truly-the system-area-pointer - (sb!kernel:code-instructions code))) - (obj-start-addr (logandc2 (sb!kernel:get-lisp-obj-address code) - sb!vm:lowtag-mask)) - (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions - code))) - (ncode-words (sb!kernel:code-header-ref code 1)) - (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes)))) - (unless (member kind '(:absolute :absolute64 :relative)) - (error "Unknown code-object-fixup kind ~S." kind)) - (ecase kind - (:absolute64 - ;; Word at sap + offset contains a value to be replaced by - ;; adding that value to fixup. - (setf (sap-ref-64 sap offset) (+ fixup (sap-ref-64 sap offset))) - ;; Record absolute fixups that point within the code object. - (when (> code-end-addr (sap-ref-64 sap offset) obj-start-addr) - (add-fixup code offset))) - (:absolute - ;; Word at sap + offset contains a value to be replaced by - ;; adding that value to fixup. - (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset))) - ;; Record absolute fixups that point within the code object. - (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr) - (add-fixup code offset))) - (:relative - ;; Fixup is the actual address wanted. - ;; - ;; Record relative fixups that point outside the code - ;; object. - (when (or (< fixup obj-start-addr) (> fixup code-end-addr)) - (add-fixup code offset)) - ;; Replace word with value to add to that loc to get there. - (let* ((loc-sap (+ (sap-int sap) offset)) - (rel-val (- fixup loc-sap (/ n-word-bytes 2)))) - (declare (type (unsigned-byte 64) loc-sap) - (type (signed-byte 32) rel-val)) - (setf (signed-sap-ref-32 sap offset) rel-val)))))) - nil)) - -;;; Add a code fixup to a code object generated by GENESIS. The fixup -;;; has already been applied, it's just a matter of placing the fixup -;;; in the code's fixup vector if necessary. -;;; -;;; KLUDGE: I'd like a good explanation of why this has to be done at -;;; load time instead of in GENESIS. It's probably simple, I just haven't -;;; figured it out, or found it written down anywhere. -- WHN 19990908 -#!+gencgc -(defun !envector-load-time-code-fixup (code offset fixup kind) - (flet ((frob (code offset) - (let ((fixups (code-header-ref code code-constants-offset))) - (cond ((typep fixups '(simple-array (unsigned-byte 64) (*))) - (let ((new-fixups - (adjust-fixup-array fixups (1+ (length fixups))))) - (setf (aref new-fixups (length fixups)) offset) - (setf (code-header-ref code code-constants-offset) - new-fixups))) - (t - (unless (or (eq (widetag-of fixups) - unbound-marker-widetag) - (zerop fixups)) - (sb!impl::!cold-lose "Argh! can't process fixup")) - (setf (code-header-ref code code-constants-offset) - (make-array - 1 - :element-type '(unsigned-byte 64) - :initial-element offset))))))) - (let* ((sap (truly-the system-area-pointer - (sb!kernel:code-instructions code))) - (obj-start-addr - (logandc2 (sb!kernel:get-lisp-obj-address code) sb!vm:lowtag-mask)) - (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions - code))) - (ncode-words (sb!kernel:code-header-ref code 1)) - (code-end-addr (+ code-start-addr (* ncode-words n-word-bytes)))) + (sb!sys:without-gcing + (let ((sap (truly-the system-area-pointer + (sb!kernel:code-instructions code)))) + (unless (member kind '(:absolute :absolute64 :relative)) + (error "Unknown code-object-fixup kind ~S." kind)) (ecase kind + (:absolute64 + ;; Word at sap + offset contains a value to be replaced by + ;; adding that value to fixup. + (setf (sap-ref-64 sap offset) (+ fixup (sap-ref-64 sap offset)))) (:absolute - ;; Record absolute fixups that point within the code object. - ;; The fixup data is 32 bits, don't use SAP-REF-64 here. - (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr) - (frob code offset))) + ;; Word at sap + offset contains a value to be replaced by + ;; adding that value to fixup. + (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))) (:relative - ;; Record relative fixups that point outside the code object. - (when (or (< fixup obj-start-addr) (> fixup code-end-addr)) - (frob code offset))))))) + ;; Fixup is the actual address wanted. + ;; Replace word with value to add to that loc to get there. + (let* ((loc-sap (+ (sap-int sap) offset)) + (rel-val (- fixup loc-sap (/ n-word-bytes 2)))) + (declare (type (unsigned-byte 64) loc-sap) + (type (signed-byte 32) rel-val)) + (setf (signed-sap-ref-32 sap offset) rel-val)))))) + nil) ;;;; low-level signal context access functions ;;;; diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index ecf2735..d74575c 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1632,10 +1632,10 @@ 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) +#!+x86 (defun note-load-time-code-fixup (code-object offset value kind) ;; If CODE-OBJECT might be moved (when (= (gspace-identifier (descriptor-intuit-gspace code-object)) @@ -1644,7 +1644,7 @@ core and return a descriptor to it." (push (list code-object offset value kind) *load-time-code-fixups*)) (values)) -#!+(or x86 x86-64) +#!+x86 (defun output-load-time-code-fixups () (dolist (fixups *load-time-code-fixups*) (let ((code-object (first fixups)) @@ -1821,6 +1821,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) @@ -1842,6 +1847,14 @@ 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 @@ -1858,6 +1871,7 @@ 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 @@ -3205,7 +3219,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*) ;; Prepare for cold load. (initialize-non-nil-symbols) @@ -3273,7 +3287,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") diff --git a/version.lisp-expr b/version.lisp-expr index 4a98682..1bef3f7 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.25" +"1.0.25.1"