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