;;; -*- indent-tabs-mode: nil -*- ;;; Copyright (c) 2006 David Lichteblau ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation files ;;; (the "Software"), to deal in the Software without restriction, ;;; including without limitation the rights to use, copy, modify, merge, ;;; publish, distribute, sublicense, and/or sell copies of the Software, ;;; and to permit persons to whom the Software is furnished to do so, ;;; subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;;; SOFTWARE. (in-package :sb-heapdump) (defvar *foreign-fixups* (make-hash-table)) ;fixme: should be weak (defstruct (foreign-ref (:constructor make-foreign-ref (offset kind symbol datap))) offset kind symbol datap) (sb-ext:with-unlocked-packages (:sb-fasl) (macrolet ((doit (datap) `(let* ((kind (sb-fasl::pop-stack)) (code-object (sb-fasl::pop-stack)) (len (sb-fasl::read-byte-arg)) (sym (make-string len :element-type 'base-char))) (sb-sys:read-n-bytes sb-fasl::*fasl-input-stream* sym 0 len) (let* ((offset (sb-fasl::read-word-arg)) #-ppc (oldval (sb-sys:without-gcing (sb-sys:sap-ref-32 (sb-kernel:code-instructions code-object) offset)))) (sb-vm:fixup-code-object code-object offset (sb-sys:foreign-symbol-address sym) kind) (let ((fixups (sb-kernel:code-header-ref code-object sb-vm:code-constants-offset))) (unless (and (vectorp fixups) (find offset fixups)) #-ppc (assert (eq kind :absolute)) #-ppc (assert (zerop oldval)) (push (make-foreign-ref offset kind sym ,datap) (gethash code-object *foreign-fixups*))))) code-object))) (sb-fasl::define-fop (sb-fasl::fop-foreign-fixup 147) (doit nil)) #+linkage-table (sb-fasl::define-fop (sb-fasl::fop-foreign-dataref-fixup 150) (doit t)))) (defvar *do-core-fixups* #'sb-c::do-core-fixups) (sb-ext:with-unlocked-packages (:sb-c) (defun sb-c::do-core-fixups (code fixup-notes) (dolist (note fixup-notes) (let* ((kind (sb-c::fixup-note-kind note)) (fixup (sb-c::fixup-note-fixup note)) (offset (sb-c::fixup-note-position note)) (sym (sb-c::fixup-name fixup)) (flavor (sb-c::fixup-flavor fixup))) (funcall *do-core-fixups* code (list note)) (when (or (eq flavor :foreign) (eq flavor :foreign-dataref)) (let ((fixups (sb-kernel:code-header-ref code sb-vm:code-constants-offset)) (datap (eq flavor :foreign-dataref))) (unless (and (vectorp fixups) (find offset fixups)) #-ppc (assert (eq kind :absolute)) (push (make-foreign-ref offset kind sym datap) (gethash code *foreign-fixups*)))))))))