From: Joe Marshall Date: Mon, 9 May 2011 19:41:32 +0000 (-0700) Subject: Remove overly complex code. X-Git-Tag: 20110609-Gtk~5^2~6^2~2 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d72a3a44050bdac968c955f630e53416a720153d;p=mit-scheme.git Remove overly complex code. --- diff --git a/src/sf/analyze.scm b/src/sf/analyze.scm index 9ab44b769..a30f1e5ac 100644 --- a/src/sf/analyze.scm +++ b/src/sf/analyze.scm @@ -165,117 +165,6 @@ USA. (expression/boolean? (last (sequence/actions expression))))) (define-method/boolean? 'THE-ENVIRONMENT false-procedure) - -;; EXPRESSION/CAN-DUPLICATE? -;; -;; True if an expression can be duplicated on the consequent and -;; alternative branches of a conditional. -;; -;; SF:MAXIMUM-DUPLICATE-EXPRESSION-SIZE -;; -;; A measure of how big an expression we are willing to duplicate -;; when rewriting a conditional or disjunction. In theory, there -;; is no limit because the code is only duplicated on parallel -;; branches and could only be encountered once per branch, but -;; we want to avoid unnecessary code bloat. -;; Values: -;; 0 = inhibit all code duplication -;; 1 = allow constants to be duplicated -;; 2 - 4 = very conservative setting -;; 4 - 8 = a tad conservative -;; 8 - 16 = a bit liberal -;; 64 - 10000 = go wild. -;; -;; This has been tested at very large values, it produces -;; correct code, but the code can get quite a bit larger -;; and take longer to compile. -(define sf:maximum-duplicate-expression-size 8) - -(define (expression/can-duplicate? expression) - (< (expression/can-dup-descend? 0 expression) sf:maximum-duplicate-expression-size)) - -(define (expression/can-dup-descend? size expression) - (if (>= size sf:maximum-duplicate-expression-size) - size - ((expression/method can-dup-descend?-dispatch-vector expression) size expression))) - -(define can-dup-descend?-dispatch-vector - (expression/make-dispatch-vector)) - -(define define-method/can-dup-descend? - (expression/make-method-definer can-dup-descend?-dispatch-vector)) - -(define-integrable (dont-duplicate size expression) - (declare (ignore size expression)) - sf:maximum-duplicate-expression-size) - -(define-method/can-dup-descend? 'ACCESS dont-duplicate) - -(define-method/can-dup-descend? 'ASSIGNMENT dont-duplicate) - -(define-method/can-dup-descend? 'COMBINATION - (lambda (size expression) - (fold-left expression/can-dup-descend? - (let ((operator (combination/operator expression))) - (cond ((procedure? operator) (expression/can-dup-descend? (+ size 1) (procedure/body operator))) - (else (expression/can-dup-descend? (+ size 1) operator)))) - (combination/operands expression)))) - -(define-method/can-dup-descend? 'CONDITIONAL - (lambda (size expression) - (expression/can-dup-descend? - (cond ((expression/always-false? (conditional/predicate expression)) - (expression/can-dup-descend? (+ size 1) (conditional/alternative expression))) - ((expression/never-false? (conditional/predicate expression)) - (expression/can-dup-descend? (+ size 1) (conditional/consequent expression))) - (else - (expression/can-dup-descend? (expression/can-dup-descend? (+ size 1) (conditional/consequent expression)) - (conditional/alternative expression)))) - (conditional/predicate expression)))) - -(define-method/can-dup-descend? 'CONSTANT - (lambda (size expression) - (declare (ignore expression)) (+ size 0))) ;; no cost - -(define-method/can-dup-descend? 'DECLARATION - (lambda (size expression) - (expression/can-dup-descend? (+ size 1) (declaration/expression expression)))) - -(define-method/can-dup-descend? 'DELAY - (lambda (size expression) - (expression/can-dup-descend? (+ size 1) (delay/expression expression)))) - -(define-method/can-dup-descend? 'DISJUNCTION - (lambda (size expression) - (expression/can-dup-descend? - (if (expression/never-false? (disjunction/predicate expression)) - size - (expression/can-dup-descend? (+ size 2) (disjunction/alternative expression))) - (disjunction/predicate expression)))) - -(define-method/can-dup-descend? 'OPEN-BLOCK dont-duplicate) - -;; If it is a procedure, we don't want to duplicate it -;; in case someone might compare it with EQ? -;; We'll handle LET specially in the combination case. -(define-method/can-dup-descend? 'PROCEDURE dont-duplicate) - -(define-method/can-dup-descend? 'QUOTATION dont-duplicate) - -(define-method/can-dup-descend? 'REFERENCE - (lambda (size expression) - (if (variable/side-effected (reference/variable expression)) - sf:maximum-duplicate-expression-size - (+ size 1)))) - -(define-method/can-dup-descend? 'SEQUENCE - (lambda (size expression) - (fold-left expression/can-dup-descend? - (+ size 1) - (sequence/actions expression)))) - -(define-method/can-dup-descend? 'THE-ENVIRONMENT dont-duplicate) - ;;; EXPRESSION/EFFECT-FREE? ;; @@ -592,7 +481,7 @@ USA. (inner-info (expressions/free-variable-info (combination/operands expression) variable info))) (if (and (reference? operator) (eq? (reference/variable operator) variable)) - (cons (+ (car inner-info) 1) (cdr inner-info)) + (cons (fix:1+ (car inner-info)) (cdr inner-info)) (expression/free-variable-info-dispatch operator variable inner-info))))) (define-method/free-variable-info 'CONDITIONAL @@ -643,7 +532,7 @@ USA. (define-method/free-variable-info 'REFERENCE (lambda (expression variable info) (if (eq? (reference/variable expression) variable) - (cons (car info) (+ 1 (cdr info))) + (cons (car info) (fix:1+ (cdr info))) info))) (define-method/free-variable-info 'SEQUENCE @@ -756,9 +645,7 @@ USA. (define-method/pure-false? 'CONSTANT (lambda (expression) - (or (not (constant/value expression)) - (and (eq? (constant/value expression) unspecific) - (noisy-test sf:enable-true-unspecific? "Treating unspecific as pure false."))))) + (not (constant/value expression)))) (define-method/pure-false? 'DECLARATION (lambda (expression) @@ -827,9 +714,7 @@ USA. (define-method/pure-true? 'CONSTANT (lambda (expression) - (or (eq? (constant/value expression) #t) - (and (eq? (constant/value expression) unspecific) - (noisy-test sf:enable-true-unspecific? "Treating unspecific as pure true."))))) + (eq? (constant/value expression) #t))) (define-method/pure-true? 'DECLARATION (lambda (expression) @@ -877,59 +762,59 @@ USA. (define-method/size 'ACCESS (lambda (expression) - (+ 1 (expression/size (access/environment expression))))) + (fix:1+ (expression/size (access/environment expression))))) (define-method/size 'ASSIGNMENT (lambda (expression) - (+ 1 (expression/size (assignment/value expression))))) + (fix:1+ (expression/size (assignment/value expression))))) (define-method/size 'COMBINATION (lambda (expression) (fold-left (lambda (total operand) - (+ total (expression/size operand))) - (+ 1 (expression/size (combination/operator expression))) + (fix:+ total (expression/size operand))) + (fix:1+ (expression/size (combination/operator expression))) (combination/operands expression)))) (define-method/size 'CONDITIONAL (lambda (expression) - (+ (expression/size (conditional/predicate expression)) - (expression/size (conditional/consequent expression)) - (expression/size (conditional/alternative expression)) - 1))) + (fix:+ + (expression/size (conditional/predicate expression)) + (fix:+ + (expression/size (conditional/consequent expression)) + (fix:1+ (expression/size (conditional/alternative expression))))))) (define-method/size 'CONSTANT (lambda (expression) (declare (ignore expression)) 1)) (define-method/size 'DECLARATION (lambda (expression) - (+ (expression/size (declaration/expression expression)) 1))) + (fix:1+ (expression/size (declaration/expression expression))))) (define-method/size 'DELAY (lambda (expression) - (+ (expression/size (delay/expression expression)) 1))) + (fix:1+ (expression/size (delay/expression expression))))) (define-method/size 'DISJUNCTION (lambda (expression) - (+ (expression/size (disjunction/predicate expression)) - (expression/size (disjunction/alternative expression)) - 1))) + (fix:+ (expression/size (disjunction/predicate expression)) + (fix:1+ (expression/size (disjunction/alternative expression)))))) (define-method/size 'OPEN-BLOCK (lambda (expression) (fold-left (lambda (total action) (if (eq? action open-block/value-marker) total - (+ total (expression/size action)))) + (fix:+ total (expression/size action)))) 1 (open-block/actions expression)))) (define-method/size 'PROCEDURE (lambda (expression) - (+ (expression/size (procedure/body expression)) 1))) + (fix:1+ (expression/size (procedure/body expression))))) (define-method/size 'QUOTATION (lambda (expression) - (+ 1 (expression/size (quotation/expression expression))))) + (fix:1+ (expression/size (quotation/expression expression))))) (define-method/size 'REFERENCE (lambda (expression) @@ -939,122 +824,6 @@ USA. (define-method/size 'SEQUENCE (lambda (expression) (fold-left (lambda (total action) - (+ total (expression/size action))) + (fix:+ total (expression/size action))) 1 (sequence/actions expression)))) - -;; If true, then expression/unspecific? will return #t on -;; unspecific which will enable certain operations to treat -;; the value as something more convenient. For example, a -;; conditional might just treat an unspecific as #F to enable -;; folding. - -;; Disable for now because the pathname package uses unspecific -;; as a special marker. Ugh. -(define sf:enable-true-unspecific? #f) - -(define (expression/unspecific? expression) - (and (constant? expression) - (eq? (constant/value expression) unspecific) - (noisy-test sf:enable-true-unspecific? "Enable true unspecific"))) - -;;; EXPRESSIONS/EQUAL? -;; -;; Returns #t if two expressions always compute the same value. -;; This is not meant to be a heroic attempt to prove extrinsic equality, -;; but rather a simple check to see if we have essentially the same -;; form. Returning false is a safe default. - -(declare (integrate-operator expressions/equal?)) -(define (expressions/equal? left right) - ((expression/method equal?-dispatch-vector left) left right)) - -(define equal?-dispatch-vector - (expression/make-dispatch-vector)) - -(define define-method/equal? - (expression/make-method-definer equal?-dispatch-vector)) - -(define-method/equal? 'ACCESS - (lambda (left right) - (and (access? right) - (eq? (access/name left) (access/name right)) - (expressions/equal? (access/environment left) (access/environment right))))) - -(define-method/equal? 'ASSIGNMENT - (lambda (left right) - (and (assignment? right) - (eq? (assignment/variable left) (assignment/variable right)) - (expressions/equal? (assignment/value left) (assignment/value right))))) - -(define-method/equal? 'COMBINATION - (lambda (left right) - (and (combination? right) - (let scan ((left-args (combination/operands left)) - (right-args (combination/operands right))) - (cond ((pair? left-args) (and (pair? right-args) - (expressions/equal? (car left-args) (car right-args)) - (scan (cdr left-args) (cdr right-args)))) - ((null? left-args) (and (null? right-args) - (expressions/equal? (combination/operator left) - (combination/operator right)))) - (else #f)))))) - -(define-method/equal? 'CONDITIONAL - (lambda (left right) - (and (conditional? right) - (expressions/equal? (conditional/predicate left) (conditional/predicate right)) - (or (expression/always-false? (conditional/predicate left)) - (expressions/equal? (conditional/consequent left) (conditional/consequent right))) - (or (expression/never-false? (conditional/predicate left)) - (expressions/equal? (conditional/alternative left) (conditional/alternative right)))))) - -(define-method/equal? 'CONSTANT - (lambda (left right) - (and (constant? right) - (eq? (constant/value left) (constant/value right))))) - -(define-method/equal? 'DECLARATION false-procedure) - -(define-method/equal? 'DELAY false-procedure) - -(define-method/equal? 'DISJUNCTION - (lambda (left right) - (and (disjunction? right) - (expressions/equal? (disjunction/predicate left) - (disjunction/predicate right)) - (expressions/equal? (disjunction/alternative left) - (disjunction/alternative right))))) - -(define-method/equal? 'OPEN-BLOCK false-procedure) - -(define-method/equal? 'PROCEDURE false-procedure) - -(define-method/equal? 'QUOTATION false-procedure) - -(define-method/equal? 'REFERENCE - (lambda (left right) - (and (reference? right) - (eq? (reference/variable left) - (reference/variable right))))) - -(define-method/equal? 'SEQUENCE - (lambda (left right) - (and (sequence? right) - (let scan ((left-args (sequence/actions left)) - (right-args (sequence/actions right))) - (cond ((pair? left-args) - (and (pair? right-args) - (if (eq? (car left-args) open-block/value-marker) - (eq? (car right-args) open-block/value-marker) - (and (not (eq? (car right-args) open-block/value-marker)) - (expressions/equal? (car left-args) - (car right-args)))) - (scan (cdr left-args) (cdr right-args)))) - ((null? left-args) (null? right-args)) - (else #f)))))) - -(define-method/equal? 'THE-ENVIRONMENT - (lambda (left right) - (declare (ignore left)) - (the-environment? right))) \ No newline at end of file diff --git a/src/sf/object.scm b/src/sf/object.scm index dc5fac84b..9103709ca 100644 --- a/src/sf/object.scm +++ b/src/sf/object.scm @@ -205,11 +205,11 @@ USA. (define-simple-type access #f (block environment name)) (define-simple-type assignment #f (block variable value)) (define-simple-type combination combination/%make (block operator operands)) -(define-simple-type conditional conditional/%make (predicate consequent alternative)) +(define-simple-type conditional #f (predicate consequent alternative)) (define-simple-type constant #f (value)) (define-simple-type declaration #f (declarations expression)) (define-simple-type delay #f (expression)) -(define-simple-type disjunction disjunction/%make (predicate alternative)) +(define-simple-type disjunction #f (predicate alternative)) (define-simple-type open-block #f (block variables values actions)) (define-simple-type procedure #f (block name required optional rest body)) (define-simple-type quotation #f (block expression)) @@ -348,10 +348,6 @@ USA. ;; list. This could lead to the combination disappearing altogether. (define sf:enable-argument-deletion? #t) -;; If we apply a primitive to a conditional, rewrite such that -;; the primitive is applied to the arms of the conditional. -(define sf:enable-distribute-primitives? #t) - ;; Foldable operators primitives that are members of ;; combination/constant-folding-operators @@ -383,31 +379,13 @@ USA. (define (combination/make expression block operator operands) (cond ((and (foldable-combination? operator operands) - (noisy-test sf:enable-constant-folding? "Folding constants")) + (noisy-test sf:enable-constant-folding? "Fold constant")) (combination/fold-constant expression (constant/value operator) (map constant/value operands))) - ((and (constant? operator) - (primitive-procedure? (constant/value operator)) - (not (eq? (constant/value operator) (ucode-primitive not))) - (length=? operands 1) - (conditional? (car operands)) - (noisy-test sf:enable-distribute-primitives? - "Distribute primitives over conditionals")) - (conditional/make (and expression (object/scode expression)) - (conditional/predicate (car operands)) - (combination/make #f - block - (constant/make #f (constant/value operator)) - (list (conditional/consequent (car operands)))) - (combination/make #f - block - (constant/make #f (constant/value operator)) - (list (conditional/alternative (car operands)))))) - ((and (reducable-operator? operator) - (noisy-test sf:enable-argument-deletion? "argument deletion")) + (noisy-test sf:enable-argument-deletion? "Delete argument")) (call-with-values (lambda () (partition-operands operator operands)) (lambda (new-argument-list new-operand-list other-operands) ;; The new-argument-list has the remaining arguments @@ -416,13 +394,12 @@ USA. ;; list of operands that must be evaluated (for effect) ;; but whose value is discarded. (let ((result-body - (if (and (null? new-argument-list) + (if (or (pair? new-argument-list) ;; need to avoid things like this ;; (foo bar (let () (define (baz) ..) ..)) ;; optimizing into ;; (foo bar (define (baz) ..) ..) - (not (open-block? (procedure/body operator)))) - (procedure/body operator) + (open-block? (procedure/body operator))) (combination/%make (and expression (object/scode expression)) block @@ -434,10 +411,13 @@ USA. '() #f (procedure/body operator)) - new-operand-list)))) - (sequence/make - (and expression (object/scode expression)) - (append other-operands (list result-body))))))) + new-operand-list) + (procedure/body operator)))) + (if (null? other-operands) + result-body + (sequence/make + (and expression (object/scode expression)) + (append other-operands (list result-body)))))))) (else (combination/%make (and expression (object/scode expression)) block operator operands)))) @@ -461,80 +441,39 @@ USA. (required-parameters '()) (referenced-operands '()) (unreferenced-operands '())) - (cond ((null? parameters) - (if (or (procedure/rest operator) (null? operands)) - (values (reverse required-parameters) ; preserve order + (cond ((null? parameters) + (if (or (procedure/rest operator) (null? operands)) + (values (reverse required-parameters) ; preserve order (reverse referenced-operands) (if (or (null? operands) (variable/integrated (procedure/rest operator))) unreferenced-operands (append operands unreferenced-operands))) - (error "Argument mismatch" operands))) - ((null? operands) - (error "Argument mismatch" parameters)) - (else - (let ((this-parameter (car parameters)) - (this-operand (car operands))) - (cond ((memq this-parameter free-in-body) - (loop (cdr parameters) - (cdr operands) - (cons this-parameter required-parameters) - (cons this-operand referenced-operands) - unreferenced-operands)) - ((variable/integrated this-parameter) - (loop (cdr parameters) - (cdr operands) - required-parameters - referenced-operands - unreferenced-operands)) - (else - (loop (cdr parameters) - (cdr operands) - required-parameters - referenced-operands - (cons this-operand - unreferenced-operands)))))))))) - -;;; 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) - (cond ((and (expression/pure-false? consequent) - (expression/pure-true? alternative) - (noisy-test sf:enable-elide-conditional-canonicalization? - "Eliding inverse conditional canonicalization")) - ;; (if #f #t) => (not ) - ;; We know that we're not making a double negative here - ;; because a call to NOT in the predicate would already - ;; have been inverted. - (combination/%make scode #f (constant/make #f (ucode-primitive not)) (list predicate))) - - ;; If the consequent and alternative are the same, just make a sequence. - ((expressions/equal? consequent alternative) - (sequence/make scode (list predicate consequent))) - - (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) - (cond ((and (expression/pure-false? alternative) - (noisy-test sf:enable-disjunction-simplification? "Simplify disjunction")) - ;; (or (foo) #f) => (foo) - predicate) - - (else - (disjunction/%make scode predicate alternative)))) + (error "Argument mismatch" operands))) + ((null? operands) + (error "Argument mismatch" parameters)) + (else + (let ((this-parameter (car parameters)) + (this-operand (car operands))) + (cond ((memq this-parameter free-in-body) + (loop (cdr parameters) + (cdr operands) + (cons this-parameter required-parameters) + (cons this-operand referenced-operands) + unreferenced-operands)) + ((variable/integrated this-parameter) + (loop (cdr parameters) + (cdr operands) + required-parameters + referenced-operands + unreferenced-operands)) + (else + (loop (cdr parameters) + (cdr operands) + required-parameters + referenced-operands + (cons this-operand + unreferenced-operands)))))))))) ;;; Sequence diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg index d05c64c8e..2750bce4c 100644 --- a/src/sf/sf.pkg +++ b/src/sf/sf.pkg @@ -40,10 +40,7 @@ USA. combination/constant-folding-operators) (export () sf:enable-argument-deletion? - sf:enable-constant-folding? - sf:enable-disjunction-simplification? - sf:enable-distribute-primitives? - sf:enable-elide-conditional-canonicalization?)) + sf:enable-constant-folding?)) (define-package (scode-optimizer global-imports) (files "gimprt") @@ -85,17 +82,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? - sf:enable-disjunction-linearization? sf:enable-elide-double-negatives? - sf:enable-rewrite-conditional-in-disjunction? - sf:enable-rewrite-disjunction-in-conditional? - sf:enable-rewrite-nested-conditional? sf:enable-safe-integration?) (export (scode-optimizer) integrate/top-level @@ -148,13 +137,9 @@ USA. (define-package (scode-optimizer analyze) (files "analyze") (parent (scode-optimizer)) - (export () - sf:maximum-duplicate-expression-size - sf:enable-true-unspecific?) (export (scode-optimizer) expression/always-false? expression/boolean? - expression/can-duplicate? expression/effect-free? expression/free-variable? expression/free-variable-info @@ -162,9 +147,7 @@ USA. expression/never-false? expression/pure-false? expression/pure-true? - expression/size - expression/unspecific? - expressions/equal?)) + expression/size)) (define-package (scode-optimizer change-type) (files "chtype") diff --git a/src/sf/subst.scm b/src/sf/subst.scm index 7e69f7b1e..e0236d4da 100644 --- a/src/sf/subst.scm +++ b/src/sf/subst.scm @@ -167,7 +167,6 @@ USA. (combination/operands combination))))) ;;;; CONDITIONAL - (define-method/integrate 'CONDITIONAL (lambda (operations environment expression) (integrate/conditional operations environment expression @@ -179,222 +178,48 @@ USA. (define sf:enable-conditional-folding? #t) -;; If true, then when a conditional depends on a variable, -;; and that variable is not side effected and has no declarations, -;; we declare the variable to be integrable to a constant #F -;; 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 alternative) - (cond ((and (expression/never-false? integrated-predicate) - (noisy-test sf:enable-conditional-folding? "Fold constant true conditional")) - (sequence/make (and expression (conditional/scode expression)) - (list integrated-predicate - (integrate/expression operations environment consequent)))) - - ((and (expression/always-false? integrated-predicate) - (noisy-test sf:enable-conditional-folding? "Fold constant false conditional")) - (sequence/make (and expression (conditional/scode expression)) - (list integrated-predicate - (integrate/expression operations environment alternative)))) - - ((and (expression/call-to-not? integrated-predicate) - (noisy-test sf:enable-conditional-inversion? "Invert conditional")) + (cond ((expression/call-to-not? integrated-predicate) ;; (if (not ) ) => (if ) - (integrate/conditional operations environment expression - (first (combination/operands integrated-predicate)) - alternative consequent)) - - ((conditional? integrated-predicate) - (integrate/nested-conditional + (integrate/conditional operations environment expression - integrated-predicate consequent alternative)) - - ((disjunction? integrated-predicate) - (integrate/disjunction-in-conditional - operations environment expression - integrated-predicate consequent alternative)) + (first (combination/operands integrated-predicate)) + alternative consequent)) ((sequence? integrated-predicate) - (sequence/make (and expression (object/scode expression)) - (append (except-last-pair (sequence/actions integrated-predicate)) - (list (integrate/conditional operations environment #f - (last (sequence/actions integrated-predicate)) - consequent - alternative))))) + (sequence/make + (and expression (object/scode expression)) + (append (except-last-pair (sequence/actions integrated-predicate)) + (list (integrate/conditional + operations environment #f + (last (sequence/actions integrated-predicate)) + consequent + alternative))))) + + ((and (expression/never-false? integrated-predicate) + (noisy-test sf:enable-conditional-folding? + "Fold constant true conditional")) + (sequence/make + (and expression (conditional/scode expression)) + (list integrated-predicate + (integrate/expression operations environment consequent)))) - (else - (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) - - (conditional/make (and expression (conditional/scode expression)) - integrated-predicate - integrated-consequent - (integrate/expression - (operations/prepare-false-branch operations integrated-predicate) - environment alternative))))))) - -(define sf:enable-rewrite-disjunction-in-conditional? #t) -;; If #t, move disjunctions out of the predicate if possible. - -(define (integrate/disjunction-in-conditional operations environment expression - integrated-predicate consequent alternative) - (let ((e1 (disjunction/predicate integrated-predicate)) - (e2 (disjunction/alternative integrated-predicate)) - (e3 (integrate/expression operations environment consequent))) - ;; (if (or e1 e2) e3 e4) => (if e1 e3 (if e2 e3 e4)) - ;; provided that e3 can be duplicated - (if (and (expression/can-duplicate? e3) - (noisy-test sf:enable-rewrite-disjunction-in-conditional? "Rewriting disjunction within conditional")) - (integrate/conditional operations environment expression - e1 - e3 - (conditional/make #f e2 e3 alternative)) - - ;; nothing we can do. Just make the conditional. - (conditional/make (and expression (object/scode expression)) - integrated-predicate - e3 - (integrate/expression (operations/prepare-false-branch - (operations/prepare-false-branch operations e1) - e2) - environment alternative))))) - -(define sf:enable-rewrite-nested-conditional? #t) - -(define (integrate/nested-conditional operations environment expression - integrated-predicate consequent alternative) - - (let ((e1 (conditional/predicate integrated-predicate)) - (e2 (conditional/consequent integrated-predicate)) - (e3 (conditional/alternative integrated-predicate))) - ;; (if (if e1 e2 e3) e4 e5) => - ;; (if e1 (begin e2 e4) (begin e3 e5)) case 1, e2 never false, e3 always false - ;; (if e1 (begin e2 e4) (if e3 e4 e5)) case 2, e2 never false, e4 can be duplicated - ;; (if e1 (begin e2 e5) (begin e3 e4)) case 3, e2 always false, e3 never false - ;; (if e1 (begin e2 e5) (if e3 e4 e5)) case 4, e2 always false, e5 can be duplicated - ;; (if e1 (if e2 e4 e5) (begin e3 e4)) case 5, e3 never false, e4 can be duplicated - ;; (if e1 (if e2 e4 e5) (begin e3 e5)) case 6, e3 always false, e5 can be duplicated - ;; (if e1 (if e2 e4 e5) (if e3 e4 e5)) case 7, e4 and e5 can be duplicated - ;; and there is of course the general case where we can do nothing - - ;; When propagating the conditional information, there are four contexts to consider: - ;; (if e1 - ;; (if e2 CC CA) ; contexts CC and CA - ;; (if e3 AC AA)) ; contexts AC and AA - ;; - ;; In context CA, we know e2 must be #F - ;; In contect AC, we know e1 must be #F - ;; In context AA, we know e1 and e3 must be #F. - ;; othewise we can't glean any information. - ;; The predicates e2 and e3 have already been integrated, so there is - ;; nothing to be gained there. - (let ((context-CC operations) - (context-CA (operations/prepare-false-branch operations e2)) - (context-AC (operations/prepare-false-branch operations e1)) - (context-AA (operations/prepare-false-branch (operations/prepare-false-branch operations e1) e3))) - - (cond ((expression/never-false? e2) - (if (and (expression/always-false? e3) - (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (1)")) - ;; (if e1 (begin e2 e4) (begin e3 e5)) case 1, e2 never false, e3 always false - (integrate/conditional operations environment expression - e1 - (sequence/make #f (list e2 consequent)) - (sequence/make #f (list e3 alternative))) - (let ((e4 (integrate/expression context-CC environment consequent))) - (if (and (expression/can-duplicate? e4) - (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (2)")) - ;; (if e1 (begin e2 e4) (if e3 e4 e5)) case 2, e2 never false, e4 can be duplicated - (integrate/conditional operations environment expression - e1 - (sequence/make #f (list e2 consequent)) - (conditional/make #f e3 e4 alternative)) - (conditional/make (and expression (object/scode expression)) - integrated-predicate - e4 - (integrate/expression context-AA environment alternative)))))) - - ((expression/always-false? e2) - (let ((e5 (integrate/expression operations environment alternative))) - (cond ((and (expression/never-false? e3) - (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (3)")) - ;; (if e1 (begin e2 e5) (begin e3 e4)) case 3, e2 always false, e3 never false - (integrate/conditional operations environment expression - e1 - (sequence/make #f (list e2 e5)) - (sequence/make #f (list e3 consequent)))) - - ((and (expression/can-duplicate? e5) - (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (4)")) - ;; (if e1 (begin e2 e5) (if e3 e4 e5)) case 4, e2 always false, e5 can be duplicated - (integrate/conditional operations environment expression - e1 - (sequence/make #f (list e2 e5)) - (conditional/make #f e3 consequent e5))) - (else - ;; do nothing - (conditional/make (and expression (object/scode expression)) integrated-predicate - (integrate/expression context-AC environment consequent) - e5))))) - - ((expression/never-false? e3) - (let ((e4 (integrate/expression operations environment consequent))) - (if (and (expression/can-duplicate? e4) - (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (5)")) - ;; (if e1 (if e2 e4 e5) (begin e3 e4)) case 5, e3 never false, e4 can be duplicated - (integrate/conditional operations environment expression - e1 - (conditional/make #f e2 e4 alternative) - (sequence/make #f (list e3 e4))) - ;; do nothing - (conditional/make (and expression (object/scode expression)) integrated-predicate - e4 - (integrate/expression context-CA environment alternative))))) - - ((expression/always-false? e3) - (let ((e5 (integrate/expression operations environment alternative))) - (if (and (expression/can-duplicate? e5) - (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (6)")) - ;; (if e1 (if e2 e4 e5) (begin e3 e5)) case 6, e3 always false, e5 can be duplicated - (integrate/conditional operations environment expression - e1 - (conditional/make #f e2 consequent e5) - (sequence/make #f (list e3 e5))) - ;; do nothing - (conditional/make (and expression (object/scode expression)) integrated-predicate - (integrate/expression context-CC environment consequent) - e5)))) + ((and (expression/always-false? integrated-predicate) + (noisy-test sf:enable-conditional-folding? + "Fold constant false conditional")) + (sequence/make + (and expression (conditional/scode expression)) + (list integrated-predicate + (integrate/expression operations environment alternative)))) - (else - (let ((e4 (integrate/expression operations environment consequent)) - (e5 (integrate/expression operations environment alternative))) - (if (and (expression/can-duplicate? e4) - (expression/can-duplicate? e5) - (noisy-test sf:enable-rewrite-nested-conditional? "Rewrite nested conditional (7)")) - ;; (if e1 (if e2 e4 e5) (if e3 e4 e5)) case 7, e4 and e5 can be duplicated - (integrate/conditional operations environment expression - e1 - (conditional/make #f e2 e4 e5) - (conditional/make #f e3 e4 e5)) - ;; do nothing - (conditional/make (and expression (object/scode expression)) - integrated-predicate e4 e5)))))))) + (else + (conditional/make (and expression (conditional/scode expression)) + integrated-predicate + (integrate/expression operations environment consequent) + (integrate/expression operations environment alternative))))) ;;; CONSTANT (define-method/integrate 'CONSTANT @@ -405,8 +230,11 @@ USA. ;;; DECLARATION (define-method/integrate 'DECLARATION (lambda (operations environment declaration) - (let ((answer (integrate/expression (declarations/bind operations (declaration/declarations declaration)) - environment (declaration/expression declaration)))) + (let ((answer + (integrate/expression + (declarations/bind operations + (declaration/declarations declaration)) + environment (declaration/expression declaration)))) (if (constant? answer) answer (declaration/make @@ -433,120 +261,49 @@ USA. (disjunction/alternative expression)))) (define sf:enable-disjunction-folding? #t) -(define sf:enable-disjunction-inversion? #t) -(define sf:enable-disjunction-linearization? #t) -(define sf:enable-rewrite-conditional-in-disjunction? #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? "Folding constant true disjunction")) + (cond ((expression/call-to-not? integrated-predicate) + ;; (or (not e1) e2) => (if e1 e2 #t) + (integrate/conditional + operations environment expression + (first (combination/operands integrated-predicate)) + alternative + (constant/make #f #t))) + + ((and (expression/never-false? integrated-predicate) + (noisy-test sf:enable-disjunction-folding? + "Fold constant true disjunction")) ;; (or ) => if is never false integrated-predicate) - ((and (expression/call-to-not? integrated-predicate) - (noisy-test sf:enable-disjunction-inversion? "Inverting disjunction")) - ;; (or (not e1) e2) => (if e1 e2 #t) - (integrate/conditional operations environment expression - (first (combination/operands integrated-predicate)) - alternative - (constant/make #f #t))) - ((and (expression/always-false? integrated-predicate) - (noisy-test sf:enable-disjunction-folding? "Folding constant false disjunction")) - ;; (or ) => (begin ) if is always false + (noisy-test sf:enable-disjunction-folding? + "Fold constant false disjunction")) + ;; (or ) + ;; => (begin ) if is always false (sequence/make (and expression (object/scode expression)) (list integrated-predicate - (integrate/expression operations environment alternative)))) - - ((and (conditional? integrated-predicate) - (noisy-test sf:enable-rewrite-conditional-in-disjunction? - "Rewriting conditional within disjunction.")) - (integrate/conditional-in-disjunction - operations environment expression - integrated-predicate alternative)) - - ((and (disjunction? integrated-predicate) - (noisy-test sf:enable-disjunction-linearization? "Linearizing disjunction")) - ;; (or (or ) ) => (or (or )) - (integrate/disjunction operations environment expression - (disjunction/predicate integrated-predicate) - (disjunction/make #f (disjunction/alternative integrated-predicate) alternative))) + (integrate/expression + operations environment alternative)))) ((sequence? integrated-predicate) - (sequence/make (and expression (object/scode expression)) - (append (except-last-pair (sequence/actions integrated-predicate)) - (list (integrate/disjunction operations environment #f - (last (sequence/actions integrated-predicate)) - alternative))))) + (sequence/make + (and expression (object/scode expression)) + (append (except-last-pair (sequence/actions integrated-predicate)) + (list (integrate/disjunction + operations environment #f + (last (sequence/actions integrated-predicate)) + alternative))))) (else (disjunction/make (and expression (object/scode expression)) integrated-predicate (integrate/expression - (operations/prepare-false-branch operations integrated-predicate) + operations environment alternative))))) -(define (integrate/conditional-in-disjunction operations environment expression - integrated-predicate alternative) - (let ((e1 (conditional/predicate integrated-predicate)) - (e2 (conditional/consequent integrated-predicate)) - (e3 (conditional/alternative integrated-predicate))) - - ;; (or (if e1 e2 e3) alternative) => - ;; (if e1 (or e2 alternative) (or e3 alternative)) - ;; provided alternative can be duplicated, or e2 or e3 are - ;; such that alternative doesn't need to be duplicated. - ;; - ;; e1 e2 and e3 have been integrated, alternative has not. - - (cond ((expression/never-false? e2) - ;; If e2 is never false, then we can rewrite like this: - ;; (if e1 e2 (or e3 alternative)) - (integrate/conditional operations environment expression - e1 - e2 - (disjunction/make #f e3 alternative))) - - ((expression/never-false? e3) - ;; If e3 is never false, then we can rewrite like this: - ;; (if e1 (or e2 alternative) e3) - (integrate/conditional operations environment expression - e1 - (disjunction/make #f e2 alternative) - e3)) - (else - ;; See if we can duplicate the alternative. - (let ((e4 (integrate/expression operations environment alternative))) - (if (expression/can-duplicate? e4) - (integrate/conditional operations environment expression - e1 - (disjunction/make #f e2 e4) - (disjunction/make #f e3 e4)) - ;; can't rewrite. - (disjunction/make (and expression (object/scode expression)) - integrated-predicate - e4))))))) - -(define (operations/prepare-false-branch operations expression) - (if (and (reference? expression) - (variable/safely-integrable? (reference/variable expression) operations) - (noisy-test sf:enable-conditional-propagation? "Propagating conditional information.")) - (operations/bind-to-false operations expression) - operations)) - -;; Make an entry in the operations table to integrate -;; the variable as #F. Used in the false branch of -;; conditionals. -(define (operations/bind-to-false operations reference) - (operations/bind operations - 'INTEGRATE - (reference/variable reference) - (make-integration-info (constant/make #f #F)))) - ;;; OPEN-BLOCK (define-method/integrate 'OPEN-BLOCK (lambda (operations environment expression) @@ -775,19 +532,19 @@ USA. (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 + (operations/bind operations 'INTEGRATE variable (make-integration-info value))) ((procedure? value) - (let ((info (expression/free-variable-info body variable)) - (size (expression/size value))) + (let ((info (expression/free-variable-info body variable))) ;; Avoid exponential code explosion. ;; The *parser code gets out of control if you don't limit this. - (if (and (zero? (cdr info)) - (or (= (car info) 1) - (and (> (car info) 1) - (< (* size (car info)) 500))) + (if (and (fix:zero? (cdr info)) ; No argument references + (or (fix:= (car info) 1) ; Exactly one operator use + (and (fix:> (car info) 1) + (< (* (expression/size value) (car info)) 500))) (noisy-test sf:enable-safe-integration? "Safe declarations")) - (operations/bind operations 'INTEGRATE-OPERATOR variable (make-integration-info value)) + (operations/bind operations 'INTEGRATE-OPERATOR variable + (make-integration-info value)) operations))) (else operations))) @@ -880,28 +637,12 @@ USA. (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? "Eliding double negative")) + (expression/boolean? + (first (combination/operands (first operands)))) + (noisy-test sf:enable-elide-double-negatives? + "Elide 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)) @@ -911,9 +652,11 @@ USA. 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))))) + (integrate-combination/default expression operations environment + block operator operands))))) (define (integrate/primitive-operator expression operations environment block operator operands) @@ -938,7 +681,8 @@ USA. ;;; disjunction-operator (define-method/integrate-combination 'DISJUNCTION (lambda (expression operations environment block operator operands) - (integrate-combination/default expression operations environment block operator operands))) + (integrate-combination/default expression operations environment + block operator operands))) ;;; open-block-operator (define-method/integrate-combination 'OPEN-BLOCK @@ -950,7 +694,8 @@ USA. ;;; procedure-operator (let) (define-method/integrate-combination 'PROCEDURE (lambda (expression operations environment block operator operands) - (integrate-combination/default expression operations environment block operator operands))) + (integrate-combination/default expression operations environment + block operator operands))) (define (integrate/procedure-operator operations environment block procedure operands) @@ -962,7 +707,8 @@ USA. ;;; quotation-operator (define-method/integrate-combination 'QUOTATION (lambda (expression operations environment block operator operands) - (integrate-combination/default expression operations environment block operator operands))) + (integrate-combination/default expression operations environment + block operator operands))) ;;; reference-operator (define-method/integrate-combination 'REFERENCE @@ -1012,13 +758,14 @@ USA. (else (error "Unknown operation" operation)))) - (lambda () - (integration-failure)))))) + (lambda () + (integration-failure)))))) ;;; sequence-operator (define-method/integrate-combination 'SEQUENCE (lambda (expression operations environment block operator operands) - (integrate-combination/default expression operations environment block operator operands))) + (integrate-combination/default expression operations environment + block operator operands))) ;;; the-environment-operator (define-method/integrate-combination 'THE-ENVIRONMENT