Elide double negatives in combinations.

diff --git a/src/sf/object.scm b/src/sf/object.scm
index 065a3e69ea3eb5b5e939b5e52e875a34ac129061..26b5a10e14e682c5c0e72435482ea2d5013a8105 100644 (file)
--- 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 dd9a86c6f6d4ea4589454b0c032c402bd460d7eb..87d055580918425a97bb89264db6d0e696679328 100644 (file)
--- 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 44ac901cf705881c0bef91b7fc7471b65237dc76..65838068ddbdbae6c61ea84ba763dba1570c26fe 100644 (file)
--- 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)