Simply disjunction integration by moving disjunction construction logic to object.scm

diff --git a/src/sf/object.scm b/src/sf/object.scm
index fc4226a5466e773439c2da18c464156fa776024c..633cf885b7e8c7b41d9056a5a0beb87b07003c14 100644 (file)
--- a/src/sf/object.scm
+++ b/src/sf/object.scm
@@ -234,8 +234,46 @@ USA.
 (define (conditional/make scode predicate consequent alternative)
   (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)
-  (disjunction/%make scode predicate alternative))
+  (cond ((and (constant? predicate)
+             (noisy-test sf:enable-disjunction-folding? "Fold constant disjunction"))
+        (if (constant/value predicate)
+            predicate
+            alternative))
+
+       ;; (or (foo) #f) => (foo)
+       ((and (constant? alternative)
+             (not (constant/value alternative))
+             (noisy-test sf:enable-disjunction-simplification? "Simplify disjunction"))
+        predicate)
+
+       ;; (or (not e1) e2) => (if e1 e2 #t)
+       ((and (combination? predicate)
+             (constant? (combination/operator predicate))
+             (eq? (constant/value (combination/operator predicate)) (ucode-primitive not))
+             (= (length (combination/operands predicate)) 1)
+             (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"))
+        (disjunction/make scode
+                          (disjunction/predicate predicate)
+                          (disjunction/make (object/scode predicate)
+                                            (disjunction/alternative predicate)
+                                            alternative)))
+       (else
+        (disjunction/%make scode predicate alternative))))
 
 ;; Done specially so we can tweak the print method.
 ;; This makes debugging an awful lot easier.
@@ -329,4 +367,24 @@ USA.
   (cdr integration-info))
 
 (define integration-info-tag
-  (string-copy "integration-info"))
\ No newline at end of file
+  (string-copy "integration-info"))
+\f
+;;; Returns #T if switch is not #F or 'warn.
+;;; Additionally, prints text if switch is not #T.
+;;; So set switch to #f to disable,
+;;; set it to 'warn to disable, but issue a warning upon testing,
+;;; set it to #t to enable,
+;;; or set it to something like 'ok to enable *and* print noise.
+
+;;; To use, make this the last clause in a test.
+(define (noisy-test switch text)
+  (and switch
+       (cond ((eq? switch 'warn)
+             (warn "Not performing possible action:" text)
+             #f)
+            ((not (eq? switch #t))
+             (newline)
+             (write-string "; ")
+             (write-string text)
+             #t)
+            (else #t))))

diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg
index 3c5c05beee1b1a2f87e092c2ac3b4abde4afbec7..c9049b6b8abf7a62d4c514df4bcd7e15aedb28a2 100644 (file)
--- a/src/sf/sf.pkg
+++ b/src/sf/sf.pkg
@@ -34,7 +34,12 @@ USA.
         "gconst"
         "usicon"
         "tables")
-  (parent ()))
+  (parent ())
+  (export ()
+         sf:enable-disjunction-folding?
+         sf:enable-disjunction-inversion?
+         sf:enable-disjunction-linearization?
+         sf:enable-disjunction-simplification?))
 
 (define-package (scode-optimizer global-imports)
   (files "gimprt")

diff --git a/src/sf/subst.scm b/src/sf/subst.scm
index 34175c1cc84c06f24f3bfc2e9a0593598c956c40..947737a88bdce9ebbf0d5e4d427fb35757f48c4c 100644 (file)
--- a/src/sf/subst.scm
+++ b/src/sf/subst.scm
@@ -541,21 +541,12 @@ USA.
               (conditional/make (conditional/scode expression)
                                 predicate consequent alternative)))))))
 
-;; Optimize (or #f a) => a; (or #t a) => #t
-
 (define-method/integrate 'DISJUNCTION
   (lambda (operations environment expression)
-    (let ((predicate (integrate/expression operations environment
-                                          (disjunction/predicate expression)))
-         (alternative (integrate/expression
-                       operations environment
-                       (disjunction/alternative expression))))
-      (if (constant? predicate)
-         (if (constant/value predicate)
-             predicate
-             alternative)
-         (disjunction/make (disjunction/scode expression)
-                           predicate alternative)))))
+    (disjunction/make 
+     (disjunction/scode expression)
+     (integrate/expression operations environment (disjunction/predicate expression))
+     (integrate/expression operations environment (disjunction/alternative expression)))))
 \f
 (define-method/integrate 'SEQUENCE
   (lambda (operations environment expression)