Add hooks to generate debugging info about constraints.

diff --git a/v7/src/compiler/fgopt/closan.scm b/v7/src/compiler/fgopt/closan.scm
index a88939b81f16a59fa4a628ecbe564a758c16c151..e0e9f637f1b9c61cc8e9b0be8efe10d7b3892c2f 100644 (file)
--- a/v7/src/compiler/fgopt/closan.scm
+++ b/v7/src/compiler/fgopt/closan.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: closan.scm,v 4.21 2001/11/01 18:42:59 cph Exp $
+$Id: closan.scm,v 4.22 2001/11/01 21:29:00 cph Exp $
 
 Copyright (c) 1987-1991, 1998, 1999, 2001 Massachusetts Institute of Technology
 
@@ -319,6 +319,11 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
 \f
 (define *undrifting-constraints*)
 
+(define debug-constraints? #f)
+(define (debug-constraints key block block* condition)
+  (if debug-constraints?
+      (write-line (list key block block* condition))))
+
 (define (undrifting-constraint! block block* procedure reason1 reason2)
   ;; Undrift `block' so it is a descendant of `block*' in order not
   ;; to close `procedure' for <`reason1',`reason2'>
@@ -335,6 +340,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
                   (loop (block-parent block))
                   block)))
            (condition (and procedure (list procedure reason1 reason2))))
+       (debug-constraints 'ADD block block* condition)
        (let ((entry (assq block *undrifting-constraints*))
              (generate-caller-constraints
               (lambda ()
@@ -376,7 +382,14 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
          (set-cdr! entry*
                    (list-transform-negative! (cdr entry*)
                      (lambda (condition)
-                       (and condition (eq? procedure (car condition)))))))
+                       (and condition
+                            (eq? procedure (car condition))
+                            (begin
+                              (debug-constraints 'REMOVE
+                                                 (car entry)
+                                                 (car entry*)
+                                                 condition)
+                              #t))))))
        (cdr entry))
        (if (there-exists? (cdr entry)
             (lambda (entry*)