(in-package "SB!C")
-(file-comment
- "$Header$")
-
(defvar *args* ()
#!+sb-doc
"This variable is bound to the format arguments when an error is signalled
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*
(: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-FUNS* is similar, but records all the lambdas we
+;;; reached by recursing on top level functions.
+;;; FIXME: Is it really only LAMBDAs, not e.g. FUNCTIONALs? Then
+;;; shouldn't it be *SEEN-LAMBDAS*?
(defvar *seen-blocks* (make-hash-table :test 'eq))
+(defvar *seen-funs* (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*)
+ (unless (gethash (ctran-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-VARS*, *FREE-FUNS* 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*)
- (clrhash *seen-functions*)
+ (clrhash *seen-funs*)
(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))
|#
))
- (check-function-consistency components)
+ (check-fun-consistency components)
(dolist (c components)
(do ((block (block-next (component-head c)) (block-next block)))
((null (block-next block)))
(check-block-consistency block)))
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (unless (or (constant-p v)
- (and (global-var-p v)
- (member (global-var-kind v)
- '(:global :special :constant))))
- (barf "strange *FREE-VARIABLES* entry: ~S" v))
- (dolist (n (leaf-refs v))
- (check-node-reached n))
- (when (basic-var-p v)
- (dolist (n (basic-var-sets v))
- (check-node-reached n))))
- *free-variables*)
-
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (unless (constant-p v)
- (barf "strange *CONSTANTS* entry: ~S" v))
- (dolist (n (leaf-refs v))
- (check-node-reached n)))
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (unless (or (constant-p v)
+ (and (global-var-p v)
+ (member (global-var-kind v)
+ '(:global :special))))
+ (barf "strange *FREE-VARS* entry: ~S" v))
+ (dolist (n (leaf-refs v))
+ (check-node-reached n))
+ (when (basic-var-p v)
+ (dolist (n (basic-var-sets v))
+ (check-node-reached n))))
+ *free-vars*)
+
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (unless (constant-p v)
+ (barf "strange *CONSTANTS* entry: ~S" v))
+ (dolist (n (leaf-refs v))
+ (check-node-reached n)))
*constants*)
- (maphash #'(lambda (k v)
- (declare (ignore k))
- (unless (or (functional-p v)
- (and (global-var-p v)
- (eq (global-var-kind v) :global-function)))
- (barf "strange *FREE-FUNCTIONS* entry: ~S" v))
- (dolist (n (leaf-refs v))
- (check-node-reached n)))
- *free-functions*)
- (clrhash *seen-functions*)
+ (maphash (lambda (k v)
+ (declare (ignore k))
+ (unless (or (functional-p v)
+ (and (global-var-p v)
+ (eq (global-var-kind v) :global-function)))
+ (barf "strange *FREE-FUNS* entry: ~S" v))
+ (dolist (n (leaf-refs v))
+ (check-node-reached n)))
+ *free-funs*)
+ (clrhash *seen-funs*)
(clrhash *seen-blocks*)
(values))
\f
(defun observe-functional (x)
(declare (type functional x))
- (when (gethash x *seen-functions*)
+ (when (gethash x *seen-funs*)
(barf "~S was seen more than once." x))
(unless (eq (functional-kind x) :deleted)
- (setf (gethash x *seen-functions*) t)))
+ (setf (gethash x *seen-funs*) t)))
;;; Check that the specified function has been seen.
-(defun check-function-reached (fun where)
+(defun check-fun-reached (fun where)
(declare (type functional fun))
- (unless (gethash fun *seen-functions*)
+ (unless (gethash fun *seen-funs*)
(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.
-(defun check-function-stuff (functional)
+;;; 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-fun-stuff (functional)
(ecase (functional-kind functional)
(:external
- (let ((fun (functional-entry-function functional)))
- (check-function-reached fun functional)
+ (let ((fun (functional-entry-fun functional)))
+ (check-fun-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)
+ ((: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))
(unless (member functional (lambda-lets (lambda-home functional)))
(barf "The LET ~S is not in LETs for HOME." functional))
(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)
+ (check-fun-reached ef functional)
(unless (or (member functional (optional-dispatch-entry-points ef))
(eq functional (optional-dispatch-more-entry ef))
(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)
+ (check-fun-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)))
+ (return-from check-fun-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)
(barf "The home in ~S is not ~S." fun functional))
- (check-function-reached fun functional))
+ (check-fun-reached fun functional))
(unless (eq (lambda-home functional) functional)
(barf "home not self-pointer in ~S" functional)))))
(barf "HOME in ~S should be ~S." var functional))))
(optional-dispatch
(dolist (ep (optional-dispatch-entry-points functional))
- (check-function-reached ep functional))
+ (check-fun-reached ep functional))
(let ((more (optional-dispatch-more-entry functional)))
- (when more (check-function-reached more functional)))
- (check-function-reached (optional-dispatch-main-entry functional)
- functional))))
+ (when more (check-fun-reached more functional)))
+ (check-fun-reached (optional-dispatch-main-entry functional)
+ functional))))
-(defun check-function-consistency (components)
+(defun check-fun-consistency (components)
(dolist (c components)
- (dolist (fun (component-new-functions c))
- (observe-functional fun))
+ (dolist (new-fun (component-new-functionals 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)
(observe-functional let))))
(dolist (c components)
- (dolist (fun (component-new-functions c))
- (check-function-stuff fun))
+ (dolist (new-fun (component-new-functionals c))
+ (check-fun-stuff new-fun))
(dolist (fun (component-lambdas c))
(when (eq (functional-kind fun) :deleted)
(barf "deleted lambda ~S in Lambdas for ~S" fun c))
- (check-function-stuff fun)
+ (check-fun-stuff fun)
(dolist (let (lambda-lets fun))
- (check-function-stuff let)))))
+ (check-fun-stuff let)))))
\f
;;;; loop consistency checking
|#
-;;; Check a block for consistency at the general flow-graph level, and call
-;;; Check-Node-Consistency on each node to locally check for semantic
-;;; consistency.
+;;; Check a block for consistency at the general flow-graph level, and
+;;; call CHECK-NODE-CONSISTENCY on each node to locally check for
+;;; semantic consistency.
(declaim (ftype (function (cblock) (values)) check-block-consistency))
(defun check-block-consistency (block)
(this-cont (block-start block))
(last (block-last block)))
(unless fun-deleted
- (check-function-reached fun block))
+ (check-fun-reached fun block))
(when (not this-cont)
(barf "~S has no START." block))
(when (not last)
(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))
(unless fun-deleted
(check-node-consistency node))
-
+
(let ((cont (node-cont node)))
(when (not cont)
(barf "~S has no CONT." node))
(unless (eq (continuation-use cont) node)
(barf "USE in ~S should be ~S." cont node))
(setq this-cont cont))))
-
+
(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)
\f
;;;; node consistency checking
-;;; 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))
+;;; Check that the DEST for CONT is the specified NODE. We also mark
+;;; the block CONT is in as SEEN.
+#+nil(declaim (ftype (function (continuation node) (values)) check-dest))
(defun check-dest (cont node)
(let ((kind (continuation-kind cont)))
(ecase kind
(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 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)))))
+ (check-fun-reached leaf node)))))
(basic-combination
(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
- (let ((fun (ref-leaf (continuation-use
- (basic-combination-fun node))))
- (pos (position arg (basic-combination-args node))))
- (check-type pos fixnum) ; to suppress warning -- WHN 19990311
- (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)
(barf "IF not at block end: ~S" node)))
(cset
(check-dest (set-value node) node))
+ (cast
+ (check-dest (cast-value node) node))
(bind
- (check-function-reached (bind-lambda node) node))
+ (check-fun-reached (bind-lambda node) node))
(creturn
- (check-function-reached (return-lambda node) node)
+ (check-fun-reached (return-lambda node) node)
(check-dest (return-result node) node)
(unless (eq (block-last (node-block node)) node)
(barf "RETURN not at block end: ~S" node)))
\f
;;;; 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))
(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))
(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)
(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)
(atypes (template-arg-types info))
(rtypes (template-result-types info)))
(check-tn-refs (vop-args vop) vop nil
- (count-if-not #'(lambda (x)
- (and (consp x)
- (eq (car x) :constant)))
+ (count-if-not (lambda (x)
+ (and (consp x)
+ (eq (car x) :constant)))
atypes)
(template-more-args-type info) "args")
(check-tn-refs (vop-results vop) vop t
(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)
((: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
(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))
(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))
((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)
(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
(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)))
(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)))
+ (global-conflicts-next-blockwise conf)))
((null conf))
(let ((tn (global-conflicts-tn conf)))
(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)
\f
;;;; data structure dumping routines
-;;; When we print Continuations and TNs, we assign them small numeric IDs so
-;;; that we can get a handle on anonymous objects given a printout.
-(macrolet ((def-frob (counter vto vfrom fto ffrom)
+;;; When we print CONTINUATIONs and TNs, we assign them small numeric
+;;; IDs so that we can get a handle on anonymous objects given a
+;;; printout.
+;;;
+;;; FIXME:
+;;; * Perhaps this machinery should be #!+SB-SHOW.
+;;; * Probably the hash tables should either be weak hash tables,
+;;; or only allocated within a single compilation unit. Otherwise
+;;; there will be a tendency for them to grow without bound and
+;;; 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)
(let ((num (incf ,counter)))
(setf (gethash num ,vfrom) x)
(setf (gethash x ,vto) num))))
-
+
(defun ,ffrom (num)
(values (gethash num ,vfrom))))))
- (def-frob *continuation-number* *continuation-numbers* *number-continuations* cont-num num-cont)
- (def-frob *tn-id* *tn-ids* *id-tns* tn-id id-tn)
- (def-frob *label-id* *id-labels* *label-ids* label-id id-label))
+ (def *continuation-number* *continuation-numbers* *number-continuations*
+ cont-num num-cont)
+ (def *tn-id* *tn-ids* *id-tns* tn-id id-tn)
+ (def *label-id* *id-labels* *label-ids* label-id id-label))
-;;; Print out a terse one-line description of a leaf.
+;;; Print a terse one-line description of LEAF.
(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
- (assert (eq (functional-kind leaf) :top-level-xep))
- (format stream "TL-XEP ~S"
- (let ((info (leaf-info leaf)))
- (etypecase info
- (entry-info (entry-info-name info))
- (byte-lambda-info :byte-compiled-entry)))))))
+ (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)
(ir2-block (ir2-block-block thing))
(vop (block-or-lose (vop-block thing)))
(tn-ref (block-or-lose (tn-ref-vop thing)))
- (continuation (continuation-block thing))
+ (ctran (ctran-block thing))
(node (node-block thing))
(component (component-head thing))
#| (cloop (loop-head thing))|#
- (integer (continuation-block (num-cont thing)))
- (functional (node-block (lambda-bind (main-entry thing))))
+ (integer (ctran-block (num-cont thing)))
+ (functional (lambda-block (main-entry thing)))
(null (error "Bad thing: ~S." thing))
- (symbol (block-or-lose (gethash thing *free-functions*)))))
+ (symbol (block-or-lose (gethash thing *free-funs*)))))
;;; Print cN.
(defun print-continuation (cont)
(format t " c~D" (cont-num cont))
(values))
-;;; Print out the nodes in Block in a format oriented toward representing
-;;; what the code does.
+(defun print-ctran (cont)
+ (declare (type ctran cont))
+ (format t "c~D " (cont-num cont))
+ (values))
+(defun print-lvar (cont)
+ (declare (type lvar cont))
+ (format t "v~D " (cont-num cont))
+ (values))
+
+;;; 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)))
-
- (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 (function-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 " <none>")))))
- (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 <no value>"))
- (t
- (format t "exit <degenerate>"))))))
- (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 " <deleted>"))
+
+ (pprint-newline :mandatory)
+ (do ((ctran (block-start block) (node-next (ctran-next ctran))))
+ ((not ctran))
+ (let ((node (ctran-next ctran)))
+ (format t "~:[ ~;~:*~3D:~] "
+ (when (and (valued-node-p node) (node-lvar node))
+ (cont-num (node-lvar node))))
+ (etypecase node
+ (ref (print-leaf (ref-leaf node)))
+ (basic-combination
+ (let ((kind (basic-combination-kind node)))
+ (format t "~(~A~A ~A~) "
+ (if (node-tail-p node) "tail " "")
+ (if (fun-info-p kind) "known" kind)
+ (type-of node))
+ (print-lvar (basic-combination-fun node))
+ (dolist (arg (basic-combination-args node))
+ (if arg
+ (print-lvar arg)
+ (format t "<none> ")))))
+ (cset
+ (write-string "set ")
+ (print-leaf (set-var node))
+ (write-char #\space)
+ (print-lvar (set-value node)))
+ (cif
+ (write-string "if ")
+ (print-lvar (if-test node))
+ (print-ctran (block-start (if-consequent node)))
+ (print-ctran (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
+ (write-string "return ")
+ (print-lvar (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 ")
+ (print-lvar value))
+ ((exit-entry node)
+ (format t "exit <no value>"))
+ (t
+ (format t "exit <degenerate>")))))
+ (cast
+ (let ((value (cast-value node)))
+ (format t "cast v~D ~A[~S -> ~S]" (cont-num value)
+ (if (cast-%type-check node) #\+ #\-)
+ (cast-type-to-check node)
+ (cast-asserted-type node)))))
+ (pprint-newline :mandatory)))
+
+ (let ((succ (block-succ block)))
+ (format t "successors~{ c~D~}~%"
+ (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
(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)
(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)
(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 "<overflow>~%")))
-
- (do ((vop (ir2-block-start-vop block)
- (vop-next vop))
- (number 0 (1+ number)))
- ((null vop))
- (format t "~D: " 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 "<overflow>~:@_")))
-;;; Like Print-Nodes, but dumps the IR2 representation of the code in Block.
+ (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.
(defun print-vops (block)
(setq block (block-or-lose block))
(let ((2block (block-info block)))
(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 successor
-;;; links.
+;;; Do a PRINT-NODES on BLOCK and all blocks reachable from it by
+;;; successor links.
(defun print-blocks (block)
(setq block (block-or-lose block))
(do-blocks (block (block-component block) :both)
(walk block))
(values))
-;;; Print all blocks in Block's component in DFO.
+;;; Print all blocks in BLOCK's component in DFO.
(defun print-all-blocks (thing)
(do-blocks (block (block-component (block-or-lose thing)))
(handler-case (print-nodes block)
(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)))
(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)))
;;; Make a list out of all of the recorded conflicts.
(defun listify-conflicts-table ()
(collect ((res))
- (maphash #'(lambda (k v)
- (declare (ignore v))
- (when k
- (res k)))
+ (maphash (lambda (k v)
+ (declare (ignore v))
+ (when k
+ (res k)))
*list-conflicts-table*)
(clrhash *list-conflicts-table*)
(res)))
+;;; Return a list of a the TNs that conflict with TN. Sort of, kind
+;;; of. For debugging use only. Probably doesn't work on :COMPONENT TNs.
(defun list-conflicts (tn)
- #!+sb-doc
- "Return a list of a the TNs that conflict with TN. Sort of, kind of. For
- debugging use only. Probably doesn't work on :COMPONENT TNs."
- (assert (member (tn-kind tn) '(:normal :environment :debug-environment)))
+ (aver (member (tn-kind tn) '(:normal :environment :debug-environment)))
(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 ~D kind ~S>~%"
+ (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)
(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))
(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)))
projects / sbcl.git / blobdiff