Factor out read-var-integer into a function.
[sbcl.git] / src / compiler / target-disassem.lisp
index dc23874..aeaa79e 100644 (file)
 ;;; an alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUN-NAME) for slots
 ;;; in a symbol object that we know about
 (defparameter *grokked-symbol-slots*
-  (sort `((,sb!vm:symbol-value-slot . symbol-value)
-          (,sb!vm:symbol-plist-slot . symbol-plist)
-          (,sb!vm:symbol-name-slot . symbol-name)
-          (,sb!vm:symbol-package-slot . symbol-package))
+  (sort (copy-list `((,sb!vm:symbol-value-slot . symbol-value)
+                     (,sb!vm:symbol-plist-slot . symbol-plist)
+                     (,sb!vm:symbol-name-slot . symbol-name)
+                     (,sb!vm:symbol-package-slot . symbol-package)))
         #'<
         :key #'car))
 
          t)
         (values nil nil))))
 
-(defun get-code-constant-absolute (addr dstate)
+(defstruct code-constant-raw value)
+(def!method print-object ((self code-constant-raw) stream)
+  (format stream "#x~8,'0x" (code-constant-raw-value self)))
+
+(defun get-code-constant-absolute (addr dstate &optional width)
   (declare (type address addr))
   (declare (type disassem-state dstate))
   (let ((code (seg-code (dstate-segment dstate))))
     (if (null code)
       (return-from get-code-constant-absolute (values nil nil)))
-    (let ((code-size (ash (sb!kernel:get-header-data code) sb!vm:word-shift)))
-      (sb!sys:without-gcing
-       (let ((code-addr (- (sb!kernel:get-lisp-obj-address code)
-                           sb!vm:other-pointer-lowtag)))
-         (if (or (< addr code-addr) (>= addr (+ code-addr code-size)))
-           (values nil nil)
-           (values (sb!kernel:code-header-ref
-                    code
-                    (ash (- addr code-addr) (- sb!vm:word-shift)))
-                   t)))))))
+    (sb!sys:without-gcing
+     (let* ((n-header-words (sb!kernel:get-header-data code))
+            (n-code-words (sb!kernel:%code-code-size code))
+            (header-addr (- (sb!kernel:get-lisp-obj-address code)
+                             sb!vm:other-pointer-lowtag)))
+         (cond ((<= header-addr addr (+ header-addr (ash (1- n-header-words)
+                                                         sb!vm:word-shift)))
+                (values (sb!sys:sap-ref-lispobj (sb!sys:int-sap addr) 0) t))
+               ;; guess it's a non-descriptor constant from the instructions
+               ((and (eq width :qword)
+                     (< n-header-words
+                        ;; convert ADDR to header-relative Nth word
+                        (ash (- addr header-addr) (- sb!vm:word-shift))
+                        (+ n-header-words n-code-words)))
+                (values (make-code-constant-raw
+                         :value (sb!sys:sap-ref-64 (sb!sys:int-sap addr) 0))
+                        t))
+               (t
+                (values nil nil)))))))
 
 (defvar *assembler-routines-by-addr* nil)
 
           (invert-address-hash sb!fasl:*assembler-routines*))
     (setf *assembler-routines-by-addr*
           (invert-address-hash sb!sys:*static-foreign-symbols*
-                               *assembler-routines-by-addr*)))
+                               *assembler-routines-by-addr*))
+    (loop for static in sb!vm:*static-funs*
+          for address = (+ sb!vm::nil-value
+                           (sb!vm::static-fun-offset static))
+          do
+          (setf (gethash address *assembler-routines-by-addr*)
+                static))
+    ;; Not really a routine, but it uses the similar logic for annotations
+    #!+sb-safepoint
+    (setf (gethash sb!vm::gc-safepoint-page-addr *assembler-routines-by-addr*)
+          "safepoint"))
   (gethash address *assembler-routines-by-addr*))
 \f
 ;;;; some handy function for machine-dependent code to use...
 ;;; Store a note about the lisp constant located at ADDR in the
 ;;; current code-component, to be printed as an end-of-line comment
 ;;; after the current instruction is disassembled.
-(defun note-code-constant-absolute (addr dstate)
+(defun note-code-constant-absolute (addr dstate &optional width)
   (declare (type address addr)
            (type disassem-state dstate))
   (multiple-value-bind (const valid)
-      (get-code-constant-absolute addr dstate)
+      (get-code-constant-absolute addr dstate width)
     (when valid
       (note (lambda (stream)
               (prin1-quoted-short const stream))
   (car (svref sb!c:*backend-internal-errors* errnum)))
 
 (defun get-sc-name (sc-offs)
-  (sb!c::location-print-name
+  (sb!c:location-print-name
    ;; FIXME: This seems like an awful lot of computation just to get a name.
    ;; Couldn't we just use lookup in *BACKEND-SC-NAMES*, without having to cons
    ;; up a new object?