From f1ccb928361f104c7ed17b5310706f014f7be311 Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Mon, 8 Mar 2010 12:32:20 -0800 Subject: [PATCH] Move several routines from object.scm to analyze.scm and rewrite using dispatch-vector mechanism. --- src/sf/analyze.scm | 380 +++++++++++++++++++++++++++++++++++++++++++++ src/sf/object.scm | 186 ---------------------- src/sf/sf.pkg | 8 +- 3 files changed, 387 insertions(+), 187 deletions(-) diff --git a/src/sf/analyze.scm b/src/sf/analyze.scm index cdab38b27..9ea6cf02f 100644 --- a/src/sf/analyze.scm +++ b/src/sf/analyze.scm @@ -29,6 +29,322 @@ USA. (declare (usual-integrations) (integrate-external "object")) +;;; 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) + +;;; 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) + +;; 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? +;; +;; 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) + ;;; EXPRESSION/FREE-VARIABLES ;; ;; Returns an EQ? LSET of the free variables in an expression. @@ -232,3 +548,67 @@ USA. (sequence/actions expression)))) (define-method/free-variable? 'THE-ENVIRONMENT false-procedure) + +;;; 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) + diff --git a/src/sf/object.scm b/src/sf/object.scm index 279d78c2f..b020cbf79 100644 --- a/src/sf/object.scm +++ b/src/sf/object.scm @@ -220,131 +220,6 @@ USA. ;;; 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) @@ -463,67 +338,6 @@ USA. (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) diff --git a/src/sf/sf.pkg b/src/sf/sf.pkg index 50b27aad7..f768e4a51 100644 --- a/src/sf/sf.pkg +++ b/src/sf/sf.pkg @@ -148,8 +148,14 @@ USA. (files "analyze") (parent (scode-optimizer)) (export (scode-optimizer) + expression/always-false? + expression/boolean? + expression/can-duplicate? + expression/effect-free? expression/free-variable? - expression/free-variables)) + expression/free-variables + expression/never-false? + sf:maximum-duplicate-expression-size)) (define-package (scode-optimizer change-type) (files "chtype") -- 2.25.1