\f
;;;; :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)
\f
;;;; low-level signal context access functions
;;;;
;;; 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))
(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))
(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)
;; (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
;; 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
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)
;; 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")