From: Joe Marshall Date: Thu, 25 Feb 2010 02:46:22 +0000 (-0800) Subject: Elide double negatives in combinations. X-Git-Tag: 20100708-Gtk~147 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f55a55ef8b80aee7291424c65affd4f5bdd63db1;p=mit-scheme.git Elide double negatives in combinations. --- 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) K) => (if e1 (if e2 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)