0.9.1.38:

[sbcl.git] / src / compiler / debug-dump.lisp

diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp
index 1f58b67..0dc56c3 100644 (file)
--- a/src/compiler/debug-dump.lisp
+++ b/src/compiler/debug-dump.lisp
@@ -237,10 +237,8 @@
 
     (values (copy-seq *byte-buffer*) tlf-num)))
 \f
-;;; Return a list of DEBUG-SOURCE structures containing information
-;;; derived from INFO. Unless :BYTE-COMPILE T was specified, we always
-;;; dump the START-POSITIONS, since it is too hard figure out whether
-;;; we need them or not.
+;;; Return DEBUG-SOURCE structure containing information derived from
+;;; INFO. 
 (defun debug-source-for-info (info)
   (declare (type source-info info))
   (let* ((file-info (source-info-file-info info))
@@ -254,19 +252,25 @@
         (name (file-info-name file-info)))
     (etypecase name
       ((member :lisp)
-       (setf (debug-source-from res) name)
-       (setf (debug-source-name res)
-            (coerce (file-info-forms file-info) 'simple-vector)))
+       (setf (debug-source-from res) name
+            (debug-source-name res) (file-info-forms file-info)))
       (pathname
        (let* ((untruename (file-info-untruename file-info))
              (dir (pathname-directory untruename)))
         (setf (debug-source-name res)
+              #+sb-xc-host
+              (let ((src (position "src" dir :test #'string= :from-end t)))
+                (if src
+                    (format nil "SYS:~{~:@(~A~);~}~:@(~A~).LISP"
+                            (subseq dir src) (pathname-name untruename))
+                    ;; FIXME: just output/stuff-groveled-from-headers.lisp
+                    (namestring untruename)))
+              #-sb-xc-host
               (namestring
                (if (and dir (eq (first dir) :absolute))
                    untruename
                    name))))))
-    (list res)))
-
+    res))
 
 ;;; Given an arbitrary sequence, coerce it to an unsigned vector if
 ;;; possible. Ordinarily we coerce it to the smallest specialized
@@ -525,10 +529,11 @@
                 (compute-args fun var-locs))))
 
     (if (>= level 2)
-      (multiple-value-bind (blocks tlf-num) (compute-debug-blocks fun var-locs)
-       (setf (compiled-debug-fun-tlf-number dfun) tlf-num)
-       (setf (compiled-debug-fun-blocks dfun) blocks))
-      (setf (compiled-debug-fun-tlf-number dfun) (find-tlf-number fun)))
+       (multiple-value-bind (blocks tlf-num)
+           (compute-debug-blocks fun var-locs)
+         (setf (compiled-debug-fun-tlf-number dfun) tlf-num)
+         (setf (compiled-debug-fun-blocks dfun) blocks))
+       (setf (compiled-debug-fun-tlf-number dfun) (find-tlf-number fun)))
 
     (if (xep-p fun)
        (setf (compiled-debug-fun-returns dfun) :standard)