X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug.lisp;h=9c84d2969977d04ab88ae2527e6072a25dc779bc;hb=cf607a404d7518e8a18c9e362913f370eb9a5e38;hp=9e543c2ce6055a2316ed25ad70f4440286ee9414;hpb=82653abf5573c22c691e2243b70647ecdaa6aea8;p=sbcl.git diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 9e543c2..9c84d29 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -84,7 +84,8 @@ (dolist (c components) (let* ((head (component-head c)) (tail (component-tail c))) - (unless (and (null (block-pred head)) (null (block-succ tail))) + (unless (and (null (block-pred head)) + (null (block-succ tail))) (barf "~S is malformed." c)) (do ((prev nil block) @@ -178,7 +179,7 @@ (barf "The function for XEP ~S has kind." functional)) (unless (eq (functional-entry-fun fun) functional) (barf "bad back-pointer in function for XEP ~S" functional)))) - ((:let :mv-let :assignment) + ((:let :mv-let :assignment) ; i.e. SOMEWHAT-LETLIKE-P (check-fun-reached (lambda-home functional) functional) (when (functional-entry-fun functional) (barf "The LET ~S has entry function." functional)) @@ -245,7 +246,7 @@ (defun check-fun-consistency (components) (dolist (c components) - (dolist (new-fun (component-new-funs c)) + (dolist (new-fun (component-new-functionals c)) (observe-functional new-fun)) (dolist (fun (component-lambdas c)) (when (eq (functional-kind fun) :external) @@ -257,7 +258,7 @@ (observe-functional let)))) (dolist (c components) - (dolist (new-fun (component-new-funs c)) + (dolist (new-fun (component-new-functionals c)) (check-fun-stuff new-fun)) (dolist (fun (component-lambdas c)) (when (eq (functional-kind fun) :deleted) @@ -593,7 +594,7 @@ (unless (find-in #'tn-ref-next-ref target vop-refs) (barf "The target for ~S isn't in REFS for ~S." ref vop))))))) -;;; Verify the sanity of the VOP-Refs slot in VOP. This involves checking +;;; Verify the sanity of the VOP-REFS slot in VOP. This involves checking ;;; that each referenced TN appears as an argument, result or temp, and also ;;; basic checks for the plausibility of the specified ordering of the refs. (defun check-vop-refs (vop) @@ -703,7 +704,7 @@ ((:environment :debug-environment) (incf environment)) (t (incf global))) (do ((conf (tn-global-conflicts tn) - (global-conflicts-tn-next conf))) + (global-conflicts-next-tnwise conf))) ((null conf)) (incf confs))) (t @@ -754,7 +755,7 @@ (component-info component))) (barf "~S not in COMPONENT-TNs for ~S" tn component))) (conf - (do ((conf conf (global-conflicts-tn-next conf)) + (do ((conf conf (global-conflicts-next-tnwise conf)) (prev nil conf)) ((null conf)) (unless (eq (global-conflicts-tn conf) tn) @@ -797,7 +798,7 @@ (defun check-block-conflicts (component) (do-ir2-blocks (block component) (do ((conf (ir2-block-global-tns block) - (global-conflicts-next conf)) + (global-conflicts-next-blockwise conf)) (prev nil conf)) ((null conf)) (when prev @@ -805,7 +806,7 @@ (tn-number (global-conflicts-tn prev))) (barf "~S and ~S out of order in ~S" prev conf block))) - (unless (find-in #'global-conflicts-tn-next + (unless (find-in #'global-conflicts-next-tnwise conf (tn-global-conflicts (global-conflicts-tn conf))) @@ -834,7 +835,7 @@ (fp (ir2-physenv-old-fp 2env)) (2block (block-info (lambda-block (physenv-lambda env))))) (do ((conf (ir2-block-global-tns 2block) - (global-conflicts-next conf))) + (global-conflicts-next-blockwise conf))) ((null conf)) (let ((tn (global-conflicts-tn conf))) (unless (or (eq (global-conflicts-kind conf) :write) @@ -948,56 +949,58 @@ ;;; representing what the code does. (defun print-nodes (block) (setq block (block-or-lose block)) - (format t "~%block start c~D" (cont-num (block-start block))) - - (let ((last (block-last block))) - (terpri) - (do ((cont (block-start block) (node-cont (continuation-next 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 ")))))) - (terpri) - (when (eq node last) (return))))) - - (let ((succ (block-succ block))) - (format t "successors~{ c~D~}~%" - (mapcar (lambda (x) (cont-num (block-start x))) succ))) + (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)))) (values)) ;;; Print the guts of a TN. (logic shared between PRINT-OBJECT (TN T) @@ -1049,27 +1052,29 @@ (when (vop-results vop) (princ "=> ") (print-operands (vop-results vop)))) - (terpri)) + (pprint-newline :mandatory)) ;;; Print the VOPs in the specified IR2 block. (defun print-ir2-block (block) (declare (type ir2-block block)) - (cond - ((eq (block-info (ir2-block-block block)) block) - (format t "~%IR2 block start c~D~%" - (cont-num (block-start (ir2-block-block block)))) - (let ((label (ir2-block-%label block))) - (when label - (format t "L~D:~%" (label-id label))))) - (t - (format t "~%"))) - - (do ((vop (ir2-block-start-vop block) - (vop-next vop)) - (number 0 (1+ number))) - ((null vop)) - (format t "~W: " number) - (print-vop vop))) + (pprint-logical-block (*standard-output* nil) + (cond + ((eq (block-info (ir2-block-block block)) block) + (format t "~:@_IR2 block ~D start c~D~:@_" + (ir2-block-number block) + (cont-num (block-start (ir2-block-block block)))) + (let ((label (ir2-block-%label block))) + (when label + (format t "L~D:~:@_" (label-id label))))) + (t + (format t "~:@_"))) + + (do ((vop (ir2-block-start-vop block) + (vop-next vop)) + (number 0 (1+ number))) + ((null vop)) + (format t "~W: " number) + (print-vop vop)))) ;;; This is like PRINT-NODES, but dumps the IR2 representation of the ;;; code in BLOCK. @@ -1083,9 +1088,24 @@ (values)) ;;; Scan the IR2 blocks in emission order. -(defun print-ir2-blocks (thing) - (do-ir2-blocks (block (block-component (block-or-lose thing))) - (print-ir2-block block)) +(defun print-ir2-blocks (thing &optional full) + (let* ((block (component-head (block-component (block-or-lose thing)))) + (2block (block-info block))) + (pprint-logical-block (nil nil) + (loop while 2block + do (setq block (ir2-block-block 2block)) + do (pprint-logical-block (*standard-output* nil) + (if full + (print-nodes block) + (format t "IR1 block ~D start c~D" + (block-number block) + (cont-num (block-start block)))) + (pprint-indent :block 4) + (pprint-newline :mandatory) + (loop while (and 2block (eq (ir2-block-block 2block) block)) + do (print-ir2-block 2block) + do (setq 2block (ir2-block-next 2block)))) + do (pprint-newline :mandatory)))) (values)) ;;; Do a PRINT-NODES on BLOCK and all blocks reachable from it by @@ -1114,12 +1134,12 @@ (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) - (global-conflicts-next conf))) + (global-conflicts-next-blockwise conf))) ((null conf)) (when (eq (global-conflicts-kind conf) :live) (let ((btn (global-conflicts-tn conf))) @@ -1127,7 +1147,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))) @@ -1153,8 +1173,12 @@ (let ((confs (tn-global-conflicts tn))) (cond (confs (clrhash *list-conflicts-table*) - (do ((conf confs (global-conflicts-tn-next conf))) + (do ((conf confs (global-conflicts-next-tnwise conf))) ((null conf)) + (format t "~&#~%" + (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) (if (eq (global-conflicts-kind conf) :live) @@ -1178,7 +1202,7 @@ (not (tn-global-conflicts tn))) (res tn))))) (do ((gtn (ir2-block-global-tns block) - (global-conflicts-next gtn))) + (global-conflicts-next-blockwise gtn))) ((null gtn)) (when (or (eq (global-conflicts-kind gtn) :live) (/= (sbit confs (global-conflicts-number gtn)) 0)) @@ -1187,7 +1211,7 @@ (defun nth-vop (thing n) #!+sb-doc - "Return the Nth VOP in the IR2-Block pointed to by Thing." + "Return the Nth VOP in the IR2-BLOCK pointed to by THING." (let ((block (block-info (block-or-lose thing)))) (do ((i 0 (1+ i)) (vop (ir2-block-start-vop block) (vop-next vop)))