0.pre7.117:

	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.)

src/code/ntrace.lisp

@@ -203,7 +203,7 @@
   (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)

src/compiler/debug.lisp

@@ -65,16 +65,17 @@
     (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*)
@@ -409,7 +410,7 @@
     (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)
@@ -455,8 +456,8 @@
 
 ;;;; 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)))
@@ -475,8 +476,8 @@
 	 (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

src/compiler/entry.lisp

@@ -96,7 +96,7 @@
 		  (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)

src/compiler/ir1final.lisp

@@ -102,7 +102,7 @@
     (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)))))

src/compiler/ir1opt.lisp

@@ -347,7 +347,7 @@
 		 ;; 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)
@@ -548,13 +548,13 @@
 	(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
@@ -1276,11 +1276,10 @@
 			 (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)))

src/compiler/ir1tran.lisp

@@ -485,12 +485,21 @@
        (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

src/compiler/ir1util.lisp

@@ -247,6 +247,9 @@
 (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))))

src/compiler/locall.lisp

@@ -190,7 +190,8 @@
 	    (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))
@@ -284,6 +285,12 @@
 		      ;; 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
@@ -297,6 +304,7 @@
 		      ;; 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)))))
@@ -760,7 +768,7 @@
 
   (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)))

src/compiler/macros.lisp

@@ -685,7 +685,7 @@
       #'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*)

src/compiler/main.lisp

@@ -327,21 +327,20 @@
 	(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)
@@ -457,13 +456,27 @@
       (: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)))
@@ -527,7 +540,7 @@
 				    (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*))
@@ -1218,9 +1231,7 @@
     (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)

src/compiler/node.lisp

@@ -208,7 +208,7 @@
 ;;;    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
@@ -222,6 +222,8 @@
 (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))))

version.lisp-expr

@@ -18,4 +18,4 @@
 ;;; 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"