0.9.1.64:

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

diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp
index 9be0b07..872144a 100644 (file)
--- a/src/compiler/debug.lisp
+++ b/src/compiler/debug.lisp
@@ -195,7 +195,10 @@
        (barf ":OPTIONAL ~S has an ENTRY-FUN." functional))
      (let ((ef (lambda-optional-dispatch functional)))
        (check-fun-reached ef functional)
-       (unless (or (member functional (optional-dispatch-entry-points ef))
+       (unless (or (member functional (optional-dispatch-entry-points ef)
+                           :key (lambda (ep)
+                                  (when (promise-ready-p ep)
+                                    (force ep))))
                   (eq functional (optional-dispatch-more-entry ef))
                   (eq functional (optional-dispatch-main-entry ef)))
         (barf ":OPTIONAL ~S is not an e-p for its OPTIONAL-DISPATCH ~S."
@@ -238,7 +241,8 @@
         (barf "HOME in ~S should be ~S." var functional))))
     (optional-dispatch
      (dolist (ep (optional-dispatch-entry-points functional))
-       (check-fun-reached ep functional))
+       (when (promise-ready-p ep)
+         (check-fun-reached (force ep) functional)))
      (let ((more (optional-dispatch-more-entry functional)))
        (when more (check-fun-reached more functional)))
      (check-fun-reached (optional-dispatch-main-entry functional)
@@ -466,6 +470,18 @@
             (check-fun-reached leaf node)))))
     (basic-combination
      (check-dest (basic-combination-fun node) node)
+     (when (and (mv-combination-p node)
+                (eq (basic-combination-kind node) :local))
+       (let ((fun-lvar (basic-combination-fun node)))
+         (unless (ref-p (lvar-uses fun-lvar))
+           (barf "function in a local mv-combination is not a LEAF: ~S" node))
+         (let ((fun (ref-leaf (lvar-use fun-lvar))))
+           (unless (lambda-p fun)
+             (barf "function ~S in a local mv-combination ~S is not local"
+                   fun node))
+           (unless (eq (functional-kind fun) :mv-let)
+             (barf "function ~S in a local mv-combination ~S is not of kind :MV-LET"
+                   fun node)))))
      (dolist (arg (basic-combination-args node))
        (cond
          (arg (check-dest arg node))
@@ -650,7 +666,7 @@
 
 ;;; Dump some info about how many TNs there, and what the conflicts data
 ;;; structures are like.
-(defun pre-pack-tn-stats (component &optional (stream *error-output*))
+(defun pre-pack-tn-stats (component &optional (stream *standard-output*))
   (declare (type component component))
   (let ((wired 0)
        (global 0)
@@ -929,6 +945,11 @@
   (format t "v~D " (cont-num cont))
   (values))
 
+(defun print-lvar-stack (stack &optional (stream *standard-output*))
+  (loop for (lvar . rest) on stack
+        do (format stream "~:[u~;d~]v~D~@[ ~]"
+                   (lvar-dynamic-extent lvar) (cont-num lvar) rest)))
+
 ;;; Print out the nodes in BLOCK in a format oriented toward
 ;;; representing what the code does.
 (defun print-nodes (block)
@@ -940,6 +961,10 @@
       (format t " <deleted>"))
 
     (pprint-newline :mandatory)
+    (awhen (block-info block)
+      (format t "start stack: ")
+      (print-lvar-stack (ir2-block-start-stack it))
+      (pprint-newline :mandatory))
     (do ((ctran (block-start block) (node-next (ctran-next ctran))))
         ((not ctran))
       (let ((node (ctran-next ctran)))
@@ -953,7 +978,7 @@
            (let ((kind (basic-combination-kind node)))
              (format t "~(~A~A ~A~) "
                      (if (node-tail-p node) "tail " "")
-                     (if (fun-info-p kind) "known" kind)
+                     kind
                      (type-of node))
              (print-lvar (basic-combination-fun node))
              (dolist (arg (basic-combination-args node))
@@ -980,7 +1005,13 @@
            (print-lvar (return-result node))
            (print-leaf (return-lambda node)))
           (entry
-           (format t "entry ~S" (entry-exits node)))
+           (let ((cleanup (entry-cleanup node)))
+             (case (cleanup-kind cleanup)
+               ((:dynamic-extent)
+                (format t "entry DX~{ v~D~}"
+                        (mapcar #'cont-num (cleanup-info cleanup))))
+               (t
+                (format t "entry ~S" (entry-exits node))))))
           (exit
            (let ((value (exit-value node)))
              (cond (value
@@ -998,6 +1029,10 @@
                      (cast-asserted-type node)))))
         (pprint-newline :mandatory)))
 
+    (awhen (block-info block)
+      (format t "end stack: ")
+      (print-lvar-stack (ir2-block-end-stack it))
+      (pprint-newline :mandatory))
     (let ((succ (block-succ block)))
       (format t "successors~{ c~D~}~%"
               (mapcar (lambda (x) (cont-num (block-start x))) succ))))