From a067d702f2b26b20bad50e37698b39b65831e900 Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Tue, 2 Mar 2010 18:01:08 -0800 Subject: [PATCH] Move conditional and disjunction folding and inversion to subst.scm --- src/sf/object.scm | 47 ++----------------- src/sf/sf.pkg | 8 ++-- src/sf/subst.scm | 116 +++++++++++++++++++++++++++++++++++++--------- 3 files changed, 102 insertions(+), 69 deletions(-) diff --git a/src/sf/object.scm b/src/sf/object.scm index 131863b81..92a9a7c25 100644 --- a/src/sf/object.scm +++ b/src/sf/object.scm @@ -705,37 +705,16 @@ USA. ;;; Conditional (define sf:enable-conditional->disjunction? #t) -(define sf:enable-conditional-folding? #t) -(define sf:enable-conditional-inversion? #t) (define sf:enable-conjunction-linearization? #t) (define sf:enable-disjunction-distribution? #t) (define (conditional/make scode predicate consequent alternative) - (cond ((and (expression/never-false? predicate) - (noisy-test sf:enable-conditional-folding? "Fold constant true conditional")) - (if (expression/effect-free? predicate) - consequent - (sequence/make scode (list predicate consequent)))) - - ((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)))) - - ((and (expression/unspecific? predicate) + (cond ((and (expression/unspecific? predicate) (noisy-test sf:enable-conditional-folding? "Fold constant unspecific 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) - (noisy-test sf:enable-conditional-inversion? "Conditional inversion")) - (conditional/make scode (first (combination/operands predicate)) - alternative - consequent)) - ;; (if foo foo ...) => (or foo ...) ((and (reference? predicate) (reference? consequent) @@ -773,36 +752,16 @@ USA. (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) - (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/always-false? alternative) + (cond ((and (expression/always-false? alternative) (expression/effect-free? alternative) (noisy-test sf:enable-disjunction-simplification? "Simplify disjunction")) + ;; (or (foo) #f) => (foo) predicate) - ;; (or (not e1) e2) => (if e1 e2 #t) - ((and (expression/call-to-not? predicate) - (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")) diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg index f9fe37efa..d5aab376e 100644 --- a/src/sf/sf.pkg +++ b/src/sf/sf.pkg @@ -40,13 +40,9 @@ USA. (export () sf:enable-argument-deletion? sf:enable-conditional->disjunction? - sf:enable-conditional-folding? - sf:enable-conditional-inversion? sf:enable-conjunction-linearization? sf:enable-constant-folding? sf:enable-disjunction-distribution? - sf:enable-disjunction-folding? - sf:enable-disjunction-inversion? sf:enable-disjunction-linearization? sf:enable-disjunction-simplification? sf:enable-distribute-primitives?)) @@ -91,6 +87,10 @@ USA. (parent (scode-optimizer)) (export () sf:display-top-level-procedure-names? + sf:enable-conditional-folding? + sf:enable-conditional-inversion? + sf:enable-disjunction-folding? + sf:enable-disjunction-inversion? sf:enable-elide-conditional-canonicalization? sf:enable-elide-double-negatives?) (export (scode-optimizer) diff --git a/src/sf/subst.scm b/src/sf/subst.scm index 1ecf124ee..04fa108d2 100644 --- a/src/sf/subst.scm +++ b/src/sf/subst.scm @@ -153,23 +153,56 @@ USA. (define-method/integrate 'CONDITIONAL (lambda (operations environment expression) - (let ((ipred (integrate/expression - operations environment - (conditional/predicate expression))) - (icons (integrate/expression - operations environment - (conditional/consequent expression))) - (ialt (integrate/expression - operations environment - (conditional/alternative expression)))) - (cond ((and (expression/constant-eq? icons #t) - (expression/constant-eq? ialt #f) - (expression/boolean? ipred) - (noisy-test sf:enable-elide-conditional-canonicalization? - "elide conditional canonicalization")) - ipred) - (else - (conditional/make (conditional/scode expression) ipred icons ialt)))))) + (integrate/conditional operations environment expression + (integrate/expression + operations environment + (conditional/predicate expression)) + (conditional/consequent expression) + (conditional/alternative expression)))) + +(define sf:enable-conditional-folding? #t) +(define sf:enable-conditional-inversion? #t) + +(define (integrate/conditional operations environment expression + integrated-predicate + consequent + alternative) + (cond ((and (expression/never-false? integrated-predicate) + (noisy-test sf:enable-conditional-folding? "Fold constant true conditional")) + (let ((integrated-consequent (integrate/expression operations environment consequent))) + (if (expression/effect-free? integrated-predicate) + integrated-consequent + (sequence/make (and expression (conditional/scode expression)) + (list integrated-predicate integrated-consequent))))) + + ((and (expression/always-false? integrated-predicate) + (noisy-test sf:enable-conditional-folding? "Fold constant false conditional")) + (let ((integrated-alternative (integrate/expression operations environment alternative))) + (if (expression/effect-free? integrated-predicate) + integrated-alternative + (sequence/make (and expression (conditional/scode expression)) + (list integrated-predicate integrated-alternative))))) + + ((and (expression/call-to-not? integrated-predicate) + (noisy-test sf:enable-conditional-inversion? "Invert conditional")) + (integrate/conditional operations environment expression + (first (combination/operands integrated-predicate)) + alternative consequent)) + + (else (let ((icons (integrate/expression + operations environment + consequent)) + (ialt (integrate/expression + operations environment + alternative))) + (cond ((and (expression/constant-eq? icons #t) + (expression/constant-eq? ialt #f) + (expression/boolean? integrated-predicate) + (noisy-test sf:enable-elide-conditional-canonicalization? + "elide conditional canonicalization")) + integrated-predicate) + (else + (conditional/make (and expression (conditional/scode expression)) integrated-predicate icons ialt))))))) ;;; CONSTANT (define-method/integrate 'CONSTANT @@ -201,10 +234,45 @@ USA. ;;; DISJUNCTION (define-method/integrate 'DISJUNCTION (lambda (operations environment expression) - (disjunction/make - (disjunction/scode expression) - (integrate/expression operations environment (disjunction/predicate expression)) - (integrate/expression operations environment (disjunction/alternative expression))))) + (integrate/disjunction + operations environment expression + (integrate/expression + operations environment (disjunction/predicate expression)) + (disjunction/alternative expression)))) + +(define sf:enable-disjunction-folding? #t) +(define sf:enable-disjunction-inversion? #t) + +(define (integrate/disjunction operations environment expression + integrated-predicate alternative) + ;; Predicate has been integrated, but alternative has not. + ;; We can use information from the predicate to help in + ;; integrating the alternative. + (cond ((and (expression/never-false? integrated-predicate) + (noisy-test sf:enable-disjunction-folding? "Fold constant true disjunction")) + predicate) + + ((and (expression/always-false? integrated-predicate) + (noisy-test sf:enable-disjunction-folding? "Fold constant false disjunction")) + (let ((integrated-alternative (integrate/expression operations environment alternative))) + (if (expression/effect-free? integrated-predicate) + integrated-alternative + (sequence/make (and expression (object/scode expression)) + (list integrated-predicate + integrated-alternative))))) + + ;; (or (not e1) e2) => (if e1 e2 #t) + ((and (expression/call-to-not? integrated-predicate) + (noisy-test sf:enable-disjunction-inversion? "Invert disjunction")) + (integrate/conditional operations environment expression + (first (combination/operands integrated-predicate)) + alternative + (constant/make #f #t))) + + (else + (disjunction/make (and expression (object/scode expression)) + integrated-predicate + (integrate/expression operations environment alternative))))) ;;; OPEN-BLOCK (define-method/integrate 'OPEN-BLOCK @@ -349,6 +417,12 @@ USA. (not (variable/may-ignore? variable)) (not (variable/must-ignore? variable)))) +(define (variable/safely-integrable? variable operations) + (guarantee-variable variable 'variable/safely-integrable?) + (and (not (variable/side-effected variable)) + (block/safe? (variable/block variable)) + (operations/lookup operations variable false-procedure true-procedure))) + (define (integrate/procedure operations environment procedure) (let ((block (procedure/block procedure)) (name (procedure/name procedure)) -- 2.25.1