1.0.18.10: Record filenames in DEBUG-SOURCEs during EVAL-WHEN, LOAD.

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

diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp
index 797114a..93dc016 100644 (file)
--- a/src/compiler/debug-dump.lisp
+++ b/src/compiler/debug-dump.lisp
@@ -20,7 +20,8 @@
 
 (deftype location-kind ()
   '(member :unknown-return :known-return :internal-error :non-local-exit
-           :block-start :call-site :single-value-return :non-local-entry))
+           :block-start :call-site :single-value-return :non-local-entry
+           :step-before-vop))
 
 ;;; The LOCATION-INFO structure holds the information what we need
 ;;; about locations which code generation decided were "interesting".
@@ -89,7 +90,7 @@
 ;;; are spilled.
 (defun dump-1-location (node block kind tlf-num label live var-locs vop)
   (declare (type node node) (type ir2-block block)
-           (type local-tn-bit-vector live)
+           (type (or null local-tn-bit-vector) live)
            (type (or label index) label)
            (type location-kind kind) (type (or index null) tlf-num)
            (type hash-table var-locs) (type (or vop null) vop))
@@ -109,9 +110,19 @@
       (write-var-integer (source-path-tlf-number path) *byte-buffer*))
     (write-var-integer (source-path-form-number path) *byte-buffer*))
 
-  (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
-                           *byte-buffer*)
-
+  (if live
+      (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
+                               *byte-buffer*)
+      (write-packed-bit-vector
+       (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
+                   :initial-element 0
+                   :element-type 'bit)
+       *byte-buffer*))
+
+  (write-var-string (or (and (typep node 'combination)
+                             (combination-step-info node))
+                        "")
+                    *byte-buffer*)
   (values))
 
 ;;; Extract context info from a Location-Info structure and use it to
@@ -239,25 +250,25 @@
 \f
 ;;; Return DEBUG-SOURCE structure containing information derived from
 ;;; INFO.
-(defun debug-source-for-info (info)
+(defun debug-source-for-info (info &key function)
   (declare (type source-info info))
-  (let* ((file-info (source-info-file-info info))
-         (res (make-debug-source
-               :from :file
-               :created (file-info-write-date file-info)
-               :compiled (source-info-start-time info)
-               :source-root (file-info-source-root file-info)
-               :start-positions (coerce-to-smallest-eltype
-                                 (file-info-positions file-info))))
-         (name (file-info-name file-info)))
-    (etypecase name
-      ((member :lisp)
-       (setf (debug-source-from res) name
-             (debug-source-name res) (file-info-forms file-info)))
-      (pathname
-       (setf (debug-source-name res)
-             (make-file-info-namestring name file-info))))
-    res))
+  (let ((file-info (get-toplevelish-file-info info)))
+    (make-debug-source
+     :compiled (source-info-start-time info)
+
+     :namestring (make-file-info-namestring
+                  (if (pathnamep (file-info-name file-info))
+                      (file-info-name file-info))
+                  file-info)
+     :created (file-info-write-date file-info)
+     :source-root (file-info-source-root file-info)
+     :start-positions (coerce-to-smallest-eltype
+                       (file-info-positions file-info))
+
+     :form (let ((direct-file-info (source-info-file-info info)))
+             (if (eq :lisp (file-info-name direct-file-info))
+                 (elt (file-info-forms direct-file-info) 0)))
+     :function function)))
 
 ;;; Given an arbitrary sequence, coerce it to an unsigned vector if
 ;;; possible. Ordinarily we coerce it to the smallest specialized
@@ -312,6 +323,16 @@
   (make-sc-offset (sc-number (tn-sc tn))
                   (tn-offset tn)))
 
+(defun lambda-ancestor-p (maybe-ancestor maybe-descendant)
+  (declare (type clambda maybe-ancestor)
+           (type (or clambda null) maybe-descendant))
+  (loop
+     (when (eq maybe-ancestor maybe-descendant)
+       (return t))
+     (setf maybe-descendant (lambda-parent maybe-descendant))
+     (when (null maybe-descendant)
+       (return nil))))
+
 ;;; Dump info to represent VAR's location being TN. ID is an integer
 ;;; that makes VAR's name unique in the function. BUFFER is the vector
 ;;; we stick the result in. If MINIMAL, we suppress name dumping, and
@@ -338,7 +359,7 @@
                         (null (basic-var-sets var))))
                (not (gethash tn (ir2-component-spilled-tns
                                  (component-info *component-being-compiled*))))
-               (eq (lambda-var-home var) fun))
+               (lambda-ancestor-p (lambda-var-home var) fun))
       (setq flags (logior flags compiled-debug-var-environment-live)))
     (when save-tn
       (setq flags (logior flags compiled-debug-var-save-loc-p)))
@@ -399,8 +420,8 @@
                 (t
                  (setq id 0  prev-name name)))
           (dump-1-var fun var (cdr x) id nil buffer)
-          (setf (gethash var var-locs) i))
-        (incf i))
+          (setf (gethash var var-locs) i)
+          (incf i)))
       (coerce buffer 'simple-vector))))
 
 ;;; Return a vector suitable for use as the DEBUG-FUN-VARS of