Move conditional and disjunction folding and inversion to subst.scm

diff --git a/src/sf/object.scm b/src/sf/object.scm
index 131863b81c2a8aca662c0622a6e0187ff2009269..92a9a7c25fe6dc860d41c8c16b45ee81ff784f93 100644 (file)
--- a/src/sf/object.scm
+++ b/src/sf/object.scm
@@ -705,37 +705,16 @@ USA.
 
 ;;; Conditional
 (define sf:enable-conditional->disjunction? #t)
-(define sf:enable-conditional-folding? #t)
-(define sf:enable-conditional-inversion? #t)
 (define sf:enable-conjunction-linearization? #t)
 (define sf:enable-disjunction-distribution? #t)
 
 (define (conditional/make scode predicate consequent alternative)
-  (cond ((and (expression/never-false? predicate)
-             (noisy-test sf:enable-conditional-folding? "Fold constant true conditional"))
-        (if (expression/effect-free? predicate)
-            consequent
-            (sequence/make scode (list predicate consequent))))
-
-       ((and (expression/always-false? predicate)
-             (noisy-test sf:enable-conditional-folding? "Fold constant false conditional"))
-        (if (expression/effect-free? predicate)
-            alternative
-            (sequence/make scode (list predicate alternative))))
-
-       ((and (expression/unspecific? predicate)
+  (cond ((and (expression/unspecific? predicate)
              (noisy-test sf:enable-conditional-folding? "Fold constant unspecific conditional"))
         (if (expression/effect-free? predicate)
             alternative
             (sequence/make scode (list predicate alternative))))
 
-       ;; (if (not e) c a) => (if e a c)
-       ((and (expression/call-to-not? predicate)
-             (noisy-test sf:enable-conditional-inversion? "Conditional inversion"))
-        (conditional/make scode (first (combination/operands predicate))
-                          alternative
-                          consequent))
-
        ;; (if foo foo ...) => (or foo ...)
        ((and (reference? predicate)
              (reference? consequent)
@@ -773,36 +752,16 @@ USA.
         (conditional/%make scode predicate consequent alternative))))
 
 ;;; Disjunction
-(define sf:enable-disjunction-folding? #t)
-(define sf:enable-disjunction-inversion? #t)
 (define sf:enable-disjunction-linearization?  #t)
 (define sf:enable-disjunction-simplification? #t)
 
 (define (disjunction/make scode predicate alternative)
-  (cond ((and (expression/never-false? predicate)
-             (noisy-test sf:enable-disjunction-folding? "Fold constant true disjunction"))
-        predicate)
-
-       ((and (expression/always-false? predicate)
-             (noisy-test sf:enable-disjunction-folding? "Fold constant false disjunction"))
-        (if (expression/effect-free? predicate)
-            alternative
-            (sequence/make scode (list predicate alternative))))
-
-       ;; (or (foo) #f) => (foo)
-       ((and (expression/always-false? alternative)
+  (cond ((and (expression/always-false? alternative)
              (expression/effect-free? alternative)
              (noisy-test sf:enable-disjunction-simplification? "Simplify disjunction"))
+        ;; (or (foo) #f) => (foo)
         predicate)
 
-       ;; (or (not e1) e2) => (if e1 e2 #t)
-       ((and (expression/call-to-not? predicate)
-             (noisy-test sf:enable-disjunction-inversion? "Disjunction inversion"))
-        (conditional/make scode
-                          (first (combination/operands predicate))
-                          alternative
-                          (constant/make #f #t)))
-
        ;; Linearize complex disjunctions
        ((and (disjunction? predicate)
              (noisy-test sf:enable-disjunction-linearization? "Linearize disjunction"))

diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg
index f9fe37efa20a9694fc7f30b3f20fe62e3c82a1af..d5aab376e4b31f5772dcd664ec06a98af4fcfc37 100644 (file)
--- a/src/sf/sf.pkg
+++ b/src/sf/sf.pkg
@@ -40,13 +40,9 @@ USA.
   (export ()
          sf:enable-argument-deletion?
          sf:enable-conditional->disjunction?
-         sf:enable-conditional-folding?
-         sf:enable-conditional-inversion?
          sf:enable-conjunction-linearization?
          sf:enable-constant-folding?
          sf:enable-disjunction-distribution?
-         sf:enable-disjunction-folding?
-         sf:enable-disjunction-inversion?
          sf:enable-disjunction-linearization?
          sf:enable-disjunction-simplification?
          sf:enable-distribute-primitives?))
@@ -91,6 +87,10 @@ USA.
   (parent (scode-optimizer))
   (export ()
          sf:display-top-level-procedure-names?
+         sf:enable-conditional-folding?
+         sf:enable-conditional-inversion?
+         sf:enable-disjunction-folding?
+         sf:enable-disjunction-inversion?
          sf:enable-elide-conditional-canonicalization?
          sf:enable-elide-double-negatives?)
   (export (scode-optimizer)

diff --git a/src/sf/subst.scm b/src/sf/subst.scm
index 1ecf124eed66862b21c9c073197d280de9cff9a6..04fa108d2f5b363bf8d68b36672fd8df8a7675cc 100644 (file)
--- a/src/sf/subst.scm
+++ b/src/sf/subst.scm
@@ -153,23 +153,56 @@ USA.
 
 (define-method/integrate 'CONDITIONAL
   (lambda (operations environment expression)
-    (let ((ipred (integrate/expression
-                 operations environment
-                 (conditional/predicate expression)))
-         (icons (integrate/expression
-                 operations environment
-                 (conditional/consequent expression)))
-         (ialt (integrate/expression
-                operations environment
-                (conditional/alternative expression))))
-      (cond ((and (expression/constant-eq? icons #t)
-                 (expression/constant-eq? ialt #f)
-                 (expression/boolean? ipred)
-                 (noisy-test sf:enable-elide-conditional-canonicalization?
-                             "elide conditional canonicalization"))
-            ipred)
-           (else
-            (conditional/make (conditional/scode expression) ipred icons ialt))))))
+    (integrate/conditional operations environment expression
+                          (integrate/expression
+                           operations environment
+                           (conditional/predicate expression))
+                          (conditional/consequent expression)
+                          (conditional/alternative expression))))
+
+(define sf:enable-conditional-folding? #t)
+(define sf:enable-conditional-inversion? #t)
+
+(define (integrate/conditional operations environment expression
+                              integrated-predicate
+                              consequent
+                              alternative)
+  (cond ((and (expression/never-false? integrated-predicate)
+             (noisy-test sf:enable-conditional-folding? "Fold constant true conditional"))
+        (let ((integrated-consequent (integrate/expression operations environment consequent)))
+          (if (expression/effect-free? integrated-predicate)
+              integrated-consequent
+              (sequence/make (and expression (conditional/scode expression))
+                             (list integrated-predicate integrated-consequent)))))
+
+       ((and (expression/always-false? integrated-predicate)
+             (noisy-test sf:enable-conditional-folding? "Fold constant false conditional"))
+        (let ((integrated-alternative (integrate/expression operations environment alternative)))
+          (if (expression/effect-free? integrated-predicate)
+              integrated-alternative
+              (sequence/make (and expression (conditional/scode expression))
+                             (list integrated-predicate integrated-alternative)))))
+
+       ((and (expression/call-to-not? integrated-predicate)
+             (noisy-test sf:enable-conditional-inversion? "Invert conditional"))
+        (integrate/conditional operations environment expression
+                               (first (combination/operands integrated-predicate))
+                               alternative consequent))
+
+       (else (let ((icons (integrate/expression
+                           operations environment
+                           consequent))
+                   (ialt (integrate/expression
+                          operations environment
+                          alternative)))
+               (cond ((and (expression/constant-eq? icons #t)
+                           (expression/constant-eq? ialt #f)
+                           (expression/boolean? integrated-predicate)
+                           (noisy-test sf:enable-elide-conditional-canonicalization?
+                                       "elide conditional canonicalization"))
+                      integrated-predicate)
+                     (else
+                      (conditional/make (and expression (conditional/scode expression)) integrated-predicate icons ialt)))))))
 
 ;;; CONSTANT
 (define-method/integrate 'CONSTANT
@@ -201,10 +234,45 @@ USA.
 ;;; DISJUNCTION
 (define-method/integrate 'DISJUNCTION
   (lambda (operations environment expression)
-    (disjunction/make
-     (disjunction/scode expression)
-     (integrate/expression operations environment (disjunction/predicate expression))
-     (integrate/expression operations environment (disjunction/alternative expression)))))
+    (integrate/disjunction
+     operations environment expression
+     (integrate/expression
+      operations environment (disjunction/predicate expression))
+     (disjunction/alternative expression))))
+
+(define sf:enable-disjunction-folding? #t)
+(define sf:enable-disjunction-inversion? #t)
+
+(define (integrate/disjunction operations environment expression
+                              integrated-predicate alternative)
+  ;; Predicate has been integrated, but alternative has not.
+  ;; We can use information from the predicate to help in
+  ;; integrating the alternative.
+  (cond ((and (expression/never-false? integrated-predicate)
+             (noisy-test sf:enable-disjunction-folding? "Fold constant true disjunction"))
+        predicate)
+
+       ((and (expression/always-false? integrated-predicate)
+             (noisy-test sf:enable-disjunction-folding? "Fold constant false disjunction"))
+        (let ((integrated-alternative (integrate/expression operations environment alternative)))
+          (if (expression/effect-free? integrated-predicate)
+              integrated-alternative
+              (sequence/make (and expression (object/scode expression))
+                             (list integrated-predicate
+                                   integrated-alternative)))))
+
+       ;; (or (not e1) e2) => (if e1 e2 #t)
+       ((and (expression/call-to-not? integrated-predicate)
+             (noisy-test sf:enable-disjunction-inversion? "Invert disjunction"))
+        (integrate/conditional operations environment expression
+                               (first (combination/operands integrated-predicate))
+                               alternative
+                               (constant/make #f #t)))
+
+       (else
+        (disjunction/make (and expression (object/scode expression))
+                          integrated-predicate
+                          (integrate/expression operations environment alternative)))))
 
 ;;; OPEN-BLOCK
 (define-method/integrate 'OPEN-BLOCK
@@ -349,6 +417,12 @@ USA.
        (not (variable/may-ignore? variable))
        (not (variable/must-ignore? variable))))
 
+(define (variable/safely-integrable? variable operations)
+  (guarantee-variable variable 'variable/safely-integrable?)
+  (and (not (variable/side-effected variable))
+       (block/safe? (variable/block variable))
+       (operations/lookup operations variable false-procedure true-procedure)))
+
 (define (integrate/procedure operations environment procedure)
   (let ((block (procedure/block procedure))
        (name  (procedure/name procedure))