- (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))))