From: Joe Marshall <jmarshall@alum.mit.edu>
Date: Wed, 10 Feb 2010 01:08:18 +0000 (-0800)
Subject: Simply disjunction integration by moving disjunction construction logic to object.scm
X-Git-Tag: 20100708-Gtk~168^2~10
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=a3cecae083edea793e089ee7e141f5bfd9cad475;p=mit-scheme.git

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

diff --git a/src/sf/object.scm b/src/sf/object.scm
index fc4226a54..633cf885b 100644
--- 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"))
+
+;;; 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 3c5c05bee..c9049b6b8 100644
--- 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 34175c1cc..947737a88 100644
--- 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)))))
 
 (define-method/integrate 'SEQUENCE
   (lambda (operations environment expression)