projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
0.9.1.64:
[sbcl.git]
/
src
/
compiler
/
debug.lisp
diff --git
a/src/compiler/debug.lisp
b/src/compiler/debug.lisp
index
92b70a5
..
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)
(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."
(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))
(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)
(let ((more (optional-dispatch-more-entry functional)))
(when more (check-fun-reached more functional)))
(check-fun-reached (optional-dispatch-main-entry functional)
@@
-662,7
+666,7
@@
;;; Dump some info about how many TNs there, and what the conflicts data
;;; structures are like.
;;; 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)
(declare (type component component))
(let ((wired 0)
(global 0)
@@
-941,6
+945,11
@@
(format t "v~D " (cont-num cont))
(values))
(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)
;;; Print out the nodes in BLOCK in a format oriented toward
;;; representing what the code does.
(defun print-nodes (block)
@@
-952,6
+961,10
@@
(format t " <deleted>"))
(pprint-newline :mandatory)
(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)))
(do ((ctran (block-start block) (node-next (ctran-next ctran))))
((not ctran))
(let ((node (ctran-next ctran)))
@@
-992,7
+1005,13
@@
(print-lvar (return-result node))
(print-leaf (return-lambda node)))
(entry
(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
(exit
(let ((value (exit-value node)))
(cond (value
@@
-1010,6
+1029,10
@@
(cast-asserted-type node)))))
(pprint-newline :mandatory)))
(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))))
(let ((succ (block-succ block)))
(format t "successors~{ c~D~}~%"
(mapcar (lambda (x) (cont-num (block-start x))) succ))))