X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug.lisp;h=1bdad5baf07ed40875c28dbbefc9ab0a4d51b4a9;hb=22c1de0a40df83bb5628974010a879cb2c17ff53;hp=7f67f0ffb7294b5681b72853d3f4f59a4cb823e3;hpb=c7dc5b2a1f56ed0583a0b3ea61b6ceb540c6f89e;p=sbcl.git diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 7f67f0f..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) @@ -952,6 +957,8 @@ (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) @@ -963,7 +970,8 @@ (ref (print-leaf (ref-leaf node))) (basic-combination (let ((kind (basic-combination-kind node))) - (format t "~(~A ~A~) c~D" + (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))) @@ -981,7 +989,9 @@ (print-continuation (block-start (if-alternative node)))) (bind (write-string "bind ") - (print-leaf (bind-lambda node))) + (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))) @@ -994,7 +1004,13 @@ ((exit-entry node) (format t "exit ")) (t - (format t "exit ")))))) + (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))))) @@ -1134,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) @@ -1147,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))) @@ -1176,7 +1192,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)