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-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*)
(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))
(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))
(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))
(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)
(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)
(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))
(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.
+;;; 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)))
(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
(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))
(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))
(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))
(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)
(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))
(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*)))))
(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)))
(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
projects / sbcl.git / blobdiff