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