Commit ae5cae08 authored by rtoy's avatar rtoy
Browse files

Fix disassembler to be able to handle closures. The disassembler was

disassembling the wrong closure sometimes.  Now use the offset of the
function instead of the function name to match the corresponding

Patch from Helmut Eller, cmucl-imp, 2005-05-05.
parent d7d2552a
......@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.47 2005/04/10 15:01:44 rtoy Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/disassem.lisp,v 1.48 2005/05/06 16:41:09 rtoy Exp $")
;;; **********************************************************************
......@@ -2996,13 +2996,21 @@
;;; ----------------------------------------------------------------
(defun fun-header-pc (function)
"Return the PC of FUNCTION's header."
(declare (type compiled-function function))
(let ((code (fun-code function)))
(* (- (kernel:function-word-offset function)
(kernel:get-header-data code)) ; i.e code header length
(defun get-function-segments (function)
"Returns a list of the segments of memory containing machine code
instructions for FUNCTION."
(declare (type compiled-function function))
(let* ((code (fun-code function))
(header-pc (fun-header-pc function))
(function-map (code-function-map code))
(fname (kernel:%function-name function))
(sfcache (make-source-form-cache)))
(let ((first-block-seen-p nil)
(nil-block-seen-p nil)
......@@ -3026,16 +3034,16 @@
(setf last-debug-function nil))
(setf last-offset fmap-entry))
(let ((name (c::compiled-debug-function-name fmap-entry))
(let ((start-pc
(c::compiled-debug-function-start-pc fmap-entry))
(kind (c::compiled-debug-function-kind fmap-entry)))
(format t ";;; SAW ~s ~s ~s,~s ~d,~d~%"
(format t ";;; SAW ~s ~s ~s,~s ~d,~d [~d]~%"
name kind first-block-seen-p nil-block-seen-p
(c::compiled-debug-function-start-pc fmap-entry))
(cond (#+nil (eq last-offset fun-offset)
(and (equal name fname) (not first-block-seen-p))
(setf first-block-seen-p t))
last-offset start-pc header-pc)
(cond ((and (<= last-offset header-pc start-pc)
(not first-block-seen-p))
(setf first-block-seen-p t))
((eq kind :external)
(when first-block-seen-p
......@@ -3045,8 +3053,7 @@
(when first-block-seen-p
(setf nil-block-seen-p t))))
(setf last-debug-function
(di::make-compiled-debug-function fmap-entry code))
(di::make-compiled-debug-function fmap-entry code)))))))
(let ((max-offset (code-inst-area-length code)))
(when (and first-block-seen-p last-debug-function)
(add-seg last-offset
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment