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