From: Alastair B. <lis...@us...> - 2009-02-03 04:11:12
|
Update of /cvsroot/sbcl/sbcl/src/code In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv1003/src/code Modified Files: cold-init.lisp x86-64-vm.lisp Log Message: 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. Index: cold-init.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/cold-init.lisp,v retrieving revision 1.81 retrieving revision 1.82 diff -u -d -r1.81 -r1.82 --- cold-init.lisp 4 Jan 2009 07:35:53 -0000 1.81 +++ cold-init.lisp 3 Feb 2009 04:11:05 -0000 1.82 @@ -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) Index: x86-64-vm.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/x86-64-vm.lisp,v retrieving revision 1.8 retrieving revision 1.9 diff -u -d -r1.8 -r1.9 --- x86-64-vm.lisp 10 Apr 2007 21:43:44 -0000 1.8 +++ x86-64-vm.lisp 3 Feb 2009 04:11:05 -0000 1.9 @@ -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 ;;;; |