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