summary |
shortlog |
log |
commit | commitdiff |
tree
raw |
patch |
inline | side by side (from parent 1:
a0e89f9)
encapsulated (OR (COMPONENT-FOO ...) ...) idiom in IR1-PHASES
made TRACE :PRINT use pretty-printed line breaks to keep
indentation sane
added more checks related to bug 138, including restoring the
strength of the original LOCALL-ANALYZE-COMPONENT
assertion so that I'm back to debugging 138a again:-|
(It's too bad I didn't have the courage of my
convictions lo these many hours of debugging ago, to
keep my strong 138a assertion and immediately chase
back whatever weirdness causes it to fail, instead of
weakening it and painfully debugging the
consequences.)
12 files changed:
(dolist (ele forms)
(fresh-line)
(print-trace-indentation)
(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)
;;; Test a BREAK option, and break if true.
(defun trace-maybe-break (info break where frame)
(barf "~S was not reached." node))
(values))
(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*)
(declaim (ftype (function (list) (values)) check-ir1-consistency))
(defun check-ir1-consistency (components)
(clrhash *seen-blocks*)
(check-block-successors block))
(values))
(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)
;;; 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
\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)))
(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))
(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
(defun check-node-consistency (node)
(declare (type node node))
(etypecase node
(closure (physenv-closure
(lambda-physenv (main-entry ef)))))
(dolist (ref (leaf-refs lambda))
(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)
(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))))
(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)))))
(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
;; 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)
;; 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))
(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))
(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
;;; 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))
(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)
(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)))
t)
(t
(aver (lambda-toplevelish-p (lambda-home fun)))
(use-continuation res cont)))
(values)))
(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))
(defun maybe-reanalyze-fun (fun)
(declare (type functional fun))
(aver-live-component *current-component*)
(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*)))
(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
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-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))))
(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
(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))
(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)))
;; 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
((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))
;; 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)))))
(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))
(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)))
(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))
#'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*)
(*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 "))
(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)
(when (>= loop-count *reoptimize-after-type-check-max*)
(maybe-mumble "[reoptimize limit]")
(event reoptimize-maxed-out)
(:toplevel (return))
(:external
(unless (every (lambda (ref)
(: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)
(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)
(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)))
(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)
(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*))
(blast *free-variables*)
(blast *free-functions*)
(blast *constants*))
(flet ((loser (start)
(or (position-if (lambda (x)
(not (eq (component-kind
(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)
: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
;;; 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
;;; 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)
(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))))
(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".)
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)