module/language/tree-il/optimize.scm

   1 ;;; Tree-il optimizer
   2
   3 ;; Copyright (C) 2009, 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 ;;; Code:
  20
  21 (define-module (language tree-il optimize)
  22   #:use-module (language tree-il)
  23   #:use-module (language tree-il primitives)
  24   #:use-module (language tree-il inline)
  25   #:use-module (language tree-il fix-letrec)
  26   #:use-module (ice-9 vlist)
  27   #:use-module (ice-9 match)
  28   #:use-module (srfi srfi-1)
  29   #:use-module (srfi srfi-11)
  30   #:use-module (srfi srfi-26)
  31   #:export (optimize!))
  32
  33 (define (optimize! x env opts)
  34   (let ((peval (match (memq #:partial-eval? opts)
  35                  ((#:partial-eval? #f _ ...)
  36                   ;; Disable partial evaluation.
  37                   (lambda (x e) x))
  38                  (_ peval))))
  39    (inline!
  40     (fix-letrec!
  41      (peval (expand-primitives! (resolve-primitives! x env))
  42             env)))))
  43
  44 \f
  45 ;;;
  46 ;;; Partial evaluation.
  47 ;;;
  48
  49 (define (fresh-gensyms syms)
  50   (map (lambda (x) (gensym (string-append (symbol->string x) " ")))
  51        syms))
  52
  53 (define (alpha-rename exp)
  54   "Alpha-rename EXP.  For any lambda in EXP, generate new symbols and
  55 replace all lexical references to the former symbols with lexical
  56 references to the new symbols."
  57   ;; XXX: This should be factorized somehow.
  58   (let loop ((exp     exp)
  59              (mapping vlist-null))             ; maps old to new gensyms
  60     (match exp
  61       (($ <lambda-case> src req opt rest kw inits gensyms body alt)
  62        ;; Create new symbols to replace GENSYMS and propagate them down
  63        ;; in BODY and ALT.
  64        (let* ((new     (fresh-gensyms
  65                         (append req
  66                                 (or opt '())
  67                                 (if rest (list rest) '())
  68                                 (match kw
  69                                   ((aok? (_ name _) ...) name)
  70                                   (_ '())))))
  71               (mapping (fold vhash-consq mapping gensyms new)))
  72          (make-lambda-case src req opt rest
  73                            (match kw
  74                              ((aok? (kw name old) ...)
  75                               (cons aok? (map list
  76                                               kw
  77                                               name
  78                                               (take-right new (length old)))))
  79                              (_ #f))
  80                            (map (cut loop <> mapping) inits)
  81                            new
  82                            (loop body mapping)
  83                            (and alt (loop alt mapping)))))
  84       (($ <lexical-ref> src name gensym)
  85        ;; Possibly replace GENSYM by the new gensym defined in MAPPING.
  86        (let ((val (vhash-assq gensym mapping)))
  87          (if val
  88              (make-lexical-ref src name (cdr val))
  89              exp)))
  90       (($ <lambda> src meta body)
  91        (make-lambda src meta (loop body mapping)))
  92       (($ <let> src names gensyms vals body)
  93        ;; As for `lambda-case' rename GENSYMS to avoid any collision.
  94        (let* ((new     (fresh-gensyms names))
  95               (mapping (fold vhash-consq mapping gensyms new))
  96               (vals    (map (cut loop <> mapping) vals))
  97               (body    (loop body mapping)))
  98          (make-let src names new vals body)))
  99       (($ <letrec> src in-order? names gensyms vals body)
 100        ;; Likewise.
 101        (let* ((new     (fresh-gensyms names))
 102               (mapping (fold vhash-consq mapping gensyms new))
 103               (vals    (map (cut loop <> mapping) vals))
 104               (body    (loop body mapping)))
 105          (make-letrec src in-order? names new vals body)))
 106       (($ <fix> src names gensyms vals body)
 107        ;; Likewise.
 108        (let* ((new     (fresh-gensyms names))
 109               (mapping (fold vhash-consq mapping gensyms new))
 110               (vals    (map (cut loop <> mapping) vals))
 111               (body    (loop body mapping)))
 112          (make-fix src names new vals body)))
 113       (($ <let-values> src exp body)
 114        (make-let-values src (loop exp mapping) (loop body mapping)))
 115       (($ <const>)
 116        exp)
 117       (($ <void>)
 118        exp)
 119       (($ <toplevel-ref>)
 120        exp)
 121       (($ <module-ref>)
 122        exp)
 123       (($ <primitive-ref>)
 124        exp)
 125       (($ <toplevel-set> src name exp)
 126        (make-toplevel-set src name (loop exp mapping)))
 127       (($ <toplevel-define> src name exp)
 128        (make-toplevel-define src name (loop exp mapping)))
 129       (($ <module-set> src mod name public? exp)
 130        (make-module-set src mod name public? (loop exp mapping)))
 131       (($ <dynlet> src fluids vals body)
 132        (make-dynlet src
 133                     (map (cut loop <> mapping) fluids)
 134                     (map (cut loop <> mapping) vals)
 135                     (loop body mapping)))
 136       (($ <dynwind> src winder body unwinder)
 137        (make-dynwind src
 138                      (loop winder mapping)
 139                      (loop body mapping)
 140                      (loop unwinder mapping)))
 141       (($ <dynref> src fluid)
 142        (make-dynref src (loop fluid mapping)))
 143       (($ <conditional> src condition subsequent alternate)
 144        (make-conditional src
 145                          (loop condition mapping)
 146                          (loop subsequent mapping)
 147                          (loop alternate mapping)))
 148       (($ <application> src proc args)
 149        (make-application src (loop proc mapping)
 150                          (map (cut loop <> mapping) args)))
 151       (($ <sequence> src exps)
 152        (make-sequence src (map (cut loop <> mapping) exps))))))
 153
 154 (define-syntax-rule (let/ec k e e* ...)
 155   (let ((tag (make-prompt-tag)))
 156     (call-with-prompt
 157      tag
 158      (lambda ()
 159        (let ((k (lambda args (apply abort-to-prompt tag args))))
 160          e e* ...))
 161      (lambda (_ res) res))))
 162
 163 (define (tree-il-any proc exp)
 164   (let/ec k
 165     (tree-il-fold (lambda (exp res)
 166                     (let ((res (proc exp)))
 167                       (if res (k res) #f)))
 168                   (lambda (exp res)
 169                     (let ((res (proc exp)))
 170                       (if res (k res) #f)))
 171                   (lambda (exp res) #f)
 172                   #f exp)))
 173
 174 (define (code-contains-calls? body proc lookup)
 175   "Return true if BODY contains calls to PROC.  Use LOOKUP to look up
 176 lexical references."
 177   (tree-il-any
 178    (lambda (exp)
 179      (match exp
 180        (($ <application> _
 181            (and ref ($ <lexical-ref> _ _ gensym)) _)
 182         (or (equal? ref proc)
 183             (equal? (lookup gensym) proc)))
 184        (($ <application>
 185            (and proc* ($ <lambda>)))
 186         (equal? proc* proc))
 187        (_ #f)))
 188    body))
 189
 190 (define (vlist-any proc vlist)
 191   (let ((len (vlist-length vlist)))
 192     (let lp ((i 0))
 193       (and (< i len)
 194            (or (proc (vlist-ref vlist i))
 195                (lp (1+ i)))))))
 196
 197 (define* (peval exp #:optional (cenv (current-module)) (env vlist-null))
 198   "Partially evaluate EXP in compilation environment CENV, with
 199 top-level bindings from ENV and return the resulting expression.  Since
 200 it does not handle <fix> and <let-values>, it should be called before
 201 `fix-letrec'."
 202
 203   ;; This is a simple partial evaluator.  It effectively performs
 204   ;; constant folding, copy propagation, dead code elimination, and
 205   ;; inlining, but not across top-level bindings---there should be a way
 206   ;; to allow this (TODO).
 207   ;;
 208   ;; Unlike a full-blown partial evaluator, it does not emit definitions
 209   ;; of specialized versions of lambdas encountered on its way.  Also,
 210   ;; it's very conservative: it bails out if `set!', `prompt', etc. are
 211   ;; met.
 212
 213   (define local-toplevel-env
 214     ;; The top-level environment of the module being compiled.
 215     (match exp
 216       (($ <toplevel-define> _ name)
 217        (vhash-consq name #t env))
 218       (($ <sequence> _ exps)
 219        (fold (lambda (x r)
 220                (match x
 221                  (($ <toplevel-define> _ name)
 222                   (vhash-consq name #t r))
 223                  (_ r)))
 224              env
 225              exps))
 226       (_ env)))
 227
 228   (define (local-toplevel? name)
 229     (vhash-assq name local-toplevel-env))
 230
 231   (define (apply-primitive name args)
 232     ;; todo: further optimize commutative primitives
 233     (catch #t
 234       (lambda ()
 235         (call-with-values
 236             (lambda ()
 237               (apply (module-ref the-scm-module name) args))
 238           (lambda results
 239             (values #t results))))
 240       (lambda _
 241         (values #f '()))))
 242
 243   (define (inline-values exp src names gensyms body)
 244     (let loop ((exp exp))
 245       (match exp
 246         ;; Some expression types are always singly-valued.
 247         ((or ($ <const>)
 248              ($ <void>)
 249              ($ <lambda>)
 250              ($ <lexical-ref>)
 251              ($ <toplevel-ref>)
 252              ($ <module-ref>)
 253              ($ <primitive-ref>)
 254              ($ <dynref>)
 255              ($ <toplevel-set>)         ; FIXME: these set! expressions
 256              ($ <toplevel-define>)      ; could return zero values in
 257              ($ <module-set>))          ; the future
 258          (and (= (length names) 1)
 259               (make-let src names gensyms (list exp) body)))
 260         (($ <application> src
 261                 ($ <primitive-ref> _ (? singly-valued-primitive? name)))
 262          (and (= (length names) 1)
 263               (make-let src names gensyms (list exp) body)))
 264
 265         ;; Statically-known number of values.
 266         (($ <application> src ($ <primitive-ref> _ 'values) vals)
 267          (and (= (length names) (length vals))
 268               (make-let src names gensyms vals body)))
 269
 270         ;; Not going to copy code into both branches.
 271         (($ <conditional>) #f)
 272
 273         ;; Bail on other applications.
 274         (($ <application>) #f)
 275
 276         ;; Propagate to tail positions.
 277         (($ <let> src names gensyms vals body)
 278          (let ((body (loop body)))
 279            (and body
 280                 (make-let src names gensyms vals body))))
 281         (($ <letrec> src in-order? names gensyms vals body)
 282          (let ((body (loop body)))
 283            (and body
 284                 (make-letrec src in-order? names gensyms vals body))))
 285         (($ <fix> src names gensyms vals body)
 286          (let ((body (loop body)))
 287            (and body
 288                 (make-fix src names gensyms vals body))))
 289         (($ <let-values> src exp
 290             ($ <lambda-case> src2 req opt rest kw inits gensyms body #f))
 291          (let ((body (loop body)))
 292            (and body
 293                 (make-let-values src exp
 294                                  (make-lambda-case src2 req opt rest kw
 295                                                    inits gensyms body #f)))))
 296         (($ <dynwind> src winder body unwinder)
 297          (let ((body (loop body)))
 298            (and body
 299                 (make-dynwind src winder body unwinder))))
 300         (($ <dynlet> src fluids vals body)
 301          (let ((body (loop body)))
 302            (and body
 303                 (make-dynlet src fluids vals body))))
 304         (($ <sequence> src exps)
 305          (match exps
 306            ((head ... tail)
 307             (let ((tail (loop tail)))
 308               (and tail
 309                    (make-sequence src (append head (list tail)))))))))))
 310
 311   (define (make-values src values)
 312     (match values
 313       ((single) single)                           ; 1 value
 314       ((_ ...)                                    ; 0, or 2 or more values
 315        (make-application src (make-primitive-ref src 'values)
 316                          values))))
 317
 318   (define (const*? x)
 319     (or (const? x) (lambda? x) (void? x)))
 320
 321   (define (constant-expression? x)
 322     ;; Return true if X is constant---i.e., if it is known to have no
 323     ;; effects, does not allocate storage for a mutable object, and does
 324     ;; not access mutable data (like `car' or toplevel references).
 325     (let loop ((x x))
 326       (match x
 327         (($ <void>) #t)
 328         (($ <const>) #t)
 329         (($ <lambda>) #t)
 330         (($ <lambda-case> _ req opt rest kw inits _ body alternate)
 331          (and (every loop inits) (loop body) (loop alternate)))
 332         (($ <lexical-ref>) #t)
 333         (($ <primitive-ref>) #t)
 334         (($ <conditional> _ condition subsequent alternate)
 335          (and (loop condition) (loop subsequent) (loop alternate)))
 336         (($ <application> _ ($ <primitive-ref> _ name) args)
 337          (and (effect-free-primitive? name)
 338               (not (constructor-primitive? name))
 339               (every loop args)))
 340         (($ <application> _ ($ <lambda> _ _ body) args)
 341          (and (loop body) (every loop args)))
 342         (($ <sequence> _ exps)
 343          (every loop exps))
 344         (($ <let> _ _ _ vals body)
 345          (and (every loop vals) (loop body)))
 346         (($ <letrec> _ _ _ _ vals body)
 347          (and (every loop vals) (loop body)))
 348         (($ <fix> _ _ _ vals body)
 349          (and (every loop vals) (loop body)))
 350         (($ <let-values> _ exp body)
 351          (and (loop exp) (loop body)))
 352         (_ #f))))
 353
 354   (define (mutable? exp)
 355     ;; Return #t if EXP is a mutable object.
 356     ;; todo: add an option to assume pairs are immutable
 357     (or (pair? exp)
 358         (vector? exp)
 359         (struct? exp)
 360         (string? exp)))
 361
 362   (define (make-value-construction src exp)
 363     ;; Return an expression that builds a fresh copy of EXP at run-time,
 364     ;; or #f.
 365     (let loop ((exp exp))
 366       (match exp
 367         ((_ _ ...)                                 ; non-empty proper list
 368          (let ((args (map loop exp)))
 369            (and (every struct? args)
 370                 (make-application src (make-primitive-ref src 'list)
 371                                   args))))
 372         ((h . (? (negate pair?) t))                ; simple pair
 373          (let ((h (loop h))
 374                (t (loop t)))
 375            (and h t
 376                 (make-application src (make-primitive-ref src 'cons)
 377                                   (list h t)))))
 378         ((? vector?)                               ; vector
 379          (let ((args (map loop (vector->list exp))))
 380            (and (every struct? args)
 381                 (make-application src (make-primitive-ref src 'vector)
 382                                   args))))
 383         ((? number?) (make-const src exp))
 384         ((? string?) (make-const src exp))
 385         ((? symbol?) (make-const src exp))
 386         ;((? bytevector?) (make-const src exp))
 387         (_ #f))))
 388
 389   (define (maybe-unconst orig new)
 390     ;; If NEW is a constant, change it to a non-constant if need be.
 391     ;; Expressions that build a mutable object, such as `(list 1 2)',
 392     ;; must not be replaced by a constant; this procedure "undoes" the
 393     ;; change from `(list 1 2)' to `'(1 2)'.
 394     (match new
 395       (($ <const> src (? mutable? value))
 396        (if (equal? new orig)
 397            new
 398            (or (make-value-construction src value) orig)))
 399       (_ new)))
 400
 401   (define (maybe-unlambda orig new env)
 402     ;; If NEW is a named lambda and ORIG is what it looked like before
 403     ;; partial evaluation, then attempt to replace NEW with a lexical
 404     ;; ref, to avoid code duplication.
 405     (match new
 406       (($ <lambda> src (= (cut assq-ref <> 'name) (? symbol? name))
 407           ($ <lambda-case> _ req opt rest kw inits gensyms body))
 408        ;; Look for NEW in the current environment, starting from the
 409        ;; outermost frame.
 410        (or (vlist-any (lambda (x)
 411                         (and (equal? (cdr x) new)
 412                              (make-lexical-ref src name (car x))))
 413                       env)
 414            new))
 415       (($ <lambda> src ()
 416           (and lc ($ <lambda-case>)))
 417        ;; This is an anonymous lambda that we're going to inline.
 418        ;; Inlining creates new variable bindings, so we need to provide
 419        ;; the new code with fresh names.
 420        (make-lambda src '() (alpha-rename lc)))
 421       (_ new)))
 422
 423   (catch 'match-error
 424     (lambda ()
 425       (let loop ((exp   exp)
 426                  (env   vlist-null)  ; static environment
 427                  (calls '())         ; inlined call stack
 428                  (ctx 'value))       ; effect, value, test, or call
 429         (define (lookup var)
 430           (and=> (vhash-assq var env) cdr))
 431
 432         (match exp
 433           (($ <const>)
 434            (case ctx
 435              ((effect) (make-void #f))
 436              (else exp)))
 437           (($ <void>)
 438            (case ctx
 439              ((test) (make-const #f #t))
 440              (else exp)))
 441           (($ <lexical-ref> _ _ gensym)
 442            ;; Propagate only pure expressions that are not assigned to.
 443            (case ctx
 444              ((effect) (make-void #f))
 445              (else
 446               (let ((val (lookup gensym)))
 447                 (if (constant-expression? val)
 448                     (case ctx
 449                       ;; fixme: cache this?  it is a divergence from
 450                       ;; O(n).
 451                       ((test) (loop val env calls 'test))
 452                       (else val))
 453                     exp)))))
 454           ;; Lexical set! causes a bailout.
 455           (($ <let> src names gensyms vals body)
 456            (let* ((vals* (map (cut loop <> env calls 'value) vals))
 457                   (vals  (map maybe-unconst vals vals*))
 458                   (body* (loop body
 459                                (fold vhash-consq env gensyms vals)
 460                                calls
 461                                ctx))
 462                   (body  (maybe-unconst body body*)))
 463              (if (const? body*)
 464                  body
 465                  ;; Constants have already been propagated, so there is
 466                  ;; no need to bind them to lexicals.
 467                  (let*-values (((stripped) (remove (compose const? car)
 468                                                    (zip vals gensyms names)))
 469                                ((vals gensyms names) (unzip3 stripped)))
 470                    (if (null? stripped)
 471                        body
 472                        (make-let src names gensyms vals body))))))
 473           (($ <letrec> src in-order? names gensyms vals body)
 474            ;; Things could be done more precisely when IN-ORDER? but
 475            ;; it's OK not to do it---at worst we lost an optimization
 476            ;; opportunity.
 477            (let* ((vals* (map (cut loop <> env calls 'value) vals))
 478                   (vals  (map maybe-unconst vals vals*))
 479                   (body* (loop body
 480                                (fold vhash-consq env gensyms vals)
 481                                calls
 482                                ctx))
 483                   (body  (maybe-unconst body body*)))
 484              (if (const? body*)
 485                  body
 486                  (make-letrec src in-order? names gensyms vals body))))
 487           (($ <fix> src names gensyms vals body)
 488            (let* ((vals (map (cut loop <> env calls 'value) vals))
 489                   (body* (loop body
 490                                (fold vhash-consq env gensyms vals)
 491                                calls
 492                                ctx))
 493                   (body  (maybe-unconst body body*)))
 494              (if (const? body*)
 495                  body
 496                  (make-fix src names gensyms vals body))))
 497           (($ <let-values> lv-src producer consumer)
 498            ;; Peval the producer, then try to inline the consumer into
 499            ;; the producer.  If that succeeds, peval again.  Otherwise
 500            ;; reconstruct the let-values, pevaling the consumer.
 501            (let ((producer (maybe-unconst producer
 502                                           (loop producer env calls 'value))))
 503              (or (match consumer
 504                    (($ <lambda-case> src req #f #f #f () gensyms body #f)
 505                     (cond
 506                      ((inline-values producer src req gensyms body)
 507                       => (cut loop <> env calls ctx))
 508                      (else #f)))
 509                    (_ #f))
 510                  (make-let-values lv-src producer
 511                                   (loop consumer env calls ctx)))))
 512           (($ <dynwind> src winder body unwinder)
 513            (make-dynwind src (loop winder env calls 'value)
 514                          (loop body env calls ctx)
 515                          (loop unwinder env calls 'value)))
 516           (($ <dynlet> src fluids vals body)
 517            (make-dynlet src
 518                         (map maybe-unconst fluids
 519                              (map (cut loop <> env calls 'value) fluids))
 520                         (map maybe-unconst vals
 521                              (map (cut loop <> env calls 'value) vals))
 522                         (maybe-unconst body (loop body env calls ctx))))
 523           (($ <dynref> src fluid)
 524            (make-dynref src
 525                         (maybe-unconst fluid (loop fluid env calls 'value))))
 526           (($ <toplevel-ref> src (? effect-free-primitive? name))
 527            (if (local-toplevel? name)
 528                exp
 529                (resolve-primitives! exp cenv)))
 530           (($ <toplevel-ref>)
 531            ;; todo: open private local bindings.
 532            exp)
 533           (($ <module-ref>)
 534            exp)
 535           (($ <module-set> src mod name public? exp)
 536            (make-module-set src mod name public?
 537                             (maybe-unconst exp (loop exp env '() 'value))))
 538           (($ <toplevel-define> src name exp)
 539            (make-toplevel-define src name
 540                                  (maybe-unconst exp (loop exp env '() 'value))))
 541           (($ <toplevel-set> src name exp)
 542            (make-toplevel-set src name
 543                               (maybe-unconst exp (loop exp env '() 'value))))
 544           (($ <primitive-ref>)
 545            (case ctx
 546              ((effect) (make-void #f))
 547              ((test) (make-const #f #t))
 548              (else exp)))
 549           (($ <conditional> src condition subsequent alternate)
 550            (let ((condition (loop condition env calls 'test)))
 551              (if (const? condition)
 552                  (if (const-exp condition)
 553                      (loop subsequent env calls ctx)
 554                      (loop alternate env calls ctx))
 555                  (make-conditional src condition
 556                                    (loop subsequent env calls ctx)
 557                                    (loop alternate env calls ctx)))))
 558           (($ <application> src
 559               ($ <primitive-ref> _ '@call-with-values)
 560               (producer
 561                ($ <lambda> _ _
 562                   (and consumer
 563                        ;; No optional or kwargs.
 564                        ($ <lambda-case>
 565                           _ req #f rest #f () gensyms body #f)))))
 566            (loop (make-let-values src (make-application src producer '())
 567                                   consumer)
 568                  env calls ctx))
 569
 570           (($ <application> src orig-proc orig-args)
 571            ;; todo: augment the global env with specialized functions
 572            (let* ((proc  (loop orig-proc env calls 'call))
 573                   (proc* (maybe-unlambda orig-proc proc env))
 574                   (args  (map (cut loop <> env calls 'value) orig-args))
 575                   (args* (map (cut maybe-unlambda <> <> env)
 576                               orig-args
 577                               (map maybe-unconst orig-args args)))
 578                   (app   (make-application src proc* args*)))
 579              ;; If at least one of ARGS is static (to avoid infinite
 580              ;; inlining) and this call hasn't already been expanded
 581              ;; before (to avoid infinite recursion), then expand it
 582              ;; (todo: emit an infinite recursion warning.)
 583              (if (and (or (null? args) (any const*? args))
 584                       (not (member (cons proc args) calls)))
 585                  (match proc
 586                    (($ <primitive-ref> _ (? effect-free-primitive? name))
 587                     (if (every const? args)  ; only simple constants
 588                         (let-values (((success? values)
 589                                       (apply-primitive name
 590                                                        (map const-exp args))))
 591                           (if success?
 592                               (case ctx
 593                                 ((effect) (make-void #f))
 594                                 ((test)
 595                                  ;; Values truncation: only take the first
 596                                  ;; value.
 597                                  (if (pair? values)
 598                                      (make-const #f (car values))
 599                                      (make-values src '())))
 600                                 (else
 601                                  (make-values src (map (cut make-const src <>)
 602                                                        values))))
 603                               app))
 604                         app))
 605                    (($ <primitive-ref>)
 606                     ;; An effectful primitive.
 607                     app)
 608                    (($ <lambda> _ _
 609                        ($ <lambda-case> _ req opt #f #f inits gensyms body))
 610                     ;; Simple case: no rest, no keyword arguments.
 611                     ;; todo: handle the more complex cases
 612                     (let ((nargs  (length args))
 613                           (nreq   (length req))
 614                           (nopt   (if opt (length opt) 0)))
 615                       (if (and (>= nargs nreq) (<= nargs (+ nreq nopt))
 616                                (every constant-expression? args))
 617                           (let* ((params
 618                                   (append args
 619                                           (drop inits
 620                                                 (max 0
 621                                                      (- nargs
 622                                                         (+ nreq nopt))))))
 623                                  (body
 624                                   (loop body
 625                                         (fold vhash-consq env gensyms params)
 626                                         (cons (cons proc args) calls)
 627                                         ctx)))
 628                             ;; If the residual code contains recursive
 629                             ;; calls, give up inlining.
 630                             (if (code-contains-calls? body proc lookup)
 631                                 app
 632                                 body))
 633                           app)))
 634                    (($ <lambda>)
 635                     app)
 636                    (($ <toplevel-ref>)
 637                     app)
 638
 639                    ;; In practice, this is the clause that stops peval:
 640                    ;; module-ref applications (produced by macros,
 641                    ;; typically) don't match, and so this throws,
 642                    ;; aborting peval for an entire expression.
 643                    )
 644
 645                  app)))
 646           (($ <lambda> src meta body)
 647            (case ctx
 648              ((effect) (make-void #f))
 649              ((test) (make-const #f #t))
 650              (else
 651               (make-lambda src meta (loop body env calls 'value)))))
 652           (($ <lambda-case> src req opt rest kw inits gensyms body alt)
 653            (make-lambda-case src req opt rest kw
 654                              (map maybe-unconst inits
 655                                   (map (cut loop <> env calls 'value) inits))
 656                              gensyms
 657                              (maybe-unconst body (loop body env calls ctx))
 658                              alt))
 659           (($ <sequence> src exps)
 660            (let lp ((exps exps) (effects '()))
 661              (match exps
 662                ((last)
 663                 (if (null? effects)
 664                     (loop last env calls ctx)
 665                     (make-sequence src (append (reverse effects)
 666                                                (list
 667                                                 (maybe-unconst last
 668                                                                (loop last env calls ctx)))))))
 669                ((head . rest)
 670                 (let ((head (loop head env calls 'effect)))
 671                   (cond
 672                    ((sequence? head)
 673                     (lp (append (sequence-exps head) rest) effects))
 674                    ((void? head)
 675                     (lp rest effects))
 676                    (else
 677                     (lp rest (cons head effects))))))))))))
 678     (lambda _
 679       ;; We encountered something we don't handle, like `<lexical-set>',
 680       ;; <abort>, or some other effecting construct, so bail out.
 681       exp)))