module/language/tree-il/peval.scm

   1 ;;; Tree-IL partial evaluator
   2
   3 ;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 (define-module (language tree-il peval)
  20   #:use-module (language tree-il)
  21   #:use-module (language tree-il primitives)
  22   #:use-module (language tree-il effects)
  23   #:use-module (ice-9 vlist)
  24   #:use-module (ice-9 match)
  25   #:use-module (srfi srfi-1)
  26   #:use-module (srfi srfi-9)
  27   #:use-module (srfi srfi-11)
  28   #:use-module (srfi srfi-26)
  29   #:export (peval))
  30
  31 ;;;
  32 ;;; Partial evaluation is Guile's most important source-to-source
  33 ;;; optimization pass.  It performs copy propagation, dead code
  34 ;;; elimination, inlining, and constant folding, all while preserving
  35 ;;; the order of effects in the residual program.
  36 ;;;
  37 ;;; For more on partial evaluation, see William Cook’s excellent
  38 ;;; tutorial on partial evaluation at DSL 2011, called “Build your own
  39 ;;; partial evaluator in 90 minutes”[0].
  40 ;;;
  41 ;;; Our implementation of this algorithm was heavily influenced by
  42 ;;; Waddell and Dybvig's paper, "Fast and Effective Procedure Inlining",
  43 ;;; IU CS Dept. TR 484.
  44 ;;;
  45 ;;; [0] http://www.cs.utexas.edu/~wcook/tutorial/.
  46 ;;;
  47
  48 ;; First, some helpers.
  49 ;;
  50 (define-syntax *logging* (identifier-syntax #f))
  51
  52 ;; For efficiency we define *logging* to inline to #f, so that the call
  53 ;; to log* gets optimized out.  If you want to log, uncomment these
  54 ;; lines:
  55 ;;
  56 ;; (define %logging #f)
  57 ;; (define-syntax *logging* (identifier-syntax %logging))
  58 ;;
  59 ;; Then you can change %logging at runtime.
  60
  61 (define-syntax log
  62   (syntax-rules (quote)
  63     ((log 'event arg ...)
  64      (if (and *logging*
  65               (or (eq? *logging* #t)
  66                   (memq 'event *logging*)))
  67          (log* 'event arg ...)))))
  68
  69 (define (log* event . args)
  70   (let ((pp (module-ref (resolve-interface '(ice-9 pretty-print))
  71                         'pretty-print)))
  72     (pp `(log ,event . ,args))
  73     (newline)
  74     (values)))
  75
  76 (define-syntax-rule (let/ec k e e* ...)
  77   (let ((tag (make-prompt-tag)))
  78     (call-with-prompt
  79      tag
  80      (lambda ()
  81        (let ((k (lambda args (apply abort-to-prompt tag args))))
  82          e e* ...))
  83      (lambda (_ res) res))))
  84
  85 (define (tree-il-any proc exp)
  86   (let/ec k
  87     (tree-il-fold (lambda (exp res)
  88                     (let ((res (proc exp)))
  89                       (if res (k res) #f)))
  90                   (lambda (exp res)
  91                     (let ((res (proc exp)))
  92                       (if res (k res) #f)))
  93                   (lambda (exp res) #f)
  94                   #f exp)))
  95
  96 (define (vlist-any proc vlist)
  97   (let ((len (vlist-length vlist)))
  98     (let lp ((i 0))
  99       (and (< i len)
 100            (or (proc (vlist-ref vlist i))
 101                (lp (1+ i)))))))
 102
 103 (define (singly-valued-expression? exp)
 104   (match exp
 105     (($ <const>) #t)
 106     (($ <lexical-ref>) #t)
 107     (($ <void>) #t)
 108     (($ <lexical-ref>) #t)
 109     (($ <primitive-ref>) #t)
 110     (($ <module-ref>) #t)
 111     (($ <toplevel-ref>) #t)
 112     (($ <primcall> _ (? singly-valued-primitive?)) #t)
 113     (($ <primcall> _ 'values (val)) #t)
 114     (($ <lambda>) #t)
 115     (else #f)))
 116
 117 (define (truncate-values x)
 118   "Discard all but the first value of X."
 119   (if (singly-valued-expression? x)
 120       x
 121       (make-primcall (tree-il-src x) 'values (list x))))
 122
 123 ;; Peval will do a one-pass analysis on the source program to determine
 124 ;; the set of assigned lexicals, and to identify unreferenced and
 125 ;; singly-referenced lexicals.
 126 ;;
 127 (define-record-type <var>
 128   (make-var name gensym refcount set?)
 129   var?
 130   (name var-name)
 131   (gensym var-gensym)
 132   (refcount var-refcount set-var-refcount!)
 133   (set? var-set? set-var-set?!))
 134
 135 (define* (build-var-table exp #:optional (table vlist-null))
 136   (tree-il-fold
 137    (lambda (exp res)
 138      (match exp
 139        (($ <lexical-ref> src name gensym)
 140         (let ((var (cdr (vhash-assq gensym res))))
 141           (set-var-refcount! var (1+ (var-refcount var)))
 142           res))
 143        (_ res)))
 144    (lambda (exp res)
 145      (match exp
 146        (($ <lambda-case> src req opt rest kw init gensyms body alt)
 147         (fold (lambda (name sym res)
 148                 (vhash-consq sym (make-var name sym 0 #f) res))
 149               res
 150               (append req (or opt '()) (if rest (list rest) '())
 151                       (match kw
 152                         ((aok? (kw name sym) ...) name)
 153                         (_ '())))
 154               gensyms))
 155        (($ <let> src names gensyms vals body)
 156         (fold (lambda (name sym res)
 157                 (vhash-consq sym (make-var name sym 0 #f) res))
 158               res names gensyms))
 159        (($ <letrec> src in-order? names gensyms vals body)
 160         (fold (lambda (name sym res)
 161                 (vhash-consq sym (make-var name sym 0 #f) res))
 162               res names gensyms))
 163        (($ <fix> src names gensyms vals body)
 164         (fold (lambda (name sym res)
 165                 (vhash-consq sym (make-var name sym 0 #f) res))
 166               res names gensyms))
 167        (($ <lexical-set> src name gensym exp)
 168         (set-var-set?! (cdr (vhash-assq gensym res)) #t)
 169         res)
 170        (_ res)))
 171    (lambda (exp res) res)
 172    table exp))
 173
 174 ;; Counters are data structures used to limit the effort that peval
 175 ;; spends on particular inlining attempts.  Each call site in the source
 176 ;; program is allocated some amount of effort.  If peval exceeds the
 177 ;; effort counter while attempting to inline a call site, it aborts the
 178 ;; inlining attempt and residualizes a call instead.
 179 ;;
 180 ;; As there is a fixed number of call sites, that makes `peval' O(N) in
 181 ;; the number of call sites in the source program.
 182 ;;
 183 ;; Counters should limit the size of the residual program as well, but
 184 ;; currently this is not implemented.
 185 ;;
 186 ;; At the top level, before seeing any peval call, there is no counter,
 187 ;; because inlining will terminate as there is no recursion.  When peval
 188 ;; sees a call at the top level, it will make a new counter, allocating
 189 ;; it some amount of effort and size.
 190 ;;
 191 ;; This top-level effort counter effectively "prints money".  Within a
 192 ;; toplevel counter, no more effort is printed ex nihilo; for a nested
 193 ;; inlining attempt to proceed, effort must be transferred from the
 194 ;; toplevel counter to the nested counter.
 195 ;;
 196 ;; Via `data' and `prev', counters form a linked list, terminating in a
 197 ;; toplevel counter.  In practice `data' will be the a pointer to the
 198 ;; source expression of the procedure being inlined.
 199 ;;
 200 ;; In this way peval can detect a recursive inlining attempt, by walking
 201 ;; back on the `prev' links looking for matching `data'.  Recursive
 202 ;; counters receive a more limited effort allocation, as we don't want
 203 ;; to spend all of the effort for a toplevel inlining site on loops.
 204 ;; Also, recursive counters don't need a prompt at each inlining site:
 205 ;; either the call chain folds entirely, or it will be residualized at
 206 ;; its original call.
 207 ;;
 208 (define-record-type <counter>
 209   (%make-counter effort size continuation recursive? data prev)
 210   counter?
 211   (effort effort-counter)
 212   (size size-counter)
 213   (continuation counter-continuation)
 214   (recursive? counter-recursive? set-counter-recursive?!)
 215   (data counter-data)
 216   (prev counter-prev))
 217
 218 (define (abort-counter c)
 219   ((counter-continuation c)))
 220
 221 (define (record-effort! c)
 222   (let ((e (effort-counter c)))
 223     (if (zero? (variable-ref e))
 224         (abort-counter c)
 225         (variable-set! e (1- (variable-ref e))))))
 226
 227 (define (record-size! c)
 228   (let ((s (size-counter c)))
 229     (if (zero? (variable-ref s))
 230         (abort-counter c)
 231         (variable-set! s (1- (variable-ref s))))))
 232
 233 (define (find-counter data counter)
 234   (and counter
 235        (if (eq? data (counter-data counter))
 236            counter
 237            (find-counter data (counter-prev counter)))))
 238
 239 (define* (transfer! from to #:optional
 240                     (effort (variable-ref (effort-counter from)))
 241                     (size (variable-ref (size-counter from))))
 242   (define (transfer-counter! from-v to-v amount)
 243     (let* ((from-balance (variable-ref from-v))
 244            (to-balance (variable-ref to-v))
 245            (amount (min amount from-balance)))
 246       (variable-set! from-v (- from-balance amount))
 247       (variable-set! to-v (+ to-balance amount))))
 248
 249   (transfer-counter! (effort-counter from) (effort-counter to) effort)
 250   (transfer-counter! (size-counter from) (size-counter to) size))
 251
 252 (define (make-top-counter effort-limit size-limit continuation data)
 253   (%make-counter (make-variable effort-limit)
 254                  (make-variable size-limit)
 255                  continuation
 256                  #t
 257                  data
 258                  #f))
 259
 260 (define (make-nested-counter continuation data current)
 261   (let ((c (%make-counter (make-variable 0)
 262                           (make-variable 0)
 263                           continuation
 264                           #f
 265                           data
 266                           current)))
 267     (transfer! current c)
 268     c))
 269
 270 (define (make-recursive-counter effort-limit size-limit orig current)
 271   (let ((c (%make-counter (make-variable 0)
 272                           (make-variable 0)
 273                           (counter-continuation orig)
 274                           #t
 275                           (counter-data orig)
 276                           current)))
 277     (transfer! current c effort-limit size-limit)
 278     c))
 279
 280 ;; Operand structures allow bindings to be processed lazily instead of
 281 ;; eagerly.  By doing so, hopefully we can get process them in a way
 282 ;; appropriate to their use contexts.  Operands also prevent values from
 283 ;; being visited multiple times, wasting effort.
 284 ;;
 285 ;; TODO: Record value size in operand structure?
 286 ;;
 287 (define-record-type <operand>
 288   (%make-operand var sym visit source visit-count residualize?
 289                  copyable? residual-value constant-value alias-value)
 290   operand?
 291   (var operand-var)
 292   (sym operand-sym)
 293   (visit %operand-visit)
 294   (source operand-source)
 295   (visit-count operand-visit-count set-operand-visit-count!)
 296   (residualize? operand-residualize? set-operand-residualize?!)
 297   (copyable? operand-copyable? set-operand-copyable?!)
 298   (residual-value operand-residual-value %set-operand-residual-value!)
 299   (constant-value operand-constant-value set-operand-constant-value!)
 300   (alias-value operand-alias-value set-operand-alias-value!))
 301
 302 (define* (make-operand var sym #:optional source visit alias)
 303   ;; Bind SYM to VAR, with value SOURCE.  Unassigned bound operands are
 304   ;; considered copyable until we prove otherwise.  If we have a source
 305   ;; expression, truncate it to one value.  Copy propagation does not
 306   ;; work on multiply-valued expressions.
 307   (let ((source (and=> source truncate-values)))
 308     (%make-operand var sym visit source 0 #f
 309                    (and source (not (var-set? var))) #f #f
 310                    (and (not (var-set? var)) alias))))
 311
 312 (define* (make-bound-operands vars syms sources visit #:optional aliases)
 313   (if aliases
 314       (map (lambda (name sym source alias)
 315              (make-operand name sym source visit alias))
 316            vars syms sources aliases)
 317       (map (lambda (name sym source)
 318              (make-operand name sym source visit #f))
 319            vars syms sources)))
 320
 321 (define (make-unbound-operands vars syms)
 322   (map make-operand vars syms))
 323
 324 (define (set-operand-residual-value! op val)
 325   (%set-operand-residual-value!
 326    op
 327    (match val
 328     (($ <primcall> src 'values (first))
 329      ;; The continuation of a residualized binding does not need the
 330      ;; introduced `values' node, so undo the effects of truncation.
 331      first)
 332     (else
 333      val))))
 334
 335 (define* (visit-operand op counter ctx #:optional effort-limit size-limit)
 336   ;; Peval is O(N) in call sites of the source program.  However,
 337   ;; visiting an operand can introduce new call sites.  If we visit an
 338   ;; operand outside a counter -- i.e., outside an inlining attempt --
 339   ;; this can lead to divergence.  So, if we are visiting an operand to
 340   ;; try to copy it, and there is no counter, make a new one.
 341   ;;
 342   ;; This will only happen at most as many times as there are lexical
 343   ;; references in the source program.
 344   (and (zero? (operand-visit-count op))
 345        (dynamic-wind
 346          (lambda ()
 347            (set-operand-visit-count! op (1+ (operand-visit-count op))))
 348          (lambda ()
 349            (and (operand-source op)
 350                 (if (or counter (and (not effort-limit) (not size-limit)))
 351                     ((%operand-visit op) (operand-source op) counter ctx)
 352                     (let/ec k
 353                       (define (abort)
 354                         ;; If we abort when visiting the value in a
 355                         ;; fresh context, we won't succeed in any future
 356                         ;; attempt, so don't try to copy it again.
 357                         (set-operand-copyable?! op #f)
 358                         (k #f))
 359                       ((%operand-visit op)
 360                        (operand-source op)
 361                        (make-top-counter effort-limit size-limit abort op)
 362                        ctx)))))
 363          (lambda ()
 364            (set-operand-visit-count! op (1- (operand-visit-count op)))))))
 365
 366 ;; A helper for constant folding.
 367 ;;
 368 (define (types-check? primitive-name args)
 369   (case primitive-name
 370     ((values) #t)
 371     ((not pair? null? list? symbol? vector? struct?)
 372      (= (length args) 1))
 373     ((eq? eqv? equal?)
 374      (= (length args) 2))
 375     ;; FIXME: add more cases?
 376     (else #f)))
 377
 378 (define* (peval exp #:optional (cenv (current-module)) (env vlist-null)
 379                 #:key
 380                 (operator-size-limit 40)
 381                 (operand-size-limit 20)
 382                 (value-size-limit 10)
 383                 (effort-limit 500)
 384                 (recursive-effort-limit 100))
 385   "Partially evaluate EXP in compilation environment CENV, with
 386 top-level bindings from ENV and return the resulting expression."
 387
 388   ;; This is a simple partial evaluator.  It effectively performs
 389   ;; constant folding, copy propagation, dead code elimination, and
 390   ;; inlining.
 391
 392   ;; TODO:
 393   ;;
 394   ;; Propagate copies across toplevel bindings, if we can prove the
 395   ;; bindings to be immutable.
 396   ;;
 397   ;; Specialize lambda expressions with invariant arguments.
 398
 399   (define local-toplevel-env
 400     ;; The top-level environment of the module being compiled.
 401     (let ()
 402       (define (env-folder x env)
 403         (match x
 404           (($ <toplevel-define> _ name)
 405            (vhash-consq name #t env))
 406           (($ <seq> _ head tail)
 407            (env-folder tail (env-folder head env)))
 408           (_ env)))
 409       (env-folder exp vlist-null)))
 410
 411   (define (local-toplevel? name)
 412     (vhash-assq name local-toplevel-env))
 413
 414   ;; gensym -> <var>
 415   ;; renamed-term -> original-term
 416   ;;
 417   (define store (build-var-table exp))
 418
 419   (define (record-new-temporary! name sym refcount)
 420     (set! store (vhash-consq sym (make-var name sym refcount #f) store)))
 421
 422   (define (lookup-var sym)
 423     (let ((v (vhash-assq sym store)))
 424       (if v (cdr v) (error "unbound var" sym (vlist->list store)))))
 425
 426   (define (fresh-gensyms vars)
 427     (map (lambda (var)
 428            (let ((new (gensym (string-append (symbol->string (var-name var))
 429                                              "-"))))
 430              (set! store (vhash-consq new var store))
 431              new))
 432          vars))
 433
 434   (define (assigned-lexical? sym)
 435     (var-set? (lookup-var sym)))
 436
 437   (define (lexical-refcount sym)
 438     (var-refcount (lookup-var sym)))
 439
 440   ;; ORIG has been alpha-renamed to NEW.  Analyze NEW and record a link
 441   ;; from it to ORIG.
 442   ;;
 443   (define (record-source-expression! orig new)
 444     (set! store (vhash-consq new (source-expression orig) store))
 445     new)
 446
 447   ;; Find the source expression corresponding to NEW.  Used to detect
 448   ;; recursive inlining attempts.
 449   ;;
 450   (define (source-expression new)
 451     (let ((x (vhash-assq new store)))
 452       (if x (cdr x) new)))
 453
 454   (define* (residualize-lexical op #:optional ctx val)
 455     (log 'residualize op)
 456     (set-operand-residualize?! op #t)
 457     (if (eq? ctx 'value)
 458         (set-operand-residual-value! op val))
 459     (make-lexical-ref #f (var-name (operand-var op)) (operand-sym op)))
 460
 461   (define (fold-constants src name args ctx)
 462     (define (apply-primitive name args)
 463       ;; todo: further optimize commutative primitives
 464       (catch #t
 465         (lambda ()
 466           (call-with-values
 467               (lambda ()
 468                 (apply (module-ref the-scm-module name) args))
 469             (lambda results
 470               (values #t results))))
 471         (lambda _
 472           (values #f '()))))
 473     (define (make-values src values)
 474       (match values
 475         ((single) single)               ; 1 value
 476         ((_ ...)                        ; 0, or 2 or more values
 477          (make-primcall src 'values values))))
 478     (define (residualize-call)
 479       (make-primcall src name args))
 480     (cond
 481      ((every const? args)
 482       (let-values (((success? values)
 483                     (apply-primitive name (map const-exp args))))
 484         (log 'fold success? values name args)
 485         (if success?
 486             (case ctx
 487               ((effect) (make-void src))
 488               ((test)
 489                ;; Values truncation: only take the first
 490                ;; value.
 491                (if (pair? values)
 492                    (make-const src (car values))
 493                    (make-values src '())))
 494               (else
 495                (make-values src (map (cut make-const src <>) values))))
 496             (residualize-call))))
 497      ((and (eq? ctx 'effect) (types-check? name args))
 498       (make-void #f))
 499      (else
 500       (residualize-call))))
 501
 502   (define (inline-values exp src names gensyms body)
 503     (let loop ((exp exp))
 504       (match exp
 505         ;; Some expression types are always singly-valued.
 506         ((or ($ <const>)
 507              ($ <void>)
 508              ($ <lambda>)
 509              ($ <lexical-ref>)
 510              ($ <toplevel-ref>)
 511              ($ <module-ref>)
 512              ($ <primitive-ref>)
 513              ($ <dynref>)
 514              ($ <lexical-set>)          ; FIXME: these set! expressions
 515              ($ <toplevel-set>)         ; could return zero values in
 516              ($ <toplevel-define>)      ; the future
 517              ($ <module-set>)           ;
 518              ($ <dynset>))              ;
 519          (and (= (length names) 1)
 520               (make-let src names gensyms (list exp) body)))
 521         (($ <primcall> src (? singly-valued-primitive? name))
 522          (and (= (length names) 1)
 523               (make-let src names gensyms (list exp) body)))
 524
 525         ;; Statically-known number of values.
 526         (($ <primcall> src 'values vals)
 527          (and (= (length names) (length vals))
 528               (make-let src names gensyms vals body)))
 529
 530         ;; Not going to copy code into both branches.
 531         (($ <conditional>) #f)
 532
 533         ;; Bail on other applications.
 534         (($ <call>) #f)
 535         (($ <primcall>) #f)
 536
 537         ;; Bail on prompt and abort.
 538         (($ <prompt>) #f)
 539         (($ <abort>) #f)
 540
 541         ;; Propagate to tail positions.
 542         (($ <let> src names gensyms vals body)
 543          (let ((body (loop body)))
 544            (and body
 545                 (make-let src names gensyms vals body))))
 546         (($ <letrec> src in-order? names gensyms vals body)
 547          (let ((body (loop body)))
 548            (and body
 549                 (make-letrec src in-order? names gensyms vals body))))
 550         (($ <fix> src names gensyms vals body)
 551          (let ((body (loop body)))
 552            (and body
 553                 (make-fix src names gensyms vals body))))
 554         (($ <let-values> src exp
 555             ($ <lambda-case> src2 req opt rest kw inits gensyms body #f))
 556          (let ((body (loop body)))
 557            (and body
 558                 (make-let-values src exp
 559                                  (make-lambda-case src2 req opt rest kw
 560                                                    inits gensyms body #f)))))
 561         (($ <dynwind> src winder pre body post unwinder)
 562          (let ((body (loop body)))
 563            (and body
 564                 (make-dynwind src winder pre body post unwinder))))
 565         (($ <dynlet> src fluids vals body)
 566          (let ((body (loop body)))
 567            (and body
 568                 (make-dynlet src fluids vals body))))
 569         (($ <seq> src head tail)
 570          (let ((tail (loop tail)))
 571            (and tail (make-seq src head tail)))))))
 572
 573   (define compute-effects
 574     (make-effects-analyzer assigned-lexical?))
 575
 576   (define (constant-expression? x)
 577     ;; Return true if X is constant, for the purposes of copying or
 578     ;; elision---i.e., if it is known to have no effects, does not
 579     ;; allocate storage for a mutable object, and does not access
 580     ;; mutable data (like `car' or toplevel references).
 581     (constant? (compute-effects x)))
 582
 583   (define (prune-bindings ops in-order? body counter ctx build-result)
 584     ;; This helper handles both `let' and `letrec'/`fix'.  In the latter
 585     ;; cases we need to make sure that if referenced binding A needs
 586     ;; as-yet-unreferenced binding B, that B is processed for value.
 587     ;; Likewise if C, when processed for effect, needs otherwise
 588     ;; unreferenced D, then D needs to be processed for value too.
 589     ;;
 590     (define (referenced? op)
 591       ;; When we visit lambdas in operator context, we just copy them,
 592       ;; as we will process their body later.  However this does have
 593       ;; the problem that any free var referenced by the lambda is not
 594       ;; marked as needing residualization.  Here we hack around this
 595       ;; and treat all bindings as referenced if we are in operator
 596       ;; context.
 597       (or (eq? ctx 'operator) (operand-residualize? op)))
 598
 599     ;; values := (op ...)
 600     ;; effects := (op ...)
 601     (define (residualize values effects)
 602       ;; Note, values and effects are reversed.
 603       (cond
 604        (in-order?
 605         (let ((values (filter operand-residual-value ops)))
 606           (if (null? values)
 607               body
 608               (build-result (map (compose var-name operand-var) values)
 609                             (map operand-sym values)
 610                             (map operand-residual-value values)
 611                             body))))
 612        (else
 613         (let ((body
 614                (if (null? effects)
 615                    body
 616                    (let ((effect-vals (map operand-residual-value effects)))
 617                      (list->seq #f (reverse (cons body effect-vals)))))))
 618           (if (null? values)
 619               body
 620               (let ((values (reverse values)))
 621                 (build-result (map (compose var-name operand-var) values)
 622                               (map operand-sym values)
 623                               (map operand-residual-value values)
 624                               body)))))))
 625
 626     ;; old := (bool ...)
 627     ;; values := (op ...)
 628     ;; effects := ((op . value) ...)
 629     (let prune ((old (map referenced? ops)) (values '()) (effects '()))
 630       (let lp ((ops* ops) (values values) (effects effects))
 631         (cond
 632          ((null? ops*)
 633           (let ((new (map referenced? ops)))
 634             (if (not (equal? new old))
 635                 (prune new values '())
 636                 (residualize values
 637                              (map (lambda (op val)
 638                                     (set-operand-residual-value! op val)
 639                                     op)
 640                                   (map car effects) (map cdr effects))))))
 641          (else
 642           (let ((op (car ops*)))
 643             (cond
 644              ((memq op values)
 645               (lp (cdr ops*) values effects))
 646              ((operand-residual-value op)
 647               (lp (cdr ops*) (cons op values) effects))
 648              ((referenced? op)
 649               (set-operand-residual-value! op (visit-operand op counter 'value))
 650               (lp (cdr ops*) (cons op values) effects))
 651              (else
 652               (lp (cdr ops*)
 653                   values
 654                   (let ((effect (visit-operand op counter 'effect)))
 655                     (if (void? effect)
 656                         effects
 657                         (acons op effect effects))))))))))))
 658
 659   (define (small-expression? x limit)
 660     (let/ec k
 661       (tree-il-fold
 662        (lambda (x res)                  ; leaf
 663          (1+ res))
 664        (lambda (x res)                  ; down
 665          (1+ res))
 666        (lambda (x res)                  ; up
 667          (if (< res limit)
 668              res
 669              (k #f)))
 670        0 x)
 671       #t))
 672
 673   (define (extend-env sym op env)
 674     (vhash-consq (operand-sym op) op (vhash-consq sym op env)))
 675
 676   (let loop ((exp   exp)
 677              (env   vlist-null)         ; vhash of gensym -> <operand>
 678              (counter #f)               ; inlined call stack
 679              (ctx 'values))   ; effect, value, values, test, operator, or call
 680     (define (lookup var)
 681       (cond
 682        ((vhash-assq var env) => cdr)
 683        (else (error "unbound var" var))))
 684
 685     (define (visit exp ctx)
 686       (loop exp env counter ctx))
 687
 688     (define (for-value exp)    (visit exp 'value))
 689     (define (for-values exp)   (visit exp 'values))
 690     (define (for-test exp)     (visit exp 'test))
 691     (define (for-effect exp)   (visit exp 'effect))
 692     (define (for-call exp)     (visit exp 'call))
 693     (define (for-tail exp)     (visit exp ctx))
 694
 695     (if counter
 696         (record-effort! counter))
 697
 698     (log 'visit ctx (and=> counter effort-counter)
 699          (unparse-tree-il exp))
 700
 701     (match exp
 702       (($ <const>)
 703        (case ctx
 704          ((effect) (make-void #f))
 705          (else exp)))
 706       (($ <void>)
 707        (case ctx
 708          ((test) (make-const #f #t))
 709          (else exp)))
 710       (($ <lexical-ref> _ _ gensym)
 711        (log 'begin-copy gensym)
 712        (let ((op (lookup gensym)))
 713          (cond
 714           ((eq? ctx 'effect)
 715            (log 'lexical-for-effect gensym)
 716            (make-void #f))
 717           ((operand-alias-value op)
 718            ;; This is an unassigned operand that simply aliases some
 719            ;; other operand.  Recurse to avoid residualizing the leaf
 720            ;; binding.
 721            => for-tail)
 722           ((eq? ctx 'call)
 723            ;; Don't propagate copies if we are residualizing a call.
 724            (log 'residualize-lexical-call gensym op)
 725            (residualize-lexical op))
 726           ((var-set? (operand-var op))
 727            ;; Assigned lexicals don't copy-propagate.
 728            (log 'assigned-var gensym op)
 729            (residualize-lexical op))
 730           ((not (operand-copyable? op))
 731            ;; We already know that this operand is not copyable.
 732            (log 'not-copyable gensym op)
 733            (residualize-lexical op))
 734           ((and=> (operand-constant-value op)
 735                   (lambda (x) (or (const? x) (void? x) (primitive-ref? x))))
 736            ;; A cache hit.
 737            (let ((val (operand-constant-value op)))
 738              (log 'memoized-constant gensym val)
 739              (for-tail val)))
 740           ((visit-operand op counter (if (eq? ctx 'values) 'value ctx)
 741                           recursive-effort-limit operand-size-limit)
 742            =>
 743            ;; If we end up deciding to residualize this value instead of
 744            ;; copying it, save that residualized value.
 745            (lambda (val)
 746              (cond
 747               ((not (constant-expression? val))
 748                (log 'not-constant gensym op)
 749                ;; At this point, ctx is operator, test, or value.  A
 750                ;; value that is non-constant in one context will be
 751                ;; non-constant in the others, so it's safe to record
 752                ;; that here, and avoid future visits.
 753                (set-operand-copyable?! op #f)
 754                (residualize-lexical op ctx val))
 755               ((or (const? val)
 756                    (void? val)
 757                    (primitive-ref? val))
 758                ;; Always propagate simple values that cannot lead to
 759                ;; code bloat.
 760                (log 'copy-simple gensym val)
 761                ;; It could be this constant is the result of folding.
 762                ;; If that is the case, cache it.  This helps loop
 763                ;; unrolling get farther.
 764                (if (or (eq? ctx 'value) (eq? ctx 'values))
 765                    (begin
 766                      (log 'memoize-constant gensym val)
 767                      (set-operand-constant-value! op val)))
 768                val)
 769               ((= 1 (var-refcount (operand-var op)))
 770                ;; Always propagate values referenced only once.
 771                (log 'copy-single gensym val)
 772                val)
 773               ;; FIXME: do demand-driven size accounting rather than
 774               ;; these heuristics.
 775               ((eq? ctx 'operator)
 776                ;; A pure expression in the operator position.  Inline
 777                ;; if it's a lambda that's small enough.
 778                (if (and (lambda? val)
 779                         (small-expression? val operator-size-limit))
 780                    (begin
 781                      (log 'copy-operator gensym val)
 782                      val)
 783                    (begin
 784                      (log 'too-big-for-operator gensym val)
 785                      (residualize-lexical op ctx val))))
 786               (else
 787                ;; A pure expression, processed for call or for value.
 788                ;; Don't inline lambdas, because they will probably won't
 789                ;; fold because we don't know the operator.
 790                (if (and (small-expression? val value-size-limit)
 791                         (not (tree-il-any lambda? val)))
 792                    (begin
 793                      (log 'copy-value gensym val)
 794                      val)
 795                    (begin
 796                      (log 'too-big-or-has-lambda gensym val)
 797                      (residualize-lexical op ctx val)))))))
 798           (else
 799            ;; Visit failed.  Either the operand isn't bound, as in
 800            ;; lambda formal parameters, or the copy was aborted.
 801            (log 'unbound-or-aborted gensym op)
 802            (residualize-lexical op)))))
 803       (($ <lexical-set> src name gensym exp)
 804        (let ((op (lookup gensym)))
 805          (if (zero? (var-refcount (operand-var op)))
 806              (let ((exp (for-effect exp)))
 807                (if (void? exp)
 808                    exp
 809                    (make-seq src exp (make-void #f))))
 810              (begin
 811                (set-operand-residualize?! op #t)
 812                (make-lexical-set src name (operand-sym op) (for-value exp))))))
 813       (($ <let> src names gensyms vals body)
 814        (define (compute-alias exp)
 815          ;; It's very common for macros to introduce something like:
 816          ;;
 817          ;;   ((lambda (x y) ...) x-exp y-exp)
 818          ;;
 819          ;; In that case you might end up trying to inline something like:
 820          ;;
 821          ;;   (let ((x x-exp) (y y-exp)) ...)
 822          ;;
 823          ;; But if x-exp is itself a lexical-ref that aliases some much
 824          ;; larger expression, perhaps it will fail to inline due to
 825          ;; size.  However we don't want to introduce a useless alias
 826          ;; (in this case, x).  So if the RHS of a let expression is a
 827          ;; lexical-ref, we record that expression.  If we end up having
 828          ;; to residualize X, then instead we residualize X-EXP, as long
 829          ;; as it isn't assigned.
 830          ;;
 831          (match exp
 832            (($ <lexical-ref> _ _ sym)
 833             (let ((op (lookup sym)))
 834               (and (not (var-set? (operand-var op)))
 835                    (or (operand-alias-value op)
 836                        exp))))
 837            (_ #f)))
 838
 839        (let* ((vars (map lookup-var gensyms))
 840               (new (fresh-gensyms vars))
 841               (ops (make-bound-operands vars new vals
 842                                         (lambda (exp counter ctx)
 843                                           (loop exp env counter ctx))
 844                                         (map compute-alias vals)))
 845               (env (fold extend-env env gensyms ops))
 846               (body (loop body env counter ctx)))
 847          (cond
 848           ((const? body)
 849            (for-tail (list->seq src (append vals (list body)))))
 850           ((and (lexical-ref? body)
 851                 (memq (lexical-ref-gensym body) new))
 852            (let ((sym (lexical-ref-gensym body))
 853                  (pairs (map cons new vals)))
 854              ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
 855              (for-tail
 856               (list->seq
 857                src
 858                (append (map cdr (alist-delete sym pairs eq?))
 859                        (list (assq-ref pairs sym)))))))
 860           (else
 861            ;; Only include bindings for which lexical references
 862            ;; have been residualized.
 863            (prune-bindings ops #f body counter ctx
 864                            (lambda (names gensyms vals body)
 865                              (if (null? names) (error "what!" names))
 866                              (make-let src names gensyms vals body)))))))
 867       (($ <letrec> src in-order? names gensyms vals body)
 868        ;; Note the difference from the `let' case: here we use letrec*
 869        ;; so that the `visit' procedure for the new operands closes over
 870        ;; an environment that includes the operands.  Also we don't try
 871        ;; to elide aliases, because we can't sensibly reduce something
 872        ;; like (letrec ((a b) (b a)) a).
 873        (letrec* ((visit (lambda (exp counter ctx)
 874                           (loop exp env* counter ctx)))
 875                  (vars (map lookup-var gensyms))
 876                  (new (fresh-gensyms vars))
 877                  (ops (make-bound-operands vars new vals visit))
 878                  (env* (fold extend-env env gensyms ops))
 879                  (body* (visit body counter ctx)))
 880          (if (and (const? body*) (every constant-expression? vals))
 881              ;; We may have folded a loop completely, even though there
 882              ;; might be cyclical references between the bound values.
 883              ;; Handle this degenerate case specially.
 884              body*
 885              (prune-bindings ops in-order? body* counter ctx
 886                              (lambda (names gensyms vals body)
 887                                (make-letrec src in-order?
 888                                             names gensyms vals body))))))
 889       (($ <fix> src names gensyms vals body)
 890        (letrec* ((visit (lambda (exp counter ctx)
 891                           (loop exp env* counter ctx)))
 892                  (vars (map lookup-var gensyms))
 893                  (new (fresh-gensyms vars))
 894                  (ops (make-bound-operands vars new vals visit))
 895                  (env* (fold extend-env env gensyms ops))
 896                  (body* (visit body counter ctx)))
 897          (if (const? body*)
 898              body*
 899              (prune-bindings ops #f body* counter ctx
 900                              (lambda (names gensyms vals body)
 901                                (make-fix src names gensyms vals body))))))
 902       (($ <let-values> lv-src producer consumer)
 903        ;; Peval the producer, then try to inline the consumer into
 904        ;; the producer.  If that succeeds, peval again.  Otherwise
 905        ;; reconstruct the let-values, pevaling the consumer.
 906        (let ((producer (for-values producer)))
 907          (or (match consumer
 908                (($ <lambda-case> src req #f #f #f () gensyms body #f)
 909                 (cond
 910                  ((inline-values producer src req gensyms body)
 911                   => for-tail)
 912                  (else #f)))
 913                (_ #f))
 914              (make-let-values lv-src producer (for-tail consumer)))))
 915       (($ <dynwind> src winder pre body post unwinder)
 916        (make-dynwind src (for-value winder) (for-effect pre)
 917                      (for-tail body)
 918                      (for-effect post) (for-value unwinder)))
 919       (($ <dynlet> src fluids vals body)
 920        (make-dynlet src (map for-value fluids) (map for-value vals)
 921                     (for-tail body)))
 922       (($ <dynref> src fluid)
 923        (make-dynref src (for-value fluid)))
 924       (($ <dynset> src fluid exp)
 925        (make-dynset src (for-value fluid) (for-value exp)))
 926       (($ <toplevel-ref> src (? effect-free-primitive? name))
 927        exp)
 928       (($ <toplevel-ref>)
 929        ;; todo: open private local bindings.
 930        exp)
 931       (($ <module-ref> src module (? effect-free-primitive? name) #f)
 932        (let ((module (false-if-exception
 933                       (resolve-module module #:ensure #f))))
 934          (if (module? module)
 935              (let ((var (module-variable module name)))
 936                (if (eq? var (module-variable the-scm-module name))
 937                    (make-primitive-ref src name)
 938                    exp))
 939              exp)))
 940       (($ <module-ref>)
 941        exp)
 942       (($ <module-set> src mod name public? exp)
 943        (make-module-set src mod name public? (for-value exp)))
 944       (($ <toplevel-define> src name exp)
 945        (make-toplevel-define src name (for-value exp)))
 946       (($ <toplevel-set> src name exp)
 947        (make-toplevel-set src name (for-value exp)))
 948       (($ <primitive-ref>)
 949        (case ctx
 950          ((effect) (make-void #f))
 951          ((test) (make-const #f #t))
 952          (else exp)))
 953       (($ <conditional> src condition subsequent alternate)
 954        (match (for-test condition)
 955          (($ <const> _ val)
 956           (if val
 957               (for-tail subsequent)
 958               (for-tail alternate)))
 959          ;; Swap the arms of (if (not FOO) A B), to simplify.
 960          (($ <primcall> _ 'not (c))
 961           (make-conditional src c
 962                             (for-tail alternate)
 963                             (for-tail subsequent)))
 964          (c
 965           (make-conditional src c
 966                             (for-tail subsequent)
 967                             (for-tail alternate)))))
 968       (($ <primcall> src '@call-with-values
 969           (producer
 970            ($ <lambda> _ _
 971               (and consumer
 972                    ;; No optional or kwargs.
 973                    ($ <lambda-case>
 974                       _ req #f rest #f () gensyms body #f)))))
 975        (for-tail (make-let-values src (make-call src producer '())
 976                                   consumer)))
 977       (($ <primcall> src 'dynamic-wind (w thunk u))
 978        (for-tail
 979         (cond
 980          ((not (constant-expression? w))
 981           (cond
 982            ((not (constant-expression? u))
 983             (let ((w-sym (gensym "w ")) (u-sym (gensym "u ")))
 984               (record-new-temporary! 'w w-sym 2)
 985               (record-new-temporary! 'u u-sym 2)
 986               (make-let src '(w u) (list w-sym u-sym) (list w u)
 987                         (make-dynwind
 988                          src
 989                          (make-lexical-ref #f 'w w-sym)
 990                          (make-call #f (make-lexical-ref #f 'w w-sym) '())
 991                          (make-call #f thunk '())
 992                          (make-call #f (make-lexical-ref #f 'u u-sym) '())
 993                          (make-lexical-ref #f 'u u-sym)))))
 994            (else
 995             (let ((w-sym (gensym "w ")))
 996               (record-new-temporary! 'w w-sym 2)
 997               (make-let src '(w) (list w-sym) (list w)
 998                         (make-dynwind
 999                          src
1000                          (make-lexical-ref #f 'w w-sym)
1001                          (make-call #f (make-lexical-ref #f 'w w-sym) '())
1002                          (make-call #f thunk '())
1003                          (make-call #f u '())
1004                          u))))))
1005          ((not (constant-expression? u))
1006           (let ((u-sym (gensym "u ")))
1007             (record-new-temporary! 'u u-sym 2)
1008             (make-let src '(u) (list u-sym) (list u)
1009                       (make-dynwind
1010                        src
1011                        w
1012                        (make-call #f w '())
1013                        (make-call #f thunk '())
1014                        (make-call #f (make-lexical-ref #f 'u u-sym) '())
1015                        (make-lexical-ref #f 'u u-sym)))))
1016          (else
1017           (make-dynwind src w (make-call #f w '()) (make-call #f thunk '())
1018                         (make-call #f u '()) u)))))
1019
1020       (($ <primcall> src 'values exps)
1021        (cond
1022         ((null? exps)
1023          (if (eq? ctx 'effect)
1024              (make-void #f)
1025              exp))
1026         (else
1027          (let ((vals (map for-value exps)))
1028            (if (and (case ctx
1029                       ((value test effect) #t)
1030                       (else (null? (cdr vals))))
1031                     (every singly-valued-expression? vals))
1032                (for-tail (list->seq src (append (cdr vals) (list (car vals)))))
1033                (make-primcall src 'values vals))))))
1034
1035       (($ <primcall> src (? constructor-primitive? name) args)
1036        (cond
1037         ((and (memq ctx '(effect test))
1038               (match (cons name args)
1039                 ((or ('cons _ _)
1040                      ('list . _)
1041                      ('vector . _)
1042                      ('make-prompt-tag)
1043                      ('make-prompt-tag ($ <const> _ (? string?))))
1044                  #t)
1045                 (_ #f)))
1046          ;; Some expressions can be folded without visiting the
1047          ;; arguments for value.
1048          (let ((res (if (eq? ctx 'effect)
1049                         (make-void #f)
1050                         (make-const #f #t))))
1051            (for-tail (list->seq src (append args (list res))))))
1052         (else
1053          (match (cons name (map for-value args))
1054            (('cons x ($ <const> _ (? (cut eq? <> '()))))
1055             (make-primcall src 'list (list x)))
1056            (('cons x ($ <primcall> _ 'list elts))
1057             (make-primcall src 'list (cons x elts)))
1058            ((name . args)
1059             (make-primcall src name args))))))
1060
1061       (($ <primcall> src (? accessor-primitive? name) args)
1062        (match (cons name (map for-value args))
1063          ;; FIXME: these for-tail recursions could take place outside
1064          ;; an effort counter.
1065          (('car ($ <primcall> src 'cons (head tail)))
1066           (for-tail (make-seq src tail head)))
1067          (('cdr ($ <primcall> src 'cons (head tail)))
1068           (for-tail (make-seq src head tail)))
1069          (('car ($ <primcall> src 'list (head . tail)))
1070           (for-tail (list->seq src (append tail (list head)))))
1071          (('cdr ($ <primcall> src 'list (head . tail)))
1072           (for-tail (make-seq src head (make-primcall #f 'list tail))))
1073
1074          (('car ($ <const> src (head . tail)))
1075           (for-tail (make-const src head)))
1076          (('cdr ($ <const> src (head . tail)))
1077           (for-tail (make-const src tail)))
1078          (((or 'memq 'memv) k ($ <const> _ (elts ...)))
1079           ;; FIXME: factor
1080           (case ctx
1081             ((effect)
1082              (for-tail
1083               (make-seq src k (make-void #f))))
1084             ((test)
1085              (cond
1086               ((const? k)
1087                ;; A shortcut.  The `else' case would handle it, but
1088                ;; this way is faster.
1089                (let ((member (case name ((memq) memq) ((memv) memv))))
1090                  (make-const #f (and (member (const-exp k) elts) #t))))
1091               ((null? elts)
1092                (for-tail
1093                 (make-seq src k (make-const #f #f))))
1094               (else
1095                (let ((t (gensym "t "))
1096                      (eq (if (eq? name 'memq) 'eq? 'eqv?)))
1097                  (record-new-temporary! 't t (length elts))
1098                  (for-tail
1099                   (make-let
1100                    src (list 't) (list t) (list k)
1101                    (let lp ((elts elts))
1102                      (define test
1103                        (make-primcall #f eq
1104                                       (list (make-lexical-ref #f 't t)
1105                                             (make-const #f (car elts)))))
1106                      (if (null? (cdr elts))
1107                          test
1108                          (make-conditional src test
1109                                            (make-const #f #t)
1110                                            (lp (cdr elts)))))))))))
1111             (else
1112              (cond
1113               ((const? k)
1114                (let ((member (case name ((memq) memq) ((memv) memv))))
1115                  (make-const #f (member (const-exp k) elts))))
1116               ((null? elts)
1117                (for-tail (make-seq src k (make-const #f #f))))
1118               (else
1119                (make-primcall src name (list k (make-const #f elts))))))))
1120          ((name . args)
1121           (fold-constants src name args ctx))))
1122
1123       (($ <primcall> src (? equality-primitive? name) (a b))
1124        (let ((val-a (for-value a))
1125              (val-b (for-value b)))
1126          (log 'equality-primitive name val-a val-b)
1127          (cond ((and (lexical-ref? val-a) (lexical-ref? val-b)
1128                      (eq? (lexical-ref-gensym val-a)
1129                           (lexical-ref-gensym val-b)))
1130                 (for-tail (make-const #f #t)))
1131                (else
1132                 (fold-constants src name (list val-a val-b) ctx)))))
1133
1134       (($ <primcall> src (? effect-free-primitive? name) args)
1135        (fold-constants src name (map for-value args) ctx))
1136
1137       (($ <primcall> src name args)
1138        (make-primcall src name (map for-value args)))
1139
1140       (($ <call> src orig-proc orig-args)
1141        ;; todo: augment the global env with specialized functions
1142        (let ((proc (visit orig-proc 'operator)))
1143          (match proc
1144            (($ <primitive-ref> _ name)
1145             (for-tail (make-primcall src name orig-args)))
1146            (($ <lambda> _ _
1147                ($ <lambda-case> _ req opt #f #f inits gensyms body #f))
1148             ;; Simple case: no rest, no keyword arguments.
1149             ;; todo: handle the more complex cases
1150             (let* ((nargs (length orig-args))
1151                    (nreq (length req))
1152                    (nopt (if opt (length opt) 0))
1153                    (key (source-expression proc)))
1154               (cond
1155                ((or (< nargs nreq) (> nargs (+ nreq nopt)))
1156                 ;; An error, or effecting arguments.
1157                 (make-call src (for-call orig-proc) (map for-value orig-args)))
1158                ((or (and=> (find-counter key counter) counter-recursive?)
1159                     (lambda? orig-proc))
1160                 ;; A recursive call, or a lambda in the operator
1161                 ;; position of the source expression.  Process again in
1162                 ;; tail context.
1163                 ;;
1164                 ;; In the recursive case, mark intervening counters as
1165                 ;; recursive, so we can handle a toplevel counter that
1166                 ;; recurses mutually with some other procedure.
1167                 ;; Otherwise, the next time we see the other procedure,
1168                 ;; the effort limit would be clamped to 100.
1169                 ;;
1170                 (let ((found (find-counter key counter)))
1171                   (if (and found (counter-recursive? found))
1172                       (let lp ((counter counter))
1173                         (if (not (eq? counter found))
1174                             (begin
1175                               (set-counter-recursive?! counter #t)
1176                               (lp (counter-prev counter)))))))
1177
1178                 (log 'inline-recurse key)
1179                 (loop (make-let src (append req (or opt '()))
1180                                 gensyms
1181                                 (append orig-args
1182                                         (drop inits (- nargs nreq)))
1183                                 body)
1184                   env counter ctx))
1185                (else
1186                 ;; An integration at the top-level, the first
1187                 ;; recursion of a recursive procedure, or a nested
1188                 ;; integration of a procedure that hasn't been seen
1189                 ;; yet.
1190                 (log 'inline-begin exp)
1191                 (let/ec k
1192                   (define (abort)
1193                     (log 'inline-abort exp)
1194                     (k (make-call src (for-call orig-proc)
1195                                   (map for-value orig-args))))
1196                   (define new-counter
1197                     (cond
1198                      ;; These first two cases will transfer effort
1199                      ;; from the current counter into the new
1200                      ;; counter.
1201                      ((find-counter key counter)
1202                       => (lambda (prev)
1203                            (make-recursive-counter recursive-effort-limit
1204                                                    operand-size-limit
1205                                                    prev counter)))
1206                      (counter
1207                       (make-nested-counter abort key counter))
1208                      ;; This case opens a new account, effectively
1209                      ;; printing money.  It should only do so once
1210                      ;; for each call site in the source program.
1211                      (else
1212                       (make-top-counter effort-limit operand-size-limit
1213                                         abort key))))
1214                   (define result
1215                     (loop (make-let src (append req (or opt '()))
1216                                     gensyms
1217                                     (append orig-args
1218                                             (drop inits (- nargs nreq)))
1219                                     body)
1220                       env new-counter ctx))
1221
1222                   (if counter
1223                       ;; The nested inlining attempt succeeded.
1224                       ;; Deposit the unspent effort and size back
1225                       ;; into the current counter.
1226                       (transfer! new-counter counter))
1227
1228                   (log 'inline-end result exp)
1229                   result)))))
1230            (_
1231             (make-call src (for-call orig-proc) (map for-value orig-args))))))
1232       (($ <lambda> src meta body)
1233        (case ctx
1234          ((effect) (make-void #f))
1235          ((test) (make-const #f #t))
1236          ((operator) exp)
1237          (else (record-source-expression!
1238                 exp
1239                 (make-lambda src meta (for-values body))))))
1240       (($ <lambda-case> src req opt rest kw inits gensyms body alt)
1241        (define (lift-applied-lambda body gensyms)
1242          (and (not opt) rest (not kw)
1243               (match body
1244                 (($ <primcall> _ '@apply
1245                     (($ <lambda> _ _ lcase)
1246                      ($ <lexical-ref> _ _ sym)
1247                      ...))
1248                  (and (equal? sym gensyms)
1249                       (not (lambda-case-alternate lcase))
1250                       lcase))
1251                 (_ #f))))
1252        (let* ((vars (map lookup-var gensyms))
1253               (new (fresh-gensyms vars))
1254               (env (fold extend-env env gensyms
1255                          (make-unbound-operands vars new)))
1256               (new-sym (lambda (old)
1257                          (operand-sym (cdr (vhash-assq old env)))))
1258               (body (loop body env counter ctx)))
1259          (or
1260           ;; (lambda args (apply (lambda ...) args)) => (lambda ...)
1261           (lift-applied-lambda body new)
1262           (make-lambda-case src req opt rest
1263                             (match kw
1264                               ((aok? (kw name old) ...)
1265                                (cons aok? (map list kw name (map new-sym old))))
1266                               (_ #f))
1267                             (map (cut loop <> env counter 'value) inits)
1268                             new
1269                             body
1270                             (and alt (for-tail alt))))))
1271       (($ <seq> src head tail)
1272        (let ((head (for-effect head))
1273              (tail (for-tail tail)))
1274          (if (void? head)
1275              tail
1276              (make-seq src
1277                        (if (and (seq? head)
1278                                 (void? (seq-tail head)))
1279                            (seq-head head)
1280                            head)
1281                        tail))))
1282       (($ <prompt> src tag body handler)
1283        (define (singly-used-definition x)
1284          (cond
1285           ((and (lexical-ref? x)
1286                 ;; Only fetch definitions with single uses.
1287                 (= (lexical-refcount (lexical-ref-gensym x)) 1)
1288                 (lookup (lexical-ref-gensym x)))
1289            => (lambda (x)
1290                 (singly-used-definition (visit-operand x counter 'value 10 10))))
1291           (else x)))
1292        (match (singly-used-definition tag)
1293          (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
1294           ;; There is no way that an <abort> could know the tag
1295           ;; for this <prompt>, so we can elide the <prompt>
1296           ;; entirely.
1297           (for-tail body))
1298          (_
1299           (make-prompt src (for-value tag) (for-tail body)
1300                        (for-value handler)))))
1301       (($ <abort> src tag args tail)
1302        (make-abort src (for-value tag) (map for-value args)
1303                    (for-value tail))))))