(dolist (ele forms)
(fresh-line)
(print-trace-indentation)
- (format t "~S = ~S" (car ele) (funcall (cdr ele) frame))))
+ (format t "~@<~S ~_= ~S~:>" (car ele) (funcall (cdr ele) frame))))
;;; Test a BREAK option, and break if true.
(defun trace-maybe-break (info break where frame)
(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*)
(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
(closure (physenv-closure
(lambda-physenv (main-entry ef)))))
(dolist (ref (leaf-refs lambda))
- (let ((ref-component (block-component (node-block ref))))
+ (let ((ref-component (node-component ref)))
(cond ((eq ref-component component))
((or (not (component-toplevelish-p ref-component))
closure)
(let ((atype (info :function :assumed-type name)))
(dolist (ref (leaf-refs var))
(let ((dest (continuation-dest (node-cont ref))))
- (when (and (eq (block-component (node-block ref)) component)
+ (when (and (eq (node-component ref) component)
(combination-p dest)
(eq (continuation-use (basic-combination-fun dest)) ref))
(setq atype (note-function-use dest atype)))))
;; If next-cont does have a dest, it must be
;; unreachable, since there are no uses.
;; DELETE-CONTINUATION will mark the dest block as
- ;; delete-p [and also this block, unless it is no
+ ;; DELETE-P [and also this block, unless it is no
;; longer backward reachable from the dest block.]
(delete-continuation next-cont)
(setf (node-prev next-node) last-cont)
(flush-dest test)
(when (rest (block-succ block))
(unlink-blocks block victim))
- (setf (component-reanalyze (block-component (node-block node))) t)
+ (setf (component-reanalyze (node-component node)) t)
(unlink-node node))))
(values))
-;;; Create a new copy of an IF Node that tests the value of the node
-;;; Use. The test must have >1 use, and must be immediately used by
-;;; Use. Node must be the only node in its block (implying that
+;;; Create a new copy of an IF node that tests the value of the node
+;;; USE. The test must have >1 use, and must be immediately used by
+;;; USE. NODE must be the only node in its block (implying that
;;; block-start = if-test).
;;;
;;; This optimization has an effect semantically similar to the
(values-subtypep (leaf-type leaf)
(continuation-asserted-type arg)))
(propagate-to-refs var (continuation-type arg))
- (let ((this-comp (block-component (node-block use))))
+ (let ((use-component (node-component use)))
(substitute-leaf-if
#'(lambda (ref)
- (cond ((eq (block-component (node-block ref))
- this-comp)
+ (cond ((eq (node-component ref) use-component)
t)
(t
(aver (lambda-toplevelish-p (lambda-home fun)))
(use-continuation res cont)))
(values)))
-;;; Add FUN to the COMPONENT-REANALYZE-FUNS. FUN is returned.
+;;; Add FUN to the COMPONENT-REANALYZE-FUNS, unless it's some
+;;; trivial type for which reanalysis is a trivial no-op. FUN is returned.
(defun maybe-reanalyze-fun (fun)
(declare (type functional fun))
+
(aver-live-component *current-component*)
+ (when (lambda-p fun) ; when it's easy to ask FUN its COMPONENT
+ ;; general sanity check, specifically related to bug 138
+ (aver (eql (lambda-component fun) *current-component*)))
+
+ ;; I *think* this means "unless FUN is of some type for which
+ ;; reanalysis is a no-op". -- WHN 2001-01-06
(when (typep fun '(or optional-dispatch clambda))
(pushnew fun (component-reanalyze-funs *current-component*)))
+
fun)
;;; Generate a REF node for LEAF, frobbing the LEAF structure as
(defun node-block (node)
(declare (type node node))
(the cblock (continuation-block (node-prev node))))
+(defun node-component (node)
+ (declare (type node node))
+ (block-component (node-block node)))
(defun node-physenv (node)
(declare (type node node))
(the physenv (lambda-physenv (node-home-lambda node))))
(component-reanalyze *current-component*) t
(component-reoptimize *current-component*) t)
(etypecase fun
- (clambda (locall-analyze-fun-1 fun))
+ (clambda
+ (locall-analyze-fun-1 fun))
(optional-dispatch
(dolist (ep (optional-dispatch-entry-points fun))
(locall-analyze-fun-1 ep))
;; FUN becomes part of COMPONENT-LAMBDAS now.
(aver (not (member fun (component-lambdas component))))
(push fun (component-lambdas component)))
+ ;; FIXME: Maybe we don't need this clause?
+ ;; The only time I really thought I needed it
+ ;; was bug 138, and adding this clause didn't
+ ;; fix bug 138 but instead caused all sorts
+ ;; of other things to fail downstream...
+ #|
((eql (lambda-inlinep fun) :inline)
;; FUNs marked :INLINE are sometimes in
;; COMPONENT-LAMBDAS and sometimes not. I (WHN
;; expansions of local functions might in
;; COMPONENT-LAMBDAS?)
(values))
+ |#
(t ; FUN is old.
;; FUN should be in COMPONENT-LAMBDAS already.
(aver (member fun (component-lambdas component)))))
(declare (type clambda clambda) (type basic-combination call))
- (let ((component (block-component (node-block call))))
+ (let ((component (node-component call)))
(unlink-blocks (component-head component) (lambda-block clambda))
(setf (component-lambdas component)
(delete clambda (component-lambdas component)))
#'closure-needing-ir1-environment-from-node)))
(defun %with-ir1-environment-from-node (node fun)
(declare (type node node) (type function fun))
- (let ((*current-component* (block-component (node-block node)))
+ (let ((*current-component* (node-component node))
(*lexenv* (node-lexenv node))
(*current-path* (node-source-path node)))
(aver-live-component *current-component*)
(constraint-propagate component))
(when (retry-delayed-ir1-transforms :constraint)
(maybe-mumble "Rtran "))
- ;; Delay the generation of type checks until the type
- ;; constraints have had time to propagate, else the compiler can
- ;; confuse itself.
- (unless (and (or (component-reoptimize component)
- (component-reanalyze component)
- (component-new-funs component)
- (component-reanalyze-funs component))
- (< loop-count (- *reoptimize-after-type-check-max* 4)))
- (maybe-mumble "type ")
- (generate-type-checks component)
- (unless (or (component-reoptimize component)
- (component-reanalyze component)
- (component-new-funs component)
- (component-reanalyze-funs component))
- (return)))
+ (flet ((want-reoptimization-p ()
+ (or (component-reoptimize component)
+ (component-reanalyze component)
+ (component-new-funs component)
+ (component-reanalyze-funs component))))
+ (unless (and (want-reoptimization-p)
+ ;; We delay the generation of type checks until
+ ;; the type constraints have had time to
+ ;; propagate, else the compiler can confuse itself.
+ (< loop-count (- *reoptimize-after-type-check-max* 4)))
+ (maybe-mumble "type ")
+ (generate-type-checks component)
+ (unless (want-reoptimization-p)
+ (return))))
(when (>= loop-count *reoptimize-after-type-check-max*)
(maybe-mumble "[reoptimize limit]")
(event reoptimize-maxed-out)
(:toplevel (return))
(:external
(unless (every (lambda (ref)
- (eq (block-component (node-block ref))
- component))
+ (eq (node-component ref) component))
(leaf-refs fun))
(return))))))
(defun compile-component (component)
+
+ ;; miscellaneous sanity checks
+ ;;
+ ;; FIXME: These are basically pretty wimpy compared to the checks done
+ ;; by the old CHECK-IR1-CONSISTENCY code. It would be really nice to
+ ;; make those internal consistency checks work again and use them.
(aver-live-component component)
+ (do-blocks (block component)
+ (aver (eql (block-component block) component)))
+ (dolist (lambda (component-lambdas component))
+ ;; sanity check to prevent weirdness from propagating insidiously as
+ ;; far from its root cause as it did in bug 138: Make sure that
+ ;; thing-to-COMPONENT links are consistent.
+ (aver (eql (lambda-component lambda) component))
+ (aver (eql (node-component (lambda-bind lambda)) component)))
+
(let* ((*component-being-compiled* component))
(when sb!xc:*compile-print*
(compiler-mumble "~&; compiling ~A: " (component-name component)))
(delete-if #'here-p (basic-var-sets v))))))
x))
(here-p (x)
- (eq (block-component (node-block x)) component)))
+ (eq (node-component x) component)))
(blast *free-variables*)
(blast *free-functions*)
(blast *constants*))
(flet ((loser (start)
(or (position-if (lambda (x)
(not (eq (component-kind
- (block-component
- (node-block
- (lambda-bind x))))
+ (node-component (lambda-bind x)))
:toplevel)))
lambdas
:start start)
;;; checking blocks we have already checked.
;;; -- DELETE-P is true when this block is used to indicate that this block
;;; has been determined to be unreachable and should be deleted. IR1
-;;; phases should not attempt to examine or modify blocks with DELETE-P
+;;; phases should not attempt to examine or modify blocks with DELETE-P
;;; set, since they may:
;;; - be in the process of being deleted, or
;;; - have no successors, or
(def-boolean-attribute block
reoptimize flush-p type-check delete-p type-asserted test-modified)
+;;; FIXME: Tweak so that definitions of e.g. BLOCK-DELETE-P is
+;;; findable by grep for 'def.*block-delete-p'.
(macrolet ((frob (slot)
`(defmacro ,(symbolicate "BLOCK-" slot) (block)
`(block-attributep (block-flags ,block) ,',slot))))
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.115"
+"0.pre7.117"
projects / sbcl.git / commitdiff