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-2014 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 (rnrs bytevectors) ;; for the bytevector primitives
  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 ()
  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     (primcall
 350      +
 351      (primcall
 352       +
 353       (const -1)                      ; (f -1 0)
 354       (seq (toplevel y) (const -1)))  ; (f -1 y)
 355      (toplevel y))                    ; (f 2 y)
 356     (let (x y) (_ _) ((toplevel z) (toplevel y))  ; (f z y)
 357          (if (primcall > (lexical x _) (const 0))
 358              (lexical y _)
 359              (lexical x _)))))
 360
 361   (pass-if-peval
 362     ;; First order, conditional.
 363     (let ((y 2))
 364       (lambda (x)
 365         (if (> y 0)
 366             (display x)
 367             'never-reached)))
 368     (lambda ()
 369       (lambda-case
 370        (((x) #f #f #f () (_))
 371         (call (toplevel display) (lexical x _))))))
 372
 373   (pass-if-peval
 374     ;; First order, recursive procedure.
 375     (letrec ((fibo (lambda (n)
 376                      (if (<= n 1)
 377                          n
 378                          (+ (fibo (- n 1))
 379                             (fibo (- n 2)))))))
 380       (fibo 4))
 381     (const 3))
 382
 383   (pass-if-peval
 384    ;; Don't propagate toplevel references, as intervening expressions
 385    ;; could alter their bindings.
 386    (let ((x top))
 387      (foo)
 388      x)
 389    (let (x) (_) ((toplevel top))
 390         (seq
 391           (call (toplevel foo))
 392           (lexical x _))))
 393
 394   (pass-if-peval
 395     ;; Higher order.
 396     ((lambda (f x)
 397        (f (* (car x) (cadr x))))
 398      (lambda (x)
 399        (+ x 1))
 400      '(2 3))
 401     (const 7))
 402
 403   (pass-if-peval
 404     ;; Higher order with optional argument (default value).
 405     ((lambda* (f x #:optional (y 0))
 406        (+ y (f (* (car x) (cadr x)))))
 407      (lambda (x)
 408        (+ x 1))
 409      '(2 3))
 410     (const 7))
 411
 412   (pass-if-peval
 413     ;; Higher order with optional argument (default uses earlier argument).
 414     ;; <http://bugs.gnu.org/17634>
 415     ((lambda* (f x #:optional (y (+ 3 (car x))))
 416        (+ y (f (* (car x) (cadr x)))))
 417      (lambda (x)
 418        (+ x 1))
 419      '(2 3))
 420     (const 12))
 421
 422   (pass-if-peval
 423     ;; Higher order with optional arguments
 424     ;; (default uses earlier optional argument).
 425     ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
 426        (+ y z (f (* (car x) (cadr x)))))
 427      (lambda (x)
 428        (+ x 1))
 429      '(2 3))
 430     (const 20))
 431
 432   (pass-if-peval
 433     ;; Higher order with optional arguments (one caller-supplied value,
 434     ;; one default that uses earlier optional argument).
 435     ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
 436        (+ y z (f (* (car x) (cadr x)))))
 437      (lambda (x)
 438        (+ x 1))
 439      '(2 3)
 440      -3)
 441     (const 4))
 442
 443   (pass-if-peval
 444     ;; Higher order with optional arguments (caller-supplied values).
 445     ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
 446        (+ y z (f (* (car x) (cadr x)))))
 447      (lambda (x)
 448        (+ x 1))
 449      '(2 3)
 450      -3
 451      17)
 452     (const 21))
 453
 454   (pass-if-peval
 455     ;; Higher order with optional and rest arguments (one
 456     ;; caller-supplied value, one default that uses earlier optional
 457     ;; argument).
 458     ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
 459                  #:rest r)
 460        (list r (+ y z (f (* (car x) (cadr x))))))
 461      (lambda (x)
 462        (+ x 1))
 463      '(2 3)
 464      -3)
 465     (primcall list (const ()) (const 4)))
 466
 467   (pass-if-peval
 468     ;; Higher order with optional and rest arguments
 469     ;; (caller-supplied values for optionals).
 470     ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
 471                  #:rest r)
 472        (list r (+ y z (f (* (car x) (cadr x))))))
 473      (lambda (x)
 474        (+ x 1))
 475      '(2 3)
 476      -3
 477      17)
 478     (primcall list (const ()) (const 21)))
 479
 480   (pass-if-peval
 481     ;; Higher order with optional and rest arguments
 482     ;; (caller-supplied values for optionals and rest).
 483     ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
 484                  #:rest r)
 485        (list r (+ y z (f (* (car x) (cadr x))))))
 486      (lambda (x)
 487        (+ x 1))
 488      '(2 3)
 489      -3
 490      17
 491      8
 492      3)
 493     (let (r) (_) ((primcall list (const 8) (const 3)))
 494          (primcall list (lexical r _) (const 21))))
 495
 496   (pass-if-peval
 497     ;; Higher order with optional argument (caller-supplied value).
 498     ((lambda* (f x #:optional (y 0))
 499        (+ y (f (* (car x) (cadr x)))))
 500      (lambda (x)
 501        (+ x 1))
 502      '(2 3)
 503      35)
 504     (const 42))
 505
 506   (pass-if-peval
 507     ;; Higher order with optional argument (side-effecting default
 508     ;; value).
 509     ((lambda* (f x #:optional (y (foo)))
 510        (+ y (f (* (car x) (cadr x)))))
 511      (lambda (x)
 512        (+ x 1))
 513      '(2 3))
 514     (let (y) (_) ((call (toplevel foo)))
 515          (primcall + (lexical y _) (const 7))))
 516
 517   (pass-if-peval
 518     ;; Higher order with optional argument (caller-supplied value).
 519     ((lambda* (f x #:optional (y (foo)))
 520        (+ y (f (* (car x) (cadr x)))))
 521      (lambda (x)
 522        (+ x 1))
 523      '(2 3)
 524      35)
 525     (const 42))
 526
 527   (pass-if-peval
 528     ;; Higher order.
 529     ((lambda (f) (f x)) (lambda (x) x))
 530     (toplevel x))
 531
 532   (pass-if-peval
 533     ;; Bug reported at
 534     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
 535     (let ((fold (lambda (f g) (f (g top)))))
 536       (fold 1+ (lambda (x) x)))
 537     (primcall 1+ (toplevel top)))
 538
 539   (pass-if-peval
 540     ;; Procedure not inlined when residual code contains recursive calls.
 541     ;; <http://debbugs.gnu.org/9542>
 542     (letrec ((fold (lambda (f x3 b null? car cdr)
 543                      (if (null? x3)
 544                          b
 545                          (f (car x3) (fold f (cdr x3) b null? car cdr))))))
 546       (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
 547     (letrec (fold) (_) (_)
 548             (call (lexical fold _)
 549                    (primitive *)
 550                    (toplevel x)
 551                    (const 1)
 552                    (primitive zero?)
 553                    (lambda ()
 554                      (lambda-case
 555                       (((x1) #f #f #f () (_))
 556                        (lexical x1 _))))
 557                    (lambda ()
 558                      (lambda-case
 559                       (((x2) #f #f #f () (_))
 560                        (primcall 1- (lexical x2 _))))))))
 561
 562   (pass-if "inlined lambdas are alpha-renamed"
 563     ;; In this example, `make-adder' is inlined more than once; thus,
 564     ;; they should use different gensyms for their arguments, because
 565     ;; the various optimization passes assume uniquely-named variables.
 566     ;;
 567     ;; Bug reported at
 568     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
 569     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
 570     (pmatch (unparse-tree-il
 571              (peval (expand-primitives
 572                      (resolve-primitives
 573                       (compile
 574                        '(let ((make-adder
 575                                (lambda (x) (lambda (y) (+ x y)))))
 576                           (cons (make-adder 1) (make-adder 2)))
 577                        #:to 'tree-il)
 578                       (current-module)))))
 579       ((primcall cons
 580                  (lambda ()
 581                    (lambda-case
 582                     (((y) #f #f #f () (,gensym1))
 583                      (primcall +
 584                                (const 1)
 585                                (lexical y ,ref1)))))
 586                  (lambda ()
 587                    (lambda-case
 588                     (((y) #f #f #f () (,gensym2))
 589                      (primcall +
 590                                (const 2)
 591                                (lexical y ,ref2))))))
 592        (and (eq? gensym1 ref1)
 593             (eq? gensym2 ref2)
 594             (not (eq? gensym1 gensym2))))
 595       (_ #f)))
 596
 597   (pass-if-peval
 598    ;; Unused letrec bindings are pruned.
 599    (letrec ((a (lambda () (b)))
 600             (b (lambda () (a)))
 601             (c (lambda (x) x)))
 602      (c 10))
 603    (const 10))
 604
 605   (pass-if-peval
 606    ;; Unused letrec bindings are pruned.
 607    (letrec ((a (foo!))
 608             (b (lambda () (a)))
 609             (c (lambda (x) x)))
 610      (c 10))
 611    (seq (call (toplevel foo!))
 612         (const 10)))
 613
 614   (pass-if-peval
 615     ;; Higher order, mutually recursive procedures.
 616     (letrec ((even? (lambda (x)
 617                       (or (= 0 x)
 618                           (odd? (- x 1)))))
 619              (odd?  (lambda (x)
 620                       (not (even? x)))))
 621       (and (even? 4) (odd? 7)))
 622     (const #t))
 623
 624   (pass-if-peval
 625     ;; Memv with constants.
 626     (memv 1 '(3 2 1))
 627     (const '(1)))
 628
 629   (pass-if-peval
 630     ;; Memv with non-constant list.  It could fold but doesn't
 631     ;; currently.
 632     (memv 1 (list 3 2 1))
 633     (primcall memv
 634               (const 1)
 635               (primcall list (const 3) (const 2) (const 1))))
 636
 637   (pass-if-peval
 638     ;; Memv with non-constant key, constant list, test context
 639     (case foo
 640       ((3 2 1) 'a)
 641       (else 'b))
 642     (let (key) (_) ((toplevel foo))
 643          (if (if (primcall eqv? (lexical key _) (const 3))
 644                  (const #t)
 645                  (if (primcall eqv? (lexical key _) (const 2))
 646                      (const #t)
 647                      (primcall eqv? (lexical key _) (const 1))))
 648              (const a)
 649              (const b))))
 650
 651   (pass-if-peval
 652     ;; Memv with non-constant key, empty list, test context.
 653     (case foo
 654       (() 'a)
 655       (else 'b))
 656     (seq (toplevel foo) (const 'b)))
 657
 658   ;;
 659   ;; Below are cases where constant propagation should bail out.
 660   ;;
 661
 662   (pass-if-peval
 663     ;; Non-constant lexical is not propagated.
 664     (let ((v (make-vector 6 #f)))
 665       (lambda (n)
 666         (vector-set! v n n)))
 667     (let (v) (_)
 668          ((primcall make-vector (const 6) (const #f)))
 669          (lambda ()
 670            (lambda-case
 671             (((n) #f #f #f () (_))
 672              (primcall vector-set!
 673                        (lexical v _) (lexical n _) (lexical n _)))))))
 674
 675   (pass-if-peval
 676     ;; Mutable lexical is not propagated.
 677     (let ((v (vector 1 2 3)))
 678       (lambda ()
 679         v))
 680     (let (v) (_)
 681          ((primcall vector (const 1) (const 2) (const 3)))
 682          (lambda ()
 683            (lambda-case
 684             ((() #f #f #f () ())
 685              (lexical v _))))))
 686
 687   (pass-if-peval
 688     ;; Lexical that is not provably pure is not inlined nor propagated.
 689     (let* ((x (if (> p q) (frob!) (display 'chbouib)))
 690            (y (* x 2)))
 691       (+ x x y))
 692     (let (x) (_) ((if (primcall > (toplevel p) (toplevel q))
 693                       (call (toplevel frob!))
 694                       (call (toplevel display) (const chbouib))))
 695          (let (y) (_) ((primcall * (lexical x _) (const 2)))
 696               (primcall +
 697                         (primcall + (lexical x _) (lexical x _))
 698                         (lexical y _)))))
 699
 700   (pass-if-peval
 701     ;; Non-constant arguments not propagated to lambdas.
 702     ((lambda (x y z)
 703        (vector-set! x 0 0)
 704        (set-car! y 0)
 705        (set-cdr! z '()))
 706      (vector 1 2 3)
 707      (make-list 10)
 708      (list 1 2 3))
 709     (let (x y z) (_ _ _)
 710          ((primcall vector (const 1) (const 2) (const 3))
 711           (call (toplevel make-list) (const 10))
 712           (primcall list (const 1) (const 2) (const 3)))
 713          (seq
 714            (primcall vector-set!
 715                      (lexical x _) (const 0) (const 0))
 716            (seq (primcall set-car!
 717                           (lexical y _) (const 0))
 718                 (primcall set-cdr!
 719                           (lexical z _) (const ()))))))
 720
 721   (pass-if-peval
 722    (let ((foo top-foo) (bar top-bar))
 723      (let* ((g (lambda (x y) (+ x y)))
 724             (f (lambda (g x) (g x x))))
 725        (+ (f g foo) (f g bar))))
 726    (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
 727         (primcall +
 728                   (primcall + (lexical foo _) (lexical foo _))
 729                   (primcall + (lexical bar _) (lexical bar _)))))
 730
 731   (pass-if-peval
 732     ;; Fresh objects are not turned into constants, nor are constants
 733     ;; turned into fresh objects.
 734     (let* ((c '(2 3))
 735            (x (cons 1 c))
 736            (y (cons 0 x)))
 737       y)
 738     (let (x) (_) ((primcall cons (const 1) (const (2 3))))
 739          (primcall cons (const 0) (lexical x _))))
 740
 741   (pass-if-peval
 742     ;; Bindings mutated.
 743     (let ((x 2))
 744       (set! x 3)
 745       x)
 746     (let (x) (_) ((const 2))
 747          (seq
 748            (set! (lexical x _) (const 3))
 749            (lexical x _))))
 750
 751   (pass-if-peval
 752     ;; Bindings mutated.
 753     (letrec ((x 0)
 754              (f (lambda ()
 755                   (set! x (+ 1 x))
 756                   x)))
 757       (frob f) ; may mutate `x'
 758       x)
 759     (letrec (x) (_) ((const 0))
 760             (seq
 761               (call (toplevel frob) (lambda _ _))
 762               (lexical x _))))
 763
 764   (pass-if-peval
 765     ;; Bindings mutated.
 766     (letrec ((f (lambda (x)
 767                   (set! f (lambda (_) x))
 768                   x)))
 769       (f 2))
 770     (letrec _ . _))
 771
 772   (pass-if-peval
 773     ;; Bindings possibly mutated.
 774     (let ((x (make-foo)))
 775       (frob! x) ; may mutate `x'
 776       x)
 777     (let (x) (_) ((call (toplevel make-foo)))
 778          (seq
 779            (call (toplevel frob!) (lexical x _))
 780            (lexical x _))))
 781
 782   (pass-if-peval
 783     ;; Inlining stops at recursive calls with dynamic arguments.
 784     (let loop ((x x))
 785       (if (< x 0) x (loop (1- x))))
 786     (letrec (loop) (_) ((lambda (_)
 787                           (lambda-case
 788                            (((x) #f #f #f () (_))
 789                             (if _ _
 790                                 (call (lexical loop _)
 791                                        (primcall 1-
 792                                                  (lexical x _))))))))
 793             (call (lexical loop _) (toplevel x))))
 794
 795   (pass-if-peval
 796     ;; Recursion on the 2nd argument is fully evaluated.
 797     (let ((x (top)))
 798       (let loop ((x x) (y 10))
 799         (if (> y 0)
 800             (loop x (1- y))
 801             (foo x y))))
 802     (let (x) (_) ((call (toplevel top)))
 803          (call (toplevel foo) (lexical x _) (const 0))))
 804
 805   (pass-if-peval
 806     ;; Inlining aborted when residual code contains recursive calls.
 807     ;;
 808     ;; <http://debbugs.gnu.org/9542>
 809     (let loop ((x x) (y 0))
 810       (if (> y 0)
 811           (loop (1- x) (1- y))
 812           (if (< x 0)
 813               x
 814               (loop (1+ x) (1+ y)))))
 815     (letrec (loop) (_) ((lambda (_)
 816                           (lambda-case
 817                            (((x y) #f #f #f () (_ _))
 818                             (if (primcall >
 819                                           (lexical y _) (const 0))
 820                                 _ _)))))
 821             (call (lexical loop _) (toplevel x) (const 0))))
 822
 823   (pass-if-peval
 824     ;; Infinite recursion: `peval' gives up and leaves it as is.
 825     (letrec ((f (lambda (x) (g (1- x))))
 826              (g (lambda (x) (h (1+ x))))
 827              (h (lambda (x) (f x))))
 828       (f 0))
 829     (letrec _ . _))
 830
 831   (pass-if-peval
 832     ;; Infinite recursion: all the arguments to `loop' are static, but
 833     ;; unrolling it would lead `peval' to enter an infinite loop.
 834     (let loop ((x 0))
 835       (and (< x top)
 836            (loop (1+ x))))
 837     (letrec (loop) (_) ((lambda . _))
 838             (call (lexical loop _) (const 0))))
 839
 840   (pass-if-peval
 841     ;; This test checks that the `start' binding is indeed residualized.
 842     ;; See the `referenced?' procedure in peval's `prune-bindings'.
 843     (let ((pos 0))
 844       (let ((here (let ((start pos)) (lambda () start))))
 845         (set! pos 1) ;; Cause references to `pos' to residualize.
 846         (here)))
 847     (let (pos) (_) ((const 0))
 848          (let (here) (_) (_)
 849               (seq
 850                (set! (lexical pos _) (const 1))
 851                (call (lexical here _))))))
 852
 853   (pass-if-peval
 854    ;; FIXME: should this one residualize the binding?
 855    (letrec ((a a))
 856      1)
 857    (const 1))
 858
 859   (pass-if-peval
 860    ;; This is a fun one for peval to handle.
 861    (letrec ((a a))
 862      a)
 863    (letrec (a) (_) ((lexical a _))
 864            (lexical a _)))
 865
 866   (pass-if-peval
 867    ;; Another interesting recursive case.
 868    (letrec ((a b) (b a))
 869      a)
 870    (letrec (a) (_) ((lexical a _))
 871            (lexical a _)))
 872
 873   (pass-if-peval
 874    ;; Another pruning case, that `a' is residualized.
 875    (letrec ((a (lambda () (a)))
 876             (b (lambda () (a)))
 877             (c (lambda (x) x)))
 878      (let ((d (foo b)))
 879        (c d)))
 880
 881    ;; "b c a" is the current order that we get with unordered letrec,
 882    ;; but it's not important to this test, so if it changes, just adapt
 883    ;; the test.
 884    (letrec (b a) (_ _)
 885            ((lambda _
 886               (lambda-case
 887                ((() #f #f #f () ())
 888                 (call (lexical a _)))))
 889             (lambda _
 890               (lambda-case
 891                ((() #f #f #f () ())
 892                 (call (lexical a _))))))
 893      (call (toplevel foo) (lexical b _))))
 894
 895   (pass-if-peval
 896    ;; In this case, we can prune the bindings.  `a' ends up being copied
 897    ;; because it is only referenced once in the source program.  Oh
 898    ;; well.
 899    (letrec* ((a (lambda (x) (top x)))
 900              (b (lambda () a)))
 901      (foo (b) (b)))
 902    (call (toplevel foo)
 903          (lambda _
 904            (lambda-case
 905             (((x) #f #f #f () (_))
 906              (call (toplevel top) (lexical x _)))))
 907          (lambda _
 908            (lambda-case
 909             (((x) #f #f #f () (_))
 910              (call (toplevel top) (lexical x _)))))))
 911
 912   (pass-if-peval
 913     ;; The inliner sees through a `let'.
 914     ((let ((a 10)) (lambda (b) (* b 2))) 30)
 915     (const 60))
 916
 917   (pass-if-peval
 918       ((lambda ()
 919          (define (const x) (lambda (_) x))
 920          (let ((v #f))
 921            ((const #t) v))))
 922     (const #t))
 923
 924   (pass-if-peval
 925       ;; Applications of procedures with rest arguments can get inlined.
 926       ((lambda (x y . z)
 927          (list x y z))
 928        1 2 3 4)
 929     (let (z) (_) ((primcall list (const 3) (const 4)))
 930          (primcall list (const 1) (const 2) (lexical z _))))
 931
 932   (pass-if-peval
 933     ;; Unmutated lists can get inlined.
 934     (let ((args (list 2 3)))
 935       (apply (lambda (x y z w)
 936                (list x y z w))
 937              0 1 args))
 938     (primcall list (const 0) (const 1) (const 2) (const 3)))
 939
 940   (pass-if-peval
 941     ;; However if the list might have been mutated, it doesn't propagate.
 942     (let ((args (list 2 3)))
 943       (foo! args)
 944       (apply (lambda (x y z w)
 945                (list x y z w))
 946              0 1 args))
 947     (let (args) (_) ((primcall list (const 2) (const 3)))
 948          (seq
 949           (call (toplevel foo!) (lexical args _))
 950           (primcall apply
 951                     (lambda ()
 952                       (lambda-case
 953                        (((x y z w) #f #f #f () (_ _ _ _))
 954                         (primcall list
 955                                   (lexical x _) (lexical y _)
 956                                   (lexical z _) (lexical w _)))))
 957                     (const 0)
 958                     (const 1)
 959                     (lexical args _)))))
 960
 961   (pass-if-peval
 962     ;; Here the `args' that gets built by the application of the lambda
 963     ;; takes more than effort "10" to visit.  Test that we fall back to
 964     ;; the source expression of the operand, which is still a call to
 965     ;; `list', so the inlining still happens.
 966     (lambda (bv offset n)
 967       (let ((x (bytevector-ieee-single-native-ref
 968                 bv
 969                 (+ offset 0)))
 970             (y (bytevector-ieee-single-native-ref
 971                 bv
 972                 (+ offset 4))))
 973         (let ((args (list x y)))
 974           (apply
 975            (lambda (bv offset x y)
 976              (bytevector-ieee-single-native-set!
 977               bv
 978               (+ offset 0)
 979               x)
 980              (bytevector-ieee-single-native-set!
 981               bv
 982               (+ offset 4)
 983               y))
 984            bv
 985            offset
 986            args))))
 987     (lambda ()
 988       (lambda-case
 989        (((bv offset n) #f #f #f () (_ _ _))
 990         (let (x y) (_ _) ((primcall bytevector-ieee-single-native-ref
 991                                     (lexical bv _)
 992                                     (primcall +
 993                                               (lexical offset _) (const 0)))
 994                           (primcall bytevector-ieee-single-native-ref
 995                                     (lexical bv _)
 996                                     (primcall +
 997                                               (lexical offset _) (const 4))))
 998              (seq
 999               (primcall bytevector-ieee-single-native-set!
1000                         (lexical bv _)
1001                         (primcall +
1002                                   (lexical offset _) (const 0))
1003                         (lexical x _))
1004               (primcall bytevector-ieee-single-native-set!
1005                         (lexical bv _)
1006                         (primcall +
1007                                   (lexical offset _) (const 4))
1008                         (lexical y _))))))))
1009
1010   (pass-if-peval
1011     ;; Here we ensure that non-constant expressions are not copied.
1012     (lambda ()
1013       (let ((args (list (foo!))))
1014         (apply
1015          (lambda (z x)
1016            (list z x))
1017          ;; This toplevel ref might raise an unbound variable exception.
1018          ;; The effects of `(foo!)' must be visible before this effect.
1019          z
1020          args)))
1021     (lambda ()
1022       (lambda-case
1023        ((() #f #f #f () ())
1024         (let (_) (_) ((call (toplevel foo!)))
1025              (let (z) (_) ((toplevel z))
1026                   (primcall 'list
1027                             (lexical z _)
1028                             (lexical _ _))))))))
1029
1030   (pass-if-peval
1031     ;; Rest args referenced more than once are not destructured.
1032     (lambda ()
1033       (let ((args (list 'foo)))
1034         (set-car! args 'bar)
1035         (apply
1036          (lambda (z x)
1037            (list z x))
1038          z
1039          args)))
1040     (lambda ()
1041       (lambda-case
1042        ((() #f #f #f () ())
1043         (let (args) (_)
1044              ((primcall list (const foo)))
1045              (seq
1046               (primcall set-car! (lexical args _) (const bar))
1047               (primcall apply
1048                         (lambda . _)
1049                         (toplevel z)
1050                         (lexical args _))))))))
1051
1052   (pass-if-peval
1053     ;; Let-values inlining, even with consumers with rest args.
1054     (call-with-values (lambda () (values 1 2))
1055       (lambda args
1056         (apply list args)))
1057     (primcall list (const 1) (const 2)))
1058
1059   (pass-if-peval
1060     ;; When we can't inline let-values but can prove that the producer
1061     ;; has just one value, reduce to "let" (which can then fold
1062     ;; further).
1063     (call-with-values (lambda () (if foo 1 2))
1064       (lambda args
1065         (apply values args)))
1066     (if (toplevel foo) (const 1) (const 2)))
1067
1068   (pass-if-peval
1069    ;; Constant folding: cons of #nil does not make list
1070    (cons 1 #nil)
1071    (primcall cons (const 1) (const '#nil)))
1072
1073   (pass-if-peval
1074     ;; Constant folding: cons
1075    (begin (cons 1 2) #f)
1076    (const #f))
1077
1078   (pass-if-peval
1079     ;; Constant folding: cons
1080    (begin (cons (foo) 2) #f)
1081    (seq (call (toplevel foo)) (const #f)))
1082
1083   (pass-if-peval
1084     ;; Constant folding: cons
1085    (if (cons 0 0) 1 2)
1086    (const 1))
1087
1088   (pass-if-peval
1089    ;; Constant folding: car+cons
1090    (car (cons 1 0))
1091    (const 1))
1092
1093   (pass-if-peval
1094    ;; Constant folding: cdr+cons
1095    (cdr (cons 1 0))
1096    (const 0))
1097
1098   (pass-if-peval
1099    ;; Constant folding: car+cons, impure
1100    (car (cons 1 (bar)))
1101    (seq (call (toplevel bar)) (const 1)))
1102
1103   (pass-if-peval
1104    ;; Constant folding: cdr+cons, impure
1105    (cdr (cons (bar) 0))
1106    (seq (call (toplevel bar)) (const 0)))
1107
1108   (pass-if-peval
1109    ;; Constant folding: car+list
1110    (car (list 1 0))
1111    (const 1))
1112
1113   (pass-if-peval
1114    ;; Constant folding: cdr+list
1115    (cdr (list 1 0))
1116    (primcall list (const 0)))
1117
1118   (pass-if-peval
1119    ;; Constant folding: car+list, impure
1120    (car (list 1 (bar)))
1121    (seq (call (toplevel bar)) (const 1)))
1122
1123   (pass-if-peval
1124    ;; Constant folding: cdr+list, impure
1125    (cdr (list (bar) 0))
1126    (seq (call (toplevel bar)) (primcall list (const 0))))
1127
1128   (pass-if-peval
1129    ;; Equality primitive: same lexical
1130    (let ((x (random))) (eq? x x))
1131    (seq (call (toplevel random)) (const #t)))
1132
1133   (pass-if-peval
1134    ;; Equality primitive: merge lexical identities
1135    (let* ((x (random)) (y x)) (eq? x y))
1136    (seq (call (toplevel random)) (const #t)))
1137
1138   (pass-if-peval
1139    ;; Non-constant guards get lexical bindings, invocation of winder and
1140    ;; unwinder lifted out.  Unfortunately both have the generic variable
1141    ;; name "tmp", so we can't distinguish them in this test, and they
1142    ;; also collide in generic names with the single-value result from
1143    ;; the dynwind; alack.
1144    (dynamic-wind foo (lambda () bar) baz)
1145    (let (tmp tmp) (_ _) ((toplevel foo) (toplevel baz))
1146         (seq (seq (if (primcall thunk? (lexical tmp _))
1147                       (call (lexical tmp _))
1148                       (primcall scm-error . _))
1149                   (primcall wind (lexical tmp _) (lexical tmp _)))
1150              (let (tmp) (_) ((toplevel bar))
1151                   (seq (seq (primcall unwind)
1152                             (call (lexical tmp _)))
1153                        (lexical tmp _))))))
1154
1155   (pass-if-peval
1156    ;; Constant guards don't need lexical bindings or thunk? checks.
1157    (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
1158    (seq (seq (toplevel foo)
1159              (primcall wind
1160                        (lambda ()
1161                          (lambda-case
1162                           ((() #f #f #f () ()) (toplevel foo))))
1163                        (lambda ()
1164                          (lambda-case
1165                           ((() #f #f #f () ()) (toplevel baz))))))
1166         (let (tmp) (_) ((toplevel bar))
1167              (seq (seq (primcall unwind)
1168                        (toplevel baz))
1169                   (lexical tmp _)))))
1170
1171   (pass-if-peval
1172    ;; Dynwind bodies that return an unknown number of values need a
1173    ;; let-values.
1174    (dynamic-wind (lambda () foo) (lambda () (bar)) (lambda () baz))
1175    (seq (seq (toplevel foo)
1176              (primcall wind
1177                        (lambda ()
1178                          (lambda-case
1179                           ((() #f #f #f () ()) (toplevel foo))))
1180                        (lambda ()
1181                          (lambda-case
1182                           ((() #f #f #f () ()) (toplevel baz))))))
1183         (let-values (call (toplevel bar))
1184           (lambda-case
1185            ((() #f vals #f () (_))
1186             (seq (seq (primcall unwind)
1187                       (toplevel baz))
1188                  (primcall apply (primitive values) (lexical vals _))))))))
1189
1190   (pass-if-peval
1191    ;; Prompt is removed if tag is unreferenced
1192    (let ((tag (make-prompt-tag)))
1193      (call-with-prompt tag
1194                        (lambda () 1)
1195                        (lambda args args)))
1196    (const 1))
1197
1198   (pass-if-peval
1199    ;; Prompt is removed if tag is unreferenced, with explicit stem
1200    (let ((tag (make-prompt-tag "foo")))
1201      (call-with-prompt tag
1202                        (lambda () 1)
1203                        (lambda args args)))
1204    (const 1))
1205
1206   ;; Handler lambda inlined
1207   (pass-if-peval
1208    (call-with-prompt tag
1209                      (lambda () 1)
1210                      (lambda (k x) x))
1211    (prompt #t
1212            (toplevel tag)
1213            (const 1)
1214            (lambda _
1215              (lambda-case
1216               (((k x) #f #f #f () (_ _))
1217                (lexical x _))))))
1218
1219   ;; Handler toplevel not inlined
1220   (pass-if-peval
1221       (call-with-prompt tag
1222                         (lambda () 1)
1223                         handler)
1224     (prompt #f
1225             (toplevel tag)
1226             (lambda _
1227               (lambda-case
1228                ((() #f #f #f () ())
1229                 (const 1))))
1230             (toplevel handler)))
1231
1232   (pass-if-peval
1233    ;; `while' without `break' or `continue' has no prompts and gets its
1234    ;; condition folded.  Unfortunately the outer `lp' does not yet get
1235    ;; elided, and the continuation tag stays around.  (The continue tag
1236    ;; stays around because although it is not referenced, recursively
1237    ;; visiting the loop in the continue handler manages to visit the tag
1238    ;; twice before aborting.  The abort doesn't unroll the recursive
1239    ;; reference.)
1240    (while #t #t)
1241    (let (_) (_) ((primcall make-prompt-tag . _))
1242         (letrec (lp) (_)
1243                 ((lambda _
1244                    (lambda-case
1245                     ((() #f #f #f () ())
1246                      (letrec (loop) (_)
1247                              ((lambda _
1248                                 (lambda-case
1249                                  ((() #f #f #f () ())
1250                                   (call (lexical loop _))))))
1251                              (call (lexical loop _)))))))
1252                 (call (lexical lp _)))))
1253
1254   (pass-if-peval
1255    (lambda (a . rest)
1256      (apply (lambda (x y) (+ x y))
1257             a rest))
1258    (lambda _
1259      (lambda-case
1260       (((x y) #f #f #f () (_ _))
1261        _))))
1262
1263   (pass-if-peval
1264     (car '(1 2))
1265     (const 1))
1266
1267   ;; If we bail out when inlining an identifier because it's too big,
1268   ;; but the identifier simply aliases some other identifier, then avoid
1269   ;; residualizing a reference to the leaf identifier.  The bailout is
1270   ;; driven by the recursive-effort-limit, which is currently 100.  We
1271   ;; make sure to trip it with this recursive sum thing.
1272   (pass-if-peval
1273     (let ((x (let sum ((n 0) (out 0))
1274                (if (< n 10000)
1275                    (sum (1+ n) (+ out n))
1276                    out))))
1277       ((lambda (y) (list y)) x))
1278     (let (x) (_) (_)
1279          (primcall list (lexical x _))))
1280
1281   ;; Here we test that a common test in a chain of ifs gets lifted.
1282   (pass-if-peval
1283     (if (and (struct? x) (eq? (struct-vtable x) A))
1284         (foo x)
1285         (if (and (struct? x) (eq? (struct-vtable x) B))
1286             (bar x)
1287             (if (and (struct? x) (eq? (struct-vtable x) C))
1288                 (baz x)
1289                 (qux x))))
1290     (let (failure) (_) ((lambda _
1291                           (lambda-case
1292                            ((() #f #f #f () ())
1293                             (call (toplevel qux) (toplevel x))))))
1294          (if (primcall struct? (toplevel x))
1295              (if (primcall eq?
1296                            (primcall struct-vtable (toplevel x))
1297                            (toplevel A))
1298                  (call (toplevel foo) (toplevel x))
1299                  (if (primcall eq?
1300                                (primcall struct-vtable (toplevel x))
1301                                (toplevel B))
1302                      (call (toplevel bar) (toplevel x))
1303                      (if (primcall eq?
1304                                    (primcall struct-vtable (toplevel x))
1305                                    (toplevel C))
1306                          (call (toplevel baz) (toplevel x))
1307                          (call (lexical failure _)))))
1308              (call (lexical failure _)))))
1309
1310   ;; Multiple common tests should get lifted as well.
1311   (pass-if-peval
1312     (if (and (struct? x) (eq? (struct-vtable x) A) B)
1313         (foo x)
1314         (if (and (struct? x) (eq? (struct-vtable x) A) C)
1315             (bar x)
1316             (if (and (struct? x) (eq? (struct-vtable x) A) D)
1317                 (baz x)
1318                 (qux x))))
1319     (let (failure) (_) ((lambda _
1320                           (lambda-case
1321                            ((() #f #f #f () ())
1322                             (call (toplevel qux) (toplevel x))))))
1323          (if (primcall struct? (toplevel x))
1324              (if (primcall eq?
1325                            (primcall struct-vtable (toplevel x))
1326                            (toplevel A))
1327                  (if (toplevel B)
1328                      (call (toplevel foo) (toplevel x))
1329                      (if (toplevel C)
1330                          (call (toplevel bar) (toplevel x))
1331                          (if (toplevel D)
1332                              (call (toplevel baz) (toplevel x))
1333                              (call (lexical failure _)))))
1334                  (call (lexical failure _)))
1335              (call (lexical failure _)))))
1336
1337   (pass-if-peval
1338     (apply (lambda (x y) (cons x y)) '(1 2))
1339     (primcall cons (const 1) (const 2)))
1340
1341   (pass-if-peval
1342     (apply (lambda (x y) (cons x y)) (list 1 2))
1343     (primcall cons (const 1) (const 2)))
1344
1345   ;; Disable after removal of abort-in-tail-position optimization, in
1346   ;; hopes that CPS does a uniformly better job.
1347   #;
1348   (pass-if-peval
1349     (let ((t (make-prompt-tag)))
1350       (call-with-prompt t
1351                         (lambda () (abort-to-prompt t 1 2 3))
1352                         (lambda (k x y z) (list x y z))))
1353     (primcall list (const 1) (const 2) (const 3)))
1354
1355   (pass-if-peval
1356       (call-with-values foo (lambda (x) (bar x)))
1357     (let (x) (_) ((call (toplevel foo)))
1358          (call (toplevel bar) (lexical x _))))
1359
1360   (pass-if-peval
1361       ((lambda (foo)
1362          (define* (bar a #:optional (b (1+ a)))
1363            (list a b))
1364          (bar 1))
1365        1)
1366     (primcall list (const 1) (const 2)))
1367
1368   (pass-if-peval
1369       ;; Should not inline tail list to apply if it is mutable.
1370       ;; <http://debbugs.gnu.org/15533>
1371       (let ((l '()))
1372         (if (pair? arg)
1373             (set! l arg))
1374         (apply f l))
1375     (let (l) (_) ((const ()))
1376          (seq
1377            (if (primcall pair? (toplevel arg))
1378                (set! (lexical l _) (toplevel arg))
1379                (void))
1380            (primcall apply (toplevel f) (lexical l _))))))