diff options
author | Andy Wingo <wingo@pobox.com> | 2011-09-28 19:39:25 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-09-28 19:39:39 +0200 |
commit | b275fb2691af150cc57e395e65df5a66e315017e (patch) | |
tree | c16f6098aa757489c222509c3b946f6031761544 /module/language/tree-il/optimize.scm | |
parent | df40b969780df2979f9f5e1c9ae8b9d6f09dbd9a (diff) | |
download | guile-b275fb2691af150cc57e395e65df5a66e315017e.tar.gz |
separate peval and a new canonicalization pass into their own modules
* module/language/tree-il/peval.scm: Move to its own file. Remove the
bits about <prompt> thunk-application bodies, as they are not
optimizations, simply expectations of the compiler. `canonicalize'
handles that now.
* module/language/tree-il/optimize.scm: Use peval from its module.
Don't call `inline!', as that's useless now.
* module/language/tree-il/canonicalize.scm: New file, implementing a
pass that `compile-tree-il' runs on the result from the optimizer.
The compiler currently expects a <let> form to have bindings, for
example, and this pass turns a <let> without bindings into its body.
* module/language/tree-il/inline.scm: Deprecate, as `peval' does
everything this function ever did.
* module/language/tree-il/compile-glil.scm: Canonicalize after
optimizing. This should allow us to skip the optimizer entirely, if
we want.
* module/Makefile.am: Update and reorder a little bit.
Diffstat (limited to 'module/language/tree-il/optimize.scm')
-rw-r--r-- | module/language/tree-il/optimize.scm | 964 |
1 files changed, 2 insertions, 962 deletions
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm index fee629a06..cb199053d 100644 --- a/module/language/tree-il/optimize.scm +++ b/module/language/tree-il/optimize.scm @@ -21,14 +21,9 @@ (define-module (language tree-il optimize) #:use-module (language tree-il) #:use-module (language tree-il primitives) - #:use-module (language tree-il inline) + #:use-module (language tree-il peval) #:use-module (language tree-il fix-letrec) - #:use-module (ice-9 vlist) #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) #:export (optimize!)) (define (optimize! x env opts) @@ -37,961 +32,6 @@ ;; Disable partial evaluation. (lambda (x e) x)) (_ peval)))) - (inline! (fix-letrec! (peval (expand-primitives! (resolve-primitives! x env)) - env))))) - - -;;; -;;; Partial evaluation. -;;; - -(define (fresh-gensyms syms) - (map (lambda (x) (gensym (string-append (symbol->string x) " "))) - syms)) - -(define (alpha-rename exp) - "Alpha-rename EXP. For any lambda in EXP, generate new symbols and -replace all lexical references to the former symbols with lexical -references to the new symbols." - ;; XXX: This should be factorized somehow. - (let loop ((exp exp) - (mapping vlist-null)) ; maps old to new gensyms - (match exp - (($ <lambda-case> src req opt rest kw inits gensyms body alt) - ;; Create new symbols to replace GENSYMS and propagate them down - ;; in BODY and ALT. - (let* ((new (fresh-gensyms - (append req - (or opt '()) - (if rest (list rest) '()) - (match kw - ((aok? (_ name _) ...) name) - (_ '()))))) - (mapping (fold vhash-consq mapping gensyms new))) - (make-lambda-case src req opt rest - (match kw - ((aok? (kw name old) ...) - (cons aok? (map list - kw - name - (take-right new (length old))))) - (_ #f)) - (map (cut loop <> mapping) inits) - new - (loop body mapping) - (and alt (loop alt mapping))))) - (($ <lexical-ref> src name gensym) - ;; Possibly replace GENSYM by the new gensym defined in MAPPING. - (let ((val (vhash-assq gensym mapping))) - (if val - (make-lexical-ref src name (cdr val)) - exp))) - (($ <lexical-set> src name gensym exp) - (let ((val (vhash-assq gensym mapping))) - (make-lexical-set src name (if val (cdr val) gensym) - (loop exp mapping)))) - (($ <lambda> src meta body) - (make-lambda src meta (loop body mapping))) - (($ <let> src names gensyms vals body) - ;; As for `lambda-case' rename GENSYMS to avoid any collision. - (let* ((new (fresh-gensyms names)) - (mapping (fold vhash-consq mapping gensyms new)) - (vals (map (cut loop <> mapping) vals)) - (body (loop body mapping))) - (make-let src names new vals body))) - (($ <letrec> src in-order? names gensyms vals body) - ;; Likewise. - (let* ((new (fresh-gensyms names)) - (mapping (fold vhash-consq mapping gensyms new)) - (vals (map (cut loop <> mapping) vals)) - (body (loop body mapping))) - (make-letrec src in-order? names new vals body))) - (($ <fix> src names gensyms vals body) - ;; Likewise. - (let* ((new (fresh-gensyms names)) - (mapping (fold vhash-consq mapping gensyms new)) - (vals (map (cut loop <> mapping) vals)) - (body (loop body mapping))) - (make-fix src names new vals body))) - (($ <let-values> src exp body) - (make-let-values src (loop exp mapping) (loop body mapping))) - (($ <const>) - exp) - (($ <void>) - exp) - (($ <toplevel-ref>) - exp) - (($ <module-ref>) - exp) - (($ <primitive-ref>) - exp) - (($ <toplevel-set> src name exp) - (make-toplevel-set src name (loop exp mapping))) - (($ <toplevel-define> src name exp) - (make-toplevel-define src name (loop exp mapping))) - (($ <module-set> src mod name public? exp) - (make-module-set src mod name public? (loop exp mapping))) - (($ <dynlet> src fluids vals body) - (make-dynlet src - (map (cut loop <> mapping) fluids) - (map (cut loop <> mapping) vals) - (loop body mapping))) - (($ <dynwind> src winder body unwinder) - (make-dynwind src - (loop winder mapping) - (loop body mapping) - (loop unwinder mapping))) - (($ <dynref> src fluid) - (make-dynref src (loop fluid mapping))) - (($ <dynset> src fluid exp) - (make-dynset src (loop fluid mapping) (loop exp mapping))) - (($ <conditional> src condition subsequent alternate) - (make-conditional src - (loop condition mapping) - (loop subsequent mapping) - (loop alternate mapping))) - (($ <application> src proc args) - (make-application src (loop proc mapping) - (map (cut loop <> mapping) args))) - (($ <sequence> src exps) - (make-sequence src (map (cut loop <> mapping) exps))) - (($ <prompt> src tag body handler) - (make-prompt src (loop tag mapping) (loop body mapping) - (loop handler mapping))) - (($ <abort> src tag args tail) - (make-abort src (loop tag mapping) (map (cut loop <> mapping) args) - (loop tail mapping)))))) - -(define-syntax-rule (let/ec k e e* ...) - (let ((tag (make-prompt-tag))) - (call-with-prompt - tag - (lambda () - (let ((k (lambda args (apply abort-to-prompt tag args)))) - e e* ...)) - (lambda (_ res) res)))) - -(define (tree-il-any proc exp) - (let/ec k - (tree-il-fold (lambda (exp res) - (let ((res (proc exp))) - (if res (k res) #f))) - (lambda (exp res) - (let ((res (proc exp))) - (if res (k res) #f))) - (lambda (exp res) #f) - #f exp))) - -(define (vlist-any proc vlist) - (let ((len (vlist-length vlist))) - (let lp ((i 0)) - (and (< i len) - (or (proc (vlist-ref vlist i)) - (lp (1+ i))))))) - -(define-record-type <var> - (make-var name gensym refcount set?) - var? - (name var-name) - (gensym var-gensym) - (refcount var-refcount set-var-refcount!) - (set? var-set? set-var-set?!)) - -(define* (build-var-table exp #:optional (table vlist-null)) - (tree-il-fold - (lambda (exp res) - (match exp - (($ <lexical-ref> src name gensym) - (let ((var (vhash-assq gensym res))) - (if var - (begin - (set-var-refcount! (cdr var) (1+ (var-refcount (cdr var)))) - res) - (vhash-consq gensym (make-var name gensym 1 #f) res)))) - (_ res))) - (lambda (exp res) - (match exp - (($ <lexical-set> src name gensym exp) - (let ((var (vhash-assq gensym res))) - (if var - (begin - (set-var-set?! (cdr var) #t) - res) - (vhash-consq gensym (make-var name gensym 0 #t) res)))) - (_ res))) - (lambda (exp res) res) - table exp)) - -(define-record-type <counter> - (%make-counter effort size continuation recursive? data prev) - counter? - (effort effort-counter) - (size size-counter) - (continuation counter-continuation) - (recursive? counter-recursive?) - (data counter-data) - (prev counter-prev)) - -(define (abort-counter c) - ((counter-continuation c))) - -(define (record-effort! c) - (let ((e (effort-counter c))) - (if (zero? (variable-ref e)) - (abort-counter c) - (variable-set! e (1- (variable-ref e)))))) - -(define (record-size! c) - (let ((s (size-counter c))) - (if (zero? (variable-ref s)) - (abort-counter c) - (variable-set! s (1- (variable-ref s)))))) - -(define (find-counter data counter) - (and counter - (if (eq? data (counter-data counter)) - counter - (find-counter data (counter-prev counter))))) - -(define* (transfer! from to #:optional - (effort (variable-ref (effort-counter from))) - (size (variable-ref (size-counter from)))) - (define (transfer-counter! from-v to-v amount) - (let* ((from-balance (variable-ref from-v)) - (to-balance (variable-ref to-v)) - (amount (min amount from-balance))) - (variable-set! from-v (- from-balance amount)) - (variable-set! to-v (+ to-balance amount)))) - - (transfer-counter! (effort-counter from) (effort-counter to) effort) - (transfer-counter! (size-counter from) (size-counter to) size)) - -(define (make-top-counter effort-limit size-limit continuation data) - (%make-counter (make-variable effort-limit) - (make-variable size-limit) - continuation - #t - data - #f)) - -(define (make-nested-counter continuation data current) - (let ((c (%make-counter (make-variable 0) - (make-variable 0) - continuation - #f - data - current))) - (transfer! current c) - c)) - -(define (make-recursive-counter effort-limit size-limit orig current) - (let ((c (%make-counter (make-variable 0) - (make-variable 0) - (counter-continuation orig) - #t - (counter-data orig) - current))) - (transfer! current c effort-limit size-limit) - c)) - -(define (types-check? primitive-name args) - (case primitive-name - ((values) #t) - ((not pair? null? list? symbol? vector? struct?) - (= (length args) 1)) - ((eq? eqv? equal?) - (= (length args) 2)) - ;; FIXME: add more cases? - (else #f))) - -(define* (peval exp #:optional (cenv (current-module)) (env vlist-null) - #:key - (operator-size-limit 40) - (operand-size-limit 20) - (value-size-limit 10) - (effort-limit 500) - (recursive-effort-limit 100)) - "Partially evaluate EXP in compilation environment CENV, with -top-level bindings from ENV and return the resulting expression. Since -it does not handle <fix> and <let-values>, it should be called before -`fix-letrec'." - - ;; This is a simple partial evaluator. It effectively performs - ;; constant folding, copy propagation, dead code elimination, and - ;; inlining, but not across top-level bindings---there should be a way - ;; to allow this (TODO). - ;; - ;; Unlike a full-blown partial evaluator, it does not emit definitions - ;; of specialized versions of lambdas encountered on its way. Also, - ;; it's not yet complete: it bails out for `prompt', etc. - - (define local-toplevel-env - ;; The top-level environment of the module being compiled. - (match exp - (($ <toplevel-define> _ name) - (vhash-consq name #t env)) - (($ <sequence> _ exps) - (fold (lambda (x r) - (match x - (($ <toplevel-define> _ name) - (vhash-consq name #t r)) - (_ r))) - env - exps)) - (_ env))) - - (define (local-toplevel? name) - (vhash-assq name local-toplevel-env)) - - (define store (build-var-table exp)) - - (define (assigned-lexical? sym) - (let ((v (vhash-assq sym store))) - (and v (var-set? (cdr v))))) - - (define (lexical-refcount sym) - (let ((v (vhash-assq sym store))) - (if v (var-refcount (cdr v)) 0))) - - (define (record-source-expression! orig new) - (set! store (vhash-consq new - (source-expression orig) - (build-var-table new store))) - new) - - (define (source-expression new) - (let ((x (vhash-assq new store))) - (if x (cdr x) new))) - - (define residual-lexical-references (make-hash-table)) - - (define (record-residual-lexical-reference! sym) - (hashq-set! residual-lexical-references sym #t)) - - (define (apply-primitive name args) - ;; todo: further optimize commutative primitives - (catch #t - (lambda () - (call-with-values - (lambda () - (apply (module-ref the-scm-module name) args)) - (lambda results - (values #t results)))) - (lambda _ - (values #f '())))) - - (define (inline-values exp src names gensyms body) - (let loop ((exp exp)) - (match exp - ;; Some expression types are always singly-valued. - ((or ($ <const>) - ($ <void>) - ($ <lambda>) - ($ <lexical-ref>) - ($ <toplevel-ref>) - ($ <module-ref>) - ($ <primitive-ref>) - ($ <dynref>) - ($ <lexical-set>) ; FIXME: these set! expressions - ($ <toplevel-set>) ; could return zero values in - ($ <toplevel-define>) ; the future - ($ <module-set>) ; - ($ <dynset>)) ; - (and (= (length names) 1) - (make-let src names gensyms (list exp) body))) - (($ <application> src - ($ <primitive-ref> _ (? singly-valued-primitive? name))) - (and (= (length names) 1) - (make-let src names gensyms (list exp) body))) - - ;; Statically-known number of values. - (($ <application> src ($ <primitive-ref> _ 'values) vals) - (and (= (length names) (length vals)) - (make-let src names gensyms vals body))) - - ;; Not going to copy code into both branches. - (($ <conditional>) #f) - - ;; Bail on other applications. - (($ <application>) #f) - - ;; Bail on prompt and abort. - (($ <prompt>) #f) - (($ <abort>) #f) - - ;; Propagate to tail positions. - (($ <let> src names gensyms vals body) - (let ((body (loop body))) - (and body - (make-let src names gensyms vals body)))) - (($ <letrec> src in-order? names gensyms vals body) - (let ((body (loop body))) - (and body - (make-letrec src in-order? names gensyms vals body)))) - (($ <fix> src names gensyms vals body) - (let ((body (loop body))) - (and body - (make-fix src names gensyms vals body)))) - (($ <let-values> src exp - ($ <lambda-case> src2 req opt rest kw inits gensyms body #f)) - (let ((body (loop body))) - (and body - (make-let-values src exp - (make-lambda-case src2 req opt rest kw - inits gensyms body #f))))) - (($ <dynwind> src winder body unwinder) - (let ((body (loop body))) - (and body - (make-dynwind src winder body unwinder)))) - (($ <dynlet> src fluids vals body) - (let ((body (loop body))) - (and body - (make-dynlet src fluids vals body)))) - (($ <sequence> src exps) - (match exps - ((head ... tail) - (let ((tail (loop tail))) - (and tail - (make-sequence src (append head (list tail))))))))))) - - (define (make-values src values) - (match values - ((single) single) ; 1 value - ((_ ...) ; 0, or 2 or more values - (make-application src (make-primitive-ref src 'values) - values)))) - - (define (constant-expression? x) - ;; Return true if X is constant---i.e., if it is known to have no - ;; effects, does not allocate storage for a mutable object, and does - ;; not access mutable data (like `car' or toplevel references). - (let loop ((x x)) - (match x - (($ <void>) #t) - (($ <const>) #t) - (($ <lambda>) #t) - (($ <lambda-case> _ req opt rest kw inits _ body alternate) - (and (every loop inits) (loop body) (loop alternate))) - (($ <lexical-ref> _ _ gensym) - (not (assigned-lexical? gensym))) - (($ <primitive-ref>) #t) - (($ <conditional> _ condition subsequent alternate) - (and (loop condition) (loop subsequent) (loop alternate))) - (($ <application> _ ($ <primitive-ref> _ name) args) - (and (effect-free-primitive? name) - (not (constructor-primitive? name)) - (types-check? name args) - (every loop args))) - (($ <application> _ ($ <lambda> _ _ body) args) - (and (loop body) (every loop args))) - (($ <sequence> _ exps) - (every loop exps)) - (($ <let> _ _ _ vals body) - (and (every loop vals) (loop body))) - (($ <letrec> _ _ _ _ vals body) - (and (every loop vals) (loop body))) - (($ <fix> _ _ _ vals body) - (and (every loop vals) (loop body))) - (($ <let-values> _ exp body) - (and (loop exp) (loop body))) - (($ <prompt> _ tag body handler) - (and (loop tag) (loop body) (loop handler))) - (_ #f)))) - - (define (prune-bindings names syms vals body for-effect - build-result) - (let lp ((names names) (syms syms) (vals vals) - (names* '()) (syms* '()) (vals* '()) - (effects '())) - (match (list names syms vals) - ((() () ()) - (let ((body (if (null? effects) - body - (make-sequence #f (reverse (cons body effects)))))) - (if (null? names*) - body - (build-result (reverse names*) (reverse syms*) - (reverse vals*) body)))) - (((name . names) (sym . syms) (val . vals)) - (if (hashq-ref residual-lexical-references sym) - (lp names syms vals - (cons name names*) (cons sym syms*) (cons val vals*) - effects) - (let ((effect (for-effect val))) - (lp names syms vals - names* syms* vals* - (if (void? effect) - effects - (cons effect effects))))))))) - - (define (small-expression? x limit) - (let/ec k - (tree-il-fold - (lambda (x res) ; leaf - (1+ res)) - (lambda (x res) ; down - (1+ res)) - (lambda (x res) ; up - (if (< res limit) - res - (k #f))) - 0 x) - #t)) - - (let loop ((exp exp) - (env vlist-null) ; static environment - (counter #f) ; inlined call stack - (ctx 'value)) ; effect, value, test, operator, or operand - (define (lookup var) - (and=> (vhash-assq var env) cdr)) - - (define (for-value exp) - (loop exp env counter 'value)) - (define (for-operand exp) - (loop exp env counter 'operand)) - (define (for-test exp) - (loop exp env counter 'test)) - (define (for-effect exp) - (loop exp env counter 'effect)) - (define (for-tail exp) - (loop exp env counter ctx)) - - (if counter - (record-effort! counter)) - - (match exp - (($ <const>) - (case ctx - ((effect) (make-void #f)) - (else exp))) - (($ <void>) - (case ctx - ((test) (make-const #f #t)) - (else exp))) - (($ <lexical-ref> _ _ gensym) - (case ctx - ((effect) (make-void #f)) - (else - (let ((val (lookup gensym))) - (cond - ((or (not val) - (assigned-lexical? gensym) - (not (constant-expression? val))) - ;; Don't copy-propagate through assigned variables, - ;; and don't reorder effects. - (record-residual-lexical-reference! gensym) - exp) - ((lexical-ref? val) - (for-tail val)) - ((or (const? val) - (void? val) - (primitive-ref? val)) - ;; Always propagate simple values that cannot lead to - ;; code bloat. - (for-tail val)) - ((= 1 (lexical-refcount gensym)) - ;; Always propagate values referenced only once. - ;; There is no need to rename the bindings, as they - ;; are only being moved, not copied. However in - ;; operator context we do rename it, as that - ;; effectively clears out the residualized-lexical - ;; flags that may have been set when this value was - ;; visited previously as an operand. - (case ctx - ((test) (for-test val)) - ((operator) (record-source-expression! val (alpha-rename val))) - (else val))) - ;; FIXME: do demand-driven size accounting rather than - ;; these heuristics. - ((eq? ctx 'operator) - ;; A pure expression in the operator position. Inline - ;; if it's a lambda that's small enough. - (if (and (lambda? val) - (small-expression? val operator-size-limit)) - (record-source-expression! val (alpha-rename val)) - (begin - (record-residual-lexical-reference! gensym) - exp))) - ((eq? ctx 'operand) - ;; A pure expression in the operand position. Inline - ;; if it's small enough. - (if (small-expression? val operand-size-limit) - (record-source-expression! val (alpha-rename val)) - (begin - (record-residual-lexical-reference! gensym) - exp))) - (else - ;; A pure expression, processed for value. Don't - ;; inline lambdas, because they will probably won't - ;; fold because we don't know the operator. - (if (and (small-expression? val value-size-limit) - (not (tree-il-any lambda? val))) - (record-source-expression! val (alpha-rename val)) - (begin - (record-residual-lexical-reference! gensym) - exp)))))))) - (($ <lexical-set> src name gensym exp) - (if (zero? (lexical-refcount gensym)) - (let ((exp (for-effect exp))) - (if (void? exp) - exp - (make-sequence src (list exp (make-void #f))))) - (begin - (record-residual-lexical-reference! gensym) - (make-lexical-set src name gensym (for-value exp))))) - (($ <let> src names gensyms vals body) - (let* ((vals (map for-operand vals)) - (body (loop body - (fold vhash-consq env gensyms vals) - counter - ctx))) - (cond - ((const? body) - (for-tail (make-sequence src (append vals (list body))))) - ((and (lexical-ref? body) - (memq (lexical-ref-gensym body) gensyms)) - (let ((sym (lexical-ref-gensym body)) - (pairs (map cons gensyms vals))) - ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo) - (for-tail - (make-sequence - src - (append (map cdr (alist-delete sym pairs eq?)) - (list (assq-ref pairs sym))))))) - (else - ;; Only include bindings for which lexical references - ;; have been residualized. - (prune-bindings names gensyms vals body for-effect - (lambda (names gensyms vals body) - (if (null? names) (error "what!" names)) - (make-let src names gensyms vals body))))))) - (($ <letrec> src in-order? names gensyms vals body) - ;; Things could be done more precisely when IN-ORDER? but - ;; it's OK not to do it---at worst we lost an optimization - ;; opportunity. - (let* ((vals (map for-operand vals)) - (body (loop body - (fold vhash-consq env gensyms vals) - counter - ctx))) - (if (and (const? body) - (every constant-expression? vals)) - body - (prune-bindings names gensyms vals body for-effect - (lambda (names gensyms vals body) - (make-letrec src in-order? - names gensyms vals body)))))) - (($ <fix> src names gensyms vals body) - (let* ((vals (map for-operand vals)) - (body (loop body - (fold vhash-consq env gensyms vals) - counter - ctx))) - (if (const? body) - body - (prune-bindings names gensyms vals body for-effect - (lambda (names gensyms vals body) - (make-fix src names gensyms vals body)))))) - (($ <let-values> lv-src producer consumer) - ;; Peval the producer, then try to inline the consumer into - ;; the producer. If that succeeds, peval again. Otherwise - ;; reconstruct the let-values, pevaling the consumer. - (let ((producer (for-value producer))) - (or (match consumer - (($ <lambda-case> src req #f #f #f () gensyms body #f) - (cond - ((inline-values producer src req gensyms body) - => for-tail) - (else #f))) - (_ #f)) - (make-let-values lv-src producer (for-tail consumer))))) - (($ <dynwind> src winder body unwinder) - (make-dynwind src (for-value winder) (for-tail body) - (for-value unwinder))) - (($ <dynlet> src fluids vals body) - (make-dynlet src (map for-value fluids) (map for-value vals) - (for-tail body))) - (($ <dynref> src fluid) - (make-dynref src (for-value fluid))) - (($ <dynset> src fluid exp) - (make-dynset src (for-value fluid) (for-value exp))) - (($ <toplevel-ref> src (? effect-free-primitive? name)) - (if (local-toplevel? name) - exp - (resolve-primitives! exp cenv))) - (($ <toplevel-ref>) - ;; todo: open private local bindings. - exp) - (($ <module-ref>) - exp) - (($ <module-set> src mod name public? exp) - (make-module-set src mod name public? (for-value exp))) - (($ <toplevel-define> src name exp) - (make-toplevel-define src name (for-value exp))) - (($ <toplevel-set> src name exp) - (make-toplevel-set src name (for-value exp))) - (($ <primitive-ref>) - (case ctx - ((effect) (make-void #f)) - ((test) (make-const #f #t)) - (else exp))) - (($ <conditional> src condition subsequent alternate) - (let ((condition (for-test condition))) - (if (const? condition) - (if (const-exp condition) - (for-tail subsequent) - (for-tail alternate)) - (make-conditional src condition - (for-tail subsequent) - (for-tail alternate))))) - (($ <application> src - ($ <primitive-ref> _ '@call-with-values) - (producer - ($ <lambda> _ _ - (and consumer - ;; No optional or kwargs. - ($ <lambda-case> - _ req #f rest #f () gensyms body #f))))) - (for-tail (make-let-values src (make-application src producer '()) - consumer))) - - (($ <application> src orig-proc orig-args) - ;; todo: augment the global env with specialized functions - (let ((proc (loop orig-proc env counter 'operator))) - (match proc - (($ <primitive-ref> _ (? constructor-primitive? name)) - (case ctx - ((effect test) - (let ((res (if (eq? ctx 'effect) - (make-void #f) - (make-const #f #t)))) - (match (for-value exp) - (($ <application> _ ($ <primitive-ref> _ 'cons) (x xs)) - (for-tail - (make-sequence src (list x xs res)))) - (($ <application> _ ($ <primitive-ref> _ 'list) elts) - (for-tail - (make-sequence src (append elts (list res))))) - (($ <application> _ ($ <primitive-ref> _ 'vector) elts) - (for-tail - (make-sequence src (append elts (list res))))) - (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) ()) - res) - (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) - (($ <const> _ (? string?)))) - res) - (exp exp)))) - (else - (match (cons name (map for-value orig-args)) - (('cons head tail) - (match tail - (($ <const> src ()) - (make-application src (make-primitive-ref #f 'list) - (list head))) - (($ <application> src ($ <primitive-ref> _ 'list) elts) - (make-application src (make-primitive-ref #f 'list) - (cons head elts))) - (_ (make-application src proc - (list head tail))))) - - ;; FIXME: these for-tail recursions could take - ;; place outside an effort counter. - (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail))) - (for-tail (make-sequence src (list tail head)))) - (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail))) - (for-tail (make-sequence src (list head tail)))) - (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail))) - (for-tail (make-sequence src (append tail (list head))))) - (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail))) - (for-tail (make-sequence - src - (list head - (make-application - src (make-primitive-ref #f 'list) tail))))) - - (('car ($ <const> src (head . tail))) - (for-tail (make-const src head))) - (('cdr ($ <const> src (head . tail))) - (for-tail (make-const src tail))) - - ((_ . args) - (make-application src proc args)))))) - (($ <primitive-ref> _ (? effect-free-primitive? name)) - (let ((args (map for-value orig-args))) - (if (every const? args) ; only simple constants - (let-values (((success? values) - (apply-primitive name - (map const-exp args)))) - (if success? - (case ctx - ((effect) (make-void #f)) - ((test) - ;; Values truncation: only take the first - ;; value. - (if (pair? values) - (make-const #f (car values)) - (make-values src '()))) - (else - (make-values src (map (cut make-const src <>) - values)))) - (make-application src proc args))) - (cond - ((and (eq? ctx 'effect) (types-check? name args)) - (make-void #f)) - (else - (make-application src proc args)))))) - (($ <lambda> _ _ - ($ <lambda-case> _ req opt #f #f inits gensyms body #f)) - ;; Simple case: no rest, no keyword arguments. - ;; todo: handle the more complex cases - (let* ((nargs (length orig-args)) - (nreq (length req)) - (nopt (if opt (length opt) 0)) - (key (source-expression proc))) - (cond - ((or (< nargs nreq) (> nargs (+ nreq nopt))) - ;; An error, or effecting arguments. - (make-application src (for-value orig-proc) - (map for-value orig-args))) - ((or (and=> (find-counter key counter) counter-recursive?) - (lambda? orig-proc)) - ;; A recursive call, or a lambda in the operator - ;; position of the source expression. Process again in - ;; tail context. - (loop (make-let src (append req (or opt '())) - gensyms - (append orig-args - (drop inits (- nargs nreq))) - body) - env counter ctx)) - (else - ;; An integration at the top-level, the first - ;; recursion of a recursive procedure, or a nested - ;; integration of a procedure that hasn't been seen - ;; yet. - (let/ec k - (define (abort) - (k (make-application src - (for-value orig-proc) - (map for-value orig-args)))) - (define new-counter - (cond - ;; These first two cases will transfer effort - ;; from the current counter into the new - ;; counter. - ((find-counter key counter) - => (lambda (prev) - (make-recursive-counter recursive-effort-limit - operand-size-limit - prev counter))) - (counter - (make-nested-counter abort key counter)) - ;; This case opens a new account, effectively - ;; printing money. It should only do so once - ;; for each call site in the source program. - (else - (make-top-counter effort-limit operand-size-limit - abort key)))) - (define result - (loop (make-let src (append req (or opt '())) - gensyms - (append orig-args - (drop inits (- nargs nreq))) - body) - env new-counter ctx)) - - (if counter - ;; The nested inlining attempt succeeded. - ;; Deposit the unspent effort and size back - ;; into the current counter. - (transfer! new-counter counter)) - - result))))) - (_ - (make-application src proc - (map for-value orig-args)))))) - (($ <lambda> src meta body) - (case ctx - ((effect) (make-void #f)) - ((test) (make-const #f #t)) - ((operator) exp) - (else - (make-lambda src meta (for-value body))))) - (($ <lambda-case> src req opt rest kw inits gensyms body alt) - (make-lambda-case src req opt rest kw - (map for-value inits) - gensyms - (for-tail body) - (and alt (for-tail alt)))) - (($ <sequence> src exps) - (let lp ((exps exps) (effects '())) - (match exps - ((last) - (if (null? effects) - (for-tail last) - (make-sequence - src - (reverse (cons (for-tail last) effects))))) - ((head . rest) - (let ((head (for-effect head))) - (cond - ((sequence? head) - (lp (append (sequence-exps head) rest) effects)) - ((void? head) - (lp rest effects)) - (else - (lp rest (cons head effects))))))))) - (($ <prompt> src tag body handler) - (define (singly-used-definition x) - (cond - ((and (lexical-ref? x) - ;; Only fetch definitions with single uses. - (= (lexical-refcount (lexical-ref-gensym x)) 1) - (lookup (lexical-ref-gensym x))) - => singly-used-definition) - (else x))) - (define (escape-only? handler) - (match handler - (($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f) - (tree-il-any (lambda (x) - (and (lexical-ref? x) - (eq? (lexical-ref-gensym x) cont))) - body)) - (else #f))) - (define (thunk-application? x) - (match x - (($ <application> _ - ($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f)) - ()) #t) - (_ #f))) - (define (make-thunk-application body) - (define thunk - (make-lambda #f '() - (make-lambda-case #f '() #f #f #f '() '() body #f))) - (make-application #f thunk '())) - - (match (singly-used-definition tag) - (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) - (or () ((? constant-expression?)))) - ;; There is no way that an <abort> could know the tag - ;; for this <prompt>, so we can elide the <prompt> - ;; entirely. - (for-tail body)) - (_ - ;; It's a nasty, but this code has another job to do: to - ;; ensure that either the handler is escape-only, or the - ;; body is the application of a thunk. Sad but true. - (let ((tag (for-value tag)) - (body (for-value body)) - (handler (for-value handler))) - (make-prompt src tag - (if (or (escape-only? handler) - (thunk-application? body)) - body - (make-thunk-application body)) - handler))))) - (($ <abort> src tag args tail) - (make-abort src (for-value tag) (map for-value args) - (for-value tail)))))) + env)))) |