From: Alastair B. <lis...@us...> - 2009-02-03 04:15:17
|
Update of /cvsroot/sbcl/sbcl/src/code In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv1254/src/code Modified Files: cold-init.lisp x86-vm.lisp Log Message: 1.0.25.3: earlier x86 code-object fixup envectorization In order to be able to relocate code-objects, the x86 port has to keep track of the locations of certain fixups within the objects (these fixups being relative fixups pointing to addresses outside the code-object and absolute fixups pointing to addresses within the code-object). Since time immemorial, the build process involved having genesis dump a record of each fixup to be recorded as a cold-toplevel, and cold-init passing such cold-toplevel information to !envector-load-time-code-fixup. * Change genesis to create fixup-vectors directly, instead of dumping the fixup information as cold-toplevels. * Strip out the (now dead) code for envectoring cold-toplevels during cold-init. Index: cold-init.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/cold-init.lisp,v retrieving revision 1.83 retrieving revision 1.84 diff -u -d -r1.83 -r1.84 --- cold-init.lisp 3 Feb 2009 04:13:13 -0000 1.83 +++ cold-init.lisp 3 Feb 2009 04:15:13 -0000 1.84 @@ -201,12 +201,6 @@ (third toplevel-thing)) (get-lisp-obj-address (svref *!load-time-values* (fourth toplevel-thing))))) - #!+(and x86 gencgc) - (:load-time-code-fixup - (sb!vm::!envector-load-time-code-fixup (second toplevel-thing) - (third toplevel-thing) - (fourth toplevel-thing) - (fifth toplevel-thing))) (t (!cold-lose "bogus fixup code in *!REVERSED-COLD-TOPLEVELS*")))) (t (!cold-lose "bogus function in *!REVERSED-COLD-TOPLEVELS*"))))) Index: x86-vm.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/code/x86-vm.lisp,v retrieving revision 1.32 retrieving revision 1.33 diff -u -d -r1.32 -r1.33 --- x86-vm.lisp 14 Nov 2006 03:59:52 -0000 1.32 +++ x86-vm.lisp 3 Feb 2009 04:15:13 -0000 1.33 @@ -139,52 +139,6 @@ (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 32) (*))) - (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 32) - :initial-element offset))))))) - (let* ((sap (truly-the system-area-pointer - (sb!kernel:code-instructions code))) - (obj-start-addr - ;; FIXME: looks like (LOGANDC2 foo typebits) - (logand (sb!kernel:get-lisp-obj-address code) #xfffffff8)) - (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)))) - (ecase kind - (:absolute - ;; Record absolute fixups that point within the code object. - (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr) - (frob code offset))) - (:relative - ;; Record relative fixups that point outside the code object. - (when (or (< fixup obj-start-addr) (> fixup code-end-addr)) - (frob code offset))))))) ;;;; low-level signal context access functions ;;;; |