X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug.lisp;h=1bdad5baf07ed40875c28dbbefc9ab0a4d51b4a9;hb=b7a8f5313a83dea33ce60551a4fb987b415c2cc6;hp=b6e2753767c3b2e304758c8fd1024f8041ac85ce;hpb=581e3d62de8cb37e13ad9db63e5537c0f962be28;p=sbcl.git diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index b6e2753..1bdad5b 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -475,7 +475,10 @@ (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))))) + (barf "DEST for ~S should be ~S." cont node)) + (unless (find-uses cont) + (barf "Continuation ~S has a destinatin, but no uses." + cont))))) (values)) ;;; This function deals with checking for consistency of the @@ -496,25 +499,25 @@ (check-dest (basic-combination-fun node) 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))))))) + (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)))) (when (and (return-p dest) (eq (basic-combination-kind node) :local) @@ -528,6 +531,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 @@ -892,11 +897,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,7 +928,7 @@ (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) @@ -949,56 +954,69 @@ ;;; 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))) + (when (block-delete-p block) + (format t " ")) + + (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 ~A~) c~D" + (if (node-tail-p node) "tail " "") + (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)) + (when (functional-kind (bind-lambda node)) + (format t " ~S ~S" :kind (functional-kind (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 "))))) + (cast + (let ((value (cast-value node))) + (format t "cast c~D ~A[~S -> ~S]" (cont-num value) + (if (cast-%type-check node) #\+ #\-) + (cast-type-to-check node) + (cast-asserted-type node))))) + (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) @@ -1050,27 +1068,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. @@ -1084,9 +1104,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 @@ -1115,8 +1150,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) @@ -1128,7 +1163,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))) @@ -1156,6 +1191,10 @@ (clrhash *list-conflicts-table*) (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)