From 92a462d59bdcc949cc6310262cc69e1b91e689b7 Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Fri, 12 Mar 2010 16:42:23 -0800 Subject: [PATCH] Add sf:enable-safe-integration? --- src/sf/object.scm | 34 +++----- src/sf/sf.pkg | 11 +-- src/sf/subst.scm | 215 ++++++++++++++++++++++++++++++++++------------ 3 files changed, 177 insertions(+), 83 deletions(-) diff --git a/src/sf/object.scm b/src/sf/object.scm index cec41effe..f64ef48df 100644 --- a/src/sf/object.scm +++ b/src/sf/object.scm @@ -323,8 +323,10 @@ USA. (length (combination/operands expression))))))))) (define (expression/constant-eq? expression value) - (and (constant? expression) - (eq? (constant/value expression) value))) + (cond ((constant? expression) (eq? (constant/value expression) value)) + ((declaration? expression) + (expression/constant-eq? (declaration/expression expression) value)) + (else #f))) (define-integrable (global-ref/make name) (access/make #f @@ -357,7 +359,6 @@ USA. ;; If we apply a primitive to a conditional, rewrite such that ;; the primitive is applied to the arms of the conditional. -;; (This usually occurs with an (not (if foo ))) (define sf:enable-distribute-primitives? #t) ;; Foldable operators primitives that are members of @@ -506,11 +507,12 @@ USA. unreferenced-operands)))))))))) ;;; Conditional -(define sf:enable-conditional->disjunction? #t) -(define sf:enable-conditional-inversion? #t) -(define sf:enable-conjunction-linearization? #t) -(define sf:enable-disjunction-distribution? #t) -;; Expression such as (if (pair? x) #t #f) don't need the conditional. + +;; If the arms of a conditional are #T and #F, then +;; we're just canonicalizing the predicate value to a boolean. +;; If we already know the predicate is a boolean we can elide +;; this step. Additionally, if the arms are #F and #T, +;; we're simply calling NOT. (define sf:enable-elide-conditional-canonicalization? #t) (define (conditional/make scode predicate consequent alternative) @@ -524,24 +526,12 @@ USA. ;; have been inverted. (combination/%make scode #f (constant/make #f (ucode-primitive not)) (list predicate))) - ((and (expression/boolean? predicate) - (expression/pure-true? consequent) - (noisy-test sf:enable-elide-conditional-canonicalization? - "Converting conditional canonicalization to disjunction")) - ;; (if #t e1) => (or e1) - ;; NOTE: if e1 is #F, then the disjunction will be eliminated. - (disjunction/make scode predicate alternative)) - - ((and (reference? predicate) - (reference? consequent) - (eq? (reference/variable predicate) - (reference/variable consequent))) - (disjunction/make scode predicate alternative)) - (else (conditional/%make scode predicate consequent alternative)))) ;;; Disjunction + +;; If the alternative of a disjunction is #F, we can elide the disjunction. (define sf:enable-disjunction-simplification? #t) (define (disjunction/make scode predicate alternative) diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg index f57398bc9..43c01f509 100644 --- a/src/sf/sf.pkg +++ b/src/sf/sf.pkg @@ -39,11 +39,8 @@ USA. combination/constant-folding-operators) (export () sf:enable-argument-deletion? - sf:enable-conditional->disjunction? - sf:enable-conditional-inversion? sf:enable-conjunction-linearization? sf:enable-constant-folding? - sf:enable-disjunction-distribution? sf:enable-disjunction-simplification? sf:enable-distribute-primitives? sf:enable-elide-conditional-canonicalization?)) @@ -88,7 +85,9 @@ USA. (parent (scode-optimizer)) (export () sf:display-top-level-procedure-names? + sf:enable-conditional->disjunction? sf:enable-conditional-folding? + sf:enable-conditional-inversion? sf:enable-conditional-propagation? sf:enable-disjunction-folding? sf:enable-disjunction-inversion? @@ -96,7 +95,8 @@ USA. sf:enable-elide-double-negatives? sf:enable-rewrite-conditional-in-disjunction? sf:enable-rewrite-disjunction-in-conditional? - sf:enable-rewrite-nested-conditional?) + sf:enable-rewrite-nested-conditional? + sf:enable-safe-integration?) (export (scode-optimizer) integrate/top-level integrate/get-top-level-block @@ -161,7 +161,8 @@ USA. expression/never-false? expression/pure-false? expression/pure-true? - expression/unspecific?)) + expression/unspecific? + expressions/equal?)) (define-package (scode-optimizer change-type) (files "chtype") diff --git a/src/sf/subst.scm b/src/sf/subst.scm index 077478fb5..111d50d4a 100644 --- a/src/sf/subst.scm +++ b/src/sf/subst.scm @@ -103,13 +103,29 @@ USA. (let ((environment* (integrate/expression operations environment (access/environment expression))) (name (access/name expression))) - (cond ((and (constant/system-global-environment? environment*) - (assq name usual-integrations/constant-alist)) - => (lambda (entry) - (constant/make (access/scode expression) - (constant/value (cdr entry))))) - (else (access/make (access/scode expression) - environment* name)))))) + + (define (dont-integrate) + (access/make (access/scode expression) environment* name)) + + (if (not (constant/system-global-environment? environment*)) + (dont-integrate) + (operations/lookup-global + operations name + (lambda (operation info) + (case operation + ((#F EXPAND INTEGRATE-OPERATOR) (dont-integrate)) + + ((IGNORE) + (ignored-variable-warning (variable/name variable)) + (dont-integrate)) + + ((INTEGRATE) + (reassign name (copy/expression/intern + block (integration-info/expression info)))) + + (else + (error "Unknown operation" operation)))) + dont-integrate))))) ;;;; ASSIGNMENT (define-method/integrate 'ASSIGNMENT @@ -165,6 +181,12 @@ USA. ;; in the alternative branch. (define sf:enable-conditional-propagation? #t) +;; If the predicate is a call to NOT, flip the consequent and +;; alternative and the sense of the predicate. +(define sf:enable-conditional-inversion? #t) + +(define sf:enable-conditional->disjunction? #t) + (define (integrate/conditional operations environment expression integrated-predicate consequent @@ -203,11 +225,27 @@ USA. integrated-predicate consequent alternative)) (else - (conditional/make (and expression (conditional/scode expression)) - integrated-predicate - (integrate/expression operations environment consequent) - (integrate/expression (operations/prepare-false-branch operations integrated-predicate) - environment alternative))))) + (let ((integrated-consequent (integrate/expression operations environment consequent))) + (if (or (and (expressions/equal? integrated-predicate integrated-consequent) + (expression/effect-free? integrated-predicate) + (noisy-test sf:enable-conditional->disjunction? "Converting conditional to disjunction")) + (and (expression/boolean? integrated-predicate) + (expression/pure-true? integrated-consequent) + (noisy-test sf:enable-elide-conditional-canonicalization? "Eliding conditional canonicalization"))) + (integrate/disjunction operations environment expression integrated-predicate alternative) + + (let ((integrated-alternative (integrate/expression + (operations/prepare-false-branch operations integrated-predicate) + environment alternative))) + (if (expressions/equal? integrated-consequent integrated-alternative) + (if (expression/effect-free? integrated-predicate) + integrated-consequent + (sequence/make (and expression (conditional/scode expression)) + (list integrated-predicate integrated-consequent))) + (conditional/make (and expression (conditional/scode expression)) + integrated-predicate + integrated-consequent + integrated-alternative)))))))) (define sf:enable-rewrite-disjunction-in-conditional? #t) ;; If #t, move disjunctions out of the predicate if possible. @@ -406,14 +444,14 @@ USA. ;;; DECLARATION (define-method/integrate 'DECLARATION (lambda (operations environment declaration) - (let ((declarations (declaration/declarations declaration)) - (expression (declaration/expression declaration))) - (declaration/make - (declaration/scode declaration) - declarations - (integrate/expression (declarations/bind operations declarations) - environment - expression))))) + (let ((answer (integrate/expression (declarations/bind operations (declaration/declarations declaration)) + environment (declaration/expression declaration)))) + (if (constant? answer) + answer + (declaration/make + (declaration/scode declaration) + (declaration/declarations declaration) + answer))))) ;;; DELAY (define-method/integrate 'DELAY @@ -608,33 +646,33 @@ USA. (define-method/integrate 'REFERENCE (lambda (operations environment expression) (let ((variable (reference/variable expression))) - (letrec ((integration-success - (lambda (new-expression) - (variable/integrated! variable) - new-expression)) - (integration-failure - (lambda () - (variable/reference! variable) - expression))) - (operations/lookup operations variable - (lambda (operation info) - (case operation - ((IGNORE) - (ignored-variable-warning (variable/name variable)) - (integration-failure)) - ((EXPAND INTEGRATE-OPERATOR) - (variable/reference! variable) - expression) - ((INTEGRATE) - (let ((new-expression - (integrate/name expression expression info environment))) - (if new-expression - (integration-success new-expression) - (integration-failure)))) - (else - (error "Unknown operation" operation)))) - (lambda () - (integration-failure))))))) + (define (dont-integrate) + (variable/reference! variable) + expression) + + (operations/lookup + operations variable + (lambda (operation info) + (case operation + ((IGNORE) + (ignored-variable-warning (variable/name variable)) + (dont-integrate)) + + ((EXPAND INTEGRATE-OPERATOR) + (dont-integrate)) + + ((INTEGRATE) + (let ((new-expression + (integrate/name expression expression info environment))) + (if new-expression + (begin (variable/integrated! variable) + new-expression) + (dont-integrate)))) + + (else + (error "Unknown operation" operation)))) + + dont-integrate)))) (define (reassign expr object) (if (and expr (object/scode expr)) @@ -731,15 +769,20 @@ USA. name (lambda () (fluid-let ((*current-block-names* (cons name *current-block-names*))) - (let ((body - (integrate/expression - (declarations/bind - (operations/shadow - operations - (append required optional (if rest (list rest) '()))) - (block/declarations block)) - environment - (procedure/body procedure)))) + (let* ((operations (declarations/bind + (operations/shadow + operations + (append required optional (if rest (list rest) '()))) + (block/declarations block))) + + (body (integrate/expression + (if (block/safe? block) + (make-additional-declarations + operations environment + (block/bound-variables block)) + operations) + environment + (procedure/body procedure)))) ;; Possibly complain about variables bound and not ;; referenced. (if (block/safe? block) @@ -758,6 +801,47 @@ USA. optional rest body))))))) + +(define sf:enable-safe-integration? #t) + +(define (make-additional-declarations operations environment variables) + (fold-left (lambda (operations variable) + (make-additional-declaration operations environment variable)) + operations + variables)) + +(define (make-additional-declaration operations environment variable) + ;; Possibly augment operations with an appropriate declaration. + ;; Returns the original operations if no declaration is appropriate. + (if (variable/side-effected variable) + operations + (operations/lookup + operations variable + ;; Already a declaration, don't override it. + (constant-procedure operations) + (lambda () + ;; No operations on this variable, check if it has + ;; a value + (environment/lookup + environment variable + (lambda (value) + ;; it has a value, see if we should integrate it + (make-additional-declaration-with-value operations variable value)) + ;; No value + (constant-procedure operations) + ;; No binding + (constant-procedure operations)))))) + +(define (make-additional-declaration-with-value operations variable value) + (if (and (or (and (access? value) (global-ref? value)) + (constant? value) + (and (reference? value) + (not (variable/side-effected (reference/variable value))) + (block/safe? (variable/block (reference/variable value))))) + (noisy-test sf:enable-safe-integration? "Safe declarations")) + (operations/bind operations 'INTEGRATE variable + (make-integration-info value)) + operations)) ;;; INTEGRATE-COMBINATION @@ -849,6 +933,25 @@ USA. (expression/boolean? (first (combination/operands (first operands)))) (noisy-test sf:enable-elide-double-negatives? "Eliding double negative")) (first (combination/operands (first operands)))) + ((and (expression/constant-eq? operator (ucode-primitive not)) + (length=? operands 1) + (conditional? (first operands)) + (or (expression/call-to-not? (conditional/consequent (first operands))) + (expression/pure-true? (conditional/consequent (first operands))) + (expression/pure-false? (conditional/consequent (first operands)))) + (or (expression/call-to-not? (conditional/alternative (first operands))) + (expression/pure-true? (conditional/alternative (first operands))) + (expression/pure-false? (conditional/alternative (first operands))))) + (integrate/conditional operations environment expression + (conditional/predicate (first operands)) + (combination/make (conditional/consequent (first operands)) + #f + (constant/make #f (ucode-primitive not)) + (list (conditional/consequent (first operands)))) + (combination/make (conditional/alternative (first operands)) + #f + (constant/make #f (ucode-primitive not)) + (list (conditional/alternative (first operands)))))) ((primitive-procedure? (constant/value operator)) (let ((operands* (and (eq? (constant/value operator) (ucode-primitive apply)) -- 2.25.1