diff options
Diffstat (limited to 'module/language/tree-il/peval.scm')
-rw-r--r-- | module/language/tree-il/peval.scm | 1675 |
1 files changed, 1675 insertions, 0 deletions
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm new file mode 100644 index 000000000..b8a0fe9d0 --- /dev/null +++ b/module/language/tree-il/peval.scm @@ -0,0 +1,1675 @@ +;;; Tree-IL partial evaluator + +;; Copyright (C) 2011-2014, 2017 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 +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(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) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (ice-9 control) + #:export (peval)) + +;;; +;;; Partial evaluation is Guile's most important source-to-source +;;; optimization pass. It performs copy propagation, dead code +;;; elimination, inlining, and constant folding, all while preserving +;;; the order of effects in the residual program. +;;; +;;; For more on partial evaluation, see William Cook’s excellent +;;; tutorial on partial evaluation at DSL 2011, called “Build your own +;;; partial evaluator in 90 minutes”[0]. +;;; +;;; Our implementation of this algorithm was heavily influenced by +;;; Waddell and Dybvig's paper, "Fast and Effective Procedure Inlining", +;;; IU CS Dept. TR 484. +;;; +;;; [0] http://www.cs.utexas.edu/~wcook/tutorial/. +;;; + +;; First, some helpers. +;; +(define-syntax *logging* (identifier-syntax #f)) + +;; For efficiency we define *logging* to inline to #f, so that the call +;; to log* gets optimized out. If you want to log, uncomment these +;; lines: +;; +;; (define %logging #f) +;; (define-syntax *logging* (identifier-syntax %logging)) +;; +;; Then you can change %logging at runtime. + +(define-syntax log + (syntax-rules (quote) + ((log 'event arg ...) + (if (and *logging* + (or (eq? *logging* #t) + (memq 'event *logging*))) + (log* 'event arg ...))))) + +(define (log* event . args) + (let ((pp (module-ref (resolve-interface '(ice-9 pretty-print)) + 'pretty-print))) + (pp `(log ,event . ,args)) + (newline) + (values))) + +(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) #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 (singly-valued-expression? exp) + (match exp + (($ <const>) #t) + (($ <void>) #t) + (($ <lexical-ref>) #t) + (($ <primitive-ref>) #t) + (($ <module-ref>) #t) + (($ <toplevel-ref>) #t) + (($ <primcall> _ (? singly-valued-primitive?)) #t) + (($ <primcall> _ 'values (val)) #t) + (($ <lambda>) #t) + (($ <conditional> _ test consequent alternate) + (and (singly-valued-expression? consequent) + (singly-valued-expression? alternate))) + (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. +;; +(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 (cdr (vhash-assq gensym res)))) + (set-var-refcount! var (1+ (var-refcount var))) + res)) + (($ <lambda-case> src req opt rest kw init gensyms body alt) + (fold (lambda (name sym res) + (vhash-consq sym (make-var name sym 0 #f) res)) + res + (append req (or opt '()) (if rest (list rest) '()) + (match kw + ((aok? (kw name sym) ...) name) + (_ '()))) + gensyms)) + (($ <let> src names gensyms vals body) + (fold (lambda (name sym res) + (vhash-consq sym (make-var name sym 0 #f) res)) + res names gensyms)) + (($ <letrec> src in-order? names gensyms vals body) + (fold (lambda (name sym res) + (vhash-consq sym (make-var name sym 0 #f) res)) + res names gensyms)) + (($ <fix> src names gensyms vals body) + (fold (lambda (name sym res) + (vhash-consq sym (make-var name sym 0 #f) res)) + res names gensyms)) + (($ <lexical-set> src name gensym exp) + (set-var-set?! (cdr (vhash-assq gensym res)) #t) + res) + (_ res))) + (lambda (exp res) res) + table exp)) + +;; Counters are data structures used to limit the effort that peval +;; spends on particular inlining attempts. Each call site in the source +;; program is allocated some amount of effort. If peval exceeds the +;; effort counter while attempting to inline a call site, it aborts the +;; inlining attempt and residualizes a call instead. +;; +;; As there is a fixed number of call sites, that makes `peval' O(N) in +;; the number of call sites in the source program. +;; +;; Counters should limit the size of the residual program as well, but +;; currently this is not implemented. +;; +;; At the top level, before seeing any peval call, there is no counter, +;; because inlining will terminate as there is no recursion. When peval +;; sees a call at the top level, it will make a new counter, allocating +;; it some amount of effort and size. +;; +;; This top-level effort counter effectively "prints money". Within a +;; toplevel counter, no more effort is printed ex nihilo; for a nested +;; inlining attempt to proceed, effort must be transferred from the +;; toplevel counter to the nested counter. +;; +;; Via `data' and `prev', counters form a linked list, terminating in a +;; toplevel counter. In practice `data' will be the a pointer to the +;; source expression of the procedure being inlined. +;; +;; In this way peval can detect a recursive inlining attempt, by walking +;; back on the `prev' links looking for matching `data'. Recursive +;; counters receive a more limited effort allocation, as we don't want +;; to spend all of the effort for a toplevel inlining site on loops. +;; Also, recursive counters don't need a prompt at each inlining site: +;; either the call chain folds entirely, or it will be residualized at +;; its original call. +;; +(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? set-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)) + +;; Operand structures allow bindings to be processed lazily instead of +;; eagerly. By doing so, hopefully we can get process them in a way +;; appropriate to their use contexts. Operands also prevent values from +;; being visited multiple times, wasting effort. +;; +;; TODO: Record value size in operand structure? +;; +(define-record-type <operand> + (%make-operand var sym visit source visit-count use-count + copyable? residual-value constant-value alias) + operand? + (var operand-var) + (sym operand-sym) + (visit %operand-visit) + (source operand-source) + (visit-count operand-visit-count set-operand-visit-count!) + (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!) + (alias operand-alias set-operand-alias!)) + +(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 + (($ <primcall> 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 + ;; operand outside a counter -- i.e., outside an inlining attempt -- + ;; this can lead to divergence. So, if we are visiting an operand to + ;; try to copy it, and there is no counter, make a new one. + ;; + ;; This will only happen at most as many times as there are lexical + ;; references in the source program. + (and (zero? (operand-visit-count op)) + (dynamic-wind + (lambda () + (set-operand-visit-count! op (1+ (operand-visit-count op)))) + (lambda () + (and (operand-source op) + (if (or counter (and (not effort-limit) (not size-limit))) + ((%operand-visit op) (operand-source op) counter ctx) + (let/ec k + (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) + ctx))))) + (lambda () + (set-operand-visit-count! op (1- (operand-visit-count op))))))) + +;; A helper for constant folding. +;; +(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." + + ;; This is a simple partial evaluator. It effectively performs + ;; constant folding, copy propagation, dead code elimination, and + ;; inlining. + + ;; TODO: + ;; + ;; Propagate copies across toplevel bindings, if we can prove the + ;; bindings to be immutable. + ;; + ;; Specialize lambda expressions with invariant arguments. + + (define local-toplevel-env + ;; The top-level environment of the module being compiled. + (let () + (define (env-folder x env) + (match x + (($ <toplevel-define> _ name) + (vhash-consq name #t env)) + (($ <seq> _ head tail) + (env-folder tail (env-folder head env))) + (_ env))) + (env-folder exp vlist-null))) + + (define (local-toplevel? name) + (vhash-assq name local-toplevel-env)) + + ;; gensym -> <var> + ;; renamed-term -> original-term + ;; + (define store (build-var-table exp)) + + (define (record-new-temporary! name sym refcount) + (set! store (vhash-consq sym (make-var name sym refcount #f) store))) + + (define (lookup-var sym) + (let ((v (vhash-assq sym store))) + (if v (cdr v) (error "unbound var" sym (vlist->list store))))) + + (define (fresh-gensyms vars) + (map (lambda (var) + (let ((new (gensym (string-append (symbol->string (var-name var)) + " ")))) + (set! store (vhash-consq new var store)) + 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))) + + (define (lexical-refcount sym) + (var-refcount (lookup-var sym))) + + (define (with-temporaries src exps refcount can-copy? k) + (let* ((pairs (map (match-lambda + ((and exp (? can-copy?)) + (cons #f exp)) + (exp + (let ((sym (gensym "tmp "))) + (record-new-temporary! 'tmp sym refcount) + (cons sym exp)))) + exps)) + (tmps (filter car pairs))) + (match tmps + (() (k exps)) + (tmps + (make-let src + (make-list (length tmps) 'tmp) + (map car tmps) + (map cdr tmps) + (k (map (match-lambda + ((#f . val) val) + ((sym . _) + (make-lexical-ref #f 'tmp sym))) + pairs))))))) + + (define (make-begin0 src first second) + (make-let-values + src + first + (let ((vals (gensym "vals "))) + (record-new-temporary! 'vals vals 1) + (make-lambda-case + #f + '() #f 'vals #f '() (list vals) + (make-seq + src + second + (make-primcall #f 'apply + (list + (make-primitive-ref #f 'values) + (make-lexical-ref #f 'vals vals)))) + #f)))) + + ;; ORIG has been alpha-renamed to NEW. Analyze NEW and record a link + ;; from it to ORIG. + ;; + (define (record-source-expression! orig new) + (set! store (vhash-consq new (source-expression orig) store)) + new) + + ;; Find the source expression corresponding to NEW. Used to detect + ;; recursive inlining attempts. + ;; + (define (source-expression new) + (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) + (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 (fold-constants src name args ctx) + (define (apply-primitive name args) + ;; todo: further optimize commutative primitives + (catch #t + (lambda () + (call-with-values + (lambda () + (case name + ((eq? eqv?) + ;; Constants will be deduplicated later, but eq? + ;; folding can happen now. Anticipate the + ;; deduplication by using equal? instead of eq?. + ;; Same for eqv?. + (apply equal? args)) + (else + (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 + ((every const? args) + (let-values (((success? values) + (apply-primitive name (map const-exp args)))) + (log 'fold success? values name args) + (if success? + (case ctx + ((effect) (make-void src)) + ((test) + ;; Values truncation: only take the first + ;; value. + (if (pair? values) + (make-const src (car values)) + (make-values src '()))) + (else + (make-values src (map (cut make-const src <>) values)))) + (residualize-call)))) + ((and (eq? ctx 'effect) (types-check? name args)) + (make-void #f)) + (else + (residualize-call)))) + + (define (inline-values src exp nmin nmax consumer) + (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>) + ($ <lexical-set>) ; FIXME: these set! expressions + ($ <toplevel-set>) ; could return zero values in + ($ <toplevel-define>) ; the future + ($ <module-set>) ; + ($ <primcall> 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. + (($ <primcall> src 'values vals) + (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. + (($ <conditional>) #f) + + ;; Bail on other applications. + (($ <call>) #f) + (($ <primcall>) #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))))) + (($ <seq> src head tail) + (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). + (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 + ;; cases we need to make sure that if referenced binding A needs + ;; as-yet-unreferenced binding B, that B is processed for value. + ;; Likewise if C, when processed for effect, needs otherwise + ;; unreferenced D, then D needs to be processed for value too. + ;; + (define (referenced? op) + ;; When we visit lambdas in operator context, we just copy them, + ;; as we will process their body later. However this does have + ;; the problem that any free var referenced by the lambda is not + ;; 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) + (not (zero? (operand-use-count op))))) + + ;; values := (op ...) + ;; effects := (op ...) + (define (residualize values effects) + ;; Note, values and effects are reversed. + (cond + (in-order? + (let ((values (filter operand-residual-value ops))) + (if (null? values) + body + (build-result (map (compose var-name operand-var) values) + (map operand-sym values) + (map operand-residual-value values) + body)))) + (else + (let ((body + (if (null? effects) + body + (let ((effect-vals (map operand-residual-value effects))) + (list->seq #f (reverse (cons body effect-vals))))))) + (if (null? values) + body + (let ((values (reverse values))) + (build-result (map (compose var-name operand-var) values) + (map operand-sym values) + (map operand-residual-value values) + body))))))) + + ;; old := (bool ...) + ;; values := (op ...) + ;; effects := ((op . value) ...) + (let prune ((old (map referenced? ops)) (values '()) (effects '())) + (let lp ((ops* ops) (values values) (effects effects)) + (cond + ((null? ops*) + (let ((new (map referenced? ops))) + (if (not (equal? new old)) + (prune new values '()) + (residualize values + (map (lambda (op val) + (set-operand-residual-value! op val) + op) + (map car effects) (map cdr effects)))))) + (else + (let ((op (car ops*))) + (cond + ((memq op values) + (lp (cdr ops*) values effects)) + ((operand-residual-value op) + (lp (cdr ops*) (cons op values) effects)) + ((referenced? op) + (set-operand-residual-value! op (visit-operand op counter 'value)) + (lp (cdr ops*) (cons op values) effects)) + (else + (lp (cdr ops*) + values + (let ((effect (visit-operand op counter 'effect))) + (if (void? effect) + effects + (acons op effect effects)))))))))))) + + (define (small-expression? x limit) + (let/ec k + (tree-il-fold + (lambda (x res) ; down + (1+ res)) + (lambda (x res) ; up + (if (< res limit) + res + (k #f))) + 0 x) + #t)) + + (define (extend-env sym op env) + (vhash-consq (operand-sym op) op (vhash-consq sym op env))) + + (let loop ((exp exp) + (env vlist-null) ; vhash of gensym -> <operand> + (counter #f) ; inlined call stack + (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) + (if (var-set? (operand-var op)) + (values #f #f) + (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)) + (define (for-tail exp) (visit exp ctx)) + + (if counter + (record-effort! counter)) + + (log 'visit ctx (and=> counter effort-counter) + (unparse-tree-il exp)) + + (match exp + (($ <const>) + (case ctx + ((effect) (make-void #f)) + (else exp))) + (($ <void>) + (case ctx + ((test) (make-const #f #t)) + (else exp))) + (($ <lexical-ref> _ _ gensym) + (log 'begin-copy gensym) + (let lp ((op (lookup gensym))) + (cond + ((eq? ctx 'effect) + (log 'lexical-for-effect gensym) + (make-void #f)) + ((operand-alias op) + ;; This is an unassigned operand that simply aliases some + ;; other operand. Recurse to avoid residualizing the leaf + ;; binding. + => lp) + ((eq? ctx 'call) + ;; Don't propagate copies if we are residualizing a call. + (log 'residualize-lexical-call gensym op) + (residualize-lexical op)) + ((var-set? (operand-var op)) + ;; Assigned lexicals don't copy-propagate. + (log 'assigned-var gensym op) + (residualize-lexical op)) + ((not (operand-copyable? op)) + ;; We already know that this operand is not copyable. + (log 'not-copyable gensym op) + (residualize-lexical op)) + ((and=> (operand-constant-value op) + (lambda (x) (or (const? x) (void? x) (primitive-ref? x)))) + ;; A cache hit. + (let ((val (operand-constant-value op))) + (log 'memoized-constant gensym val) + (for-tail val))) + ((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. + (lambda (val) + (cond + ((not (constant-expression? val)) + (log 'not-constant gensym op) + ;; At this point, ctx is operator, test, or value. A + ;; value that is non-constant in one context will be + ;; non-constant in the others, so it's safe to record + ;; that here, and avoid future visits. + (set-operand-copyable?! op #f) + (residualize-lexical op ctx val)) + ((or (const? val) + (void? val) + (primitive-ref? val)) + ;; Always propagate simple values that cannot lead to + ;; code bloat. + (log 'copy-simple gensym val) + ;; It could be this constant is the result of folding. + ;; If that is the case, cache it. This helps loop + ;; unrolling get farther. + (if (or (eq? ctx 'value) (eq? ctx 'values)) + (begin + (log 'memoize-constant gensym val) + (set-operand-constant-value! op val))) + val) + ((= 1 (var-refcount (operand-var op))) + ;; Always propagate values referenced only once. + (log 'copy-single gensym val) + 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)) + (begin + (log 'copy-operator gensym val) + val) + (begin + (log 'too-big-for-operator gensym val) + (residualize-lexical op ctx val)))) + (else + ;; A pure expression, processed for call or 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))) + (begin + (log 'copy-value gensym val) + val) + (begin + (log 'too-big-or-has-lambda gensym val) + (residualize-lexical op ctx val))))))) + (else + ;; Visit failed. Either the operand isn't bound, as in + ;; lambda formal parameters, or the copy was aborted. + (log 'unbound-or-aborted gensym op) + (residualize-lexical op))))) + (($ <lexical-set> src name gensym exp) + (let ((op (lookup gensym))) + (if (zero? (var-refcount (operand-var op))) + (let ((exp (for-effect exp))) + (if (void? exp) + exp + (make-seq src exp (make-void #f)))) + (begin + (record-operand-use op) + (make-lexical-set src name (operand-sym op) (for-value exp)))))) + (($ <let> src + (names ... rest) + (gensyms ... rest-sym) + (vals ... ($ <primcall> _ 'list rest-args)) + ($ <primcall> asrc 'apply + (proc args ... + ($ <lexical-ref> _ + (? (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))))))) + (($ <let> src names gensyms vals body) + (define (lookup-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 + (($ <lexical-ref> _ _ sym) + (let ((op (lookup sym))) + (and (not (var-set? (operand-var op))) op))) + (_ #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)) + (map lookup-alias vals))) + (env (fold extend-env env gensyms ops)) + (body (loop body env counter ctx))) + (match body + (($ <const>) + (for-tail (list->seq src (append vals (list body))))) + (($ <lexical-ref> _ _ (? (lambda (sym) (memq sym new)) sym)) + (let ((pairs (map cons new vals))) + ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo) + (for-tail + (list->seq + src + (append (map cdr (alist-delete sym pairs eq?)) + (list (assq-ref pairs sym))))))) + ((and ($ <conditional> src* + ($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym) alt) + (? (lambda (_) + (case ctx + ((test effect) + (and (equal? (list sym) new) + (= (lexical-refcount sym) 2))) + (else #f))))) + ;; (let ((x EXP)) (if x x ALT)) -> (if EXP #t ALT) in test context + (make-conditional src* (visit-operand (car ops) counter 'test) + (make-const src* #t) alt)) + (_ + ;; Only include bindings for which lexical references + ;; have been residualized. + (prune-bindings ops #f body counter ctx + (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) + ;; 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. 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)) + (new (fresh-gensyms vars)) + (ops (make-bound-operands vars new vals visit)) + (env* (fold extend-env env gensyms ops)) + (body* (visit body counter ctx))) + (if (and (const? body*) (every constant-expression? vals)) + ;; We may have folded a loop completely, even though there + ;; might be cyclical references between the bound values. + ;; Handle this degenerate case specially. + body* + (prune-bindings ops in-order? body* counter ctx + (lambda (names gensyms vals body) + (make-letrec src in-order? + names gensyms vals body)))))) + (($ <fix> src names gensyms vals body) + (letrec* ((visit (lambda (exp counter ctx) + (loop exp env* counter ctx))) + (vars (map lookup-var gensyms)) + (new (fresh-gensyms vars)) + (ops (make-bound-operands vars new vals visit)) + (env* (fold extend-env env gensyms ops)) + (body* (visit body counter ctx))) + (if (const? body*) + body* + (prune-bindings ops #f body* counter ctx + (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-values producer))) + (or (match consumer + ((and ($ <lambda-case> src () #f rest #f () (rest-sym) body #f) + (? (lambda _ (singly-valued-expression? producer)))) + (let ((tmp (gensym "tmp "))) + (record-new-temporary! 'tmp tmp 1) + (for-tail + (make-let + src (list 'tmp) (list tmp) (list producer) + (make-let + src (list rest) (list rest-sym) + (list + (make-primcall #f 'list + (list (make-lexical-ref #f 'tmp tmp)))) + body))))) + (($ <lambda-case> 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))))) + (($ <toplevel-ref> src (? effect-free-primitive? name)) + exp) + (($ <toplevel-ref>) + ;; todo: open private local bindings. + exp) + (($ <module-ref> src module (? effect-free-primitive? name) #f) + (let ((module (false-if-exception + (resolve-module module #:ensure #f)))) + (if (module? module) + (let ((var (module-variable module name))) + (if (eq? var (module-variable the-scm-module name)) + (make-primitive-ref src name) + exp)) + 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) + (define (call-with-failure-thunk exp proc) + (match exp + (($ <call> _ _ ()) (proc exp)) + (($ <primcall> _ _ ()) (proc exp)) + (($ <const>) (proc exp)) + (($ <void>) (proc exp)) + (($ <lexical-ref>) (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. + (($ <conditional> src ($ <primcall> _ 'not (pred)) + subsequent alternate) + (simplify-conditional + (make-conditional src pred alternate subsequent))) + ;; In the following four cases, we try to expose the test to + ;; the conditional. This will let the CPS conversion avoid + ;; reifying boolean literals in some cases. + (($ <conditional> src ($ <let> src* names vars vals body) + subsequent alternate) + (make-let src* names vars vals + (simplify-conditional + (make-conditional src body subsequent alternate)))) + (($ <conditional> src + ($ <letrec> src* in-order? names vars vals body) + subsequent alternate) + (make-letrec src* in-order? names vars vals + (simplify-conditional + (make-conditional src body subsequent alternate)))) + (($ <conditional> src ($ <fix> src* names vars vals body) + subsequent alternate) + (make-fix src* names vars vals + (simplify-conditional + (make-conditional src body subsequent alternate)))) + (($ <conditional> src ($ <seq> src* head tail) + subsequent alternate) + (make-seq src* head + (simplify-conditional + (make-conditional src tail subsequent alternate)))) + ;; Special cases for common tests in the predicates of chains + ;; of if expressions. + (($ <conditional> src + ($ <conditional> src* outer-test inner-test ($ <const> _ #f)) + inner-subsequent + alternate) + (let lp ((alternate alternate)) + (match alternate + ;; Lift a common repeated test out of a chain of if + ;; expressions. + (($ <conditional> _ (? (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> let-src (name) (sym) ((and thunk ($ <lambda>))) 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) + (($ <const> _ val) + (if val + (for-tail subsequent) + (for-tail alternate))) + (c + (simplify-conditional + (make-conditional src c (for-tail subsequent) + (for-tail alternate)))))) + (($ <primcall> src '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-call src producer '()) + consumer))) + (($ <primcall> src 'dynamic-wind (w thunk u)) + (for-tail + (with-temporaries + src (list w u) 2 constant-expression? + (match-lambda + ((w u) + (make-seq + src + (make-seq + src + (make-conditional + src + ;; fixme: introduce logic to fold thunk? + (make-primcall src 'thunk? (list u)) + (make-call src w '()) + (make-primcall + src 'throw + (list + (make-const #f 'wrong-type-arg) + (make-const #f "dynamic-wind") + (make-const #f "Wrong type (expecting thunk): ~S") + (make-primcall #f 'list (list u)) + (make-primcall #f 'list (list u))))) + (make-primcall src 'wind (list w u))) + (make-begin0 src + (make-call src thunk '()) + (make-seq src + (make-primcall src 'unwind '()) + (make-call src u '()))))))))) + + (($ <primcall> src 'with-fluid* (f v thunk)) + (for-tail + (with-temporaries + src (list f v thunk) 1 constant-expression? + (match-lambda + ((f v thunk) + (make-seq src + (make-primcall src 'push-fluid (list f v)) + (make-begin0 src + (make-call src thunk '()) + (make-primcall src 'pop-fluid '())))))))) + + (($ <primcall> src 'with-dynamic-state (state thunk)) + (for-tail + (with-temporaries + src (list state thunk) 1 constant-expression? + (match-lambda + ((state thunk) + (make-seq src + (make-primcall src 'push-dynamic-state (list state)) + (make-begin0 src + (make-call src thunk '()) + (make-primcall src 'pop-dynamic-state + '())))))))) + + (($ <primcall> 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)))))) + + (($ <primcall> src '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* + (($ <const> _ (args* ...)) + (let ((args* (map (cut make-const #f <>) args*))) + (for-tail (make-call src proc (append args args*))))) + (($ <primcall> _ 'cons + ((and head (? copyable?)) (and tail (? copyable?)))) + (for-tail (make-primcall src 'apply + (cons proc + (append args (list head tail)))))) + (($ <primcall> _ '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)))))))) + + (($ <primcall> src (? constructor-primitive? name) args) + (cond + ((and (memq ctx '(effect test)) + (match (cons name args) + ((or ('cons _ _) + ('list . _) + ('vector . _) + ('make-prompt-tag) + ('make-prompt-tag ($ <const> _ (? string?)))) + #t) + (_ #f))) + ;; Some expressions can be folded without visiting the + ;; arguments for value. + (let ((res (if (eq? ctx 'effect) + (make-void #f) + (make-const #f #t)))) + (for-tail (list->seq src (append args (list res)))))) + (else + (match (cons name (map for-value args)) + (('cons x ($ <const> _ (? (cut eq? <> '())))) + (make-primcall src 'list (list x))) + (('cons x ($ <primcall> _ 'list elts)) + (make-primcall src 'list (cons x elts))) + (('list) + (make-const src '())) + (('vector) + (make-const src '#())) + ((name . args) + (make-primcall src name args)))))) + + (($ <primcall> src 'thunk? (proc)) + (case ctx + ((effect) + (for-tail (make-seq src proc (make-void src)))) + (else + (match (for-value proc) + (($ <lambda> _ _ ($ <lambda-case> _ req)) + (for-tail (make-const src (null? req)))) + (proc + (match (find-definition proc 2) + (($ <lambda> _ _ ($ <lambda-case> _ req)) + (for-tail (make-const src (null? req)))) + (_ + (make-primcall src 'thunk? (list proc))))))))) + + (($ <primcall> src name args) + (match (cons name (map for-value args)) + ;; FIXME: these for-tail recursions could take place outside + ;; an effort counter. + (('car ($ <primcall> src 'cons (head tail))) + (for-tail (make-seq src tail head))) + (('cdr ($ <primcall> src 'cons (head tail))) + (for-tail (make-seq src head tail))) + (('car ($ <primcall> src 'list (head . tail))) + (for-tail (list->seq src (append tail (list head))))) + (('cdr ($ <primcall> src 'list (head . tail))) + (for-tail (make-seq src head (make-primcall #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))) + (((or 'memq 'memv) k ($ <const> _ (elts ...))) + ;; FIXME: factor + (case ctx + ((effect) + (for-tail + (make-seq src k (make-void #f)))) + ((test) + (cond + ((const? k) + ;; A shortcut. The `else' case would handle it, but + ;; this way is faster. + (let ((member (case name ((memq) memq) ((memv) memv)))) + (make-const #f (and (member (const-exp k) elts) #t)))) + ((null? elts) + (for-tail + (make-seq src k (make-const #f #f)))) + (else + (let ((t (gensym "t ")) + (eq (if (eq? name 'memq) 'eq? 'eqv?))) + (record-new-temporary! 't t (length elts)) + (for-tail + (make-let + src (list 't) (list t) (list k) + (let lp ((elts elts)) + (define test + (make-primcall #f eq + (list (make-lexical-ref #f 't t) + (make-const #f (car elts))))) + (if (null? (cdr elts)) + test + (make-conditional src test + (make-const #f #t) + (lp (cdr elts))))))))))) + (else + (cond + ((const? k) + (let ((member (case name ((memq) memq) ((memv) memv)))) + (make-const #f (member (const-exp k) elts)))) + ((null? elts) + (for-tail (make-seq src k (make-const #f #f)))) + (else + (make-primcall src name (list k (make-const #f elts)))))))) + (((? equality-primitive?) + ($ <lexical-ref> _ _ sym) ($ <lexical-ref> _ _ sym)) + (for-tail (make-const #f #t))) + + (('logbit? ($ <const> src2 + (? (lambda (bit) + (and (exact-integer? bit) + (<= 0 bit (logcount most-positive-fixnum)))) + bit)) + val) + (for-tail + (make-primcall src 'logtest + (list (make-const src2 (ash 1 bit)) val)))) + + (('logtest a b) + (for-tail + (make-primcall + src + 'not + (list + (make-primcall src 'eq? + (list (make-primcall src 'logand (list a b)) + (make-const src 0))))))) + + (((? effect-free-primitive?) . args) + (fold-constants src name args ctx)) + + ((name . args) + (make-primcall src name args)))) + + (($ <call> src orig-proc orig-args) + ;; todo: augment the global env with specialized functions + (let revisit-proc ((proc (visit orig-proc 'operator))) + (match proc + (($ <primitive-ref> _ name) + (for-tail + (expand-primcall (make-primcall src name orig-args)))) + (($ <lambda> _ _ + ($ <lambda-case> _ 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)) + (opt (or opt '())) + (rest (if rest (list rest) '())) + (nopt (length opt)) + (key (source-expression proc))) + (define (singly-referenced-lambda? orig-proc) + (match orig-proc + (($ <lambda>) #t) + (($ <lexical-ref> _ _ sym) + (and (not (assigned-lexical? sym)) + (= (lexical-refcount sym) 1) + (singly-referenced-lambda? + (operand-source (lookup sym))))) + (_ #f))) + (define (inlined-call) + (let ((req-vals (list-head orig-args nreq)) + (opt-vals (let lp ((args (drop orig-args nreq)) + (inits inits) + (out '())) + (match inits + (() (reverse out)) + ((init . inits) + (match args + (() + (lp '() inits (cons init out))) + ((arg . args) + (lp args inits (cons arg out)))))))) + (rest-vals (cond + ((> nargs (+ nreq nopt)) + (list (make-primcall + #f 'list + (drop orig-args (+ nreq nopt))))) + ((null? rest) '()) + (else (list (make-const #f '())))))) + (if (>= nargs (+ nreq nopt)) + (make-let src + (append req opt rest) + gensyms + (append req-vals opt-vals rest-vals) + body) + ;; The default initializers of optional arguments + ;; may refer to earlier arguments, so in the general + ;; case we must expand into a series of nested let + ;; expressions. + ;; + ;; In the generated code, the outermost let + ;; expression will bind all required arguments, as + ;; well as the empty rest argument, if any. Each + ;; optional argument will be bound within an inner + ;; let. + (make-let src + (append req rest) + (append (list-head gensyms nreq) + (last-pair gensyms)) + (append req-vals rest-vals) + (fold-right (lambda (var gensym val body) + (make-let src + (list var) + (list gensym) + (list val) + body)) + body + opt + (list-head (drop gensyms nreq) nopt) + opt-vals))))) + + (cond + ((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?) + (singly-referenced-lambda? orig-proc)) + ;; A recursive call, or a lambda in the operator + ;; position of the source expression. Process again in + ;; tail context. + ;; + ;; In the recursive case, mark intervening counters as + ;; recursive, so we can handle a toplevel counter that + ;; recurses mutually with some other procedure. + ;; Otherwise, the next time we see the other procedure, + ;; the effort limit would be clamped to 100. + ;; + (let ((found (find-counter key counter))) + (if (and found (counter-recursive? found)) + (let lp ((counter counter)) + (if (not (eq? counter found)) + (begin + (set-counter-recursive?! counter #t) + (lp (counter-prev counter))))))) + + (log 'inline-recurse key) + (loop (inlined-call) 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. + (log 'inline-begin exp) + (let/ec k + (define (abort) + (log 'inline-abort exp) + (k (make-call src (for-call 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 (inlined-call) 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)) + + (log 'inline-end result exp) + result))))) + (($ <let> _ _ _ 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) + (($ <let> 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)))))) + (($ <lambda> src meta body) + (case ctx + ((effect) (make-void #f)) + ((test) (make-const #f #t)) + ((operator) exp) + (else (record-source-expression! + exp + (make-lambda src meta (and body (for-values body))))))) + (($ <lambda-case> src req opt rest kw inits gensyms body alt) + (define (lift-applied-lambda body gensyms) + (and (not opt) rest (not kw) + (match body + (($ <primcall> _ 'apply + (($ <lambda> _ _ (and lcase ($ <lambda-case> _ req1))) + ($ <lexical-ref> _ _ sym) + ...)) + (and (equal? sym gensyms) + (not (lambda-case-alternate lcase)) + (<= (length req) (length req1)) + (every (lambda (s) + (= (lexical-refcount s) 1)) + sym) + 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))))) + (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)))))) + (($ <seq> src head tail) + (let ((head (for-effect head)) + (tail (for-tail tail))) + (if (void? head) + tail + (make-seq src + (if (and (seq? head) + (void? (seq-tail head))) + (seq-head head) + head) + tail)))) + (($ <prompt> src escape-only? tag body handler) + (define (make-prompt-tag? x) + (match x + (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?)))) + #t) + (_ #f))) + + (let ((tag (for-value tag)) + (body (if escape-only? (for-tail body) (for-value body)))) + (cond + ((find-definition tag 1) + (lambda (val op) + (make-prompt-tag? val)) + => (lambda (val op) + ;; There is no way that an <abort> could know the tag + ;; for this <prompt>, so we can elide the <prompt> + ;; entirely. + (unrecord-operand-uses op 1) + (for-tail (if escape-only? body (make-call src body '()))))) + (else + (let ((handler (for-value handler))) + (define (escape-only-handler? handler) + (match handler + (($ <lambda> _ _ + ($ <lambda-case> _ (_ . _) _ _ _ _ (k . _) body #f)) + (not (tree-il-any + (match-lambda + (($ <lexical-ref> _ _ (? (cut eq? <> k))) #t) + (_ #f)) + body))) + (else #f))) + (if (and (not escape-only?) (escape-only-handler? handler)) + ;; Prompt transitioning to escape-only; transition body + ;; to be an expression. + (for-tail + (make-prompt src #t tag (make-call #f body '()) handler)) + (make-prompt src escape-only? tag body handler))))))) + + (($ <abort> src tag args tail) + (make-abort src (for-value tag) (map for-value args) + (for-value tail)))))) |