;;; *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
+;;; *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-functions* (make-hash-table :test 'eq))
+(defvar *seen-funs* (make-hash-table :test 'eq))
;;; Barf if NODE is in a block which wasn't reached during the graph
;;; walk.
;;; 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*.
+;;; we also look at the *FREE-VARS*, *FREE-FUNS* and *CONSTANTS*.
;;;
;;; First we do a pre-pass which finds all the CBLOCKs and CLAMBDAs,
;;; testing that they are linked together properly and entering them
(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)))
|#
))
- (check-function-consistency components)
+ (check-fun-consistency components)
(dolist (c components)
(do ((block (block-next (component-head c)) (block-next block)))
(and (global-var-p v)
(member (global-var-kind v)
'(:global :special))))
- (barf "strange *FREE-VARIABLES* entry: ~S" v))
+ (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-variables*)
+ *free-vars*)
(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))
+ (barf "strange *FREE-FUNS* entry: ~S" v))
(dolist (n (leaf-refs v))
(check-node-reached n)))
- *free-functions*)
- (clrhash *seen-functions*)
+ *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 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)
+(defun check-fun-stuff (functional)
(ecase (functional-kind functional)
(:external
(let ((fun (functional-entry-fun functional)))
- (check-function-reached fun functional)
+ (check-fun-reached fun functional)
(when (functional-kind fun)
(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)
- (check-function-reached (lambda-home functional) functional)
+ (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)))
(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)))
((nil :escape :cleanup)
(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-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 :toplevel :escape :cleanup)
(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 (new-fun (component-new-funs c))
(observe-functional new-fun))
(dolist (c components)
(dolist (new-fun (component-new-funs c))
- (check-function-stuff new-fun))
+ (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
(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)
: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))
(cset
(check-dest (set-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)))
(integer (continuation-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)
(basic-combination
(let ((kind (basic-combination-kind node)))
(format t "~(~A ~A~) c~D"
- (if (function-info-p kind) "known" kind)
+ (if (fun-info-p kind) "known" kind)
(type-of node)
(cont-num (basic-combination-fun node)))
(dolist (arg (basic-combination-args node))
projects / sbcl.git / blobdiff