(declare (usual-integrations)
(integrate-external "object"))
\f
+;;; EXPRESSION/ALWAYS-FALSE?
+
+;; True iff expression can be shown to always return #F.
+;; That is, the expression counts as #f to a conditional.
+;; Expression is not shown to be side-effect free.
+(declare (integrate-operator expression/always-false?))
+(define (expression/always-false? expression)
+ ((expression/method always-false?-dispatch-vector expression) expression))
+
+(define always-false?-dispatch-vector
+ (expression/make-dispatch-vector))
+
+(define define-method/always-false?
+ (expression/make-method-definer always-false?-dispatch-vector))
+
+(define-method/always-false? 'ACCESS false-procedure)
+
+(define-method/always-false? 'ASSIGNMENT false-procedure)
+
+(define-method/always-false? 'COMBINATION
+ (lambda (expression)
+ (cond ((expression/call-to-not? expression)
+ (expression/never-false? (first (combination/operands expression))))
+ ((procedure? (combination/operator expression))
+ (expression/always-false? (procedure/body (combination/operator expression))))
+ (else #f))))
+
+(define-method/always-false? 'CONDITIONAL
+ (lambda (expression)
+ (and (or (expression/always-false? (conditional/predicate expression))
+ (expression/always-false? (conditional/consequent expression)))
+ (or (expression/never-false? (conditional/predicate expression))
+ (expression/always-false? (conditional/alternative expression))))))
+
+(define-method/always-false? 'CONSTANT
+ (lambda (expression)
+ (not (constant/value expression))))
+
+(define-method/always-false? 'DECLARATION
+ (lambda (expression)
+ (expression/always-false?
+ (declaration/expression expression))))
+
+;; A promise is not a false value.
+(define-method/always-false? 'DELAY false-procedure)
+
+(define-method/always-false? 'DISJUNCTION
+ (lambda (expression)
+ (and (expression/always-false? (disjunction/predicate expression))
+ (expression/always-false? (disjunction/alternative expression)))))
+
+(define-method/always-false? 'OPEN-BLOCK
+ (lambda (expression)
+ (expression/always-false?
+ (open-block/actions expression))))
+
+;; A closure is not a false value.
+(define-method/always-false? 'PROCEDURE false-procedure)
+
+(define-method/always-false? 'QUOTATION false-procedure)
+
+(define-method/always-false? 'REFERENCE false-procedure)
+
+(define-method/always-false? 'SEQUENCE
+ (lambda (expression)
+ (expression/always-false?
+ (last (sequence/actions expression)))))
+
+(define-method/always-false? 'THE-ENVIRONMENT false-procedure)
+\f
+;;; EXPRESSION/BOOLEAN?
+;;
+;; T if expression can be shown to return only #T or #F.
+;;
+(declare (integrate-operator expression/boolean?))
+(define (expression/boolean? expression)
+ ((expression/method boolean?-dispatch-vector expression) expression))
+
+(define boolean?-dispatch-vector
+ (expression/make-dispatch-vector))
+
+(define define-method/boolean?
+ (expression/make-method-definer boolean?-dispatch-vector))
+
+(define-method/boolean? 'ACCESS false-procedure)
+
+(define-method/boolean? 'ASSIGNMENT false-procedure)
+
+(define-method/boolean? 'COMBINATION
+ (lambda (expression)
+ (or (expression/call-to-boolean-predicate? expression)
+ (and (procedure? (combination/operator expression))
+ (boolean? (procedure/body (combination/operator expression)))))))
+
+(define-method/boolean? 'CONDITIONAL
+ (lambda (expression)
+ (and (or (expression/always-false? (conditional/predicate expression))
+ (expression/boolean? (conditional/consequent expression)))
+ (or (expression/never-false? (conditional/predicate expression))
+ (expression/boolean? (conditional/alternative expression))))))
+
+(define-method/boolean? 'CONSTANT
+ (lambda (expression)
+ ;; jrm: do not accept unspecific here.
+ (or (not (constant/value expression))
+ (eq? (constant/value expression) #t))))
+
+(define-method/boolean? 'DECLARATION
+ (lambda (expression)
+ (expression/boolean? (declaration/expression expression))))
+
+(define-method/boolean? 'DELAY false-procedure)
+
+(define-method/boolean? 'DISJUNCTION
+ (lambda (expression)
+ (and (expression/boolean? (disjunction/predicate expression))
+ (or (expression/never-false? (disjunction/predicate expression))
+ (expression/boolean? (disjunction/alternative expression))))))
+
+(define-method/boolean? 'OPEN-BLOCK
+ (lambda (expression)
+ (expression/boolean? (open-block/actions expression))))
+
+(define-method/boolean? 'PROCEDURE false-procedure)
+
+(define-method/boolean? 'QUOTATION false-procedure)
+
+(define-method/boolean? 'REFERENCE false-procedure)
+
+(define-method/boolean? 'SEQUENCE
+ (lambda (expression)
+ (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?
+;;
+;; True iff evaluation of expression has no side effects.
+(declare (integrate-operator expression/effect-free?))
+(define (expression/effect-free? expression)
+ ((expression/method effect-free?-dispatch-vector expression) expression))
+
+(define effect-free?-dispatch-vector
+ (expression/make-dispatch-vector))
+
+(define define-method/effect-free?
+ (expression/make-method-definer effect-free?-dispatch-vector))
+
+(define-method/effect-free? 'ACCESS
+ (lambda (expression)
+ (expression/effect-free? (access/environment expression))))
+
+(define-method/effect-free? 'ASSIGNMENT false-procedure)
+
+(define-method/effect-free? 'COMBINATION
+ (lambda (expression)
+ (and (for-all? (combination/operands expression) expression/effect-free?)
+ (or (expression/call-to-effect-free-primitive? expression)
+ (and (procedure? (combination/operator expression))
+ (expression/effect-free? (procedure/body (combination/operator expression))))))))
+
+(define-method/effect-free? 'CONDITIONAL
+ (lambda (expression)
+ (and (expression/effect-free? (conditional/predicate expression))
+ (or (expression/always-false? (conditional/predicate expression))
+ (expression/effect-free? (conditional/consequent expression)))
+ (or (expression/never-false? (conditional/predicate expression))
+ (expression/effect-free? (conditional/alternative expression))))))
+
+(define-method/effect-free? 'CONSTANT true-procedure)
+
+(define-method/effect-free? 'DECLARATION
+ (lambda (expression)
+ (expression/effect-free? (declaration/expression expression))))
+
+;; Consing a promise is not considered an effect.
+(define-method/effect-free? 'DELAY true-procedure)
+
+(define-method/effect-free? 'DISJUNCTION
+ (lambda (expression)
+ (and (expression/effect-free? (disjunction/predicate expression))
+ (or (expression/never-false? (disjunction/predicate expression))
+ (expression/effect-free? (disjunction/alternative expression))))))
+
+;; This could be smarter and skip the assignments
+;; done for the letrec, but it is easier to just
+;; assume it causes effects.
+(define-method/effect-free? 'OPEN-BLOCK
+ (lambda (expression)
+ (declare (ignore expression))
+ #f))
+
+;; Just consing a closure is not considered a side-effect.
+(define-method/effect-free? 'PROCEDURE true-procedure)
+
+(define-method/effect-free? 'QUOTATION false-procedure)
+
+(define-method/effect-free? 'REFERENCE true-procedure)
+
+(define-method/effect-free? 'SEQUENCE
+ (lambda (expression)
+ (for-all? (sequence/actions expression) expression/effect-free?)))
+
+(define-method/effect-free? 'THE-ENVIRONMENT true-procedure)
+\f
;;; EXPRESSION/FREE-VARIABLES
;;
;; Returns an EQ? LSET of the free variables in an expression.
(sequence/actions expression))))
(define-method/free-variable? 'THE-ENVIRONMENT false-procedure)
+\f
+;;; EXPRESSION/NEVER-FALSE?
+;;
+;; True iff expression can be shown to never return #F.
+;; That is, the expression counts as #t to a conditional.
+;; Expression is not shown to be side-effect free.
+(declare (integrate-operator expression/never-false?))
+(define (expression/never-false? expression)
+ ((expression/method never-false?-dispatch-vector expression) expression))
+
+(define never-false?-dispatch-vector
+ (expression/make-dispatch-vector))
+
+(define define-method/never-false?
+ (expression/make-method-definer never-false?-dispatch-vector))
+
+(define-method/never-false? 'ACCESS false-procedure)
+
+(define-method/never-false? 'ASSIGNMENT false-procedure)
+
+(define-method/never-false? 'COMBINATION
+ (lambda (expression)
+ (cond ((expression/call-to-not? expression)
+ (expression/always-false? (first (combination/operands expression))))
+ ((procedure? (combination/operator expression))
+ (expression/never-false? (procedure/body (combination/operator expression))))
+ (else #f))))
+
+(define-method/never-false? 'CONDITIONAL
+ (lambda (expression)
+ (and (or (expression/always-false? (conditional/predicate expression))
+ (expression/never-false? (conditional/consequent expression)))
+ (or (expression/never-false? (conditional/predicate expression))
+ (expression/never-false? (conditional/alternative expression))))))
+
+(define-method/never-false? 'CONSTANT constant/value)
+
+(define-method/never-false? 'DECLARATION
+ (lambda (expression)
+ (expression/never-false? (declaration/expression expression))))
+
+(define-method/never-false? 'DELAY true-procedure)
+
+(define-method/never-false? 'DISJUNCTION
+ (lambda (expression)
+ (or (expression/never-false? (disjunction/predicate expression))
+ (expression/never-false? (disjunction/alternative expression)))))
+
+(define-method/never-false? 'OPEN-BLOCK
+ (lambda (expression)
+ (expression/never-false? (open-block/actions expression))))
+
+(define-method/never-false? 'PROCEDURE true-procedure)
+
+(define-method/never-false? 'QUOTATION false-procedure)
+
+(define-method/never-false? 'REFERENCE false-procedure)
+
+(define-method/never-false? 'SEQUENCE
+ (lambda (expression)
+ (expression/never-false? (last (sequence/actions expression)))))
+
+(define-method/never-false? 'THE-ENVIRONMENT true-procedure)
+
;;; Helpers for expressions
-;; True iff expression can be shown to always return #F.
-;; That is, the expression counts as #f to a conditional.
-(define (expression/always-false? expression)
- (cond ((combination? expression)
- (cond ((expression/call-to-not? expression)
- (expression/never-false? (first (combination/operands expression))))
- ((procedure? (combination/operator expression))
- (expression/always-false? (procedure/body (combination/operator expression))))
- (else #f)))
-
- ((conditional? expression)
- (and (or (expression/always-false? (conditional/predicate expression))
- (expression/always-false? (conditional/consequent expression)))
- (or (expression/never-false? (conditional/predicate expression))
- (expression/always-false? (conditional/alternative expression)))))
-
- ((constant? expression) (not (constant/value expression)))
-
- ((declaration? expression)
- (expression/always-false? (declaration/expression expression)))
-
- ((disjunction? expression)
- (and (expression/always-false? (disjunction/predicate expression))
- (expression/always-false? (disjunction/alternative expression))))
-
- ((sequence? expression)
- (expression/always-false? (last (sequence/actions expression))))
-
- (else #f)))
-
-;; T if expression can be shown to return only #T or #F.
-(define (expression/boolean? expression)
- (cond ((expression/call-to-boolean-predicate? expression))
-
- ((conditional? expression)
- (and (or (expression/always-false? (conditional/predicate expression))
- (expression/boolean? (conditional/consequent expression)))
- (or (expression/never-false? (conditional/predicate expression))
- (expression/boolean? (conditional/alternative expression)))))
-
- ((constant? expression)
- (or (not (constant/value expression))
- (eq? (constant/value expression) #t)))
-
- ((declaration? expression)
- (expression/boolean? (declaration/expression expression)))
-
- ((disjunction? expression)
- (and (expression/boolean? (disjunction/predicate expression))
- (or (expression/never-false? (disjunction/predicate expression))
- (expression/boolean? (conditional/alternative expression)))))
-
- ((sequence? expression) (expression/boolean? (last (sequence/actions expression))))
-
- (else #f)))
-
-;; True iff evaluation of expression has no side effects.
-(define (expression/effect-free? expression)
- (cond ((access? expression)
- (expression/effect-free? (access/environment expression)))
-
- ((combination? expression)
- (and (for-all? (combination/operands expression) expression/effect-free?)
- (or (expression/call-to-effect-free-primitive? expression)
- (and (procedure? (combination/operator expression))
- (expression/effect-free? (procedure/body (combination/operator expression)))))))
-
- ((conditional? expression)
- (and (expression/effect-free? (conditional/predicate expression))
- (or (expression/always-false? (conditional/predicate expression))
- (expression/effect-free? (conditional/consequent expression)))
- (or (expression/never-false? (conditional/predicate expression))
- (expression/effect-free? (conditional/alternative expression)))))
-
- ((constant? expression) #t)
-
- ((declaration? expression)
- (expression/effect-free? (declaration/expression expression)))
-
- ((delay? expression) #t)
-
- ((disjunction? expression)
- (and (expression/effect-free? (disjunction/predicate expression))
- (or (expression/never-false? (disjunction/predicate expression))
- (expression/effect-free? (disjunction/alternative expression)))))
-
- ((procedure? expression) #t)
-
- ((sequence? expression)
- (for-all? (sequence/actions expression) expression/effect-free?))
-
- ((reference? expression) #t)
-
- (else #f)))
-
-;; True iff expression can be shown to never return #F.
-;; That is, the expression counts as #t to a conditional.
-(define (expression/never-false? expression)
- (cond ((combination? expression)
- (cond ((expression/call-to-not? expression)
- (expression/always-false? (first (combination/operands expression))))
- ((procedure? (combination/operator expression))
- (expression/never-false? (procedure/body (combination/operator expression))))
- (else #f)))
-
- ((conditional? expression)
- (and (or (expression/always-false? (conditional/predicate expression))
- (expression/never-false? (conditional/consequent expression)))
- (or (expression/never-false? (conditional/predicate expression))
- (expression/never-false? (conditional/alternative expression)))))
-
- ((constant? expression) (constant/value expression))
-
- ((declaration? expression)
- (expression/never-false? (declaration/expression expression)))
-
- ((disjunction? expression)
- (or (expression/never-false? (disjunction/predicate expression))
- (expression/never-false? (disjunction/alternative expression))))
-
- ((sequence? expression)
- (expression/never-false? (last (sequence/actions expression))))
-
- (else #f)))
-
;; The primitive predicates that only return #T or #F.
(define primitive-boolean-predicates
(map (lambda (name)
(eq? (constant/value expression) unspecific)
(noisy-test sf:enable-true-unspecific? "Enable true unspecific")))
-;; 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, so don't worry about
-;; cranking it up. The code will be correct, but it will get larger.
-(define sf:maximum-duplicate-expression-size 16)
-
-(define (expression/can-duplicate? expression)
- (define (descend size subexpression)
- (cond ((>= size sf:maximum-duplicate-expression-size) size)
-
- ((combination? subexpression)
- (fold-left descend
- (descend (+ size 1) (combination/operator subexpression))
- (combination/operands subexpression)))
-
- ((conditional? subexpression)
- (descend
- (cond ((expression/always-false? (conditional/predicate subexpression))
- (descend (+ size 1) (conditional/alternative subexpression)))
- ((expression/never-false? (conditional/predicate subexpression))
- (descend (+ size 1) (conditional/consequent subexpression)))
- (else
- (descend (descend (+ size 1) (conditional/consequent subexpression))
- (conditional/alternative subexpression))))
- (conditional/predicate subexpression)))
-
- ((constant? subexpression) (+ size 0))
-
- ((declaration? subexpression)
- (descend (+ size 1) (declaration/expression subexpression)))
-
- ((disjunction? subexpression)
- (descend
- (if (expression/never-false? (disjunction/predicate subexpression))
- (+ size 1)
- (descend (+ size 1) (disjunction/alternative subexpression)))
- (disjunction/predicate subexpression)))
-
- ((and (reference? subexpression)
- (not (variable/side-effected (reference/variable subexpression))))
- (+ size 1))
-
- ((sequence? subexpression)
- (fold-left descend
- (+ size 1)
- (sequence/actions subexpression)))
-
- (else (+ size sf:maximum-duplicate-expression-size))))
- (< (descend 0 expression) sf:maximum-duplicate-expression-size))
-
(define-integrable (global-ref/make name)
(access/make #f
(constant/make #f system-global-environment)
projects / mit-scheme.git / commitdiff