module/language/tree-il/peval.scm

   1 ;;; Tree-IL partial evaluator
   2
   3 ;; Copyright (C) 2011 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 (ice-9 vlist)
  23   #:use-module (ice-9 match)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-9)
  26   #:use-module (srfi srfi-11)
  27   #:use-module (srfi srfi-26)
  28   #:export (peval))
  29
  30 ;;;
  31 ;;; Partial evaluation is Guile's most important source-to-source
  32 ;;; optimization pass.  It performs copy propagation, dead code
  33 ;;; elimination, inlining, and constant folding, all while preserving
  34 ;;; the order of effects in the residual program.
  35 ;;;
  36 ;;; For more on partial evaluation, see William Cook’s excellent
  37 ;;; tutorial on partial evaluation at DSL 2011, called “Build your own
  38 ;;; partial evaluator in 90 minutes”[0].
  39 ;;;
  40 ;;; Our implementation of this algorithm was heavily influenced by
  41 ;;; Waddell and Dybvig's paper, "Fast and Effective Procedure Inlining",
  42 ;;; IU CS Dept. TR 484.
  43 ;;;
  44 ;;; [0] http://www.cs.utexas.edu/~wcook/tutorial/.
  45 ;;;
  46
  47 ;; First, some helpers.
  48 ;;
  49 (define-syntax-rule (let/ec k e e* ...)
  50   (let ((tag (make-prompt-tag)))
  51     (call-with-prompt
  52      tag
  53      (lambda ()
  54        (let ((k (lambda args (apply abort-to-prompt tag args))))
  55          e e* ...))
  56      (lambda (_ res) res))))
  57
  58 (define (tree-il-any proc exp)
  59   (let/ec k
  60     (tree-il-fold (lambda (exp res)
  61                     (let ((res (proc exp)))
  62                       (if res (k res) #f)))
  63                   (lambda (exp res)
  64                     (let ((res (proc exp)))
  65                       (if res (k res) #f)))
  66                   (lambda (exp res) #f)
  67                   #f exp)))
  68
  69 (define (vlist-any proc vlist)
  70   (let ((len (vlist-length vlist)))
  71     (let lp ((i 0))
  72       (and (< i len)
  73            (or (proc (vlist-ref vlist i))
  74                (lp (1+ i)))))))
  75
  76 ;; Peval will do a one-pass analysis on the source program to determine
  77 ;; the set of assigned lexicals, and to identify unreferenced and
  78 ;; singly-referenced lexicals.
  79 ;;
  80 ;; If peval introduces more code, via copy-propagation, it will need to
  81 ;; run `build-var-table' on the new code to add to make sure it can find
  82 ;; a <var> for each gensym bound in the program.
  83 ;;
  84 (define-record-type <var>
  85   (make-var name gensym refcount set?)
  86   var?
  87   (name var-name)
  88   (gensym var-gensym)
  89   (refcount var-refcount set-var-refcount!)
  90   (set? var-set? set-var-set?!))
  91
  92 (define* (build-var-table exp #:optional (table vlist-null))
  93   (tree-il-fold
  94    (lambda (exp res)
  95      (match exp
  96        (($ <lexical-ref> src name gensym)
  97         (let ((var (vhash-assq gensym res)))
  98           (if var
  99               (begin
 100                 (set-var-refcount! (cdr var) (1+ (var-refcount (cdr var))))
 101                 res)
 102               (vhash-consq gensym (make-var name gensym 1 #f) res))))
 103        (_ res)))
 104    (lambda (exp res)
 105      (match exp
 106        (($ <lexical-set> src name gensym exp)
 107         (let ((var (vhash-assq gensym res)))
 108           (if var
 109               (begin
 110                 (set-var-set?! (cdr var) #t)
 111                 res)
 112               (vhash-consq gensym (make-var name gensym 0 #t) res))))
 113        (_ res)))
 114    (lambda (exp res) res)
 115    table exp))
 116
 117 ;; Counters are data structures used to limit the effort that peval
 118 ;; spends on particular inlining attempts.  Each call site in the source
 119 ;; program is allocated some amount of effort.  If peval exceeds the
 120 ;; effort counter while attempting to inline a call site, it aborts the
 121 ;; inlining attempt and residualizes a call instead.
 122 ;;
 123 ;; As there is a fixed number of call sites, that makes `peval' O(N) in
 124 ;; the number of call sites in the source program.
 125 ;;
 126 ;; Counters should limit the size of the residual program as well, but
 127 ;; currently this is not implemented.
 128 ;;
 129 ;; At the top level, before seeing any peval call, there is no counter,
 130 ;; because inlining will terminate as there is no recursion.  When peval
 131 ;; sees a call at the top level, it will make a new counter, allocating
 132 ;; it some amount of effort and size.
 133 ;;
 134 ;; This top-level effort counter effectively "prints money".  Within a
 135 ;; toplevel counter, no more effort is printed ex nihilo; for a nested
 136 ;; inlining attempt to proceed, effort must be transferred from the
 137 ;; toplevel counter to the nested counter.
 138 ;;
 139 ;; Via `data' and `prev', counters form a linked list, terminating in a
 140 ;; toplevel counter.  In practice `data' will be the a pointer to the
 141 ;; source expression of the procedure being inlined.
 142 ;;
 143 ;; In this way peval can detect a recursive inlining attempt, by walking
 144 ;; back on the `prev' links looking for matching `data'.  Recursive
 145 ;; counters receive a more limited effort allocation, as we don't want
 146 ;; to spend all of the effort for a toplevel inlining site on loops.
 147 ;; Also, recursive counters don't need a prompt at each inlining site:
 148 ;; either the call chain folds entirely, or it will be residualized at
 149 ;; its original call.
 150 ;;
 151 (define-record-type <counter>
 152   (%make-counter effort size continuation recursive? data prev)
 153   counter?
 154   (effort effort-counter)
 155   (size size-counter)
 156   (continuation counter-continuation)
 157   (recursive? counter-recursive?)
 158   (data counter-data)
 159   (prev counter-prev))
 160
 161 (define (abort-counter c)
 162   ((counter-continuation c)))
 163
 164 (define (record-effort! c)
 165   (let ((e (effort-counter c)))
 166     (if (zero? (variable-ref e))
 167         (abort-counter c)
 168         (variable-set! e (1- (variable-ref e))))))
 169
 170 (define (record-size! c)
 171   (let ((s (size-counter c)))
 172     (if (zero? (variable-ref s))
 173         (abort-counter c)
 174         (variable-set! s (1- (variable-ref s))))))
 175
 176 (define (find-counter data counter)
 177   (and counter
 178        (if (eq? data (counter-data counter))
 179            counter
 180            (find-counter data (counter-prev counter)))))
 181
 182 (define* (transfer! from to #:optional
 183                     (effort (variable-ref (effort-counter from)))
 184                     (size (variable-ref (size-counter from))))
 185   (define (transfer-counter! from-v to-v amount)
 186     (let* ((from-balance (variable-ref from-v))
 187            (to-balance (variable-ref to-v))
 188            (amount (min amount from-balance)))
 189       (variable-set! from-v (- from-balance amount))
 190       (variable-set! to-v (+ to-balance amount))))
 191
 192   (transfer-counter! (effort-counter from) (effort-counter to) effort)
 193   (transfer-counter! (size-counter from) (size-counter to) size))
 194
 195 (define (make-top-counter effort-limit size-limit continuation data)
 196   (%make-counter (make-variable effort-limit)
 197                  (make-variable size-limit)
 198                  continuation
 199                  #t
 200                  data
 201                  #f))
 202
 203 (define (make-nested-counter continuation data current)
 204   (let ((c (%make-counter (make-variable 0)
 205                           (make-variable 0)
 206                           continuation
 207                           #f
 208                           data
 209                           current)))
 210     (transfer! current c)
 211     c))
 212
 213 (define (make-recursive-counter effort-limit size-limit orig current)
 214   (let ((c (%make-counter (make-variable 0)
 215                           (make-variable 0)
 216                           (counter-continuation orig)
 217                           #t
 218                           (counter-data orig)
 219                           current)))
 220     (transfer! current c effort-limit size-limit)
 221     c))
 222
 223 (define (types-check? primitive-name args)
 224   (case primitive-name
 225     ((values) #t)
 226     ((not pair? null? list? symbol? vector? struct?)
 227      (= (length args) 1))
 228     ((eq? eqv? equal?)
 229      (= (length args) 2))
 230     ;; FIXME: add more cases?
 231     (else #f)))
 232
 233 (define (fresh-gensyms syms)
 234   (map (lambda (x) (gensym (string-append (symbol->string x) " ")))
 235        syms))
 236
 237 ;; Copy propagation of terms that bind variables, like `lambda' terms,
 238 ;; will need to bind fresh variables.  This procedure renames all the
 239 ;; lexicals in a term.
 240 ;;
 241 (define (alpha-rename exp)
 242   "Alpha-rename EXP.  For any lambda in EXP, generate new symbols and
 243 replace all lexical references to the former symbols with lexical
 244 references to the new symbols."
 245   ;; XXX: This should be factorized somehow.
 246   (let loop ((exp     exp)
 247              (mapping vlist-null))             ; maps old to new gensyms
 248     (match exp
 249       (($ <lambda-case> src req opt rest kw inits gensyms body alt)
 250        ;; Create new symbols to replace GENSYMS and propagate them down
 251        ;; in BODY and ALT.
 252        (let* ((new     (fresh-gensyms
 253                         (append req
 254                                 (or opt '())
 255                                 (if rest (list rest) '())
 256                                 (match kw
 257                                   ((aok? (_ name _) ...) name)
 258                                   (_ '())))))
 259               (mapping (fold vhash-consq mapping gensyms new)))
 260          (make-lambda-case src req opt rest
 261                            (match kw
 262                              ((aok? (kw name old) ...)
 263                               (cons aok? (map list
 264                                               kw
 265                                               name
 266                                               (take-right new (length old)))))
 267                              (_ #f))
 268                            (map (cut loop <> mapping) inits)
 269                            new
 270                            (loop body mapping)
 271                            (and alt (loop alt mapping)))))
 272       (($ <lexical-ref> src name gensym)
 273        ;; Possibly replace GENSYM by the new gensym defined in MAPPING.
 274        (let ((val (vhash-assq gensym mapping)))
 275          (if val
 276              (make-lexical-ref src name (cdr val))
 277              exp)))
 278       (($ <lexical-set> src name gensym exp)
 279        (let ((val (vhash-assq gensym mapping)))
 280          (make-lexical-set src name (if val (cdr val) gensym)
 281                            (loop exp mapping))))
 282       (($ <lambda> src meta body)
 283        (make-lambda src meta (loop body mapping)))
 284       (($ <let> src names gensyms vals body)
 285        ;; As for `lambda-case' rename GENSYMS to avoid any collision.
 286        (let* ((new     (fresh-gensyms names))
 287               (mapping (fold vhash-consq mapping gensyms new))
 288               (vals    (map (cut loop <> mapping) vals))
 289               (body    (loop body mapping)))
 290          (make-let src names new vals body)))
 291       (($ <letrec> src in-order? names gensyms vals body)
 292        ;; Likewise.
 293        (let* ((new     (fresh-gensyms names))
 294               (mapping (fold vhash-consq mapping gensyms new))
 295               (vals    (map (cut loop <> mapping) vals))
 296               (body    (loop body mapping)))
 297          (make-letrec src in-order? names new vals body)))
 298       (($ <fix> src names gensyms vals body)
 299        ;; Likewise.
 300        (let* ((new     (fresh-gensyms names))
 301               (mapping (fold vhash-consq mapping gensyms new))
 302               (vals    (map (cut loop <> mapping) vals))
 303               (body    (loop body mapping)))
 304          (make-fix src names new vals body)))
 305       (($ <let-values> src exp body)
 306        (make-let-values src (loop exp mapping) (loop body mapping)))
 307       (($ <const>)
 308        exp)
 309       (($ <void>)
 310        exp)
 311       (($ <toplevel-ref>)
 312        exp)
 313       (($ <module-ref>)
 314        exp)
 315       (($ <primitive-ref>)
 316        exp)
 317       (($ <toplevel-set> src name exp)
 318        (make-toplevel-set src name (loop exp mapping)))
 319       (($ <toplevel-define> src name exp)
 320        (make-toplevel-define src name (loop exp mapping)))
 321       (($ <module-set> src mod name public? exp)
 322        (make-module-set src mod name public? (loop exp mapping)))
 323       (($ <dynlet> src fluids vals body)
 324        (make-dynlet src
 325                     (map (cut loop <> mapping) fluids)
 326                     (map (cut loop <> mapping) vals)
 327                     (loop body mapping)))
 328       (($ <dynwind> src winder body unwinder)
 329        (make-dynwind src
 330                      (loop winder mapping)
 331                      (loop body mapping)
 332                      (loop unwinder mapping)))
 333       (($ <dynref> src fluid)
 334        (make-dynref src (loop fluid mapping)))
 335       (($ <dynset> src fluid exp)
 336        (make-dynset src (loop fluid mapping) (loop exp mapping)))
 337       (($ <conditional> src condition subsequent alternate)
 338        (make-conditional src
 339                          (loop condition mapping)
 340                          (loop subsequent mapping)
 341                          (loop alternate mapping)))
 342       (($ <application> src proc args)
 343        (make-application src (loop proc mapping)
 344                          (map (cut loop <> mapping) args)))
 345       (($ <sequence> src exps)
 346        (make-sequence src (map (cut loop <> mapping) exps)))
 347       (($ <prompt> src tag body handler)
 348        (make-prompt src (loop tag mapping) (loop body mapping)
 349                     (loop handler mapping)))
 350       (($ <abort> src tag args tail)
 351        (make-abort src (loop tag mapping) (map (cut loop <> mapping) args)
 352                    (loop tail mapping))))))
 353
 354 (define* (peval exp #:optional (cenv (current-module)) (env vlist-null)
 355                 #:key
 356                 (operator-size-limit 40)
 357                 (operand-size-limit 20)
 358                 (value-size-limit 10)
 359                 (effort-limit 500)
 360                 (recursive-effort-limit 100))
 361   "Partially evaluate EXP in compilation environment CENV, with
 362 top-level bindings from ENV and return the resulting expression."
 363
 364   ;; This is a simple partial evaluator.  It effectively performs
 365   ;; constant folding, copy propagation, dead code elimination, and
 366   ;; inlining.
 367
 368   ;; TODO:
 369   ;;
 370   ;; Propagate copies across toplevel bindings, if we can prove the
 371   ;; bindings to be immutable.
 372   ;;
 373   ;; Specialize lambda expressions with invariant arguments.
 374
 375   (define local-toplevel-env
 376     ;; The top-level environment of the module being compiled.
 377     (match exp
 378       (($ <toplevel-define> _ name)
 379        (vhash-consq name #t env))
 380       (($ <sequence> _ exps)
 381        (fold (lambda (x r)
 382                (match x
 383                  (($ <toplevel-define> _ name)
 384                   (vhash-consq name #t r))
 385                  (_ r)))
 386              env
 387              exps))
 388       (_ env)))
 389
 390   (define (local-toplevel? name)
 391     (vhash-assq name local-toplevel-env))
 392
 393   ;; gensym -> <var>
 394   ;; renamed-term -> original-term
 395   ;;
 396   (define store (build-var-table exp))
 397
 398   (define (assigned-lexical? sym)
 399     (let ((v (vhash-assq sym store)))
 400       (and v (var-set? (cdr v)))))
 401
 402   (define (lexical-refcount sym)
 403     (let ((v (vhash-assq sym store)))
 404       (if v (var-refcount (cdr v)) 0)))
 405
 406   ;; ORIG has been alpha-renamed to NEW.  Analyze NEW and record a link
 407   ;; from it to ORIG.
 408   ;;
 409   (define (record-source-expression! orig new)
 410     (set! store (vhash-consq new
 411                              (source-expression orig)
 412                              (build-var-table new store)))
 413     new)
 414
 415   ;; Find the source expression corresponding to NEW.  Used to detect
 416   ;; recursive inlining attempts.
 417   ;;
 418   (define (source-expression new)
 419     (let ((x (vhash-assq new store)))
 420       (if x (cdr x) new)))
 421
 422   (define residual-lexical-references (make-hash-table))
 423
 424   (define (record-residual-lexical-reference! sym)
 425     (hashq-set! residual-lexical-references sym #t))
 426
 427   (define (apply-primitive name args)
 428     ;; todo: further optimize commutative primitives
 429     (catch #t
 430       (lambda ()
 431         (call-with-values
 432             (lambda ()
 433               (apply (module-ref the-scm-module name) args))
 434           (lambda results
 435             (values #t results))))
 436       (lambda _
 437         (values #f '()))))
 438
 439   (define (inline-values exp src names gensyms body)
 440     (let loop ((exp exp))
 441       (match exp
 442         ;; Some expression types are always singly-valued.
 443         ((or ($ <const>)
 444              ($ <void>)
 445              ($ <lambda>)
 446              ($ <lexical-ref>)
 447              ($ <toplevel-ref>)
 448              ($ <module-ref>)
 449              ($ <primitive-ref>)
 450              ($ <dynref>)
 451              ($ <lexical-set>)          ; FIXME: these set! expressions
 452              ($ <toplevel-set>)         ; could return zero values in
 453              ($ <toplevel-define>)      ; the future
 454              ($ <module-set>)           ;
 455              ($ <dynset>))              ;
 456          (and (= (length names) 1)
 457               (make-let src names gensyms (list exp) body)))
 458         (($ <application> src
 459             ($ <primitive-ref> _ (? singly-valued-primitive? name)))
 460          (and (= (length names) 1)
 461               (make-let src names gensyms (list exp) body)))
 462
 463         ;; Statically-known number of values.
 464         (($ <application> src ($ <primitive-ref> _ 'values) vals)
 465          (and (= (length names) (length vals))
 466               (make-let src names gensyms vals body)))
 467
 468         ;; Not going to copy code into both branches.
 469         (($ <conditional>) #f)
 470
 471         ;; Bail on other applications.
 472         (($ <application>) #f)
 473
 474         ;; Bail on prompt and abort.
 475         (($ <prompt>) #f)
 476         (($ <abort>) #f)
 477
 478         ;; Propagate to tail positions.
 479         (($ <let> src names gensyms vals body)
 480          (let ((body (loop body)))
 481            (and body
 482                 (make-let src names gensyms vals body))))
 483         (($ <letrec> src in-order? names gensyms vals body)
 484          (let ((body (loop body)))
 485            (and body
 486                 (make-letrec src in-order? names gensyms vals body))))
 487         (($ <fix> src names gensyms vals body)
 488          (let ((body (loop body)))
 489            (and body
 490                 (make-fix src names gensyms vals body))))
 491         (($ <let-values> src exp
 492             ($ <lambda-case> src2 req opt rest kw inits gensyms body #f))
 493          (let ((body (loop body)))
 494            (and body
 495                 (make-let-values src exp
 496                                  (make-lambda-case src2 req opt rest kw
 497                                                    inits gensyms body #f)))))
 498         (($ <dynwind> src winder body unwinder)
 499          (let ((body (loop body)))
 500            (and body
 501                 (make-dynwind src winder body unwinder))))
 502         (($ <dynlet> src fluids vals body)
 503          (let ((body (loop body)))
 504            (and body
 505                 (make-dynlet src fluids vals body))))
 506         (($ <sequence> src exps)
 507          (match exps
 508            ((head ... tail)
 509             (let ((tail (loop tail)))
 510               (and tail
 511                    (make-sequence src (append head (list tail)))))))))))
 512
 513   (define (make-values src values)
 514     (match values
 515       ((single) single)                 ; 1 value
 516       ((_ ...)                          ; 0, or 2 or more values
 517        (make-application src (make-primitive-ref src 'values)
 518                          values))))
 519
 520   (define (constant-expression? x)
 521     ;; Return true if X is constant---i.e., if it is known to have no
 522     ;; effects, does not allocate storage for a mutable object, and does
 523     ;; not access mutable data (like `car' or toplevel references).
 524     (let loop ((x x))
 525       (match x
 526         (($ <void>) #t)
 527         (($ <const>) #t)
 528         (($ <lambda>) #t)
 529         (($ <lambda-case> _ req opt rest kw inits _ body alternate)
 530          (and (every loop inits) (loop body) (loop alternate)))
 531         (($ <lexical-ref> _ _ gensym)
 532          (not (assigned-lexical? gensym)))
 533         (($ <primitive-ref>) #t)
 534         (($ <conditional> _ condition subsequent alternate)
 535          (and (loop condition) (loop subsequent) (loop alternate)))
 536         (($ <application> _ ($ <primitive-ref> _ name) args)
 537          (and (effect-free-primitive? name)
 538               (not (constructor-primitive? name))
 539               (types-check? name args)
 540               (every loop args)))
 541         (($ <application> _ ($ <lambda> _ _ body) args)
 542          (and (loop body) (every loop args)))
 543         (($ <sequence> _ exps)
 544          (every loop exps))
 545         (($ <let> _ _ _ vals body)
 546          (and (every loop vals) (loop body)))
 547         (($ <letrec> _ _ _ _ vals body)
 548          (and (every loop vals) (loop body)))
 549         (($ <fix> _ _ _ vals body)
 550          (and (every loop vals) (loop body)))
 551         (($ <let-values> _ exp body)
 552          (and (loop exp) (loop body)))
 553         (($ <prompt> _ tag body handler)
 554          (and (loop tag) (loop body) (loop handler)))
 555         (_ #f))))
 556
 557   (define (prune-bindings names syms vals body for-effect
 558                           build-result)
 559     (let lp ((names names) (syms syms) (vals vals)
 560              (names* '()) (syms* '()) (vals* '())
 561              (effects '()))
 562       (match (list names syms vals)
 563        ((() () ())
 564         (let ((body (if (null? effects)
 565                         body
 566                         (make-sequence #f (reverse (cons body effects))))))
 567           (if (null? names*)
 568               body
 569               (build-result (reverse names*) (reverse syms*)
 570                             (reverse vals*) body))))
 571        (((name . names) (sym . syms) (val . vals))
 572         (if (hashq-ref residual-lexical-references sym)
 573             (lp names syms vals
 574                 (cons name names*) (cons sym syms*) (cons val vals*)
 575                 effects)
 576             (let ((effect (for-effect val)))
 577               (lp names syms vals
 578                   names* syms* vals*
 579                   (if (void? effect)
 580                       effects
 581                       (cons effect effects)))))))))
 582
 583   (define (small-expression? x limit)
 584     (let/ec k
 585       (tree-il-fold
 586        (lambda (x res)                  ; leaf
 587          (1+ res))
 588        (lambda (x res)                  ; down
 589          (1+ res))
 590        (lambda (x res)                  ; up
 591          (if (< res limit)
 592              res
 593              (k #f)))
 594        0 x)
 595       #t))
 596
 597   (let loop ((exp   exp)
 598              (env   vlist-null)         ; static environment
 599              (counter #f)               ; inlined call stack
 600              (ctx 'value))   ; effect, value, test, operator, or operand
 601     (define (lookup var)
 602       (and=> (vhash-assq var env) cdr))
 603
 604     (define (for-value exp)
 605       (loop exp env counter 'value))
 606     (define (for-operand exp)
 607       (loop exp env counter 'operand))
 608     (define (for-test exp)
 609       (loop exp env counter 'test))
 610     (define (for-effect exp)
 611       (loop exp env counter 'effect))
 612     (define (for-tail exp)
 613       (loop exp env counter ctx))
 614
 615     (if counter
 616         (record-effort! counter))
 617
 618     (match exp
 619       (($ <const>)
 620        (case ctx
 621          ((effect) (make-void #f))
 622          (else exp)))
 623       (($ <void>)
 624        (case ctx
 625          ((test) (make-const #f #t))
 626          (else exp)))
 627       (($ <lexical-ref> _ _ gensym)
 628        (case ctx
 629          ((effect) (make-void #f))
 630          (else
 631           (let ((val (lookup gensym)))
 632             (cond
 633              ((or (not val)
 634                   (assigned-lexical? gensym)
 635                   (not (constant-expression? val)))
 636               ;; Don't copy-propagate through assigned variables,
 637               ;; and don't reorder effects.
 638               (record-residual-lexical-reference! gensym)
 639               exp)
 640              ((lexical-ref? val)
 641               (for-tail val))
 642              ((or (const? val)
 643                   (void? val)
 644                   (primitive-ref? val))
 645               ;; Always propagate simple values that cannot lead to
 646               ;; code bloat.
 647               (for-tail val))
 648              ((= 1 (lexical-refcount gensym))
 649               ;; Always propagate values referenced only once.
 650               ;; There is no need to rename the bindings, as they
 651               ;; are only being moved, not copied.  However in
 652               ;; operator context we do rename it, as that
 653               ;; effectively clears out the residualized-lexical
 654               ;; flags that may have been set when this value was
 655               ;; visited previously as an operand.
 656               (case ctx
 657                 ((test) (for-test val))
 658                 ((operator) (record-source-expression! val (alpha-rename val)))
 659                 (else val)))
 660              ;; FIXME: do demand-driven size accounting rather than
 661              ;; these heuristics.
 662              ((eq? ctx 'operator)
 663               ;; A pure expression in the operator position.  Inline
 664               ;; if it's a lambda that's small enough.
 665               (if (and (lambda? val)
 666                        (small-expression? val operator-size-limit))
 667                   (record-source-expression! val (alpha-rename val))
 668                   (begin
 669                     (record-residual-lexical-reference! gensym)
 670                     exp)))
 671              ((eq? ctx 'operand)
 672               ;; A pure expression in the operand position.  Inline
 673               ;; if it's small enough.
 674               (if (small-expression? val operand-size-limit)
 675                   (record-source-expression! val (alpha-rename val))
 676                   (begin
 677                     (record-residual-lexical-reference! gensym)
 678                     exp)))
 679              (else
 680               ;; A pure expression, processed for value.  Don't
 681               ;; inline lambdas, because they will probably won't
 682               ;; fold because we don't know the operator.
 683               (if (and (small-expression? val value-size-limit)
 684                        (not (tree-il-any lambda? val)))
 685                   (record-source-expression! val (alpha-rename val))
 686                   (begin
 687                     (record-residual-lexical-reference! gensym)
 688                     exp))))))))
 689       (($ <lexical-set> src name gensym exp)
 690        (if (zero? (lexical-refcount gensym))
 691            (let ((exp (for-effect exp)))
 692              (if (void? exp)
 693                  exp
 694                  (make-sequence src (list exp (make-void #f)))))
 695            (begin
 696              (record-residual-lexical-reference! gensym)
 697              (make-lexical-set src name gensym (for-value exp)))))
 698       (($ <let> src names gensyms vals body)
 699        (let* ((vals (map for-operand vals))
 700               (body (loop body
 701                       (fold vhash-consq env gensyms vals)
 702                       counter
 703                       ctx)))
 704          (cond
 705           ((const? body)
 706            (for-tail (make-sequence src (append vals (list body)))))
 707           ((and (lexical-ref? body)
 708                 (memq (lexical-ref-gensym body) gensyms))
 709            (let ((sym (lexical-ref-gensym body))
 710                  (pairs (map cons gensyms vals)))
 711              ;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
 712              (for-tail
 713               (make-sequence
 714                src
 715                (append (map cdr (alist-delete sym pairs eq?))
 716                        (list (assq-ref pairs sym)))))))
 717           (else
 718            ;; Only include bindings for which lexical references
 719            ;; have been residualized.
 720            (prune-bindings names gensyms vals body for-effect
 721                            (lambda (names gensyms vals body)
 722                              (if (null? names) (error "what!" names))
 723                              (make-let src names gensyms vals body)))))))
 724       (($ <letrec> src in-order? names gensyms vals body)
 725        ;; Things could be done more precisely when IN-ORDER? but
 726        ;; it's OK not to do it---at worst we lost an optimization
 727        ;; opportunity.
 728        (let* ((vals (map for-operand vals))
 729               (body (loop body
 730                       (fold vhash-consq env gensyms vals)
 731                       counter
 732                       ctx)))
 733          (if (and (const? body)
 734                   (every constant-expression? vals))
 735              body
 736              (prune-bindings names gensyms vals body for-effect
 737                              (lambda (names gensyms vals body)
 738                                (make-letrec src in-order?
 739                                             names gensyms vals body))))))
 740       (($ <fix> src names gensyms vals body)
 741        (let* ((vals (map for-operand vals))
 742               (body (loop body
 743                       (fold vhash-consq env gensyms vals)
 744                       counter
 745                       ctx)))
 746          (if (const? body)
 747              body
 748              (prune-bindings names gensyms vals body for-effect
 749                              (lambda (names gensyms vals body)
 750                                (make-fix src names gensyms vals body))))))
 751       (($ <let-values> lv-src producer consumer)
 752        ;; Peval the producer, then try to inline the consumer into
 753        ;; the producer.  If that succeeds, peval again.  Otherwise
 754        ;; reconstruct the let-values, pevaling the consumer.
 755        (let ((producer (for-value producer)))
 756          (or (match consumer
 757                (($ <lambda-case> src req #f #f #f () gensyms body #f)
 758                 (cond
 759                  ((inline-values producer src req gensyms body)
 760                   => for-tail)
 761                  (else #f)))
 762                (_ #f))
 763              (make-let-values lv-src producer (for-tail consumer)))))
 764       (($ <dynwind> src winder body unwinder)
 765        (make-dynwind src (for-value winder) (for-tail body)
 766                      (for-value unwinder)))
 767       (($ <dynlet> src fluids vals body)
 768        (make-dynlet src (map for-value fluids) (map for-value vals)
 769                     (for-tail body)))
 770       (($ <dynref> src fluid)
 771        (make-dynref src (for-value fluid)))
 772       (($ <dynset> src fluid exp)
 773        (make-dynset src (for-value fluid) (for-value exp)))
 774       (($ <toplevel-ref> src (? effect-free-primitive? name))
 775        (if (local-toplevel? name)
 776            exp
 777            (resolve-primitives! exp cenv)))
 778       (($ <toplevel-ref>)
 779        ;; todo: open private local bindings.
 780        exp)
 781       (($ <module-ref> src module (? effect-free-primitive? name) #f)
 782        (let ((module (false-if-exception
 783                       (resolve-module module #:ensure #f))))
 784          (if (module? module)
 785              (let ((var (module-variable module name)))
 786                (if (eq? var (module-variable the-scm-module name))
 787                    (make-primitive-ref src name)
 788                    exp))
 789              exp)))
 790       (($ <module-ref>)
 791        exp)
 792       (($ <module-set> src mod name public? exp)
 793        (make-module-set src mod name public? (for-value exp)))
 794       (($ <toplevel-define> src name exp)
 795        (make-toplevel-define src name (for-value exp)))
 796       (($ <toplevel-set> src name exp)
 797        (make-toplevel-set src name (for-value exp)))
 798       (($ <primitive-ref>)
 799        (case ctx
 800          ((effect) (make-void #f))
 801          ((test) (make-const #f #t))
 802          (else exp)))
 803       (($ <conditional> src condition subsequent alternate)
 804        (let ((condition (for-test condition)))
 805          (if (const? condition)
 806              (if (const-exp condition)
 807                  (for-tail subsequent)
 808                  (for-tail alternate))
 809              (make-conditional src condition
 810                                (for-tail subsequent)
 811                                (for-tail alternate)))))
 812       (($ <application> src
 813           ($ <primitive-ref> _ '@call-with-values)
 814           (producer
 815            ($ <lambda> _ _
 816               (and consumer
 817                    ;; No optional or kwargs.
 818                    ($ <lambda-case>
 819                       _ req #f rest #f () gensyms body #f)))))
 820        (for-tail (make-let-values src (make-application src producer '())
 821                                   consumer)))
 822
 823       (($ <application> src orig-proc orig-args)
 824        ;; todo: augment the global env with specialized functions
 825        (let ((proc (loop orig-proc env counter 'operator)))
 826          (match proc
 827            (($ <primitive-ref> _ (? constructor-primitive? name))
 828             (case ctx
 829               ((effect test)
 830                (let ((res (if (eq? ctx 'effect)
 831                               (make-void #f)
 832                               (make-const #f #t))))
 833                  (match (for-value exp)
 834                    (($ <application> _ ($ <primitive-ref> _ 'cons) (x xs))
 835                     (for-tail
 836                      (make-sequence src (list x xs res))))
 837                    (($ <application> _ ($ <primitive-ref> _ 'list) elts)
 838                     (for-tail
 839                      (make-sequence src (append elts (list res)))))
 840                    (($ <application> _ ($ <primitive-ref> _ 'vector) elts)
 841                     (for-tail
 842                      (make-sequence src (append elts (list res)))))
 843                    (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag) ())
 844                     res)
 845                    (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
 846                        (($ <const> _ (? string?))))
 847                     res)
 848                    (exp exp))))
 849               (else
 850                (match (cons name (map for-value orig-args))
 851                  (('cons head tail)
 852                   (match tail
 853                     (($ <const> src ())
 854                      (make-application src (make-primitive-ref #f 'list)
 855                                        (list head)))
 856                     (($ <application> src ($ <primitive-ref> _ 'list) elts)
 857                      (make-application src (make-primitive-ref #f 'list)
 858                                        (cons head elts)))
 859                     (_ (make-application src proc
 860                                          (list head tail)))))
 861
 862                  ;; FIXME: these for-tail recursions could take
 863                  ;; place outside an effort counter.
 864                  (('car ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
 865                   (for-tail (make-sequence src (list tail head))))
 866                  (('cdr ($ <application> src ($ <primitive-ref> _ 'cons) (head tail)))
 867                   (for-tail (make-sequence src (list head tail))))
 868                  (('car ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
 869                   (for-tail (make-sequence src (append tail (list head)))))
 870                  (('cdr ($ <application> src ($ <primitive-ref> _ 'list) (head . tail)))
 871                   (for-tail (make-sequence
 872                              src
 873                              (list head
 874                                    (make-application
 875                                     src (make-primitive-ref #f 'list) tail)))))
 876
 877                  (('car ($ <const> src (head . tail)))
 878                   (for-tail (make-const src head)))
 879                  (('cdr ($ <const> src (head . tail)))
 880                   (for-tail (make-const src tail)))
 881
 882                  ((_ . args)
 883                   (make-application src proc args))))))
 884            (($ <primitive-ref> _ (? effect-free-primitive? name))
 885             (let ((args (map for-value orig-args)))
 886               (if (every const? args)   ; only simple constants
 887                   (let-values (((success? values)
 888                                 (apply-primitive name
 889                                                  (map const-exp args))))
 890                     (if success?
 891                         (case ctx
 892                           ((effect) (make-void #f))
 893                           ((test)
 894                            ;; Values truncation: only take the first
 895                            ;; value.
 896                            (if (pair? values)
 897                                (make-const #f (car values))
 898                                (make-values src '())))
 899                           (else
 900                            (make-values src (map (cut make-const src <>)
 901                                                  values))))
 902                         (make-application src proc args)))
 903                   (cond
 904                    ((and (eq? ctx 'effect) (types-check? name args))
 905                     (make-void #f))
 906                    (else
 907                     (make-application src proc args))))))
 908            (($ <lambda> _ _
 909                ($ <lambda-case> _ req opt #f #f inits gensyms body #f))
 910             ;; Simple case: no rest, no keyword arguments.
 911             ;; todo: handle the more complex cases
 912             (let* ((nargs (length orig-args))
 913                    (nreq (length req))
 914                    (nopt (if opt (length opt) 0))
 915                    (key (source-expression proc)))
 916               (cond
 917                ((or (< nargs nreq) (> nargs (+ nreq nopt)))
 918                 ;; An error, or effecting arguments.
 919                 (make-application src (for-value orig-proc)
 920                                   (map for-value orig-args)))
 921                ((or (and=> (find-counter key counter) counter-recursive?)
 922                     (lambda? orig-proc))
 923                 ;; A recursive call, or a lambda in the operator
 924                 ;; position of the source expression.  Process again in
 925                 ;; tail context.
 926                 (loop (make-let src (append req (or opt '()))
 927                                 gensyms
 928                                 (append orig-args
 929                                         (drop inits (- nargs nreq)))
 930                                 body)
 931                   env counter ctx))
 932                (else
 933                 ;; An integration at the top-level, the first
 934                 ;; recursion of a recursive procedure, or a nested
 935                 ;; integration of a procedure that hasn't been seen
 936                 ;; yet.
 937                 (let/ec k
 938                   (define (abort)
 939                     (k (make-application src
 940                                          (for-value orig-proc)
 941                                          (map for-value orig-args))))
 942                   (define new-counter
 943                     (cond
 944                      ;; These first two cases will transfer effort
 945                      ;; from the current counter into the new
 946                      ;; counter.
 947                      ((find-counter key counter)
 948                       => (lambda (prev)
 949                            (make-recursive-counter recursive-effort-limit
 950                                                    operand-size-limit
 951                                                    prev counter)))
 952                      (counter
 953                       (make-nested-counter abort key counter))
 954                      ;; This case opens a new account, effectively
 955                      ;; printing money.  It should only do so once
 956                      ;; for each call site in the source program.
 957                      (else
 958                       (make-top-counter effort-limit operand-size-limit
 959                                         abort key))))
 960                   (define result
 961                     (loop (make-let src (append req (or opt '()))
 962                                     gensyms
 963                                     (append orig-args
 964                                             (drop inits (- nargs nreq)))
 965                                     body)
 966                       env new-counter ctx))
 967
 968                   (if counter
 969                       ;; The nested inlining attempt succeeded.
 970                       ;; Deposit the unspent effort and size back
 971                       ;; into the current counter.
 972                       (transfer! new-counter counter))
 973
 974                   result)))))
 975            (_
 976             (make-application src proc
 977                               (map for-value orig-args))))))
 978       (($ <lambda> src meta body)
 979        (case ctx
 980          ((effect) (make-void #f))
 981          ((test) (make-const #f #t))
 982          ((operator) exp)
 983          (else
 984           (make-lambda src meta (for-value body)))))
 985       (($ <lambda-case> src req opt rest kw inits gensyms body alt)
 986        (make-lambda-case src req opt rest kw
 987                          (map for-value inits)
 988                          gensyms
 989                          (for-tail body)
 990                          (and alt (for-tail alt))))
 991       (($ <sequence> src exps)
 992        (let lp ((exps exps) (effects '()))
 993          (match exps
 994            ((last)
 995             (if (null? effects)
 996                 (for-tail last)
 997                 (make-sequence
 998                  src
 999                  (reverse (cons (for-tail last) effects)))))
1000            ((head . rest)
1001             (let ((head (for-effect head)))
1002               (cond
1003                ((sequence? head)
1004                 (lp (append (sequence-exps head) rest) effects))
1005                ((void? head)
1006                 (lp rest effects))
1007                (else
1008                 (lp rest (cons head effects)))))))))
1009       (($ <prompt> src tag body handler)
1010        (define (singly-used-definition x)
1011          (cond
1012           ((and (lexical-ref? x)
1013                 ;; Only fetch definitions with single uses.
1014                 (= (lexical-refcount (lexical-ref-gensym x)) 1)
1015                 (lookup (lexical-ref-gensym x)))
1016            => singly-used-definition)
1017           (else x)))
1018        (match (singly-used-definition tag)
1019          (($ <application> _ ($ <primitive-ref> _ 'make-prompt-tag)
1020              (or () ((? constant-expression?))))
1021           ;; There is no way that an <abort> could know the tag
1022           ;; for this <prompt>, so we can elide the <prompt>
1023           ;; entirely.
1024           (for-tail body))
1025          (_
1026           (make-prompt src (for-value tag) (for-tail body)
1027                        (for-value handler)))))
1028       (($ <abort> src tag args tail)
1029        (make-abort src (for-value tag) (map for-value args)
1030                    (for-value tail))))))