X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fdebug.lisp;h=98757532e29c8147e2a6eb922b848c3263934f40;hb=11214915e9b3151ec66dc3e30e1aa7638c676428;hp=c565cae9526b1d0e181b5f888787be6b681f5450;hpb=dec94b039e8ec90baf21463df839a6181de606f6;p=sbcl.git diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index c565cae..9875753 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -39,8 +39,8 @@ One of :WARN, :ERROR or :NONE.") (declaim (type (member :warn :error :none) *burp-action*)) -;;; Called when something funny but possibly correct is noticed. Otherwise -;;; similar to Barf. +;;; Called when something funny but possibly correct is noticed. +;;; Otherwise similar to BARF. (declaim (ftype (function (string &rest t) (values)) burp)) (defun burp (string &rest *args*) (ecase *burp-action* @@ -49,31 +49,33 @@ (:none)) (values)) -;;; *Seen-Blocks* is a hashtable with true values for all blocks which appear -;;; in the DFO for one of the specified components. +;;; *SEEN-BLOCKS* is a hashtable with true values for all blocks which +;;; appear in the DFO for one of the specified components. +;;; +;;; *SEEN-FUNCTIONS* is similar, but records all the lambdas we +;;; reached by recursing on top level functions. (defvar *seen-blocks* (make-hash-table :test 'eq)) - -;;; *Seen-Functions* is similar, but records all the lambdas we reached by -;;; recursing on top-level functions. (defvar *seen-functions* (make-hash-table :test 'eq)) -;;; Barf if Node is in a block which wasn't reached during the graph walk. +;;; Barf if NODE is in a block which wasn't reached during the graph +;;; walk. (declaim (ftype (function (node) (values)) check-node-reached)) (defun check-node-reached (node) (unless (gethash (continuation-block (node-prev node)) *seen-blocks*) (barf "~S was not reached." node)) (values)) -;;; Check everything that we can think of for consistency. When a definite -;;; inconsistency is detected, we BARF. Possible problems just cause us to -;;; BURP. Our argument is a list of components, but we also look at the -;;; *FREE-VARIABLES*, *FREE-FUNCTIONS* and *CONSTANTS*. +;;; Check everything that we can think of for consistency. When a +;;; definite inconsistency is detected, we BARF. Possible problems +;;; just cause us to BURP. Our argument is a list of components, but +;;; we also look at the *FREE-VARIABLES*, *FREE-FUNCTIONS* and +;;; *CONSTANTS*. ;;; -;;; First we do a pre-pass which finds all the blocks and lambdas, testing -;;; that they are linked together properly and entering them in hashtables. -;;; Next, we iterate over the blocks again, looking at the actual code and -;;; control flow. Finally, we scan the global leaf hashtables, looking for -;;; lossage. +;;; First we do a pre-pass which finds all the CBLOCKs and CLAMBDAs, +;;; testing that they are linked together properly and entering them +;;; in hashtables. Next, we iterate over the blocks again, looking at +;;; the actual code and control flow. Finally, we scan the global leaf +;;; hashtables, looking for lossage. (declaim (ftype (function (list) (values)) check-ir1-consistency)) (defun check-ir1-consistency (components) (clrhash *seen-blocks*) @@ -118,7 +120,7 @@ (unless (or (constant-p v) (and (global-var-p v) (member (global-var-kind v) - '(:global :special :constant)))) + '(:global :special)))) (barf "strange *FREE-VARIABLES* entry: ~S" v)) (dolist (n (leaf-refs v)) (check-node-reached n)) @@ -163,21 +165,21 @@ (unless (gethash fun *seen-functions*) (barf "unseen function ~S in ~S" fun where))) -;;; In a lambda, check that the associated nodes are in seen blocks. In an -;;; optional dispatch, check that the entry points were seen. If the function -;;; is deleted, ignore it. +;;; In a CLAMBDA, check that the associated nodes are in seen blocks. +;;; In an OPTIONAL-DISPATCH, check that the entry points were seen. If +;;; the function is deleted, ignore it. (defun check-function-stuff (functional) (ecase (functional-kind functional) (:external - (let ((fun (functional-entry-function functional))) + (let ((fun (functional-entry-fun functional))) (check-function-reached fun functional) (when (functional-kind fun) (barf "The function for XEP ~S has kind." functional)) - (unless (eq (functional-entry-function fun) functional) + (unless (eq (functional-entry-fun fun) functional) (barf "bad back-pointer in function for XEP ~S" functional)))) ((:let :mv-let :assignment) (check-function-reached (lambda-home functional) functional) - (when (functional-entry-function functional) + (when (functional-entry-fun functional) (barf "The LET ~S has entry function." functional)) (unless (member functional (lambda-lets (lambda-home functional))) (barf "The LET ~S is not in LETs for HOME." functional)) @@ -187,8 +189,8 @@ (when (lambda-lets functional) (barf "LETs in a LET: ~S" functional))) (:optional - (when (functional-entry-function functional) - (barf ":OPTIONAL ~S has an ENTRY-FUNCTION." functional)) + (when (functional-entry-fun functional) + (barf ":OPTIONAL ~S has an ENTRY-FUN." functional)) (let ((ef (lambda-optional-dispatch functional))) (check-function-reached ef functional) (unless (or (member functional (optional-dispatch-entry-points ef)) @@ -196,22 +198,20 @@ (eq functional (optional-dispatch-main-entry ef))) (barf ":OPTIONAL ~S is not an e-p for its OPTIONAL-DISPATCH ~S." functional ef)))) - (:top-level - (unless (eq (functional-entry-function functional) functional) - (barf "The ENTRY-FUNCTION in ~S isn't a self-pointer." functional))) + (:toplevel + (unless (eq (functional-entry-fun functional) functional) + (barf "The ENTRY-FUN in ~S isn't a self-pointer." functional))) ((nil :escape :cleanup) - (let ((ef (functional-entry-function functional))) + (let ((ef (functional-entry-fun functional))) (when ef (check-function-reached ef functional) (unless (eq (functional-kind ef) :external) - (barf "The ENTRY-FUNCTION in ~S isn't an XEP: ~S." - functional - ef))))) + (barf "The ENTRY-FUN in ~S isn't an XEP: ~S." functional ef))))) (:deleted (return-from check-function-stuff))) (case (functional-kind functional) - ((nil :optional :external :top-level :escape :cleanup) + ((nil :optional :external :toplevel :escape :cleanup) (when (lambda-p functional) (dolist (fun (lambda-lets functional)) (unless (eq (lambda-home fun) functional) @@ -244,11 +244,11 @@ (defun check-function-consistency (components) (dolist (c components) - (dolist (fun (component-new-functions c)) - (observe-functional fun)) + (dolist (new-fun (component-new-funs c)) + (observe-functional new-fun)) (dolist (fun (component-lambdas c)) (when (eq (functional-kind fun) :external) - (let ((ef (functional-entry-function fun))) + (let ((ef (functional-entry-fun fun))) (when (optional-dispatch-p ef) (observe-functional ef)))) (observe-functional fun) @@ -256,8 +256,8 @@ (observe-functional let)))) (dolist (c components) - (dolist (fun (component-new-functions c)) - (check-function-stuff fun)) + (dolist (new-fun (component-new-funs c)) + (check-function-stuff new-fun)) (dolist (fun (component-lambdas c)) (when (eq (functional-kind fun) :deleted) (barf "deleted lambda ~S in Lambdas for ~S" fun c)) @@ -410,7 +410,7 @@ (check-block-successors block)) (values)) -;;; Check that Block is properly terminated. Each successor must be +;;; Check that BLOCK is properly terminated. Each successor must be ;;; accounted for by the type of the last node. (declaim (ftype (function (cblock) (values)) check-block-successors)) (defun check-block-successors (block) @@ -456,8 +456,8 @@ ;;;; node consistency checking -;;; Check that the Dest for Cont is the specified Node. We also mark the -;;; block Cont is in as Seen. +;;; 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))) @@ -476,18 +476,18 @@ (barf "DEST for ~S should be ~S." cont node))))) (values)) -;;; This function deals with checking for consistency the type-dependent -;;; information in a node. +;;; This function deals with checking for consistency of the +;;; type-dependent information in a node. (defun check-node-consistency (node) (declare (type node node)) (etypecase node (ref (let ((leaf (ref-leaf node))) (when (functional-p leaf) - (if (eq (functional-kind leaf) :top-level-xep) + (if (eq (functional-kind leaf) :toplevel-xep) (unless (eq (component-kind (block-component (node-block node))) - :top-level) - (barf ":TOP-LEVEL-XEP ref in non-top-level component: ~S" + :toplevel) + (barf ":TOPLEVEL-XEP ref in non-top-level component: ~S" node)) (check-function-reached leaf node))))) (basic-combination @@ -568,10 +568,10 @@ (num 0 (1+ num))) ((null ref) (when (< num count) - (barf "There should be at least ~D ~A in ~S, but are only ~D." + (barf "There should be at least ~W ~A in ~S, but there are only ~W." count what vop num)) (when (and (not more-p) (> num count)) - (barf "There should be ~D ~A in ~S, but are ~D." + (barf "There should be ~W ~A in ~S, but are ~W." count what vop num))) (unless (eq (tn-ref-vop ref) vop) (barf "VOP is ~S isn't ~S." ref vop)) @@ -714,8 +714,8 @@ (incf const)) (format stream - "~%TNs: ~D local, ~D temps, ~D constant, ~D env, ~D comp, ~D global.~@ - Wired: ~D, Unused: ~D. ~D block~:P, ~D global conflict~:P.~%" + "~%TNs: ~W local, ~W temps, ~W constant, ~W env, ~W comp, ~W global.~@ + Wired: ~W, Unused: ~W. ~W block~:P, ~W global conflict~:P.~%" local temps const environment comp global wired unused (ir2-block-count component) confs)) @@ -820,21 +820,18 @@ (barf "strange TN ~S in LTN map for ~S" tn block))))))) ;;; All TNs live at the beginning of an environment must be passing -;;; locations associated with that environment. We make an exception for wired -;;; TNs in XEP functions, since we randomly reference wired TNs to access the -;;; full call passing locations. +;;; locations associated with that environment. We make an exception +;;; for wired TNs in XEP functions, since we randomly reference wired +;;; TNs to access the full call passing locations. (defun check-environment-lifetimes (component) (dolist (fun (component-lambdas component)) - (let* ((env (lambda-environment fun)) - (2env (environment-info env)) + (let* ((env (lambda-physenv fun)) + (2env (physenv-info env)) (vars (lambda-vars fun)) - (closure (ir2-environment-environment 2env)) - (pc (ir2-environment-return-pc-pass 2env)) - (fp (ir2-environment-old-fp 2env)) - (2block (block-info - (node-block - (lambda-bind - (environment-function env)))))) + (closure (ir2-physenv-closure 2env)) + (pc (ir2-physenv-return-pc-pass 2env)) + (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))) ((null conf)) @@ -842,16 +839,16 @@ (unless (or (eq (global-conflicts-kind conf) :write) (eq tn pc) (eq tn fp) - (and (external-entry-point-p fun) - (tn-offset tn)) + (and (xep-p fun) (tn-offset tn)) (member (tn-kind tn) '(:environment :debug-environment)) (member tn vars :key #'leaf-info) (member tn closure :key #'cdr)) (barf "strange TN live at head of ~S: ~S" env tn)))))) (values)) -;;; Check for some basic sanity in the TN conflict data structures, and also -;;; check that no TNs are unexpectedly live at environment entry. +;;; Check for some basic sanity in the TN conflict data structures, +;;; and also check that no TNs are unexpectedly live at environment +;;; entry. (defun check-life-consistency (component) (check-tn-conflicts component) (check-block-conflicts component) @@ -907,19 +904,12 @@ (defun print-leaf (leaf &optional (stream *standard-output*)) (declare (type leaf leaf) (type stream stream)) (etypecase leaf - (lambda-var (prin1 (leaf-name leaf) stream)) + (lambda-var (prin1 (leaf-debug-name leaf) stream)) (constant (format stream "'~S" (constant-value leaf))) (global-var - (format stream "~S {~A}" (leaf-name leaf) (global-var-kind leaf))) - (clambda - (format stream "lambda ~S ~S" (leaf-name leaf) - (mapcar #'leaf-name (lambda-vars leaf)))) - (optional-dispatch - (format stream "optional-dispatch ~S" (leaf-name leaf))) + (format stream "~S {~A}" (leaf-debug-name leaf) (global-var-kind leaf))) (functional - (aver (eq (functional-kind leaf) :top-level-xep)) - (format stream "TL-XEP ~S" - (entry-info-name (leaf-info leaf)))))) + (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)) @@ -934,7 +924,7 @@ (component (component-head thing)) #| (cloop (loop-head thing))|# (integer (continuation-block (num-cont thing))) - (functional (node-block (lambda-bind (main-entry thing)))) + (functional (lambda-block (main-entry thing))) (null (error "Bad thing: ~S." thing)) (symbol (block-or-lose (gethash thing *free-functions*))))) @@ -944,8 +934,8 @@ (format t " c~D" (cont-num cont)) (values)) -;;; Print out the nodes in Block in a format oriented toward representing -;;; what the code does. +;;; 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)) (format t "~%block start c~D" (cont-num (block-start block))) @@ -1068,7 +1058,7 @@ (vop-next vop)) (number 0 (1+ number))) ((null vop)) - (format t "~D: " number) + (format t "~W: " number) (print-vop vop))) ;;; This is like PRINT-NODES, but dumps the IR2 representation of the