diff options
Diffstat (limited to 'backend/box.scm')
| -rw-r--r-- | backend/box.scm | 417 |
1 files changed, 417 insertions, 0 deletions
diff --git a/backend/box.scm b/backend/box.scm new file mode 100644 index 0000000..c47848a --- /dev/null +++ b/backend/box.scm @@ -0,0 +1,417 @@ +;;; box.scm -- determine which expressions need to be boxed +;;; +;;; author : Sandra Loosemore +;;; date : 03 Apr 1993 +;;; +;;; +;;; This phase determines whether expressions need to be boxed or unboxed. +;;; +;;; In the case of an expression that needs to be boxed, it determines +;;; whether it can be evaluated eagerly and boxed or whether a delay +;;; must be constructed. +;;; +;;; In the case of an expression that needs to be unboxed, it determines +;;; whether it is already known to have been evaluated and can simply +;;; be unboxed instead of checking for a delay that must be forced. +;;; +;;; This phase may mark previously non-strict variables as strict if their +;;; initializers can be evaluated eagerly. However, doing this evaluation +;;; eagerly never causes any other non-strict variables to be forced, +;;; so there is no need to propagate this strictness information backwards +;;; (as happens in the var-strictness-walk pass). + + +;;;====================================================================== +;;; Top-level function +;;;====================================================================== + + +;;; Complexity computation + +(define-integrable delay-complexity 10) +(define-integrable unbox-complexity 1) +(define-integrable box-complexity 2) +(define-integrable sel-complexity 1) +(define-integrable is-constructor-complexity 1) +(define-integrable pack-complexity 2) +(define-integrable con-number-complexity 1) + +(define (add-complexity c1 c2) + (cond ((not c1) + '#f) + ((not c2) + '#f) + (else + ;; *** We might want to establish an arbitrary cutoff here. + ;; *** e.g., if complexity > N then set it to '#f. + (the fixnum (+ (the fixnum c1) (the fixnum c2)))))) + + + +;;; The second argument to the walker is a list of things +;;; that are known to have been forced already. +;;; The third argument is a list of variables that have not yet +;;; been initialized. +;;; Walkers return two values: a new value for already-forced and +;;; the complexity of the expression. + +;;; This helper function sets the unboxed? and cheap? bits for the +;;; code generator, and adjusts the basic complexity to account for +;;; forces, boxes, and delays. +;;; +;;; The basic decision tree for the code generator should be: +;;; if unboxed? +;;; then if strict-result? +;;; then generate x (1) +;;; else if cheap? +;;; then generate (unbox x) (2) +;;; else generate (force x) (3) +;;; else if strict-result? +;;; then if cheap? +;;; then generate (box x) (4) +;;; else generate (delay x) (5) +;;; else if cheap? +;;; then generate x (6) +;;; then generate (delay (force x)) (7) +;;; See function do-codegen in codegen.scm. + + +(define (do-box-analysis object already-forced uninitialized unboxed?) + (setf (flic-exp-unboxed? object) unboxed?) + (multiple-value-bind (result complexity) + (box-analysis object already-forced uninitialized) + (setf complexity + (if unboxed? + ;; If the expression returns a boxed value and we want + ;; an unboxed one, we may need to do a force. + (if (flic-exp-strict-result? object) + (begin ; case (1) + ;; this flic-exp-cheap? bit is used only by + ;; exp-would-be-cheap? below -- not by codegen + (setf (flic-exp-cheap? object) + (if complexity '#t '#f)) + complexity) + (if (already-forced? object already-forced) + (begin ; case (2) + (setf (flic-exp-cheap? object) '#t) + (add-complexity complexity unbox-complexity)) + (begin ; case (3) + (setf (flic-exp-cheap? object) '#f) + '#f))) + ;; We want a boxed value. If the expression already + ;; returns a boxed value, return its complexity directly; + ;; otherwise return the cost of either boxing or delaying it. + (if (flic-exp-strict-result? object) + (if complexity + (begin ; case (4) + (setf (flic-exp-cheap? object) '#t) + (add-complexity complexity box-complexity)) + (begin ; case (5) + (setf (flic-exp-cheap? object) '#f) + delay-complexity)) + (if complexity + (begin + (setf (flic-exp-cheap? object) '#t) ; case (6) + complexity) + (begin ; case (7) + (setf (flic-exp-cheap? object) '#f) + delay-complexity))) + )) + (values + (if unboxed? + (note-already-forced object result) + result) + complexity))) + + + + +;;;====================================================================== +;;; Code walk +;;;====================================================================== + + +(define *local-function-calls* '()) + +(define-flic-walker box-analysis (object already-forced uninitialized)) + +(define-box-analysis flic-lambda (object already-forced uninitialized) + (do-box-analysis (flic-lambda-body object) already-forced uninitialized '#t) + (values already-forced 0)) + +(define-box-analysis flic-let (object already-forced uninitialized) + (let ((bindings (flic-let-bindings object))) + (dynamic-let ((*local-function-calls* (dynamic *local-function-calls*))) + (dolist (var bindings) + ;; Note local functions + (when (and (not (var-toplevel? var)) + (is-type? 'flic-lambda (var-value var)) + (not (var-standard-refs? var))) + (push (cons var '()) (dynamic *local-function-calls*)))) + (multiple-value-bind (already-forced complexity) + (box-analysis-let-aux object already-forced uninitialized) + (dolist (var bindings) + ;; Go back and reexamine local functions to see whether + ;; we can make more arguments strict, based on the values + ;; the function is actually called with. + (let ((stuff (assq var (dynamic *local-function-calls*)))) + (when stuff + (maybe-make-more-arguments-strict var (cdr stuff))))) + (values already-forced complexity))))) + +(define (box-analysis-let-aux object already-forced uninitialized) + (let ((recursive? (flic-let-recursive? object)) + (bindings (flic-let-bindings object)) + (body (flic-let-body object))) + (when recursive? (setf uninitialized (append bindings uninitialized))) + (dolist (var bindings) + (let* ((value (var-value var)) + (strict? (var-strict? var)) + (result (do-box-analysis value already-forced uninitialized + strict?))) + (cond (strict? + ;; Propagate information about things forced. + (setf already-forced result)) + ((and (flic-exp-cheap? value) + (flic-exp-strict-result? value)) + ;; The value expression is cheap unboxed value, so mark + ;; the variable as strict. + (setf (var-strict? var) '#t) + (setf (flic-exp-unboxed? value) '#t)))) + (when recursive? (pop uninitialized))) + ;; *** Could be smarter about computing complexity. + (values + (do-box-analysis body already-forced uninitialized '#t) + '#f))) + +(define (maybe-make-more-arguments-strict var calls) + (setf (var-strictness var) + (maybe-make-more-arguments-strict-aux + (flic-lambda-vars (var-value var)) + calls))) + +(define (maybe-make-more-arguments-strict-aux vars calls) + (if (null? vars) + '() + (let ((var (car vars))) + ;; If the variable is not already strict, check to see + ;; whether it's always called with "cheap" arguments. + (when (and (not (var-strict? var)) + (every-1 (lambda (call) + (exp-would-be-cheap? (car call) var)) + calls)) + (setf (var-strict? var) '#t) + (dolist (call calls) + (setf (flic-exp-unboxed? (car call)) '#t))) + (cons (var-strict? var) + (maybe-make-more-arguments-strict-aux + (cdr vars) + (map (function cdr) calls)))) + )) + + +;;; Look for one special fixed-point case: argument used as counter-type +;;; variable. Otherwise ignore fixed points. + +(define (exp-would-be-cheap? exp var) + (or (and (flic-exp-cheap? exp) + (flic-exp-strict-result? exp)) + (and (is-type? 'flic-ref exp) + (eq? (flic-ref-var exp) var)) + (and (is-type? 'flic-app exp) + (is-type? 'flic-ref (flic-app-fn exp)) + (var-complexity (flic-ref-var (flic-app-fn exp))) + (every-1 (lambda (a) (exp-would-be-cheap? a var)) + (flic-app-args exp))) + )) + + + +(define-box-analysis flic-app (object already-forced uninitialized) + (let ((fn (flic-app-fn object)) + (args (flic-app-args object)) + (saturated? (flic-app-saturated? object))) + (cond ((and saturated? (is-type? 'flic-ref fn)) + (let* ((var (flic-ref-var fn)) + (stuff (assq var (dynamic *local-function-calls*)))) + (when stuff + (push args (cdr stuff))) + (box-analysis-app-aux + (var-strictness var) (var-complexity var) + args already-forced uninitialized))) + ((and saturated? (is-type? 'flic-pack fn)) + (box-analysis-app-aux + (con-slot-strict? (flic-pack-con fn)) pack-complexity + args already-forced uninitialized)) + (else + ;; The function is going to be forced but all the arguments + ;; are non-strict. + (dolist (a args) + (do-box-analysis a already-forced uninitialized '#f)) + (values + (do-box-analysis fn already-forced uninitialized '#t) + '#f)) + ))) + + + +;;; Propagation of already-forced information depends on whether or +;;; not the implementation evaluates function arguments in left-to-right +;;; order. If not, we can still propagate this information upwards. + +(define (box-analysis-app-aux + strictness complexity args already-forced uninitialized) + (let ((result already-forced)) + (dolist (a args) + (let ((strict? (pop strictness))) + (multiple-value-bind (new-result new-complexity) + (do-box-analysis a already-forced uninitialized strict?) + (when strict? + (setf result + (if left-to-right-evaluation + (setf already-forced new-result) + (union-already-forced + new-result already-forced result)))) + (setf complexity (add-complexity complexity new-complexity))))) + (values result complexity))) + + +(define-box-analysis flic-ref (object already-forced uninitialized) + (values + already-forced + (if (memq (flic-ref-var object) uninitialized) + '#f + 0))) + +(define-box-analysis flic-const (object already-forced uninitialized) + (declare (ignore object uninitialized)) + (values already-forced 0)) + +(define-box-analysis flic-pack (object already-forced uninitialized) + (declare (ignore object uninitialized)) + (values already-forced 0)) + + +;;; For case-block and and, already-forced information can be propagated +;;; sequentially in the clauses. But only the first expression is +;;; guaranteed to be evaluated, so only it can propagate the information +;;; outwards. + +(define-box-analysis flic-case-block (object already-forced uninitialized) + (values + (box-analysis-sequence + (flic-case-block-exps object) already-forced uninitialized) + '#f)) + +(define-box-analysis flic-and (object already-forced uninitialized) + (values + (box-analysis-sequence + (flic-and-exps object) already-forced uninitialized) + '#f)) + +(define (box-analysis-sequence exps already-forced uninitialized) + (let ((result + (setf already-forced + (do-box-analysis + (car exps) already-forced uninitialized '#t)))) + (dolist (e (cdr exps)) + (setf already-forced + (do-box-analysis e already-forced uninitialized '#t))) + (values result already-forced))) + + +(define-box-analysis flic-return-from (object already-forced uninitialized) + (values + (do-box-analysis + (flic-return-from-exp object) already-forced uninitialized '#t) + '#f)) + + +;;; For if, the test propagates to both branches and the result. +;;; Look for an important optimization: +;;; in (if (and e1 e2 ...) e-then e-else), +;;; e-then can inherit already-forced information from all of the ei +;;; rather than only from e1. +;;; *** Could be smarter about the complexity, I suppose.... +;;; *** Also could intersect already-forced results from both +;;; *** branches. + +(define-box-analysis flic-if (object already-forced uninitialized) + (if (is-type? 'flic-and (flic-if-test-exp object)) + (box-analysis-if-and-aux object already-forced uninitialized) + (box-analysis-if-other-aux object already-forced uninitialized))) + +(define (box-analysis-if-other-aux object already-forced uninitialized) + (setf already-forced + (do-box-analysis + (flic-if-test-exp object) already-forced uninitialized '#t)) + (do-box-analysis (flic-if-then-exp object) already-forced uninitialized '#t) + (do-box-analysis (flic-if-else-exp object) already-forced uninitialized '#t) + (values already-forced '#f)) + +(define (box-analysis-if-and-aux object already-forced uninitialized) + (let* ((test-exp (flic-if-test-exp object)) + (subexps (flic-and-exps test-exp)) + (then-exp (flic-if-then-exp object)) + (else-exp (flic-if-else-exp object))) + (setf (flic-exp-unboxed? test-exp) '#t) + (multiple-value-bind (result1 resultn) + (box-analysis-sequence subexps already-forced uninitialized) + (do-box-analysis then-exp resultn uninitialized '#t) + (do-box-analysis else-exp result1 uninitialized '#t) + (values result1 '#f)))) + + +(define-box-analysis flic-sel (object already-forced uninitialized) + (multiple-value-bind (result complexity) + (do-box-analysis + (flic-sel-exp object) already-forced uninitialized '#t) + (values result (add-complexity sel-complexity complexity)))) + +(define-box-analysis flic-is-constructor (object already-forced uninitialized) + (multiple-value-bind (result complexity) + (do-box-analysis + (flic-is-constructor-exp object) already-forced uninitialized '#t) + (values result (add-complexity is-constructor-complexity complexity)))) + +(define-box-analysis flic-con-number (object already-forced uninitialized) + (multiple-value-bind (result complexity) + (do-box-analysis + (flic-con-number-exp object) already-forced uninitialized '#t) + (values result (add-complexity con-number-complexity complexity)))) + +(define-box-analysis flic-void (object already-forced uninitialized) + (declare (ignore object uninitialized)) + (values already-forced 0)) + + + + +;;;====================================================================== +;;; Already-forced bookkeeping +;;;====================================================================== + + +;;; For now, we only keep track of variables that have been forced, +;;; and not data structure accesses. + +(define (already-forced? object already-forced) + (and (is-type? 'flic-ref object) + (memq (flic-ref-var object) already-forced))) + +(define (note-already-forced object already-forced) + (if (is-type? 'flic-ref object) + (cons (flic-ref-var object) already-forced) + already-forced)) + +(define (union-already-forced new tail result) + (cond ((eq? new tail) + result) + ((memq (car new) result) + (union-already-forced (cdr new) tail result)) + (else + (union-already-forced (cdr new) tail (cons (car new) result))) + )) + + + |