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.

diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp
index 6752e22..ab221d1 100644 (file)
--- 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 (file)
--- 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)))))))
 \f
 ;;;; low-level signal context access functions
 ;;;;

diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index d6e91ad..9adf27b 100644 (file)
--- 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 (file)
--- 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"