From: Joe Marshall Date: Tue, 2 Mar 2010 17:16:41 +0000 (-0800) Subject: Add some expression helpers. X-Git-Tag: 20100708-Gtk~141 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1ce62135cbb03c195c88ae3f6021547b3bbf9665;p=mit-scheme.git Add some expression helpers. --- diff --git a/src/sf/object.scm b/src/sf/object.scm index a4c32a2ab..818fffff7 100644 --- a/src/sf/object.scm +++ b/src/sf/object.scm @@ -220,19 +220,129 @@ USA. ;;; Helpers for expressions +;; True iff expression can be shown to always return #F. +;; That is, the expression counts as #f to a conditional. +(define (expression/always-false? expression) + (cond ((combination? expression) + (cond ((expression/call-to-not? expression) + (expression/never-false? (first (combination/operands expression)))) + ((procedure? (combination/operator expression)) + (expression/always-false? (procedure/body (combination/operator expression)))) + (else #f))) + + ((conditional? expression) + (and (or (expression/always-false? (conditional/predicate expression)) + (expression/always-false? (conditional/consequent expression))) + (or (expression/never-false? (conditional/predicate expression)) + (expression/always-false? (conditional/alternative expression))))) + + ((constant? expression) (not (constant/value expression))) + + ((declaration? expression) + (expression/always-false? (declaration/expression expression))) + + ((disjunction? expression) + (and (expression/always-false? (disjunction/predicate expression)) + (expression/always-false? (disjunction/alternative expression)))) + + ((sequence? expression) + (expression/always-false? (last (sequence/actions expression)))) + + (else #f))) + ;; 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)))) + + ((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))) + +;; True iff evaluation of expression has no side effects. +(define (expression/effect-free? expression) + (cond ((access? expression) + (expresssion/effect-free? (access/environment expresssion))) + + ((combination? expression) + (and (for-all? (combination/operands expression) expression/effect-free?) + (or (expression/call-to-effect-free-primitive? expression) + (and (procedure? (combination/operator expression)) + (expression/effect-free? (procedure/body (combination/operator expression))))))) + + ((conditional? expression) + (and (expression/effect-free? (conditional/predicate expression)) + (or (expression/always-false? (conditional/predicate expression)) + (expression/effect-free? (conditional/consequent expression))) + (or (expression/never-false? (conditional/predicate expression)) + (expression/effect-free? (conditional/alternative expression))))) + + ((constant? expression) #t) + + ((declaration? expression) + (expression/effect-free? (declaration/expression expression))) + + ((delay? expression) #t) + + ((disjunction? expression) + (and (expression/effect-free? (disjunction/predicate expression)) + (or (expression/never-false? (disjunction/predicate expression)) + (expression/effect-free? (disjunction/alternative expression))))) + + ((procedure? expression) #t) + + ((sequence? expression) + (for-all? (sequence/actions expression) expression/effect-free?)) + + ((reference? expression) #t) + + (else #f))) + +;; True iff expression can be shown to never return #F. +;; That is, the expression counts as #t to a conditional. +(define (expression/never-false? expression) + (cond ((combination? expression) + (cond ((expression/call-to-not? expression) + (expression/always-false? (first (combination/operands expression)))) + ((procedure? (combination/operator expression)) + (expression/never-false? (procedure/body (combination/operator expression)))) + (else #f))) + + ((conditional? expression) + (and (or (expression/always-false? (conditional/predicate expression)) + (expression/never-false? (conditional/consequent expression))) + (or (expression/never-false? (conditional/predicate expression)) + (expression/never-false? (conditional/alternative expression))))) + + ((constant? expression) (constant/value expression)) + + ((declaration? expression) + (expression/never-false? (declaration/expression expression))) + + ((disjunction? expression) + (or (expression/never-false? (disjunction/predicate expression)) + (expression/never-false? (disjunction/alternative expression)))) + + ((sequence? expression) + (expression/never-false? (last (sequence/actions expression)))) + (else #f))) +;; The primitive predicates that only return #T or #F. (define primitive-boolean-predicates (map (lambda (name) (make-primitive-procedure name #t)) @@ -278,6 +388,7 @@ USA. ZERO? ))) +;; True if expression is a call to one of the primitive-boolean-predicates. (define (expression/call-to-boolean-predicate? expression) (and (combination? expression) (let ((operator (combination/operator expression))) @@ -288,6 +399,41 @@ USA. operator-value (length (combination/operands expression))))))))) +;; These primitives have no side effects. We consider primitives +;; that check their arguments *have* a side effect. (Conservative) +(define effect-free-primitives + (map (lambda (name) + (make-primitive-procedure name #t)) + '( + %RECORD? + BIT-STRING? + CELL? + CHAR? + EQ? + FIXNUM? + FLONUM? + NOT + NULL? + OBJECT-TYPE + OBJECT-TYPE? + PAIR? + STRING? + VECTOR? + ))) + +;; True if expression is a call to one of the effect-free-primitives. +(define (expression/call-to-effect-free-primitive? expression) + (and (combination? expression) + (let ((operator (combination/operator expression))) + (and (constant? operator) + (let ((operator-value (constant/value operator))) + (and (memq operator-value effect-free-primitives) + (procedure-arity-valid? + operator-value + (length (combination/operands expression))))))))) + +;; True if expression is a call to NOT. +;; Used in conditional simplification. (define (expression/call-to-not? expression) (and (combination? expression) (let ((operator (combination/operator expression))) @@ -489,19 +635,17 @@ USA. (define sf:enable-disjunction-distribution? #t) (define (conditional/make scode predicate consequent alternative) - (cond ((and (constant? predicate) - (noisy-test sf:enable-conditional-folding? "folding conditional")) - (if (constant/value predicate) + (cond ((and (expression/never-false? predicate) + (noisy-test sf:enable-conditional-folding? "Fold constant true conditional")) + (if (expression/effect-free? predicate) consequent - alternative)) + (sequence/make scode (list predicate consequent)))) - ;; (if foo foo ...) => (or foo ...) - ((and (reference? predicate) - (reference? consequent) - (eq? (reference/variable predicate) - (reference/variable consequent)) - (noisy-test sf:enable-conditional->disjunction? "Conditional to disjunction")) - (disjunction/make scode predicate alternative)) + ((and (expression/always-false? predicate) + (noisy-test sf:enable-conditional-folding? "Fold constant false conditional")) + (if (expression/effect-free? predicate) + alternative + (sequence/make scode (list predicate alternative)))) ;; (if (not e) c a) => (if e a c) ((and (expression/call-to-not? predicate) @@ -510,6 +654,14 @@ USA. alternative consequent)) + ;; (if foo foo ...) => (or foo ...) + ((and (reference? predicate) + (reference? consequent) + (eq? (reference/variable predicate) + (reference/variable consequent)) + (noisy-test sf:enable-conditional->disjunction? "Conditional to disjunction")) + (disjunction/make scode predicate alternative)) + ;; (if (if e1 e2 #f) K) => (if e1 (if e2 K) K) ((and (conditional? predicate) (expression/constant-eq? (conditional/alternative predicate) #f) @@ -544,14 +696,19 @@ USA. (define sf:enable-disjunction-simplification? #t) (define (disjunction/make scode predicate alternative) - (cond ((and (constant? predicate) - (noisy-test sf:enable-disjunction-folding? "Fold constant disjunction")) - (if (constant/value predicate) - predicate - alternative)) + (cond ((and (expression/never-false? predicate) + (noisy-test sf:enable-disjunction-folding? "Fold constant true disjunction")) + predicate) + + ((and (expression/always-false? predicate) + (noisy-test sf:enable-disjunction-folding? "Fold constant false disjunction")) + (if (expression/effect-free? predicate) + alternative + (sequence/make scode (list predicate alternative)))) ;; (or (foo) #f) => (foo) - ((and (expression/constant-eq? alternative #f) + ((and (expression/always-false? alternative) + (expression/effect-free? alternative) (noisy-test sf:enable-disjunction-simplification? "Simplify disjunction")) predicate)