X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug.lisp;h=b6e2753767c3b2e304758c8fd1024f8041ac85ce;hb=8a55e8e2feb7fd0faaaed6d420beec97dade94e4;hp=d6e226b4360c7474cc497e36abbdff9b7795c1be;hpb=0c7ffa8fb85a94482814835c9f28abfd0400ab99;p=sbcl.git diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index d6e226b..b6e2753 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -84,14 +84,15 @@ (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) (block head (block-next block))) ((null block) (unless (eq prev tail) - (barf "wrong Tail for DFO, ~S in ~S" prev c))) + (barf "wrong TAIL for DFO, ~S in ~S" prev c))) (setf (gethash block *seen-blocks*) t) (unless (eq (block-prev block) prev) (barf "bad PREV for ~S, should be ~S" block prev)) @@ -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) @@ -377,7 +378,7 @@ (when dest (check-node-reached dest))) - (loop + (loop (unless (eq (continuation-block this-cont) block) (barf "BLOCK in ~S should be ~S." this-cont block)) @@ -393,7 +394,7 @@ (unless fun-deleted (check-node-consistency node)) - + (let ((cont (node-cont node))) (when (not cont) (barf "~S has no CONT." node)) @@ -407,7 +408,7 @@ (unless (eq (continuation-use cont) node) (barf "USE in ~S should be ~S." cont node)) (setq this-cont cont)))) - + (check-block-successors block)) (values)) @@ -557,12 +558,12 @@ ;;;; IR2 consistency checking -;;; Check for some kind of consistency in some Refs linked together by -;;; TN-Ref-Across. VOP is the VOP that the references are in. Write-P is the -;;; value of Write-P that should be present. Count is the minimum number of -;;; operands expected. If More-P is true, then any larger number will also be -;;; accepted. What is a string describing the kind of operand in error -;;; messages. +;;; Check for some kind of consistency in some REFs linked together by +;;; TN-REF-ACROSS. VOP is the VOP that the references are in. WRITE-P +;;; is the value of WRITE-P that should be present. COUNT is the +;;; minimum number of operands expected. If MORE-P is true, then any +;;; larger number will also be accepted. WHAT is a string describing +;;; the kind of operand in error messages. (defun check-tn-refs (refs vop write-p count more-p what) (let ((vop-refs (vop-refs vop))) (do ((ref refs (tn-ref-across ref)) @@ -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) @@ -620,8 +621,8 @@ (values)) ;;; Check the basic sanity of the VOP linkage, then call some other -;;; functions to check on the TN-Refs. We grab some info out of the VOP-Info -;;; to tell us what to expect. +;;; functions to check on the TN-REFS. We grab some info out of the +;;; VOP-INFO to tell us what to expect. ;;; ;;; [### Check that operand type restrictions are met?] (defun check-ir2-block-consistency (2block) @@ -658,12 +659,12 @@ (barf "wrong number of codegen info args in ~S" vop)))) (values)) -;;; Check stuff about the IR2 representation of Component. This assumes the +;;; Check stuff about the IR2 representation of COMPONENT. This assumes the ;;; sanity of the basic flow graph. ;;; ;;; [### Also grovel global TN data structures? Assume pack not -;;; done yet? Have separate check-tn-consistency for pre-pack and -;;; check-pack-consistency for post-pack?] +;;; done yet? Have separate CHECK-TN-CONSISTENCY for pre-pack and +;;; CHECK-PACK-CONSISTENCY for post-pack?] (defun check-ir2-consistency (component) (declare (type component component)) (do-ir2-blocks (block component) @@ -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 @@ -722,7 +723,7 @@ confs)) (values)) -;;; If the entry in Local-TNs for TN in Block is :More, then do some checks +;;; If the entry in Local-TNs for TN in BLOCK is :MORE, then do some checks ;;; for the validity of the usage. (defun check-more-tn-entry (tn block) (let* ((vop (ir2-block-start-vop block)) @@ -752,9 +753,9 @@ ((eq kind :component) (unless (member tn (ir2-component-component-tns (component-info component))) - (barf "~S not in Component-TNs for ~S" tn 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) @@ -896,13 +897,13 @@ (proclaim '(hash-table ,vto ,vfrom)) (defvar ,counter 0) (proclaim '(fixnum ,counter)) - + (defun ,fto (x) (or (gethash x ,vto) (let ((num (incf ,counter))) (setf (gethash num ,vfrom) x) (setf (gethash x ,vto) num)))) - + (defun ,ffrom (num) (values (gethash num ,vfrom)))))) (def *continuation-number* *continuation-numbers* *number-continuations* @@ -1000,9 +1001,9 @@ (mapcar (lambda (x) (cont-num (block-start x))) succ))) (values)) -;;; Print a useful representation of a TN. If the TN has a leaf, then do a -;;; Print-Leaf on that, otherwise print a generated ID. -(defun print-tn (tn &optional (stream *standard-output*)) +;;; Print the guts of a TN. (logic shared between PRINT-OBJECT (TN T) +;;; and printers for compound objects which contain TNs) +(defun print-tn-guts (tn &optional (stream *standard-output*)) (declare (type tn tn)) (let ((leaf (tn-leaf tn))) (cond (leaf @@ -1013,8 +1014,8 @@ (when (and (tn-sc tn) (tn-offset tn)) (format stream "[~A]" (location-print-name tn))))) -;;; Print the TN-Refs representing some operands to a VOP, linked by -;;; TN-Ref-Across. +;;; Print the TN-REFs representing some operands to a VOP, linked by +;;; TN-REF-ACROSS. (defun print-operands (refs) (declare (type (or tn-ref null) refs)) (pprint-logical-block (*standard-output* nil) @@ -1023,15 +1024,15 @@ (let ((tn (tn-ref-tn ref)) (ltn (tn-ref-load-tn ref))) (cond ((not ltn) - (print-tn tn)) + (print-tn-guts tn)) (t - (print-tn tn) + (print-tn-guts tn) (princ (if (tn-ref-write-p ref) #\< #\>)) - (print-tn ltn))) + (print-tn-guts ltn))) (princ #\space) (pprint-newline :fill))))) -;;; Print the vop, putting args, info and results on separate lines, if +;;; Print the VOP, putting args, info and results on separate lines, if ;;; necessary. (defun print-vop (vop) (pprint-logical-block (*standard-output* nil) @@ -1119,7 +1120,7 @@ (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))) @@ -1153,7 +1154,7 @@ (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)) (let ((block (global-conflicts-block conf))) (add-always-live-tns block tn) @@ -1178,7 +1179,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 +1188,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)))