Re: Comparing disassembly across changes
Richard M Kreuter via Sbcl-help <[email protected]> Thu, 31 Oct 2024 16:08:15 -0400
| Newsgroups | gmane.lisp.steel-bank.general |
|---|---|
| Message-ID | <[email protected]> |
Thank you, Doug! That got me further along. Attaching a hack to target-disassem that threads a :VIRTUAL-LOCATION keyword up to DISASSEMBLE. (I haven't spent too much time studying the disassembler, and I'm sure I'm doing something wrong. So it's probably no good for inclusion, but perhaps it could help somebody.) Regards, Richard _______________________________________________ Sbcl-help mailing list [email protected] https://lists.sourceforge.net/lists/listinfo/sbcl-help
disassemble-virtual-location.patch
(text/x-patch, 7.1 KB)
diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp
index f870ed1b5..c7f645da5 100644
--- a/src/compiler/target-disassem.lisp
+++ b/src/compiler/target-disassem.lisp
@@ -1802,7 +1802,7 @@
;;; Return a list of the segments of memory containing machine code
;;; instructions for FUNCTION.
-(defun get-fun-segments (function)
+(defun get-fun-segments (function &key virtual-location)
(declare (type compiled-function function))
(let* ((function (%fun-fun function))
(code (fun-code-header function))
@@ -1818,7 +1818,8 @@
(when (> len 0)
(push (make-code-segment code offs len
:debug-fun df
- :source-form-cache sfcache)
+ :source-form-cache sfcache
+ :virtual-location virtual-location)
segments))))
(dotimes (fmap-index (length fun-map))
(let ((fmap-entry (aref fun-map fmap-index)))
@@ -1864,7 +1865,8 @@
(if (null segments) ; FIXME: when does this happen? Comment PLEASE
(let ((offs (sb-di::function-start-pc-offset function)))
(list
- (make-code-segment code offs (- max-offset offs))))
+ (make-code-segment code offs (- max-offset offs)
+ :virtual-location virtual-location)))
(nreverse segments)))))))
;;; Return a list of the segments of memory containing machine code
@@ -1872,9 +1874,10 @@
;;; LENGTH is supplied, only that part of the code-segment is used
;;; (but these are constrained to lie within the code-segment).
(defun get-code-segments (code
- &optional
+ &key
(start-offset 0)
- (length (%code-text-size code)))
+ (length (%code-text-size code))
+ virtual-location)
(declare (type code-component code)
(type offset start-offset)
(type disassem-length length))
@@ -1893,7 +1896,8 @@
(seg-hooks seg))
(segs seg))))
(sort (segs) #'< :key #'seg-virtual-location))
- (list (make-code-segment code start-offset length)))))
+ (list (make-code-segment code start-offset length
+ :virtual-location virtual-location)))))
(let ((segments nil)
(sfcache (make-source-form-cache))
(last-offset (code-n-unboxed-data-bytes code))
@@ -1909,7 +1913,8 @@
(push (make-code-segment code
restricted-offs restricted-len
:debug-fun df
- :source-form-cache sfcache)
+ :source-form-cache sfcache
+ :virtual-location virtual-location)
segments)))))
(dovector (fun-map-entry (code-fun-map code))
(etypecase fun-map-entry
@@ -2029,12 +2034,12 @@
;;; Disassemble the machine code instructions for FUNCTION.
(defun disassemble-fun (fun &key
(stream *standard-output*)
- (use-labels t))
+ (use-labels t) virtual-location)
(declare (type compiled-function fun)
(type stream stream)
(type boolean use-labels))
(let* ((dstate (make-dstate))
- (segments (get-fun-segments fun)))
+ (segments (get-fun-segments fun :virtual-location virtual-location)))
(when use-labels
(label-segments segments dstate))
(disassemble-segments segments stream dstate)))
@@ -2058,18 +2063,21 @@
(function
(list fun)))))
-(defun disassemble (object &key (stream *standard-output*) (use-labels t))
+(defun disassemble (object &key (stream *standard-output*) (use-labels t)
+ virtual-location)
"Disassemble the compiled code associated with OBJECT, which can be a
function, a lambda expression, or a symbol with a function definition. If
it is not already compiled, the compiler is called to produce something to
disassemble."
(if (typep object 'code-component)
- (disassemble-code-component object :stream stream :use-labels use-labels)
+ (disassemble-code-component object :stream stream :use-labels use-labels
+ :virtual-location virtual-location)
(flet ((disassemble1 (fun)
(format stream "~&; disassembly for ~S" (%fun-name fun))
(disassemble-fun fun
:stream stream
- :use-labels use-labels)))
+ :use-labels use-labels
+ :virtual-location virtual-location)))
(mapc #'disassemble1 (get-compiled-funs object))))
nil)
@@ -2085,7 +2093,7 @@
&key
(stream *standard-output*)
code-component
- (use-labels t))
+ (use-labels t) virtual-location)
(declare (type (or address system-area-pointer) address)
(type disassem-length length)
(type stream stream)
@@ -2108,8 +2116,11 @@
(> code-offs (%code-code-size code-component)))
(error "address ~X not in the code component ~S"
address code-component))
- (get-code-segments code-component code-offs length))
- (list (make-memory-segment code-component address length)))))
+ (get-code-segments code-component
+ :start-offset code-offs :length length
+ :virtual-location virtual-location))
+ (list (make-memory-segment code-component address length
+ :virtual-location virtual-location)))))
(when use-labels
(label-segments segments dstate))
(disassemble-segments segments stream dstate)))
@@ -2117,7 +2128,7 @@
;;; Disassemble the machine code instructions associated with
;;; CODE-COMPONENT (this may include multiple entry points).
(defun disassemble-code-component (thing &key (stream *standard-output*)
- (use-labels t))
+ (use-labels t) virtual-location)
(declare (type stream stream)
(type boolean use-labels))
(let* ((code-component
@@ -2125,7 +2136,8 @@
(function (fun-code-header (%fun-fun thing)))
(code-component thing)))
(dstate (make-dstate))
- (segments (get-code-segments code-component)))
+ (segments (get-code-segments code-component
+ :virtual-location virtual-location)))
(when use-labels
(label-segments segments dstate))
(disassemble-segments segments stream dstate)