diff --git a/src/compiler/target-disassem.lisp b/src/compiler/target-disassem.lisp index 81e42cab6..27cf93a20 100644 --- a/src/compiler/target-disassem.lisp +++ b/src/compiler/target-disassem.lisp @@ -1846,62 +1846,39 @@ (let* ((function (%fun-fun function)) (code (fun-code-header function)) (fun-map (code-fun-map code)) - (fname (%simple-fun-name function)) (sfcache (make-source-form-cache)) - (first-block-seen-p nil) - (nil-block-seen-p nil) - (last-offset 0) - (last-debug-fun nil) - (segments nil)) - (flet ((add-seg (offs len df) - (when (> len 0) - (push (make-code-segment code offs len - :debug-fun df - :source-form-cache sfcache) - segments)))) - (loop for fmap-entry = fun-map then next - for offset = (sb-c::compiled-debug-fun-offset fmap-entry) - for next = (sb-c::compiled-debug-fun-next fmap-entry) - do - (when first-block-seen-p - (add-seg last-offset - (- offset last-offset) - last-debug-fun) - (setf last-debug-fun nil)) - (setf last-offset offset) - (let ((name (sb-c::compiled-debug-fun-name fmap-entry)) - (kind (sb-c::compiled-debug-fun-kind fmap-entry))) - #+nil - (format t ";;; SAW ~S ~S ~S,~S ~W,~W~%" - name kind first-block-seen-p nil-block-seen-p - last-offset - (sb-c::compiled-debug-fun-start-pc fmap-entry)) - (cond (#+nil (eq last-offset fun-offset) - (and (equal name fname) - (null kind) - (not first-block-seen-p)) - (setf first-block-seen-p t)) - ((eq kind :external) - (when first-block-seen-p - (return))) - ((eq kind nil) - (when nil-block-seen-p - (return)) - (when first-block-seen-p - (setf nil-block-seen-p t)))) - (setf last-debug-fun - (sb-di::make-compiled-debug-fun fmap-entry code))) - while next) - (let ((max-offset (%code-text-size code))) - (when (and first-block-seen-p last-debug-fun) - (add-seg last-offset - (- max-offset last-offset) - last-debug-fun)) - (if (null segments) ; FIXME: when does this happen? Comment PLEASE - (let ((offs (fun-insts-offset function))) - (list - (make-code-segment code offs (- max-offset offs)))) - (nreverse segments)))))) + (fun-start (fun-insts-offset function)) + (max-offset (%code-text-size code))) + (loop for cdf = fun-map then next + for offset = (sb-c::compiled-debug-fun-offset cdf) + for next = (sb-c::compiled-debug-fun-next cdf) + when (and (not (sb-c::compiled-debug-fun-kind cdf)) + (>= offset fun-start)) + do (let* ((len (- + (if next + (sb-c::compiled-debug-fun-offset next) + max-offset) + offset)) + (elsewhere (sb-c::compiled-debug-fun-elsewhere-pc cdf)) + (elsewhere-len (and next + (- (sb-c::compiled-debug-fun-elsewhere-pc next) + elsewhere)))) + (when (plusp len) + (let ((df (sb-di::make-compiled-debug-fun cdf code))) + (return (list* (make-code-segment code offset len + :debug-fun df + :source-form-cache sfcache) + (and next ;; otherwise the above segment will already contain elsewhere + (plusp elsewhere-len) + (list (make-code-segment code elsewhere elsewhere-len + :debug-fun df + :source-form-cache sfcache)))))))) + while next + finally + ;; FIXME: when does this happen? Comment PLEASE + (return + (list + (make-code-segment code fun-start (- max-offset fun-start))))))) ;;; Return a list of the segments of memory containing machine code ;;; instructions for the code-component CODE. If START-OFFSET and/or diff --git a/tests/ccase.pure.lisp b/tests/ccase.pure.lisp index 8652cc547..100f6c3e6 100644 --- a/tests/ccase.pure.lisp +++ b/tests/ccase.pure.lisp @@ -19,7 +19,7 @@ (ct-err-not-boundp 0)) (dolist (line (split-string (with-output-to-string (stream) - (disassemble 'try-ccase :stream stream)) + (sb-disassem:disassemble-code-component #'try-ccase :stream stream)) #\newline)) (cond ((search "OBJECT-NOT-VECTOR" line) (incf ct-err-not-vector)) ((search "UNBOUND-SYMBOL-ERROR" line) (incf ct-err-not-boundp)))) diff --git a/tests/compiler-test-util.lisp b/tests/compiler-test-util.lisp index e52d98658..8d5dd53c8 100644 --- a/tests/compiler-test-util.lisp +++ b/tests/compiler-test-util.lisp @@ -135,7 +135,7 @@ (defun count-full-calls (name function) (let ((code (with-output-to-string (s) (let ((*print-right-margin* 120)) - (disassemble function :stream s)))) + (sb-disassem:disassemble-code-component function :stream s)))) (n 0)) (flet ((asm-line-calls-name-p (line name) (dolist (herald '("#