From f55a55ef8b80aee7291424c65affd4f5bdd63db1 Mon Sep 17 00:00:00 2001
From: Joe Marshall <jmarshall@alum.mit.edu>
Date: Wed, 24 Feb 2010 18:46:22 -0800
Subject: [PATCH] Elide double negatives in combinations.

---
 src/sf/object.scm | 97 ++++++++++++++++++++++++++++++++++++++++-------
 src/sf/sf.pkg     |  3 +-
 src/sf/subst.scm  | 33 ++++++++++------
 3 files changed, 106 insertions(+), 27 deletions(-)

diff --git a/src/sf/object.scm b/src/sf/object.scm
index 065a3e69e..26b5a10e1 100644
--- a/src/sf/object.scm
+++ b/src/sf/object.scm
@@ -219,17 +219,74 @@ USA.
 (define-simple-type the-environment #f                 (block))
 
 ;;; Helpers for expressions
-(define-integrable (global-ref/make name)
-  (access/make #f
-	       (constant/make #f system-global-environment)
-	       name))
 
-(define (global-ref? object)
-  (and (access? object)
-       (constant? (access/environment object))
-       (eq? system-global-environment
-	    (constant/value (access/environment object)))
-       (access/name object)))
+;; T if expression can be shown to return only #T or #F.
+(define (expression/boolean? expression)
+  (cond ((expression/call-to-boolean-predicate? expression))
+	((conditional? expression) (and (expression/boolean? (conditional/consequent expression))
+					(expression/boolean? (conditional/alternative expression))))
+	((constant? expression) (or (not (constant/value expression))
+				    (eq? (constant/value expression) #t)))
+	((declaration? expression) (expression/boolean? (declaration/expression expression)))
+	((disjunction? expression) (and (expression/boolean? (disjunction/predicate expression))
+					(expression/boolean? (conditional/alternative expression))))
+	((sequence? expression) (expression/boolean? (last (sequence/actions expression))))
+	(else #f)))
+
+(define primitive-boolean-predicates
+  (map (lambda (name)
+	 (make-primitive-procedure name #t))
+       '(
+	 %RECORD?
+	 &<
+	 &=
+	 &>
+	 BIT-STRING?
+	 CELL?
+	 CHAR-ASCII?
+	 CHAR?
+	 EQ?
+	 EQUAL-FIXNUM?
+	 FIXNUM?
+	 FLONUM-EQUAL?
+	 FLONUM-GREATER?
+	 FLONUM-LESS?
+	 FLONUM-NEGATIVE?
+	 FLONUM-POSITIVE?
+	 FLONUM-ZERO?
+	 FLONUM?
+	 GREATER-THAN-FIXNUM?
+	 INDEX-FIXNUM?
+	 INTEGER-EQUAL?
+	 INTEGER-GREATER?
+	 INTEGER-LESS?
+	 INTEGER-NEGATIVE?
+	 INTEGER-POSITIVE?
+	 INTEGER-ZERO?
+	 LESS-THAN-FIXNUM?
+	 NEGATIVE-FIXNUM?
+	 NEGATIVE?
+	 NOT
+	 NULL?
+	 OBJECT-TYPE?
+	 PAIR?
+	 POSITIVE-FIXNUM?
+	 POSITIVE?
+	 STRING?
+	 VECTOR?
+	 ZERO-FIXNUM?
+	 ZERO?
+	 )))
+
+(define (expression/call-to-boolean-predicate? expression)
+  (and (combination? expression)
+       (let ((operator (combination/operator expression)))
+	 (and (constant? operator)
+	      (let ((operator-value (constant/value operator)))
+		(and (memq operator-value primitive-boolean-predicates)
+		     (procedure-arity-valid? 
+		      operator-value
+		      (length (combination/operands expression)))))))))
 
 (define (expression/call-to-not? expression)
   (and (combination? expression)
@@ -241,6 +298,20 @@ USA.
 		      operator-value
 		      (length (combination/operands expression)))))))))
 
+(define (expression/constant-eq? expression value)
+  (and (constant? expression)
+       (eq? (constant/value expression) value)))
+
+(define-integrable (global-ref/make name)
+  (access/make #f
+	       (constant/make #f system-global-environment)
+	       name))
+
+(define (global-ref? object)
+  (and (access? object)
+       (expression/constant-eq? (access/environment object) system-global-environment)
+       (access/name object)))
+
 ;;; Constructors that need to do work.
 
 (define (combination/%make scode block operator operands)
@@ -441,8 +512,7 @@ USA.
 
 	;; (if (if e1 e2 #f) <expr> K) => (if e1 (if e2 <expr> K) K)
 	((and (conditional? predicate)
-	      (constant? (conditional/alternative predicate))
-	      (not (constant/value (conditional/alternative predicate)))
+	      (expression/constant-eq? (conditional/alternative predicate) #f)
 	      (constant? alternative)
 	      (noisy-test sf:enable-conjunction-linearization? "Conjunction linearization"))
 	 (conditional/make scode
@@ -481,8 +551,7 @@ USA.
 	     alternative))
 
 	;; (or (foo) #f) => (foo)
-	((and (constant? alternative)
-	      (not (constant/value alternative))
+	((and (expression/constant-eq? alternative #f)
 	      (noisy-test sf:enable-disjunction-simplification? "Simplify disjunction"))
 	 predicate)
 
diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg
index dd9a86c6f..87d055580 100644
--- a/src/sf/sf.pkg
+++ b/src/sf/sf.pkg
@@ -91,7 +91,8 @@ USA.
   (files "subst")
   (parent (scode-optimizer))
   (export ()
-	  sf:display-top-level-procedure-names?)
+	  sf:display-top-level-procedure-names?
+	  sf:enable-elide-double-negatives?)
   (export (scode-optimizer)
 	  integrate/top-level
 	  integrate/get-top-level-block
diff --git a/src/sf/subst.scm b/src/sf/subst.scm
index 44ac901cf..65838068d 100644
--- a/src/sf/subst.scm
+++ b/src/sf/subst.scm
@@ -456,20 +456,29 @@ USA.
     (integrate-combination/default expression operations environment block operator operands)))
 
 ;;; constant-operator
+(define sf:enable-elide-double-negatives? #t)
+
 (define-method/integrate-combination 'CONSTANT
   (lambda (expression operations environment block operator operands)
-    (if (primitive-procedure? (constant/value operator))
-	(let ((operands*
-	       (and (eq? (constant/value operator) (ucode-primitive apply))
-		    (integrate/hack-apply? operands))))
-	  (if operands*
-	      (integrate/combination expression operations environment
-				     block (car operands*) (cdr operands*))
-	      (integrate/primitive-operator expression operations environment
-					    block operator operands)))
-	(begin
-	  (warn "Application of constant value" (constant/value operator))
-	  (integrate-combination/default expression operations environment block operator operands)))))
+    ;; Elide a double negative only if it doesn't change the type of the answer.
+    (cond ((and (expression/constant-eq? operator (ucode-primitive not))
+		(length=? operands 1)
+		(expression/call-to-not? (first operands))
+		(expression/boolean? (first (combination/operands (first operands))))
+		(noisy-test sf:enable-elide-double-negatives? "elide double negative"))
+	   (first (combination/operands (first operands))))
+	  ((primitive-procedure? (constant/value operator))
+	   (let ((operands*
+		  (and (eq? (constant/value operator) (ucode-primitive apply))
+		       (integrate/hack-apply? operands))))
+	     (if operands*
+		 (integrate/combination expression operations environment
+					block (car operands*) (cdr operands*))
+		 (integrate/primitive-operator expression operations environment
+					       block operator operands))))
+	  (else
+	   (warn "Application of constant value" (constant/value operator))
+	   (integrate-combination/default expression operations environment block operator operands)))))
 
 (define (integrate/primitive-operator expression operations environment
 				      block operator operands)
-- 
2.25.1