From 92a462d59bdcc949cc6310262cc69e1b91e689b7 Mon Sep 17 00:00:00 2001
From: Joe Marshall <jmarshall@alum.mit.edu>
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 <e1> <e2>)))
(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 <boolean> #t e1) => (or <boolean> 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