From 1589f3076965a68c07efa77539137673fed17e3c Mon Sep 17 00:00:00 2001 From: Alastair Bridgewater Date: Tue, 3 Feb 2009 04:15:13 +0000 Subject: [PATCH] 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. --- src/code/cold-init.lisp | 6 ----- src/code/x86-vm.lisp | 46 --------------------------------- src/compiler/generic/genesis.lisp | 51 +++++++++++++++++-------------------- version.lisp-expr | 2 +- 4 files changed, 25 insertions(+), 80 deletions(-) diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 6752e22..ab221d1 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -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*"))))) diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index 434f345..bb1bd22 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -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 ;;;; diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index d6e91ad..9adf27b 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1638,33 +1638,34 @@ core and return a descriptor to it." (defvar *load-time-code-fixups*) #!+x86 -(defun note-load-time-code-fixup (code-object offset value kind) +(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)) #!+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 @@ -1859,9 +1860,7 @@ core and return a descriptor to it." #!+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 @@ -1875,9 +1874,7 @@ core and return a descriptor to it." ;; a fixup. #!+x86 (note-load-time-code-fixup code-object - after-header - value - kind)))))))) + after-header)))))))) (values)) (defun resolve-assembler-fixups () @@ -3221,7 +3218,7 @@ initially undefined function references:~2%") sb!vm:unbound-marker-widetag)) *cold-assembler-fixups* *cold-assembler-routines* - #!+x86 *load-time-code-fixups*) + #!+x86 (*load-time-code-fixups* (make-hash-table))) ;; Prepare for cold load. (initialize-non-nil-symbols) diff --git a/version.lisp-expr b/version.lisp-expr index 9956c63..7c3ca10 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.2" +"1.0.25.3" -- 1.7.10.4