(expression/boolean? (last (sequence/actions expression)))))
(define-method/boolean? 'THE-ENVIRONMENT false-procedure)
-\f
-;; 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)
-
\f
;;; EXPRESSION/EFFECT-FREE?
;;
(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
(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
(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)
(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)
(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)
(define-method/size 'SEQUENCE
(lambda (expression)
(fold-left (lambda (total action)
- (+ total (expression/size action)))
+ (fix:+ total (expression/size action)))
1
(sequence/actions expression))))
-\f
-;; 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")))
-\f
-;;; 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
(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))
;; 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
(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
;; 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
'()
#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))))
(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 <exp> #f #t) => (not <exp>)
- ;; 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
(combination/operands combination)))))
;;;; CONDITIONAL
-
(define-method/integrate 'CONDITIONAL
(lambda (operations environment expression)
(integrate/conditional operations environment expression
(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 <e1>) <e2> <e3>) => (if <e1> <e3> <e2>)
- (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
;;; 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
(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 <exp1> <exp2>) => <exp1> if <exp1> 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 <exp1> <exp2>) => (begin <exp1> <exp2>) if <exp1> is always false
+ (noisy-test sf:enable-disjunction-folding?
+ "Fold constant false disjunction"))
+ ;; (or <exp1> <exp2>)
+ ;; => (begin <exp1> <exp2>) if <exp1> 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 <e1> <e2>) <e3>) => (or <e1> (or <e2> <e3>))
- (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)
(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)))
\f
(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))
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)
;;; 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
;;; 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)
;;; 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
(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
projects / mit-scheme.git / commitdiff