X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/16371014d6231394dbfc9c5cc9dfcceabd8bc234..26d148066f9cb20e395a7dc4fefdf2e2ef0b2fb0:/module/language/tree-il/peval.scm diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 85865717c..fe637f0a5 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -1,6 +1,6 @@ ;;; Tree-IL partial evaluator -;; Copyright (C) 2011 Free Software Foundation, Inc. +;; Copyright (C) 2011, 2012, 2013 Free Software Foundation, Inc. ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -19,6 +19,7 @@ (define-module (language tree-il peval) #:use-module (language tree-il) #:use-module (language tree-il primitives) + #:use-module (language tree-il effects) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -99,6 +100,26 @@ (or (proc (vlist-ref vlist i)) (lp (1+ i))))))) +(define (singly-valued-expression? exp) + (match exp + (($ ) #t) + (($ ) #t) + (($ ) #t) + (($ ) #t) + (($ ) #t) + (($ ) #t) + (($ ) #t) + (($ _ (? singly-valued-primitive?)) #t) + (($ _ 'values (val)) #t) + (($ ) #t) + (else #f))) + +(define (truncate-values x) + "Discard all but the first value of X." + (if (singly-valued-expression? x) + x + (make-primcall (tree-il-src x) 'values (list x)))) + ;; Peval will do a one-pass analysis on the source program to determine ;; the set of assigned lexicals, and to identify unreferenced and ;; singly-referenced lexicals. @@ -264,29 +285,53 @@ ;; TODO: Record value size in operand structure? ;; (define-record-type - (%make-operand var sym visit source visit-count residualize? - copyable? residual-value constant-value) + (%make-operand var sym visit source visit-count use-count + copyable? residual-value constant-value alias-value) operand? (var operand-var) (sym operand-sym) (visit %operand-visit) (source operand-source) (visit-count operand-visit-count set-operand-visit-count!) - (residualize? operand-residualize? set-operand-residualize?!) + (use-count operand-use-count set-operand-use-count!) (copyable? operand-copyable? set-operand-copyable?!) - (residual-value operand-residual-value set-operand-residual-value!) - (constant-value operand-constant-value set-operand-constant-value!)) - -(define* (make-operand var sym #:optional source visit) - ;; Bound operands are considered copyable until we prove otherwise. - (%make-operand var sym visit source 0 #f (and source #t) #f #f)) - -(define (make-bound-operands vars syms sources visit) - (map (lambda (x y z) (make-operand x y z visit)) vars syms sources)) + (residual-value operand-residual-value %set-operand-residual-value!) + (constant-value operand-constant-value set-operand-constant-value!) + (alias-value operand-alias-value set-operand-alias-value!)) + +(define* (make-operand var sym #:optional source visit alias) + ;; Bind SYM to VAR, with value SOURCE. Unassigned bound operands are + ;; considered copyable until we prove otherwise. If we have a source + ;; expression, truncate it to one value. Copy propagation does not + ;; work on multiply-valued expressions. + (let ((source (and=> source truncate-values))) + (%make-operand var sym visit source 0 0 + (and source (not (var-set? var))) #f #f + (and (not (var-set? var)) alias)))) + +(define* (make-bound-operands vars syms sources visit #:optional aliases) + (if aliases + (map (lambda (name sym source alias) + (make-operand name sym source visit alias)) + vars syms sources aliases) + (map (lambda (name sym source) + (make-operand name sym source visit #f)) + vars syms sources))) (define (make-unbound-operands vars syms) (map make-operand vars syms)) +(define (set-operand-residual-value! op val) + (%set-operand-residual-value! + op + (match val + (($ src 'values (first)) + ;; The continuation of a residualized binding does not need the + ;; introduced `values' node, so undo the effects of truncation. + first) + (else + val)))) + (define* (visit-operand op counter ctx #:optional effort-limit size-limit) ;; Peval is O(N) in call sites of the source program. However, ;; visiting an operand can introduce new call sites. If we visit an @@ -305,7 +350,12 @@ (if (or counter (and (not effort-limit) (not size-limit))) ((%operand-visit op) (operand-source op) counter ctx) (let/ec k - (define (abort) (k #f)) + (define (abort) + ;; If we abort when visiting the value in a + ;; fresh context, we won't succeed in any future + ;; attempt, so don't try to copy it again. + (set-operand-copyable?! op #f) + (k #f)) ((%operand-visit op) (operand-source op) (make-top-counter effort-limit size-limit abort op) @@ -381,6 +431,13 @@ top-level bindings from ENV and return the resulting expression." new)) vars)) + (define (fresh-temporaries ls) + (map (lambda (elt) + (let ((new (gensym "tmp "))) + (record-new-temporary! 'tmp new 1) + new)) + ls)) + (define (assigned-lexical? sym) (var-set? (lookup-var sym))) @@ -401,32 +458,39 @@ top-level bindings from ENV and return the resulting expression." (let ((x (vhash-assq new store))) (if x (cdr x) new))) + (define (record-operand-use op) + (set-operand-use-count! op (1+ (operand-use-count op)))) + + (define (unrecord-operand-uses op n) + (let ((count (- (operand-use-count op) n))) + (when (zero? count) + (set-operand-residual-value! op #f)) + (set-operand-use-count! op count))) + (define* (residualize-lexical op #:optional ctx val) (log 'residualize op) - (set-operand-residualize?! op #t) - (if (eq? ctx 'value) + (record-operand-use op) + (if (memq ctx '(value values)) (set-operand-residual-value! op val)) (make-lexical-ref #f (var-name (operand-var op)) (operand-sym op))) - (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 (make-values src values) - (match values - ((single) single) ; 1 value - ((_ ...) ; 0, or 2 or more values - (make-primcall src 'values values)))) - (define (fold-constants src name args ctx) + (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 (make-values src values) + (match values + ((single) single) ; 1 value + ((_ ...) ; 0, or 2 or more values + (make-primcall src 'values values)))) (define (residualize-call) (make-primcall src name args)) (cond @@ -451,7 +515,7 @@ top-level bindings from ENV and return the resulting expression." (else (residualize-call)))) - (define (inline-values exp src names gensyms body) + (define (inline-values src exp nmin nmax consumer) (let loop ((exp exp)) (match exp ;; Some expression types are always singly-valued. @@ -467,17 +531,15 @@ top-level bindings from ENV and return the resulting expression." ($ ) ; could return zero values in ($ ) ; the future ($ ) ; - ($ )) ; - (and (= (length names) 1) - (make-let src names gensyms (list exp) body))) - (($ src (? singly-valued-primitive? name)) - (and (= (length names) 1) - (make-let src names gensyms (list exp) body))) + ($ ) ; + ($ src (? singly-valued-primitive?))) + (and (<= nmin 1) (or (not nmax) (>= nmax 1)) + (make-call src (make-lambda #f '() consumer) (list exp)))) ;; Statically-known number of values. (($ src 'values vals) - (and (= (length names) (length vals)) - (make-let src names gensyms vals body))) + (and (<= nmin (length vals)) (or (not nmax) (>= nmax (length vals))) + (make-call src (make-lambda #f '() consumer) vals))) ;; Not going to copy code into both branches. (($ ) #f) @@ -522,49 +584,15 @@ top-level bindings from ENV and return the resulting expression." (let ((tail (loop tail))) (and tail (make-seq src head tail))))))) + (define compute-effects + (make-effects-analyzer assigned-lexical?)) + (define (constant-expression? x) ;; Return true if X is constant, for the purposes of copying or ;; elision---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 - (($ ) #t) - (($ ) #t) - (($ ) #t) - (($ _ req opt rest kw inits syms body alternate) - (and (not (any assigned-lexical? syms)) - (every loop inits) (loop body) - (or (not alternate) (loop alternate)))) - (($ _ _ gensym) - (not (assigned-lexical? gensym))) - (($ ) #t) - (($ _ condition subsequent alternate) - (and (loop condition) (loop subsequent) (loop alternate))) - (($ _ name args) - (and (effect-free-primitive? name) - (not (constructor-primitive? name)) - (types-check? name args) - (if (accessor-primitive? name) - (every const? args) - (every loop args)))) - (($ _ ($ _ _ body) args) - (and (loop body) (every loop args))) - (($ _ head tail) - (and (loop head) (loop tail))) - (($ _ _ syms vals body) - (and (not (any assigned-lexical? syms)) - (every loop vals) (loop body))) - (($ _ _ _ syms vals body) - (and (not (any assigned-lexical? syms)) - (every loop vals) (loop body))) - (($ _ _ _ vals body) - (and (every loop vals) (loop body))) - (($ _ exp body) - (and (loop exp) (loop body))) - (($ _ tag body handler) - (and (loop tag) (loop body) (loop handler))) - (_ #f)))) + (constant? (compute-effects x))) (define (prune-bindings ops in-order? body counter ctx build-result) ;; This helper handles both `let' and `letrec'/`fix'. In the latter @@ -580,7 +608,8 @@ top-level bindings from ENV and return the resulting expression." ;; marked as needing residualization. Here we hack around this ;; and treat all bindings as referenced if we are in operator ;; context. - (or (eq? ctx 'operator) (operand-residualize? op))) + (or (eq? ctx 'operator) + (not (zero? (operand-use-count op))))) ;; values := (op ...) ;; effects := (op ...) @@ -662,16 +691,60 @@ top-level bindings from ENV and return the resulting expression." (let loop ((exp exp) (env vlist-null) ; vhash of gensym -> (counter #f) ; inlined call stack - (ctx 'value)) ; effect, value, test, operator, or call + (ctx 'values)) ; effect, value, values, test, operator, or call (define (lookup var) (cond ((vhash-assq var env) => cdr) (else (error "unbound var" var)))) + ;; Find a value referenced a specific number of times. This is a hack + ;; that's used for propagating fresh data structures like rest lists and + ;; prompt tags. Usually we wouldn't copy consed data, but we can do so in + ;; some special cases like `apply' or prompts if we can account + ;; for all of its uses. + ;; + ;; You don't want to use this in general because it introduces a slight + ;; nonlinearity by running peval again (though with a small effort and size + ;; counter). + ;; + (define (find-definition x n-aliases) + (cond + ((lexical-ref? x) + (cond + ((lookup (lexical-ref-gensym x)) + => (lambda (op) + (let ((y (or (operand-residual-value op) + (visit-operand op counter 'value 10 10) + (operand-source op)))) + (cond + ((and (lexical-ref? y) + (= (lexical-refcount (lexical-ref-gensym x)) 1)) + ;; X is a simple alias for Y. Recurse, regardless of + ;; the number of aliases we were expecting. + (find-definition y n-aliases)) + ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases) + ;; We found a definition that is aliased the right + ;; number of times. We still recurse in case it is a + ;; lexical. + (values (find-definition y 1) + op)) + (else + ;; We can't account for our aliases. + (values #f #f)))))) + (else + ;; A formal parameter. Can't say anything about that. + (values #f #f)))) + ((= n-aliases 1) + ;; Not a lexical: success, but only if we are looking for an + ;; unaliased value. + (values x #f)) + (else (values #f #f)))) + (define (visit exp ctx) (loop exp env counter ctx)) (define (for-value exp) (visit exp 'value)) + (define (for-values exp) (visit exp 'values)) (define (for-test exp) (visit exp 'test)) (define (for-effect exp) (visit exp 'effect)) (define (for-call exp) (visit exp 'call)) @@ -699,6 +772,11 @@ top-level bindings from ENV and return the resulting expression." ((eq? ctx 'effect) (log 'lexical-for-effect gensym) (make-void #f)) + ((operand-alias-value op) + ;; This is an unassigned operand that simply aliases some + ;; other operand. Recurse to avoid residualizing the leaf + ;; binding. + => for-tail) ((eq? ctx 'call) ;; Don't propagate copies if we are residualizing a call. (log 'residualize-lexical-call gensym op) @@ -717,7 +795,8 @@ top-level bindings from ENV and return the resulting expression." (let ((val (operand-constant-value op))) (log 'memoized-constant gensym val) (for-tail val))) - ((visit-operand op counter ctx recursive-effort-limit operand-size-limit) + ((visit-operand op counter (if (eq? ctx 'values) 'value ctx) + recursive-effort-limit operand-size-limit) => ;; If we end up deciding to residualize this value instead of ;; copying it, save that residualized value. @@ -740,7 +819,7 @@ top-level bindings from ENV and return the resulting expression." ;; It could be this constant is the result of folding. ;; If that is the case, cache it. This helps loop ;; unrolling get farther. - (if (eq? ctx 'value) + (if (or (eq? ctx 'value) (eq? ctx 'values)) (begin (log 'memoize-constant gensym val) (set-operand-constant-value! op val))) @@ -787,14 +866,64 @@ top-level bindings from ENV and return the resulting expression." exp (make-seq src exp (make-void #f)))) (begin - (set-operand-residualize?! op #t) + (record-operand-use op) (make-lexical-set src name (operand-sym op) (for-value exp)))))) + (($ src + (names ... rest) + (gensyms ... rest-sym) + (vals ... ($ _ 'list rest-args)) + ($ asrc (or 'apply '@apply) + (proc args ... + ($ _ + (? (cut eq? <> rest)) + (? (lambda (sym) + (and (eq? sym rest-sym) + (= (lexical-refcount sym) 1)))))))) + (let* ((tmps (make-list (length rest-args) 'tmp)) + (tmp-syms (fresh-temporaries tmps))) + (for-tail + (make-let src + (append names tmps) + (append gensyms tmp-syms) + (append vals rest-args) + (make-call + asrc + proc + (append args + (map (cut make-lexical-ref #f <> <>) + tmps tmp-syms))))))) (($ src names gensyms vals body) + (define (compute-alias exp) + ;; It's very common for macros to introduce something like: + ;; + ;; ((lambda (x y) ...) x-exp y-exp) + ;; + ;; In that case you might end up trying to inline something like: + ;; + ;; (let ((x x-exp) (y y-exp)) ...) + ;; + ;; But if x-exp is itself a lexical-ref that aliases some much + ;; larger expression, perhaps it will fail to inline due to + ;; size. However we don't want to introduce a useless alias + ;; (in this case, x). So if the RHS of a let expression is a + ;; lexical-ref, we record that expression. If we end up having + ;; to residualize X, then instead we residualize X-EXP, as long + ;; as it isn't assigned. + ;; + (match exp + (($ _ _ sym) + (let ((op (lookup sym))) + (and (not (var-set? (operand-var op))) + (or (operand-alias-value op) + exp)))) + (_ #f))) + (let* ((vars (map lookup-var gensyms)) (new (fresh-gensyms vars)) (ops (make-bound-operands vars new vals (lambda (exp counter ctx) - (loop exp env counter ctx)))) + (loop exp env counter ctx)) + (map compute-alias vals))) (env (fold extend-env env gensyms ops)) (body (loop body env counter ctx))) (cond @@ -820,7 +949,9 @@ top-level bindings from ENV and return the resulting expression." (($ src in-order? names gensyms vals body) ;; Note the difference from the `let' case: here we use letrec* ;; so that the `visit' procedure for the new operands closes over - ;; an environment that includes the operands. + ;; an environment that includes the operands. Also we don't try + ;; to elide aliases, because we can't sensibly reduce something + ;; like (letrec ((a b) (b a)) a). (letrec* ((visit (lambda (exp counter ctx) (loop exp env* counter ctx))) (vars (map lookup-var gensyms)) @@ -854,13 +985,15 @@ top-level bindings from ENV and return the resulting expression." ;; 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))) + (let ((producer (for-values producer))) (or (match consumer - (($ src req #f #f #f () gensyms body #f) - (cond - ((inline-values producer src req gensyms body) - => for-tail) - (else #f))) + (($ src req opt rest #f inits gensyms body #f) + (let* ((nmin (length req)) + (nmax (and (not rest) (+ nmin (if opt (length opt) 0))))) + (cond + ((inline-values lv-src producer nmin nmax consumer) + => for-tail) + (else #f)))) (_ #f)) (make-let-values lv-src producer (for-tail consumer))))) (($ src winder pre body post unwinder) @@ -902,14 +1035,79 @@ top-level bindings from ENV and return the resulting expression." ((test) (make-const #f #t)) (else exp))) (($ 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))))) + (define (call-with-failure-thunk exp proc) + (match exp + (($ _ _ ()) (proc exp)) + (($ _ _ ()) (proc exp)) + (($ ) (proc exp)) + (($ ) (proc exp)) + (($ ) (proc exp)) + (_ + (let ((t (gensym "failure-"))) + (record-new-temporary! 'failure t 2) + (make-let + src (list 'failure) (list t) + (list + (make-lambda + #f '() + (make-lambda-case #f '() #f #f #f '() '() exp #f))) + (proc (make-call #f (make-lexical-ref #f 'failure t) + '()))))))) + (define (simplify-conditional c) + (match c + ;; Swap the arms of (if (not FOO) A B), to simplify. + (($ src ($ _ 'not (pred)) + subsequent alternate) + (simplify-conditional + (make-conditional src pred alternate subsequent))) + ;; Special cases for common tests in the predicates of chains + ;; of if expressions. + (($ src + ($ src* outer-test inner-test ($ _ #f)) + inner-subsequent + alternate) + (let lp ((alternate alternate)) + (match alternate + ;; Lift a common repeated test out of a chain of if + ;; expressions. + (($ _ (? (cut tree-il=? outer-test <>)) + other-subsequent alternate) + (make-conditional + src outer-test + (simplify-conditional + (make-conditional src* inner-test inner-subsequent + other-subsequent)) + alternate)) + ;; Likewise, but punching through any surrounding + ;; failure continuations. + (($ let-src (name) (sym) ((and thunk ($ ))) body) + (make-let + let-src (list name) (list sym) (list thunk) + (lp body))) + ;; Otherwise, rotate AND tests to expose a simple + ;; condition in the front. Although this may result in + ;; lexically binding failure thunks, the thunks will be + ;; compiled to labels allocation, so there's no actual + ;; code growth. + (_ + (call-with-failure-thunk + alternate + (lambda (failure) + (make-conditional + src outer-test + (simplify-conditional + (make-conditional src* inner-test inner-subsequent failure)) + failure))))))) + (_ c))) + (match (for-test condition) + (($ _ val) + (if val + (for-tail subsequent) + (for-tail alternate))) + (c + (simplify-conditional + (make-conditional src c (for-tail subsequent) + (for-tail alternate)))))) (($ src '@call-with-values (producer ($ _ _ @@ -919,7 +1117,6 @@ top-level bindings from ENV and return the resulting expression." _ req #f rest #f () gensyms body #f))))) (for-tail (make-let-values src (make-call src producer '()) consumer))) - (($ src 'dynamic-wind (w thunk u)) (for-tail (cond @@ -963,6 +1160,47 @@ top-level bindings from ENV and return the resulting expression." (make-dynwind src w (make-call #f w '()) (make-call #f thunk '()) (make-call #f u '()) u))))) + (($ src 'values exps) + (cond + ((null? exps) + (if (eq? ctx 'effect) + (make-void #f) + exp)) + (else + (let ((vals (map for-value exps))) + (if (and (case ctx + ((value test effect) #t) + (else (null? (cdr vals)))) + (every singly-valued-expression? vals)) + (for-tail (list->seq src (append (cdr vals) (list (car vals))))) + (make-primcall src 'values vals)))))) + + (($ src (or 'apply '@apply) (proc args ... tail)) + (let lp ((tail* (find-definition tail 1)) (speculative? #t)) + (define (copyable? x) + ;; Inlining a result from find-definition effectively copies it, + ;; relying on the let-pruning to remove its original binding. We + ;; shouldn't copy non-constant expressions. + (or (not speculative?) (constant-expression? x))) + (match tail* + (($ _ (args* ...)) + (let ((args* (map (cut make-const #f <>) args*))) + (for-tail (make-call src proc (append args args*))))) + (($ _ 'cons + ((and head (? copyable?)) (and tail (? copyable?)))) + (for-tail (make-primcall src '@apply + (cons proc + (append args (list head tail)))))) + (($ _ 'list + (and args* ((? copyable?) ...))) + (for-tail (make-call src proc (append args args*)))) + (tail* + (if speculative? + (lp (for-value tail) #f) + (let ((args (append (map for-value args) (list tail*)))) + (make-primcall src '@apply + (cons (for-value proc) args)))))))) + (($ src (? constructor-primitive? name) args) (cond ((and (memq ctx '(effect test)) @@ -982,7 +1220,7 @@ top-level bindings from ENV and return the resulting expression." (for-tail (list->seq src (append args (list res)))))) (else (match (cons name (map for-value args)) - (('cons x ($ _ ())) + (('cons x ($ _ (? (cut eq? <> '())))) (make-primcall src 'list (list x))) (('cons x ($ _ 'list elts)) (make-primcall src 'list (cons x elts))) @@ -1051,6 +1289,17 @@ top-level bindings from ENV and return the resulting expression." ((name . args) (fold-constants src name args ctx)))) + (($ src (? equality-primitive? name) (a b)) + (let ((val-a (for-value a)) + (val-b (for-value b))) + (log 'equality-primitive name val-a val-b) + (cond ((and (lexical-ref? val-a) (lexical-ref? val-b) + (eq? (lexical-ref-gensym val-a) + (lexical-ref-gensym val-b))) + (for-tail (make-const #f #t))) + (else + (fold-constants src name (list val-a val-b) ctx))))) + (($ src (? effect-free-primitive? name) args) (fold-constants src name (map for-value args) ctx)) @@ -1059,20 +1308,39 @@ top-level bindings from ENV and return the resulting expression." (($ src orig-proc orig-args) ;; todo: augment the global env with specialized functions - (let ((proc (visit orig-proc 'operator))) + (let revisit-proc ((proc (visit orig-proc 'operator))) (match proc (($ _ name) (for-tail (make-primcall src name orig-args))) (($ _ _ - ($ _ req opt #f #f inits gensyms body #f)) - ;; Simple case: no rest, no keyword arguments. + ($ _ req opt rest #f inits gensyms body #f)) + ;; Simple case: 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))) + (define (inlined-call) + (make-let src + (append req + (or opt '()) + (if rest (list rest) '())) + gensyms + (if (> nargs (+ nreq nopt)) + (append (list-head orig-args (+ nreq nopt)) + (list + (make-primcall + #f 'list + (drop orig-args (+ nreq nopt))))) + (append orig-args + (drop inits (- nargs nreq)) + (if rest + (list (make-const #f '())) + '()))) + body)) + (cond - ((or (< nargs nreq) (> nargs (+ nreq nopt))) + ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt)))) ;; An error, or effecting arguments. (make-call src (for-call orig-proc) (map for-value orig-args))) ((or (and=> (find-counter key counter) counter-recursive?) @@ -1096,12 +1364,7 @@ top-level bindings from ENV and return the resulting expression." (lp (counter-prev counter))))))) (log 'inline-recurse key) - (loop (make-let src (append req (or opt '())) - gensyms - (append orig-args - (drop inits (- nargs nreq))) - body) - env counter ctx)) + (loop (inlined-call) env counter ctx)) (else ;; An integration at the top-level, the first ;; recursion of a recursive procedure, or a nested @@ -1132,12 +1395,7 @@ top-level bindings from ENV and return the resulting expression." (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)) + (loop (inlined-call) env new-counter ctx)) (if counter ;; The nested inlining attempt succeeded. @@ -1147,6 +1405,31 @@ top-level bindings from ENV and return the resulting expression." (log 'inline-end result exp) result))))) + (($ _ _ _ vals _) + ;; Attempt to inline `let' in the operator position. + ;; + ;; We have to re-visit the proc in value mode, since the + ;; `let' bindings might have been introduced or renamed, + ;; whereas the lambda (if any) in operator position has not + ;; been renamed. + (if (or (and-map constant-expression? vals) + (and-map constant-expression? orig-args)) + ;; The arguments and the let-bound values commute. + (match (for-value orig-proc) + (($ lsrc names syms vals body) + (log 'inline-let orig-proc) + (for-tail + (make-let lsrc names syms vals + (make-call src body orig-args)))) + ;; It's possible for a `let' to go away after the + ;; visit due to the fact that visiting a procedure in + ;; value context will prune unused bindings, whereas + ;; visiting in operator mode can't because it doesn't + ;; traverse through lambdas. In that case re-visit + ;; the procedure. + (proc (revisit-proc proc))) + (make-call src (for-call orig-proc) + (map for-value orig-args)))) (_ (make-call src (for-call orig-proc) (map for-value orig-args)))))) (($ src meta body) @@ -1156,23 +1439,38 @@ top-level bindings from ENV and return the resulting expression." ((operator) exp) (else (record-source-expression! exp - (make-lambda src meta (for-tail body)))))) + (make-lambda src meta (and body (for-values body))))))) (($ src req opt rest kw inits gensyms body alt) + (define (lift-applied-lambda body gensyms) + (and (not opt) rest (not kw) + (match body + (($ _ '@apply + (($ _ _ (and lcase ($ ))) + ($ _ _ sym) + ...)) + (and (equal? sym gensyms) + (not (lambda-case-alternate lcase)) + lcase)) + (_ #f)))) (let* ((vars (map lookup-var gensyms)) (new (fresh-gensyms vars)) (env (fold extend-env env gensyms (make-unbound-operands vars new))) (new-sym (lambda (old) - (operand-sym (cdr (vhash-assq old env)))))) - (make-lambda-case src req opt rest - (match kw - ((aok? (kw name old) ...) - (cons aok? (map list kw name (map new-sym old)))) - (_ #f)) - (map (cut loop <> env counter 'value) inits) - new - (loop body env counter ctx) - (and alt (for-tail alt))))) + (operand-sym (cdr (vhash-assq old env))))) + (body (loop body env counter ctx))) + (or + ;; (lambda args (apply (lambda ...) args)) => (lambda ...) + (lift-applied-lambda body new) + (make-lambda-case src req opt rest + (match kw + ((aok? (kw name old) ...) + (cons aok? (map list kw name (map new-sym old)))) + (_ #f)) + (map (cut loop <> env counter 'value) inits) + new + body + (and alt (for-tail alt)))))) (($ src head tail) (let ((head (for-effect head)) (tail (for-tail tail))) @@ -1185,24 +1483,48 @@ top-level bindings from ENV and return the resulting expression." head) tail)))) (($ src tag body handler) - (define (singly-used-definition x) + (define (make-prompt-tag? x) + (match x + (($ _ 'make-prompt-tag (or () ((? constant-expression?)))) + #t) + (_ #f))) + + (let ((tag (for-value tag)) + (body (for-tail body))) (cond - ((and (lexical-ref? x) - ;; Only fetch definitions with single uses. - (= (lexical-refcount (lexical-ref-gensym x)) 1) - (lookup (lexical-ref-gensym x))) - => (lambda (x) - (singly-used-definition (visit-operand x counter 'value 10 10)))) - (else x))) - (match (singly-used-definition tag) - (($ _ 'make-prompt-tag (or () ((? constant-expression?)))) - ;; There is no way that an could know the tag - ;; for this , so we can elide the - ;; entirely. - (for-tail body)) - (_ - (make-prompt src (for-value tag) (for-tail body) - (for-value handler))))) + ((find-definition tag 1) + (lambda (val op) + (make-prompt-tag? val)) + => (lambda (val op) + ;; There is no way that an could know the tag + ;; for this , so we can elide the + ;; entirely. + (unrecord-operand-uses op 1) + body)) + ((find-definition tag 2) + (lambda (val op) + (and (make-prompt-tag? val) + (abort? body) + (tree-il=? (abort-tag body) tag))) + => (lambda (val op) + ;; (let ((t (make-prompt-tag))) + ;; (call-with-prompt t + ;; (lambda () (abort-to-prompt t val ...)) + ;; (lambda (k arg ...) e ...))) + ;; => (let-values (((k arg ...) (values values val ...))) + ;; e ...) + (unrecord-operand-uses op 2) + (for-tail + (make-let-values + src + (make-primcall #f 'apply + `(,(make-primitive-ref #f 'values) + ,(make-primitive-ref #f 'values) + ,@(abort-args body) + ,(abort-tail body))) + (for-value handler))))) + (else + (make-prompt src tag body (for-value handler)))))) (($ src tag args tail) (make-abort src (for-value tag) (map for-value args) (for-value tail))))))