-
-;;; 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 do-load-time-code-fixup (code offset fixup kind)
- (flet ((add-load-time-code-fixup (code offset)
- (let ((fixups (code-header-ref code sb!vm:code-constants-offset)))
- (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
- (let ((new-fixups
- (adjust-array fixups (1+ (length fixups))
- :element-type '(unsigned-byte 32))))
- (setf (aref new-fixups (length fixups)) offset)
- (setf (code-header-ref code sb!vm:code-constants-offset)
- new-fixups)))
- (t
- ;; FIXME: This doesn't look like production code, and
- ;; should be a fatal error, not just a print.
- (unless (or (eq (get-type fixups)
- sb!vm:unbound-marker-type)
- (zerop fixups))
- (%primitive print "** Init. code FU"))
- (setf (code-header-ref code sb!vm:code-constants-offset)
- (make-specializable-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 4))))
- (ecase kind
- (:absolute
- ;; Record absolute fixups that point within the code object.
- (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
- (add-load-time-code-fixup code offset)))
- (:relative
- ;; Record relative fixups that point outside the code object.
- (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
- (add-load-time-code-fixup code offset)))))))