test-suite/tests/peval.test

   1 ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
   2 ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
   3 ;;;;
   4 ;;;;    Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
   5 ;;;;
   6 ;;;; This library is free software; you can redistribute it and/or
   7 ;;;; modify it under the terms of the GNU Lesser General Public
   8 ;;;; License as published by the Free Software Foundation; either
   9 ;;;; version 3 of the License, or (at your option) any later version.
  10 ;;;;
  11 ;;;; This library is distributed in the hope that it will be useful,
  12 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;;; Lesser General Public License for more details.
  15 ;;;;
  16 ;;;; You should have received a copy of the GNU Lesser General Public
  17 ;;;; License along with this library; if not, write to the Free Software
  18 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 (define-module (test-suite tree-il)
  21   #:use-module (test-suite lib)
  22   #:use-module (system base compile)
  23   #:use-module (system base pmatch)
  24   #:use-module (system base message)
  25   #:use-module (language tree-il)
  26   #:use-module (language tree-il primitives)
  27   #:use-module (language glil)
  28   #:use-module (srfi srfi-13))
  29
  30 (define peval
  31   ;; The partial evaluator.
  32   (@@ (language tree-il optimize) peval))
  33
  34 (define-syntax pass-if-peval
  35   (syntax-rules (resolve-primitives)
  36     ((_ in pat)
  37      (pass-if-peval in pat
  38                     (expand-primitives!
  39                      (resolve-primitives!
  40                       (compile 'in #:from 'scheme #:to 'tree-il)
  41                       (current-module)))))
  42     ((_ in pat code)
  43      (pass-if 'in
  44        (let ((evaled (unparse-tree-il (peval code))))
  45          (pmatch evaled
  46            (pat #t)
  47            (_   (pk 'peval-mismatch)
  48                 ((@ (ice-9 pretty-print) pretty-print)
  49                     'in)
  50                 (newline)
  51                 ((@ (ice-9 pretty-print) pretty-print)
  52                     evaled)
  53                 (newline)
  54                 ((@ (ice-9 pretty-print) pretty-print)
  55                     'pat)
  56                 (newline)
  57                 #f)))))))
  58
  59 \f
  60 (with-test-prefix "partial evaluation"
  61
  62   (pass-if-peval
  63     ;; First order, primitive.
  64     (let ((x 1) (y 2)) (+ x y))
  65     (const 3))
  66
  67   (pass-if-peval
  68     ;; First order, thunk.
  69     (let ((x 1) (y 2))
  70       (let ((f (lambda () (+ x y))))
  71         (f)))
  72     (const 3))
  73
  74   (pass-if-peval
  75     ;; First order, let-values (requires primitive expansion for
  76     ;; `call-with-values'.)
  77     (let ((x 0))
  78       (call-with-values
  79           (lambda () (if (zero? x) (values 1 2) (values 3 4)))
  80         (lambda (a b)
  81           (+ a b))))
  82     (const 3))
  83
  84   (pass-if-peval
  85     ;; First order, multiple values.
  86     (let ((x 1) (y 2))
  87       (values x y))
  88     (primcall values (const 1) (const 2)))
  89
  90   (pass-if-peval
  91     ;; First order, multiple values truncated.
  92     (let ((x (values 1 'a)) (y 2))
  93       (values x y))
  94     (primcall values (const 1) (const 2)))
  95
  96   (pass-if-peval
  97     ;; First order, multiple values truncated.
  98     (or (values 1 2) 3)
  99     (const 1))
 100
 101   (pass-if-peval
 102     ;; First order, coalesced, mutability preserved.
 103     (cons 0 (cons 1 (cons 2 (list 3 4 5))))
 104     (primcall list
 105               (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
 106
 107   (pass-if-peval
 108     ;; First order, coalesced, immutability preserved.
 109     (cons 0 (cons 1 (cons 2 '(3 4 5))))
 110     (primcall cons (const 0)
 111               (primcall cons (const 1)
 112                         (primcall cons (const 2)
 113                                   (const (3 4 5))))))
 114
 115   ;; These two tests doesn't work any more because we changed the way we
 116   ;; deal with constants -- now the algorithm will see a construction as
 117   ;; being bound to the lexical, so it won't propagate it.  It can't
 118   ;; even propagate it in the case that it is only referenced once,
 119   ;; because:
 120   ;;
 121   ;;   (let ((x (cons 1 2))) (lambda () x))
 122   ;;
 123   ;; is not the same as
 124   ;;
 125   ;;   (lambda () (cons 1 2))
 126   ;;
 127   ;; Perhaps if we determined that not only was it only referenced once,
 128   ;; it was not closed over by a lambda, then we could propagate it, and
 129   ;; re-enable these two tests.
 130   ;;
 131   #;
 132   (pass-if-peval
 133    ;; First order, mutability preserved.
 134    (let loop ((i 3) (r '()))
 135      (if (zero? i)
 136          r
 137          (loop (1- i) (cons (cons i i) r))))
 138    (primcall list
 139              (primcall cons (const 1) (const 1))
 140              (primcall cons (const 2) (const 2))
 141              (primcall cons (const 3) (const 3))))
 142   ;;
 143   ;; See above.
 144   #;
 145   (pass-if-peval
 146    ;; First order, evaluated.
 147    (let loop ((i 7)
 148               (r '()))
 149      (if (<= i 0)
 150          (car r)
 151          (loop (1- i) (cons i r))))
 152    (const 1))
 153
 154   ;; Instead here are tests for what happens for the above cases: they
 155   ;; unroll but they don't fold.
 156   (pass-if-peval
 157    (let loop ((i 3) (r '()))
 158      (if (zero? i)
 159          r
 160          (loop (1- i) (cons (cons i i) r))))
 161    (let (r) (_)
 162         ((primcall list
 163                    (primcall cons (const 3) (const 3))))
 164         (let (r) (_)
 165              ((primcall cons
 166                         (primcall cons (const 2) (const 2))
 167                         (lexical r _)))
 168              (primcall cons
 169                        (primcall cons (const 1) (const 1))
 170                        (lexical r _)))))
 171
 172   ;; See above.
 173   (pass-if-peval
 174    (let loop ((i 4)
 175               (r '()))
 176      (if (<= i 0)
 177          (car r)
 178          (loop (1- i) (cons i r))))
 179    (let (r) (_)
 180         ((primcall list (const 4)))
 181         (let (r) (_)
 182              ((primcall cons
 183                         (const 3)
 184                         (lexical r _)))
 185              (let (r) (_)
 186                   ((primcall cons
 187                              (const 2)
 188                              (lexical r _)))
 189                   (let (r) (_)
 190                        ((primcall cons
 191                                   (const 1)
 192                                   (lexical r _)))
 193                        (primcall car
 194                                  (lexical r _)))))))
 195
 196    ;; Static sums.
 197   (pass-if-peval
 198    (let loop ((l '(1 2 3 4)) (sum 0))
 199      (if (null? l)
 200          sum
 201          (loop (cdr l) (+ sum (car l)))))
 202    (const 10))
 203
 204   (pass-if-peval
 205    (let ((string->chars
 206           (lambda (s)
 207             (define (char-at n)
 208               (string-ref s n))
 209             (define (len)
 210               (string-length s))
 211             (let loop ((i 0))
 212               (if (< i (len))
 213                   (cons (char-at i)
 214                         (loop (1+ i)))
 215                   '())))))
 216      (string->chars "yo"))
 217    (primcall list (const #\y) (const #\o)))
 218
 219   (pass-if-peval
 220     ;; Primitives in module-refs are resolved (the expansion of `pmatch'
 221     ;; below leads to calls to (@@ (system base pmatch) car) and
 222     ;; similar, which is what we want to be inlined.)
 223     (begin
 224       (use-modules (system base pmatch))
 225       (pmatch '(a b c d)
 226         ((a b . _)
 227          #t)))
 228     (seq (call . _)
 229          (const #t)))
 230
 231   (pass-if-peval
 232    ;; Mutability preserved.
 233    ((lambda (x y z) (list x y z)) 1 2 3)
 234    (primcall list (const 1) (const 2) (const 3)))
 235
 236   (pass-if-peval
 237    ;; Don't propagate effect-free expressions that operate on mutable
 238    ;; objects.
 239    (let* ((x (list 1))
 240           (y (car x)))
 241      (set-car! x 0)
 242      y)
 243    (let (x) (_) ((primcall list (const 1)))
 244         (let (y) (_) ((primcall car (lexical x _)))
 245              (seq
 246                (primcall set-car! (lexical x _) (const 0))
 247                (lexical y _)))))
 248
 249   (pass-if-peval
 250    ;; Don't propagate effect-free expressions that operate on objects we
 251    ;; don't know about.
 252    (let ((y (car x)))
 253      (set-car! x 0)
 254      y)
 255    (let (y) (_) ((primcall car (toplevel x)))
 256         (seq
 257           (primcall set-car! (toplevel x) (const 0))
 258           (lexical y _))))
 259
 260   (pass-if-peval
 261    ;; Infinite recursion
 262    ((lambda (x) (x x)) (lambda (x) (x x)))
 263    (let (x) (_)
 264         ((lambda _
 265            (lambda-case
 266             (((x) _ _ _ _ _)
 267              (call (lexical x _) (lexical x _))))))
 268         (call (lexical x _) (lexical x _))))
 269
 270   (pass-if-peval
 271     ;; First order, aliased primitive.
 272     (let* ((x *) (y (x 1 2))) y)
 273     (const 2))
 274
 275   (pass-if-peval
 276     ;; First order, shadowed primitive.
 277     (begin
 278       (define (+ x y) (pk x y))
 279       (+ 1 2))
 280     (seq
 281       (define +
 282         (lambda (_)
 283           (lambda-case
 284            (((x y) #f #f #f () (_ _))
 285             (call (toplevel pk) (lexical x _) (lexical y _))))))
 286       (call (toplevel +) (const 1) (const 2))))
 287
 288   (pass-if-peval
 289     ;; First-order, effects preserved.
 290     (let ((x 2))
 291       (do-something!)
 292       x)
 293     (seq
 294       (call (toplevel do-something!))
 295       (const 2)))
 296
 297   (pass-if-peval
 298     ;; First order, residual bindings removed.
 299     (let ((x 2) (y 3))
 300       (* (+ x y) z))
 301     (primcall * (const 5) (toplevel z)))
 302
 303   (pass-if-peval
 304     ;; First order, with lambda.
 305     (define (foo x)
 306       (define (bar z) (* z z))
 307       (+ x (bar 3)))
 308     (define foo
 309       (lambda (_)
 310         (lambda-case
 311          (((x) #f #f #f () (_))
 312           (primcall + (lexical x _) (const 9)))))))
 313
 314   (pass-if-peval
 315     ;; First order, with lambda inlined & specialized twice.
 316     (let ((f (lambda (x y)
 317                (+ (* x top) y)))
 318           (x 2)
 319           (y 3))
 320       (+ (* x (f x y))
 321          (f something x)))
 322     (primcall +
 323               (primcall *
 324                         (const 2)
 325                         (primcall +     ; (f 2 3)
 326                                   (primcall *
 327                                             (const 2)
 328                                             (toplevel top))
 329                                   (const 3)))
 330               (let (x) (_) ((toplevel something)) ; (f something 2)
 331                    ;; `something' is not const, so preserve order of
 332                    ;; effects with a lexical binding.
 333                    (primcall +
 334                              (primcall *
 335                                        (lexical x _)
 336                                        (toplevel top))
 337                              (const 2)))))
 338
 339   (pass-if-peval
 340    ;; First order, with lambda inlined & specialized 3 times.
 341    (let ((f (lambda (x y) (if (> x 0) y x))))
 342      (+ (f -1 0)
 343         (f 1 0)
 344         (f -1 y)
 345         (f 2 y)
 346         (f z y)))
 347    (primcall
 348     +
 349     (const -1)                          ; (f -1 0)
 350     (primcall
 351      +
 352      (const 0)                          ; (f 1 0)
 353      (primcall
 354       +
 355       (seq (toplevel y) (const -1))     ; (f -1 y)
 356       (primcall
 357        +
 358        (toplevel y)                                 ; (f 2 y)
 359        (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
 360             (if (primcall > (lexical x _) (const 0))
 361                 (lexical y _)
 362                 (lexical x _))))))))
 363
 364   (pass-if-peval
 365     ;; First order, conditional.
 366     (let ((y 2))
 367       (lambda (x)
 368         (if (> y 0)
 369             (display x)
 370             'never-reached)))
 371     (lambda ()
 372       (lambda-case
 373        (((x) #f #f #f () (_))
 374         (call (toplevel display) (lexical x _))))))
 375
 376   (pass-if-peval
 377     ;; First order, recursive procedure.
 378     (letrec ((fibo (lambda (n)
 379                      (if (<= n 1)
 380                          n
 381                          (+ (fibo (- n 1))
 382                             (fibo (- n 2)))))))
 383       (fibo 4))
 384     (const 3))
 385
 386   (pass-if-peval
 387    ;; Don't propagate toplevel references, as intervening expressions
 388    ;; could alter their bindings.
 389    (let ((x top))
 390      (foo)
 391      x)
 392    (let (x) (_) ((toplevel top))
 393         (seq
 394           (call (toplevel foo))
 395           (lexical x _))))
 396
 397   (pass-if-peval
 398     ;; Higher order.
 399     ((lambda (f x)
 400        (f (* (car x) (cadr x))))
 401      (lambda (x)
 402        (+ x 1))
 403      '(2 3))
 404     (const 7))
 405
 406   (pass-if-peval
 407     ;; Higher order with optional argument (default value).
 408     ((lambda* (f x #:optional (y 0))
 409        (+ y (f (* (car x) (cadr x)))))
 410      (lambda (x)
 411        (+ x 1))
 412      '(2 3))
 413     (const 7))
 414
 415   (pass-if-peval
 416     ;; Higher order with optional argument (caller-supplied value).
 417     ((lambda* (f x #:optional (y 0))
 418        (+ y (f (* (car x) (cadr x)))))
 419      (lambda (x)
 420        (+ x 1))
 421      '(2 3)
 422      35)
 423     (const 42))
 424
 425   (pass-if-peval
 426     ;; Higher order with optional argument (side-effecting default
 427     ;; value).
 428     ((lambda* (f x #:optional (y (foo)))
 429        (+ y (f (* (car x) (cadr x)))))
 430      (lambda (x)
 431        (+ x 1))
 432      '(2 3))
 433     (let (y) (_) ((call (toplevel foo)))
 434          (primcall + (lexical y _) (const 7))))
 435
 436   (pass-if-peval
 437     ;; Higher order with optional argument (caller-supplied value).
 438     ((lambda* (f x #:optional (y (foo)))
 439        (+ y (f (* (car x) (cadr x)))))
 440      (lambda (x)
 441        (+ x 1))
 442      '(2 3)
 443      35)
 444     (const 42))
 445
 446   (pass-if-peval
 447     ;; Higher order.
 448     ((lambda (f) (f x)) (lambda (x) x))
 449     (toplevel x))
 450
 451   (pass-if-peval
 452     ;; Bug reported at
 453     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
 454     (let ((fold (lambda (f g) (f (g top)))))
 455       (fold 1+ (lambda (x) x)))
 456     (primcall 1+ (toplevel top)))
 457
 458   (pass-if-peval
 459     ;; Procedure not inlined when residual code contains recursive calls.
 460     ;; <http://debbugs.gnu.org/9542>
 461     (letrec ((fold (lambda (f x3 b null? car cdr)
 462                      (if (null? x3)
 463                          b
 464                          (f (car x3) (fold f (cdr x3) b null? car cdr))))))
 465       (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
 466     (letrec (fold) (_) (_)
 467             (call (lexical fold _)
 468                    (primitive *)
 469                    (toplevel x)
 470                    (const 1)
 471                    (primitive zero?)
 472                    (lambda ()
 473                      (lambda-case
 474                       (((x1) #f #f #f () (_))
 475                        (lexical x1 _))))
 476                    (lambda ()
 477                      (lambda-case
 478                       (((x2) #f #f #f () (_))
 479                        (primcall 1- (lexical x2 _))))))))
 480
 481   (pass-if "inlined lambdas are alpha-renamed"
 482     ;; In this example, `make-adder' is inlined more than once; thus,
 483     ;; they should use different gensyms for their arguments, because
 484     ;; the various optimization passes assume uniquely-named variables.
 485     ;;
 486     ;; Bug reported at
 487     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
 488     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
 489     (pmatch (unparse-tree-il
 490              (peval (expand-primitives!
 491                      (resolve-primitives!
 492                       (compile
 493                        '(let ((make-adder
 494                                (lambda (x) (lambda (y) (+ x y)))))
 495                           (cons (make-adder 1) (make-adder 2)))
 496                        #:to 'tree-il)
 497                       (current-module)))))
 498       ((primcall cons
 499                  (lambda ()
 500                    (lambda-case
 501                     (((y) #f #f #f () (,gensym1))
 502                      (primcall +
 503                                (const 1)
 504                                (lexical y ,ref1)))))
 505                  (lambda ()
 506                    (lambda-case
 507                     (((y) #f #f #f () (,gensym2))
 508                      (primcall +
 509                                (const 2)
 510                                (lexical y ,ref2))))))
 511        (and (eq? gensym1 ref1)
 512             (eq? gensym2 ref2)
 513             (not (eq? gensym1 gensym2))))
 514       (_ #f)))
 515
 516   (pass-if-peval
 517    ;; Unused letrec bindings are pruned.
 518    (letrec ((a (lambda () (b)))
 519             (b (lambda () (a)))
 520             (c (lambda (x) x)))
 521      (c 10))
 522    (const 10))
 523
 524   (pass-if-peval
 525    ;; Unused letrec bindings are pruned.
 526    (letrec ((a (foo!))
 527             (b (lambda () (a)))
 528             (c (lambda (x) x)))
 529      (c 10))
 530    (seq (call (toplevel foo!))
 531         (const 10)))
 532
 533   (pass-if-peval
 534     ;; Higher order, mutually recursive procedures.
 535     (letrec ((even? (lambda (x)
 536                       (or (= 0 x)
 537                           (odd? (- x 1)))))
 538              (odd?  (lambda (x)
 539                       (not (even? x)))))
 540       (and (even? 4) (odd? 7)))
 541     (const #t))
 542
 543   (pass-if-peval
 544     ;; Memv with constants.
 545     (memv 1 '(3 2 1))
 546     (const '(1)))
 547
 548   (pass-if-peval
 549     ;; Memv with non-constant list.  It could fold but doesn't
 550     ;; currently.
 551     (memv 1 (list 3 2 1))
 552     (primcall memv
 553               (const 1)
 554               (primcall list (const 3) (const 2) (const 1))))
 555
 556   (pass-if-peval
 557     ;; Memv with non-constant key, constant list, test context
 558     (case foo
 559       ((3 2 1) 'a)
 560       (else 'b))
 561     (let (key) (_) ((toplevel foo))
 562          (if (if (primcall eqv? (lexical key _) (const 3))
 563                  (const #t)
 564                  (if (primcall eqv? (lexical key _) (const 2))
 565                      (const #t)
 566                      (primcall eqv? (lexical key _) (const 1))))
 567              (const a)
 568              (const b))))
 569
 570   (pass-if-peval
 571     ;; Memv with non-constant key, empty list, test context.
 572     (case foo
 573       (() 'a)
 574       (else 'b))
 575     (seq (toplevel foo) (const 'b)))
 576
 577   ;;
 578   ;; Below are cases where constant propagation should bail out.
 579   ;;
 580
 581   (pass-if-peval
 582     ;; Non-constant lexical is not propagated.
 583     (let ((v (make-vector 6 #f)))
 584       (lambda (n)
 585         (vector-set! v n n)))
 586     (let (v) (_)
 587          ((call (toplevel make-vector) (const 6) (const #f)))
 588          (lambda ()
 589            (lambda-case
 590             (((n) #f #f #f () (_))
 591              (primcall vector-set!
 592                        (lexical v _) (lexical n _) (lexical n _)))))))
 593
 594   (pass-if-peval
 595     ;; Mutable lexical is not propagated.
 596     (let ((v (vector 1 2 3)))
 597       (lambda ()
 598         v))
 599     (let (v) (_)
 600          ((primcall vector (const 1) (const 2) (const 3)))
 601          (lambda ()
 602            (lambda-case
 603             ((() #f #f #f () ())
 604              (lexical v _))))))
 605
 606   (pass-if-peval
 607     ;; Lexical that is not provably pure is not inlined nor propagated.
 608     (let* ((x (if (> p q) (frob!) (display 'chbouib)))
 609            (y (* x 2)))
 610       (+ x x y))
 611     (let (x) (_) ((if (primcall > (toplevel p) (toplevel q))
 612                       (call (toplevel frob!))
 613                       (call (toplevel display) (const chbouib))))
 614          (let (y) (_) ((primcall * (lexical x _) (const 2)))
 615               (primcall +
 616                         (lexical x _)
 617                         (primcall + (lexical x _) (lexical y _))))))
 618
 619   (pass-if-peval
 620     ;; Non-constant arguments not propagated to lambdas.
 621     ((lambda (x y z)
 622        (vector-set! x 0 0)
 623        (set-car! y 0)
 624        (set-cdr! z '()))
 625      (vector 1 2 3)
 626      (make-list 10)
 627      (list 1 2 3))
 628     (let (x y z) (_ _ _)
 629          ((primcall vector (const 1) (const 2) (const 3))
 630           (call (toplevel make-list) (const 10))
 631           (primcall list (const 1) (const 2) (const 3)))
 632          (seq
 633            (primcall vector-set!
 634                      (lexical x _) (const 0) (const 0))
 635            (seq (primcall set-car!
 636                           (lexical y _) (const 0))
 637                 (primcall set-cdr!
 638                           (lexical z _) (const ()))))))
 639
 640   (pass-if-peval
 641    (let ((foo top-foo) (bar top-bar))
 642      (let* ((g (lambda (x y) (+ x y)))
 643             (f (lambda (g x) (g x x))))
 644        (+ (f g foo) (f g bar))))
 645    (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
 646         (primcall +
 647                   (primcall + (lexical foo _) (lexical foo _))
 648                   (primcall + (lexical bar _) (lexical bar _)))))
 649
 650   (pass-if-peval
 651     ;; Fresh objects are not turned into constants, nor are constants
 652     ;; turned into fresh objects.
 653     (let* ((c '(2 3))
 654            (x (cons 1 c))
 655            (y (cons 0 x)))
 656       y)
 657     (let (x) (_) ((primcall cons (const 1) (const (2 3))))
 658          (primcall cons (const 0) (lexical x _))))
 659
 660   (pass-if-peval
 661     ;; Bindings mutated.
 662     (let ((x 2))
 663       (set! x 3)
 664       x)
 665     (let (x) (_) ((const 2))
 666          (seq
 667            (set! (lexical x _) (const 3))
 668            (lexical x _))))
 669
 670   (pass-if-peval
 671     ;; Bindings mutated.
 672     (letrec ((x 0)
 673              (f (lambda ()
 674                   (set! x (+ 1 x))
 675                   x)))
 676       (frob f) ; may mutate `x'
 677       x)
 678     (letrec (x) (_) ((const 0))
 679             (seq
 680               (call (toplevel frob) (lambda _ _))
 681               (lexical x _))))
 682
 683   (pass-if-peval
 684     ;; Bindings mutated.
 685     (letrec ((f (lambda (x)
 686                   (set! f (lambda (_) x))
 687                   x)))
 688       (f 2))
 689     (letrec _ . _))
 690
 691   (pass-if-peval
 692     ;; Bindings possibly mutated.
 693     (let ((x (make-foo)))
 694       (frob! x) ; may mutate `x'
 695       x)
 696     (let (x) (_) ((call (toplevel make-foo)))
 697          (seq
 698            (call (toplevel frob!) (lexical x _))
 699            (lexical x _))))
 700
 701   (pass-if-peval
 702     ;; Inlining stops at recursive calls with dynamic arguments.
 703     (let loop ((x x))
 704       (if (< x 0) x (loop (1- x))))
 705     (letrec (loop) (_) ((lambda (_)
 706                           (lambda-case
 707                            (((x) #f #f #f () (_))
 708                             (if _ _
 709                                 (call (lexical loop _)
 710                                        (primcall 1-
 711                                                  (lexical x _))))))))
 712             (call (lexical loop _) (toplevel x))))
 713
 714   (pass-if-peval
 715     ;; Recursion on the 2nd argument is fully evaluated.
 716     (let ((x (top)))
 717       (let loop ((x x) (y 10))
 718         (if (> y 0)
 719             (loop x (1- y))
 720             (foo x y))))
 721     (let (x) (_) ((call (toplevel top)))
 722          (call (toplevel foo) (lexical x _) (const 0))))
 723
 724   (pass-if-peval
 725     ;; Inlining aborted when residual code contains recursive calls.
 726     ;;
 727     ;; <http://debbugs.gnu.org/9542>
 728     (let loop ((x x) (y 0))
 729       (if (> y 0)
 730           (loop (1- x) (1- y))
 731           (if (< x 0)
 732               x
 733               (loop (1+ x) (1+ y)))))
 734     (letrec (loop) (_) ((lambda (_)
 735                           (lambda-case
 736                            (((x y) #f #f #f () (_ _))
 737                             (if (primcall >
 738                                           (lexical y _) (const 0))
 739                                 _ _)))))
 740             (call (lexical loop _) (toplevel x) (const 0))))
 741
 742   (pass-if-peval
 743     ;; Infinite recursion: `peval' gives up and leaves it as is.
 744     (letrec ((f (lambda (x) (g (1- x))))
 745              (g (lambda (x) (h (1+ x))))
 746              (h (lambda (x) (f x))))
 747       (f 0))
 748     (letrec _ . _))
 749
 750   (pass-if-peval
 751     ;; Infinite recursion: all the arguments to `loop' are static, but
 752     ;; unrolling it would lead `peval' to enter an infinite loop.
 753     (let loop ((x 0))
 754       (and (< x top)
 755            (loop (1+ x))))
 756     (letrec (loop) (_) ((lambda . _))
 757             (call (lexical loop _) (const 0))))
 758
 759   (pass-if-peval
 760     ;; This test checks that the `start' binding is indeed residualized.
 761     ;; See the `referenced?' procedure in peval's `prune-bindings'.
 762     (let ((pos 0))
 763       (let ((here (let ((start pos)) (lambda () start))))
 764         (set! pos 1) ;; Cause references to `pos' to residualize.
 765         (here)))
 766     (let (pos) (_) ((const 0))
 767          (let (here) (_) (_)
 768               (seq
 769                (set! (lexical pos _) (const 1))
 770                (call (lexical here _))))))
 771
 772   (pass-if-peval
 773    ;; FIXME: should this one residualize the binding?
 774    (letrec ((a a))
 775      1)
 776    (const 1))
 777
 778   (pass-if-peval
 779    ;; This is a fun one for peval to handle.
 780    (letrec ((a a))
 781      a)
 782    (letrec (a) (_) ((lexical a _))
 783            (lexical a _)))
 784
 785   (pass-if-peval
 786    ;; Another interesting recursive case.
 787    (letrec ((a b) (b a))
 788      a)
 789    (letrec (a) (_) ((lexical a _))
 790            (lexical a _)))
 791
 792   (pass-if-peval
 793    ;; Another pruning case, that `a' is residualized.
 794    (letrec ((a (lambda () (a)))
 795             (b (lambda () (a)))
 796             (c (lambda (x) x)))
 797      (let ((d (foo b)))
 798        (c d)))
 799
 800    ;; "b c a" is the current order that we get with unordered letrec,
 801    ;; but it's not important to this test, so if it changes, just adapt
 802    ;; the test.
 803    (letrec (b c a) (_ _ _)
 804      ((lambda _
 805         (lambda-case
 806          ((() #f #f #f () ())
 807           (call (lexical a _)))))
 808       (lambda _
 809         (lambda-case
 810          (((x) #f #f #f () (_))
 811           (lexical x _))))
 812       (lambda _
 813         (lambda-case
 814          ((() #f #f #f () ())
 815           (call (lexical a _))))))
 816      (let (d)
 817        (_)
 818        ((call (toplevel foo) (lexical b _)))
 819        (call (lexical c _) (lexical d _)))))
 820
 821   (pass-if-peval
 822    ;; In this case, we can prune the bindings.  `a' ends up being copied
 823    ;; because it is only referenced once in the source program.  Oh
 824    ;; well.
 825    (letrec* ((a (lambda (x) (top x)))
 826              (b (lambda () a)))
 827      (foo (b) (b)))
 828    (call (toplevel foo)
 829          (lambda _
 830            (lambda-case
 831             (((x) #f #f #f () (_))
 832              (call (toplevel top) (lexical x _)))))
 833          (lambda _
 834            (lambda-case
 835             (((x) #f #f #f () (_))
 836              (call (toplevel top) (lexical x _)))))))
 837
 838   (pass-if-peval
 839    ;; Constant folding: cons of #nil does not make list
 840    (cons 1 #nil)
 841    (primcall cons (const 1) (const '#nil)))
 842
 843   (pass-if-peval
 844     ;; Constant folding: cons
 845    (begin (cons 1 2) #f)
 846    (const #f))
 847
 848   (pass-if-peval
 849     ;; Constant folding: cons
 850    (begin (cons (foo) 2) #f)
 851    (seq (call (toplevel foo)) (const #f)))
 852
 853   (pass-if-peval
 854     ;; Constant folding: cons
 855    (if (cons 0 0) 1 2)
 856    (const 1))
 857
 858   (pass-if-peval
 859    ;; Constant folding: car+cons
 860    (car (cons 1 0))
 861    (const 1))
 862
 863   (pass-if-peval
 864    ;; Constant folding: cdr+cons
 865    (cdr (cons 1 0))
 866    (const 0))
 867
 868   (pass-if-peval
 869    ;; Constant folding: car+cons, impure
 870    (car (cons 1 (bar)))
 871    (seq (call (toplevel bar)) (const 1)))
 872
 873   (pass-if-peval
 874    ;; Constant folding: cdr+cons, impure
 875    (cdr (cons (bar) 0))
 876    (seq (call (toplevel bar)) (const 0)))
 877
 878   (pass-if-peval
 879    ;; Constant folding: car+list
 880    (car (list 1 0))
 881    (const 1))
 882
 883   (pass-if-peval
 884    ;; Constant folding: cdr+list
 885    (cdr (list 1 0))
 886    (primcall list (const 0)))
 887
 888   (pass-if-peval
 889    ;; Constant folding: car+list, impure
 890    (car (list 1 (bar)))
 891    (seq (call (toplevel bar)) (const 1)))
 892
 893   (pass-if-peval
 894    ;; Constant folding: cdr+list, impure
 895    (cdr (list (bar) 0))
 896    (seq (call (toplevel bar)) (primcall list (const 0))))
 897
 898   (pass-if-peval
 899    ;; Equality primitive: same lexical
 900    (let ((x (random))) (eq? x x))
 901    (seq (call (toplevel random)) (const #t)))
 902
 903   (pass-if-peval
 904    ;; Equality primitive: merge lexical identities
 905    (let* ((x (random)) (y x)) (eq? x y))
 906    (seq (call (toplevel random)) (const #t)))
 907
 908   (pass-if-peval
 909    ;; Non-constant guards get lexical bindings.
 910    (dynamic-wind foo (lambda () bar) baz)
 911    (let (w u) (_ _) ((toplevel foo) (toplevel baz))
 912         (dynwind (lexical w _)
 913                  (call (lexical w _))
 914                  (toplevel bar)
 915                  (call (lexical u _))
 916                  (lexical u _))))
 917
 918   (pass-if-peval
 919    ;; Constant guards don't need lexical bindings.
 920    (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
 921    (dynwind
 922     (lambda ()
 923       (lambda-case
 924        ((() #f #f #f () ()) (toplevel foo))))
 925     (toplevel foo)
 926     (toplevel bar)
 927     (toplevel baz)
 928     (lambda ()
 929       (lambda-case
 930        ((() #f #f #f () ()) (toplevel baz))))))
 931
 932   (pass-if-peval
 933    ;; Prompt is removed if tag is unreferenced
 934    (let ((tag (make-prompt-tag)))
 935      (call-with-prompt tag
 936                        (lambda () 1)
 937                        (lambda args args)))
 938    (const 1))
 939
 940   (pass-if-peval
 941    ;; Prompt is removed if tag is unreferenced, with explicit stem
 942    (let ((tag (make-prompt-tag "foo")))
 943      (call-with-prompt tag
 944                        (lambda () 1)
 945                        (lambda args args)))
 946    (const 1))
 947
 948   ;; Handler lambda inlined
 949   (pass-if-peval
 950    (call-with-prompt tag
 951                      (lambda () 1)
 952                      (lambda (k x) x))
 953    (prompt (toplevel tag)
 954            (const 1)
 955            (lambda-case
 956             (((k x) #f #f #f () (_ _))
 957              (lexical x _)))))
 958
 959   ;; Handler toplevel not inlined
 960   (pass-if-peval
 961    (call-with-prompt tag
 962                      (lambda () 1)
 963                      handler)
 964    (let (handler) (_) ((toplevel handler))
 965         (prompt (toplevel tag)
 966                 (const 1)
 967                 (lambda-case
 968                  ((() #f args #f () (_))
 969                   (primcall @apply
 970                             (lexical handler _)
 971                             (lexical args _)))))))
 972
 973   (pass-if-peval
 974    ;; `while' without `break' or `continue' has no prompts and gets its
 975    ;; condition folded.  Unfortunately the outer `lp' does not yet get
 976    ;; elided.
 977    (while #t #t)
 978    (letrec (lp) (_)
 979            ((lambda _
 980               (lambda-case
 981                ((() #f #f #f () ())
 982                 (letrec (loop) (_)
 983                         ((lambda _
 984                            (lambda-case
 985                             ((() #f #f #f () ())
 986                              (call (lexical loop _))))))
 987                         (call (lexical loop _)))))))
 988            (call (lexical lp _))))
 989
 990   (pass-if-peval
 991    (lambda (a . rest)
 992      (apply (lambda (x y) (+ x y))
 993             a rest))
 994    (lambda _
 995      (lambda-case
 996       (((x y) #f #f #f () (_ _))
 997        _))))
 998
 999   (pass-if-peval
1000     (car '(1 2))
1001     (const 1))
1002
1003   ;; If we bail out when inlining an identifier because it's too big,
1004   ;; but the identifier simply aliases some other identifier, then avoid
1005   ;; residualizing a reference to the leaf identifier.  The bailout is
1006   ;; driven by the recursive-effort-limit, which is currently 100.  We
1007   ;; make sure to trip it with this recursive sum thing.
1008   (pass-if-peval
1009     (let ((x (let sum ((n 0) (out 0))
1010                (if (< n 10000)
1011                    (sum (1+ n) (+ out n))
1012                    out))))
1013       ((lambda (y) (list y)) x))
1014     (let (x) (_) (_)
1015          (primcall list (lexical x _))))
1016
1017   ;; Here we test that a common test in a chain of ifs gets lifted.
1018   (pass-if-peval
1019     (if (and (struct? x) (eq? (struct-vtable x) A))
1020         (foo x)
1021         (if (and (struct? x) (eq? (struct-vtable x) B))
1022             (bar x)
1023             (if (and (struct? x) (eq? (struct-vtable x) C))
1024                 (baz x)
1025                 (qux x))))
1026     (let (failure) (_) ((lambda _
1027                           (lambda-case
1028                            ((() #f #f #f () ())
1029                             (call (toplevel qux) (toplevel x))))))
1030          (if (primcall struct? (toplevel x))
1031              (if (primcall eq?
1032                            (primcall struct-vtable (toplevel x))
1033                            (toplevel A))
1034                  (call (toplevel foo) (toplevel x))
1035                  (if (primcall eq?
1036                                (primcall struct-vtable (toplevel x))
1037                                (toplevel B))
1038                      (call (toplevel bar) (toplevel x))
1039                      (if (primcall eq?
1040                                    (primcall struct-vtable (toplevel x))
1041                                    (toplevel C))
1042                          (call (toplevel baz) (toplevel x))
1043                          (call (lexical failure _)))))
1044              (call (lexical failure _)))))
1045
1046   ;; Multiple common tests should get lifted as well.
1047   (pass-if-peval
1048     (if (and (struct? x) (eq? (struct-vtable x) A) B)
1049         (foo x)
1050         (if (and (struct? x) (eq? (struct-vtable x) A) C)
1051             (bar x)
1052             (if (and (struct? x) (eq? (struct-vtable x) A) D)
1053                 (baz x)
1054                 (qux x))))
1055     (let (failure) (_) ((lambda _
1056                           (lambda-case
1057                            ((() #f #f #f () ())
1058                             (call (toplevel qux) (toplevel x))))))
1059          (if (primcall struct? (toplevel x))
1060              (if (primcall eq?
1061                            (primcall struct-vtable (toplevel x))
1062                            (toplevel A))
1063                  (if (toplevel B)
1064                      (call (toplevel foo) (toplevel x))
1065                      (if (toplevel C)
1066                          (call (toplevel bar) (toplevel x))
1067                          (if (toplevel D)
1068                              (call (toplevel baz) (toplevel x))
1069                              (call (lexical failure _)))))
1070                  (call (lexical failure _)))
1071              (call (lexical failure _))))))