summaryrefslogtreecommitdiff
path: root/module/language/tree-il/optimize.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-09-27 15:08:17 +0200
committerAndy Wingo <wingo@pobox.com>2011-09-28 00:13:56 +0200
commit1cc1c2d7e33bc40ac23e05636e69434d80e90af1 (patch)
tree4834258caf9fc63313f9a7255028263af40fe095 /module/language/tree-il/optimize.scm
parent6c4ffe2b2560eaeb0fe5aedb266183e3bb80dbd8 (diff)
downloadguile-1cc1c2d7e33bc40ac23e05636e69434d80e90af1.tar.gz
peval works on all expressions
* module/language/tree-il/optimize.scm (alpha-rename, peval): Add <dynset> cases. Allow any kind of <application>. Remove the `catch' wrapper as now peval handles all kinds of expressions.
Diffstat (limited to 'module/language/tree-il/optimize.scm')
-rw-r--r--module/language/tree-il/optimize.scm961
1 files changed, 462 insertions, 499 deletions
diff --git a/module/language/tree-il/optimize.scm b/module/language/tree-il/optimize.scm
index c40330ce7..e9317efd1 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -145,6 +145,8 @@ references to the new symbols."
(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)
@@ -385,11 +387,12 @@ it does not handle <fix> and <let-values>, it should be called before
($ <lexical-set>) ; FIXME: these set! expressions
($ <toplevel-set>) ; could return zero values in
($ <toplevel-define>) ; the future
- ($ <module-set>)) ;
+ ($ <module-set>) ;
+ ($ <dynset>)) ;
(and (= (length names) 1)
(make-let src names gensyms (list exp) body)))
(($ <application> src
- ($ <primitive-ref> _ (? singly-valued-primitive? name)))
+ ($ <primitive-ref> _ (? singly-valued-primitive? name)))
(and (= (length names) 1)
(make-let src names gensyms (list exp) body)))
@@ -445,8 +448,8 @@ it does not handle <fix> and <let-values>, it should be called before
(define (make-values src values)
(match values
- ((single) single) ; 1 value
- ((_ ...) ; 0, or 2 or more values
+ ((single) single) ; 1 value
+ ((_ ...) ; 0, or 2 or more values
(make-application src (make-primitive-ref src 'values)
values))))
@@ -500,509 +503,469 @@ it does not handle <fix> and <let-values>, it should be called before
0 x)
#t))
- (define (make-value-construction src exp)
- ;; Return an expression that builds a fresh copy of EXP at run-time,
- ;; or #f.
- (let loop ((exp exp))
- (match exp
- ((_ _ ...) ; non-empty proper list
- (let ((args (map loop exp)))
- (and (every struct? args)
- (make-application src (make-primitive-ref src 'list)
- args))))
- ((h . (? (negate pair?) t)) ; simple pair
- (let ((h (loop h))
- (t (loop t)))
- (and h t
- (make-application src (make-primitive-ref src 'cons)
- (list h t)))))
- ((? vector?) ; vector
- (let ((args (map loop (vector->list exp))))
- (and (every struct? args)
- (make-application src (make-primitive-ref src 'vector)
- args))))
- ((? number?) (make-const src exp))
- ((? string?) (make-const src exp))
- ((? symbol?) (make-const src exp))
- ;((? bytevector?) (make-const src exp))
- (_ #f))))
+ (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))
- (catch 'match-error
- (lambda ()
- (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))
+ (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
- (let ((val (lookup gensym)))
+ ;; 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.
+ (let*-values
+ (((stripped) (remove
+ (lambda (x)
+ (and (not (hashq-ref
+ residual-lexical-references
+ (cadr x)))
+ ;; FIXME: Here we can probably
+ ;; strip pure expressions in
+ ;; addition to constant
+ ;; expressions.
+ (constant-expression? (car x))))
+ (zip vals gensyms names)))
+ ((vals gensyms names) (unzip3 stripped)))
+ (if (null? stripped)
+ body
+ (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
+ (let*-values
+ (((stripped) (remove
+ (lambda (x)
+ (and (constant-expression? (car x))
+ (not (hashq-ref
+ residual-lexical-references
+ (cadr x)))))
+ (zip vals gensyms names)))
+ ((vals gensyms names) (unzip3 stripped)))
+ (if (null? stripped)
+ 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
+ (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
- ((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)))))))
+ ((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
- ;; Only include bindings for which lexical references
- ;; have been residualized.
- (let*-values
- (((stripped) (remove
- (lambda (x)
- (and (not (hashq-ref
- residual-lexical-references
- (cadr x)))
- ;; FIXME: Here we can probably
- ;; strip pure expressions in
- ;; addition to constant
- ;; expressions.
- (constant-expression? (car x))))
- (zip vals gensyms names)))
- ((vals gensyms names) (unzip3 stripped)))
- (if (null? stripped)
- body
- (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
- (let*-values
- (((stripped) (remove
- (lambda (x)
- (and (constant-expression? (car x))
- (not (hashq-ref
- residual-lexical-references
- (cadr x)))))
- (zip vals gensyms names)))
- ((vals gensyms names) (unzip3 stripped)))
- (if (null? stripped)
- 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
- (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)))
- (($ <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)))))
+ (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)))
- (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)))
- ((and=> (find-counter key counter) counter-recursive?)
- ;; A recursive call. Process again in tail context.
+ (('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)))
+ (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)))
+ ((and=> (find-counter key counter) counter-recursive?)
+ ;; A recursive call. 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 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))
+ 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)))))
- ((or ($ <primitive-ref>)
- ($ <lambda>)
- ($ <toplevel-ref>)
- ($ <lexical-ref>))
- (make-application src proc
- (map for-value orig-args)))
-
- ;; In practice, this is the clause that stops peval:
- ;; module-ref applications (produced by macros,
- ;; typically) don't match, and so this throws,
- ;; aborting peval for an entire expression.
- )))
- (($ <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))))
- (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))))))
- (lambda _
- ;; We encountered something we don't handle, like <abort> or
- ;; <prompt>, so bail out.
- exp)))
+ (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))))))