X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug.lisp;h=872144a9610124fea7af1854c66fa1136264bbe7;hb=6535ee98644b8fd1cea3581adb25d4d8bf7c1110;hp=7f67f0ffb7294b5681b72853d3f4f59a4cb823e3;hpb=c7dc5b2a1f56ed0583a0b3ea61b6ceb540c6f89e;p=sbcl.git diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 7f67f0f..872144a 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -63,7 +63,7 @@ ;;; walk. (declaim (ftype (function (node) (values)) check-node-reached)) (defun check-node-reached (node) - (unless (gethash (continuation-block (node-prev node)) *seen-blocks*) + (unless (gethash (ctran-block (node-prev node)) *seen-blocks*) (barf "~S was not reached." node)) (values)) @@ -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) @@ -332,82 +336,60 @@ (let* ((fun (block-home-lambda block)) (fun-deleted (eq (functional-kind fun) :deleted)) - (this-cont (block-start block)) + (this-ctran (block-start block)) (last (block-last block))) (unless fun-deleted (check-fun-reached fun block)) - (when (not this-cont) + (when (not this-ctran) (barf "~S has no START." block)) (when (not last) (barf "~S has no LAST." block)) - (unless (eq (continuation-kind this-cont) :block-start) + (unless (eq (ctran-kind this-ctran) :block-start) (barf "The START of ~S has the wrong kind." block)) - (let ((use (continuation-use this-cont)) - (uses (block-start-uses block))) - (when (and (null use) (= (length uses) 1)) - (barf "~S has a unique use, but no USE." this-cont)) - (dolist (node uses) - (unless (eq (node-cont node) this-cont) - (barf "The USE ~S for START in ~S has wrong CONT." node block)) - (check-node-reached node))) - - (let* ((last-cont (node-cont last)) - (cont-block (continuation-block last-cont)) - (dest (continuation-dest last-cont))) - (ecase (continuation-kind last-cont) - (:deleted) - (:deleted-block-start - (let ((dest (continuation-dest last-cont))) - (when dest - (check-node-reached dest))) - (unless (member last (block-start-uses cont-block)) - (barf "LAST in ~S is missing from uses of its Cont." block))) - (:block-start - (check-node-reached (continuation-next last-cont)) - (unless (member last (block-start-uses cont-block)) - (barf "LAST in ~S is missing from uses of its Cont." block))) - (:inside-block - (unless (eq cont-block block) - (barf "CONT of LAST in ~S is in a different BLOCK." block)) - (unless (eq (continuation-use last-cont) last) - (barf "USE is not LAST in CONT of LAST in ~S." block)) - (when (continuation-next last-cont) - (barf "CONT of LAST has a NEXT in ~S." block)))) - - (when dest - (check-node-reached dest))) + (when (ctran-use this-ctran) + (barf "The ctran ~S is used." this-ctran)) - (loop - (unless (eq (continuation-block this-cont) block) - (barf "BLOCK in ~S should be ~S." this-cont block)) + (when (node-next last) + (barf "Last node ~S of ~S has next ctran." last block)) - (let ((dest (continuation-dest this-cont))) - (when dest - (check-node-reached dest))) + (loop + (unless (eq (ctran-block this-ctran) block) + (barf "BLOCK of ~S should be ~S." this-ctran block)) - (let ((node (continuation-next this-cont))) + (let ((node (ctran-next this-ctran))) (unless (node-p node) - (barf "~S has strange NEXT." this-cont)) - (unless (eq (node-prev node) this-cont) - (barf "PREV in ~S should be ~S." node this-cont)) - + (barf "~S has strange NEXT." this-ctran)) + (unless (eq (node-prev node) this-ctran) + (barf "PREV in ~S should be ~S." node this-ctran)) + + (when (valued-node-p node) + (binding* ((lvar (node-lvar node) :exit-if-null)) + (unless (memq node (find-uses lvar)) + (barf "~S is not used by its LVAR ~S." node lvar)) + (when (singleton-p (lvar-uses lvar)) + (barf "~S has exactly 1 use, but LVAR-USES is a list." + lvar)) + (unless (lvar-dest lvar) + (barf "~S does not have dest." lvar)))) + + (check-node-reached node) (unless fun-deleted (check-node-consistency node)) - (let ((cont (node-cont node))) - (when (not cont) - (barf "~S has no CONT." node)) + (let ((next (node-next node))) + (when (and (not next) (not (eq node last))) + (barf "~S has no NEXT." node)) (when (eq node last) (return)) - (unless (eq (continuation-kind cont) :inside-block) - (barf "The interior continuation ~S in ~S has the wrong kind." - cont + (unless (eq (ctran-kind next) :inside-block) + (barf "The interior ctran ~S in ~S has the wrong kind." + next block)) - (unless (continuation-next cont) - (barf "~S has no NEXT." cont)) - (unless (eq (continuation-use cont) node) - (barf "USE in ~S should be ~S." cont node)) - (setq this-cont cont)))) + (unless (ctran-next next) + (barf "~S has no NEXT." next)) + (unless (eq (ctran-use next) node) + (barf "USE in ~S should be ~S." next node)) + (setq this-ctran next)))) (check-block-successors block)) (values)) @@ -458,24 +440,18 @@ ;;;; node consistency checking -;;; Check that the DEST for CONT is the specified NODE. We also mark -;;; the block CONT is in as SEEN. -(declaim (ftype (function (continuation node) (values)) check-dest)) -(defun check-dest (cont node) - (let ((kind (continuation-kind cont))) - (ecase kind - (:deleted - (unless (block-delete-p (node-block node)) - (barf "DEST ~S of deleted continuation ~S is not DELETE-P." - cont node))) - (:deleted-block-start - (unless (eq (continuation-dest cont) node) - (barf "DEST for ~S should be ~S." cont node))) - ((:inside-block :block-start) - (unless (gethash (continuation-block cont) *seen-blocks*) - (barf "~S receives ~S, which is in an unknown block." node cont)) - (unless (eq (continuation-dest cont) node) - (barf "DEST for ~S should be ~S." cont node))))) +;;; Check that the DEST for LVAR is the specified NODE. We also mark +;;; the block LVAR is in as SEEN. +#+nil(declaim (ftype (function (lvar node) (values)) check-dest)) +(defun check-dest (lvar node) + (do-uses (use lvar) + (unless (gethash (node-block use) *seen-blocks*) + (barf "Node ~S using ~S is in an unknown block." use lvar))) + (unless (eq (lvar-dest lvar) node) + (barf "DEST for ~S should be ~S." lvar node)) + (unless (find-uses lvar) + (barf "Lvar ~S has a destinatin, but no uses." + lvar)) (values)) ;;; This function deals with checking for consistency of the @@ -494,28 +470,41 @@ (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)) - ((not (and (eq (basic-combination-kind node) :local) - (combination-p node))) - (barf "flushed arg not in local call: ~S" node)) - (t - (locally - ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like - ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of - ;; POSITION. It compiles it correctly, but it issues a type - ;; mismatch warning because it can't eliminate the - ;; possibility that control will flow through the - ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15 - (declare (notinline position)) - (let ((fun (ref-leaf (continuation-use - (basic-combination-fun node)))) - (pos (position arg (basic-combination-args node)))) - (declare (type index pos)) - (when (leaf-refs (elt (lambda-vars fun) pos)) - (barf "flushed arg for referenced var in ~S" node))))))) - (let ((dest (continuation-dest (node-cont node)))) + (arg (check-dest arg node)) + ((not (and (eq (basic-combination-kind node) :local) + (combination-p node))) + (barf "flushed arg not in local call: ~S" node)) + (t + (locally + ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like + ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of + ;; POSITION. It compiles it correctly, but it issues a type + ;; mismatch warning because it can't eliminate the + ;; possibility that control will flow through the + ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15 + (declare (notinline position)) + (let ((fun (ref-leaf (lvar-use + (basic-combination-fun node)))) + (pos (position arg (basic-combination-args node)))) + (declare (type index pos)) + (when (leaf-refs (elt (lambda-vars fun) pos)) + (barf "flushed arg for referenced var in ~S" node))))))) + (let* ((lvar (node-lvar node)) + (dest (and lvar (lvar-dest lvar)))) (when (and (return-p dest) (eq (basic-combination-kind node) :local) (not (eq (lambda-tail-set (combination-lambda node)) @@ -528,6 +517,8 @@ (barf "IF not at block end: ~S" node))) (cset (check-dest (set-value node) node)) + (cast + (check-dest (cast-value node) node)) (bind (check-fun-reached (bind-lambda node) node)) (creturn @@ -675,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) @@ -892,11 +883,11 @@ ;;; keep garbage from being collected. (macrolet ((def (counter vto vfrom fto ffrom) `(progn + (declaim (type hash-table ,vto ,vfrom)) (defvar ,vto (make-hash-table :test 'eq)) (defvar ,vfrom (make-hash-table :test 'eql)) - (proclaim '(hash-table ,vto ,vfrom)) + (declaim (type fixnum ,counter)) (defvar ,counter 0) - (proclaim '(fixnum ,counter)) (defun ,fto (x) (or (gethash x ,vto) @@ -923,18 +914,18 @@ (format stream "~S ~S" (type-of leaf) (functional-debug-name leaf))))) ;;; Attempt to find a block given some thing that has to do with it. -(declaim (ftype (function (t) cblock) block-or-lose)) +(declaim (ftype (sfunction (t) cblock) block-or-lose)) (defun block-or-lose (thing) (ctypecase thing (cblock thing) (ir2-block (ir2-block-block thing)) (vop (block-or-lose (vop-block thing))) (tn-ref (block-or-lose (tn-ref-vop thing))) - (continuation (continuation-block thing)) + (ctran (ctran-block thing)) (node (node-block thing)) (component (component-head thing)) #| (cloop (loop-head thing))|# - (integer (continuation-block (num-cont thing))) + (integer (ctran-block (num-cont thing))) (functional (lambda-block (main-entry thing))) (null (error "Bad thing: ~S." thing)) (symbol (block-or-lose (gethash thing *free-funs*))))) @@ -945,62 +936,106 @@ (format t " c~D" (cont-num cont)) (values)) +(defun print-ctran (cont) + (declare (type ctran cont)) + (format t "c~D " (cont-num cont)) + (values)) +(defun print-lvar (cont) + (declare (type lvar cont)) + (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) (setq block (block-or-lose block)) (pprint-logical-block (nil nil) (format t "~:@_IR1 block ~D start c~D" - (block-number block) (cont-num (block-start block))) - - (let ((last (block-last block))) - (pprint-newline :mandatory) - (do ((cont (block-start block) (node-cont (continuation-next cont)))) - ((not cont)) - (let ((node (continuation-next cont))) - (format t "~3D: " (cont-num (node-cont node))) - (etypecase node - (ref (print-leaf (ref-leaf node))) - (basic-combination - (let ((kind (basic-combination-kind node))) - (format t "~(~A ~A~) c~D" - (if (fun-info-p kind) "known" kind) - (type-of node) - (cont-num (basic-combination-fun node))) - (dolist (arg (basic-combination-args node)) - (if arg - (print-continuation arg) - (format t " "))))) - (cset - (write-string "set ") - (print-leaf (set-var node)) - (print-continuation (set-value node))) - (cif - (format t "if c~D" (cont-num (if-test node))) - (print-continuation (block-start (if-consequent node))) - (print-continuation (block-start (if-alternative node)))) - (bind - (write-string "bind ") - (print-leaf (bind-lambda node))) - (creturn - (format t "return c~D " (cont-num (return-result node))) - (print-leaf (return-lambda node))) - (entry - (format t "entry ~S" (entry-exits node))) - (exit - (let ((value (exit-value node))) - (cond (value - (format t "exit c~D" (cont-num value))) - ((exit-entry node) - (format t "exit ")) - (t - (format t "exit ")))))) - (pprint-newline :mandatory) - (when (eq node last) (return))))) - - (let ((succ (block-succ block))) - (format t "successors~{ c~D~}~%" - (mapcar (lambda (x) (cont-num (block-start x))) succ)))) + (block-number block) (cont-num (block-start block))) + (when (block-delete-p block) + (format t " ")) + + (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))) + (format t "~3D>~:[ ~;~:*~3D:~] " + (cont-num ctran) + (when (and (valued-node-p node) (node-lvar node)) + (cont-num (node-lvar node)))) + (etypecase node + (ref (print-leaf (ref-leaf node))) + (basic-combination + (let ((kind (basic-combination-kind node))) + (format t "~(~A~A ~A~) " + (if (node-tail-p node) "tail " "") + kind + (type-of node)) + (print-lvar (basic-combination-fun node)) + (dolist (arg (basic-combination-args node)) + (if arg + (print-lvar arg) + (format t " "))))) + (cset + (write-string "set ") + (print-leaf (set-var node)) + (write-char #\space) + (print-lvar (set-value node))) + (cif + (write-string "if ") + (print-lvar (if-test node)) + (print-ctran (block-start (if-consequent node))) + (print-ctran (block-start (if-alternative node)))) + (bind + (write-string "bind ") + (print-leaf (bind-lambda node)) + (when (functional-kind (bind-lambda node)) + (format t " ~S ~S" :kind (functional-kind (bind-lambda node))))) + (creturn + (write-string "return ") + (print-lvar (return-result node)) + (print-leaf (return-lambda node))) + (entry + (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 + (format t "exit ") + (print-lvar value)) + ((exit-entry node) + (format t "exit ")) + (t + (format t "exit "))))) + (cast + (let ((value (cast-value node))) + (format t "cast v~D ~A[~S -> ~S]" (cont-num value) + (if (cast-%type-check node) #\+ #\-) + (cast-type-to-check node) + (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)))) (values)) ;;; Print the guts of a TN. (logic shared between PRINT-OBJECT (TN T) @@ -1134,8 +1169,8 @@ (defvar *list-conflicts-table* (make-hash-table :test 'eq)) -;;; Add all ALWAYS-LIVE TNs in Block to the conflicts. TN is ignored when -;;; it appears in the global conflicts. +;;; Add all ALWAYS-LIVE TNs in BLOCK to the conflicts. TN is ignored +;;; when it appears in the global conflicts. (defun add-always-live-tns (block tn) (declare (type ir2-block block) (type tn tn)) (do ((conf (ir2-block-global-tns block) @@ -1147,7 +1182,7 @@ (setf (gethash btn *list-conflicts-table*) t))))) (values)) -;;; Add all local TNs in block to the conflicts. +;;; Add all local TNs in BLOCK to the conflicts. (defun add-all-local-tns (block) (declare (type ir2-block block)) (let ((ltns (ir2-block-local-tns block))) @@ -1176,7 +1211,8 @@ (do ((conf confs (global-conflicts-next-tnwise conf))) ((null conf)) (format t "~&#~%" - (block-number (ir2-block-block (global-conflicts-block conf))) + (block-number (ir2-block-block (global-conflicts-block + conf))) (global-conflicts-kind conf)) (let ((block (global-conflicts-block conf))) (add-always-live-tns block tn)