From: Andy Wingo <wingo@pobox.com>
Date: Thu, 26 Apr 2012 20:56:45 +0000 (+0200)
Subject: Merge commit 'de1eb420a5a95b17e85b19c4d98c869036e9ecb0'
X-Git-Url: http://git.hcoop.net/bpt/guile.git/commitdiff_plain/c46e0a8a598a16b8f68b5492a13e4032b93f21f9

Merge commit 'de1eb420a5a95b17e85b19c4d98c869036e9ecb0'

Conflicts:
	module/language/tree-il/primitives.scm
	test-suite/tests/tree-il.test
---

c46e0a8a598a16b8f68b5492a13e4032b93f21f9
diff --cc module/language/tree-il/primitives.scm
index 8aecb8517,704f7c294..73d3d69e6
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@@ -29,8 -29,11 +29,12 @@@
              expand-primitives!
              effect-free-primitive? effect+exception-free-primitive?
              constructor-primitive? accessor-primitive?
-             singly-valued-primitive? equality-primitive?))
 -            singly-valued-primitive? bailout-primitive?
++            singly-valued-primitive? equality-primitive?
++            bailout-primitive?
+             negate-primitive))
  
+ ;; When adding to this, be sure to update *multiply-valued-primitives*
+ ;; if appropriate.
  (define *interesting-primitive-names* 
    '(apply @apply
      call-with-values @call-with-values
@@@ -45,8 -48,12 +49,12 @@@
      + * - / 1- 1+ quotient remainder modulo
      ash logand logior logxor
      not
-     pair? null? list? symbol? vector? string? struct?
-     nil?
 -    pair? null? list? symbol? vector? string? struct? number? char?
++    pair? null? list? symbol? vector? string? struct? number? char? nil?
+ 
+     complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+ 
+     char<? char<=? char>=? char>?
+ 
      acons cons cons*
  
      list vector
@@@ -141,9 -150,11 +151,11 @@@
      = < > <= >= zero?
      + * - / 1- 1+ quotient remainder modulo
      not
-     pair? null? list? symbol? vector? struct? string?
-     nil?
 -    pair? null? list? symbol? vector? struct? string? number? char?
++    pair? null? list? symbol? vector? struct? string? number? char? nil
+     complex? real? rational? inf? nan? integer? exact? inexact? even? odd?
+     char<? char<=? char>=? char>?
+     struct-vtable
 -    string-length
 +    string-length vector-length
      ;; These all should get expanded out by expand-primitives!.
      caar cadr cdar cddr
      caaar caadr cadar caddr cdaar cdadr cddar cdddr
@@@ -158,64 -169,38 +170,42 @@@
    '(values
      eq? eqv? equal?
      not
-     pair? null? list? symbol? vector? struct? string?
+     pair? null? list? symbol? vector? struct? string? number? char?
      acons cons cons* list vector))
  
- ;; Primitives that only return one value.
- (define *singly-valued-primitives* 
-   '(eq? eqv? equal?
-     memq memv
-     = < > <= >= zero?
-     + * - / 1- 1+ quotient remainder modulo
-     ash logand logior logxor
-     not
-     pair? null? list? symbol? vector? acons cons cons*
-     nil?
-     list vector
-     car cdr
-     set-car! set-cdr!
-     caar cadr cdar cddr
-     caaar caadr cadar caddr cdaar cdadr cddar cdddr
-     caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
-     cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
-     vector-ref vector-set!
-     variable-ref variable-set!
-     variable-bound?
-     fluid-ref fluid-set!
-     make-prompt-tag
-     struct? struct-vtable make-struct struct-ref struct-set!
-     string-length string-ref string-set!
-     bytevector-u8-ref bytevector-u8-set!
-     bytevector-s8-ref bytevector-s8-set!
-     u8vector-ref u8vector-set! s8vector-ref s8vector-set!
-     bytevector-u16-ref bytevector-u16-set!
-     bytevector-u16-native-ref bytevector-u16-native-set!
-     bytevector-s16-ref bytevector-s16-set!
-     bytevector-s16-native-ref bytevector-s16-native-set!
-     u16vector-ref u16vector-set! s16vector-ref s16vector-set!
-     bytevector-u32-ref bytevector-u32-set!
-     bytevector-u32-native-ref bytevector-u32-native-set!
-     bytevector-s32-ref bytevector-s32-set!
-     bytevector-s32-native-ref bytevector-s32-native-set!
-     u32vector-ref u32vector-set! s32vector-ref s32vector-set!
-     bytevector-u64-ref bytevector-u64-set!
-     bytevector-u64-native-ref bytevector-u64-native-set!
-     bytevector-s64-ref bytevector-s64-set!
-     bytevector-s64-native-ref bytevector-s64-native-set!
-     u64vector-ref u64vector-set! s64vector-ref s64vector-set!
-     bytevector-ieee-single-ref bytevector-ieee-single-set!
-     bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
-     bytevector-ieee-double-ref bytevector-ieee-double-set!
-     bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
-     f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
+ ;; Primitives that don't always return one value.
+ (define *multiply-valued-primitives* 
+   '(apply @apply
+     call-with-values @call-with-values
+     call-with-current-continuation @call-with-current-continuation
+     call/cc
+     dynamic-wind
+     @dynamic-wind
+     values
+     @prompt call-with-prompt @abort abort-to-prompt))
+ 
+ ;; Procedures that cause a nonlocal, non-resumable abort.
+ (define *bailout-primitives*
+   '(throw error scm-error))
+ 
+ ;; Negatable predicates.
+ (define *negatable-primitives*
+   '((even? . odd?)
+     (exact? . inexact?)
+     (< . >=)
+     (> . <=)
+     (char<? . char>=?)
+     (char>? . char<=?)))
  
 +(define *equality-primitives*
 +  '(eq? eqv? equal?))
 +
  (define *effect-free-primitive-table* (make-hash-table))
  (define *effect+exceptions-free-primitive-table* (make-hash-table))
- (define *singly-valued-primitive-table* (make-hash-table))
 +(define *equality-primitive-table* (make-hash-table))
+ (define *multiply-valued-primitive-table* (make-hash-table))
+ (define *bailout-primitive-table* (make-hash-table))
+ (define *negatable-primitive-table* (make-hash-table))
  
  (for-each (lambda (x)
              (hashq-set! *effect-free-primitive-table* x #t))
@@@ -223,12 -208,16 +213,19 @@@
  (for-each (lambda (x) 
              (hashq-set! *effect+exceptions-free-primitive-table* x #t))
            *effect+exception-free-primitives*)
- (for-each (lambda (x) 
-             (hashq-set! *singly-valued-primitive-table* x #t))
-           *singly-valued-primitives*)
 +(for-each (lambda (x)
 +            (hashq-set! *equality-primitive-table* x #t))
 +          *equality-primitives*)
+ (for-each (lambda (x) 
+             (hashq-set! *multiply-valued-primitive-table* x #t))
+           *multiply-valued-primitives*)
+ (for-each (lambda (x)
+             (hashq-set! *bailout-primitive-table* x #t))
+           *bailout-primitives*)
+ (for-each (lambda (x)
+             (hashq-set! *negatable-primitive-table* (car x) (cdr x))
+             (hashq-set! *negatable-primitive-table* (cdr x) (car x)))
+           *negatable-primitives*)
  
  (define (constructor-primitive? prim)
    (memq prim *primitive-constructors*))
@@@ -238,24 -227,14 +235,28 @@@
    (hashq-ref *effect-free-primitive-table* prim))
  (define (effect+exception-free-primitive? prim)
    (hashq-ref *effect+exceptions-free-primitive-table* prim))
- (define (singly-valued-primitive? prim)
-   (hashq-ref *singly-valued-primitive-table* prim))
 +(define (equality-primitive? prim)
 +  (hashq-ref *equality-primitive-table* prim))
+ (define (singly-valued-primitive? prim)
+   (not (hashq-ref *multiply-valued-primitive-table* prim)))
+ (define (bailout-primitive? prim)
+   (hashq-ref *bailout-primitive-table* prim))
+ (define (negate-primitive prim)
+   (hashq-ref *negatable-primitive-table* prim))
  
  (define (resolve-primitives! x mod)
 +  (define local-definitions
 +    (make-hash-table))
 +
 +  (let collect-local-definitions ((x x))
 +    (record-case x
 +      ((<toplevel-define> name)
 +       (hashq-set! local-definitions name #t))
 +      ((<seq> head tail)
 +       (collect-local-definitions head)
 +       (collect-local-definitions tail))
 +      (else #f)))
 +  
    (post-order!
     (lambda (x)
       (record-case x
diff --cc test-suite/tests/peval.test
index 000000000,400c3e7fb..310cd974e
mode 000000,100644..100644
--- a/test-suite/tests/peval.test
+++ b/test-suite/tests/peval.test
@@@ -1,0 -1,988 +1,1001 @@@
+ ;;;; tree-il.test --- test suite for compiling tree-il   -*- scheme -*-
+ ;;;; Andy Wingo <wingo@pobox.com> --- May 2009
+ ;;;;
+ ;;;; 	Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ ;;;;
+ ;;;; This library is free software; you can redistribute it and/or
+ ;;;; modify it under the terms of the GNU Lesser General Public
+ ;;;; License as published by the Free Software Foundation; either
+ ;;;; version 3 of the License, or (at your option) any later version.
+ ;;;;
+ ;;;; This library is distributed in the hope that it will be useful,
+ ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ ;;;; Lesser General Public License for more details.
+ ;;;;
+ ;;;; You should have received a copy of the GNU Lesser General Public
+ ;;;; License along with this library; if not, write to the Free Software
+ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ 
+ (define-module (test-suite tree-il)
+   #:use-module (test-suite lib)
+   #:use-module (system base compile)
+   #:use-module (system base pmatch)
+   #:use-module (system base message)
+   #:use-module (language tree-il)
+   #:use-module (language tree-il primitives)
+   #:use-module (language glil)
+   #:use-module (srfi srfi-13))
+ 
+ (define peval
+   ;; The partial evaluator.
+   (@@ (language tree-il optimize) peval))
+ 
+ (define-syntax pass-if-peval
+   (syntax-rules (resolve-primitives)
+     ((_ in pat)
 -     (pass-if-peval in pat
 -                    (compile 'in #:from 'scheme #:to 'tree-il)))
 -    ((_ resolve-primitives in pat)
+      (pass-if-peval in pat
+                     (expand-primitives!
+                      (resolve-primitives!
+                       (compile 'in #:from 'scheme #:to 'tree-il)
+                       (current-module)))))
+     ((_ in pat code)
+      (pass-if 'in
+        (let ((evaled (unparse-tree-il (peval code))))
+          (pmatch evaled
+            (pat #t)
+            (_   (pk 'peval-mismatch)
+                 ((@ (ice-9 pretty-print) pretty-print)
+                     'in)
+                 (newline)
+                 ((@ (ice-9 pretty-print) pretty-print)
+                     evaled)
+                 (newline)
+                 ((@ (ice-9 pretty-print) pretty-print)
+                     'pat)
+                 (newline)
+                 #f)))))))
+ 
+ 
+ (with-test-prefix "partial evaluation"
+ 
+   (pass-if-peval
+     ;; First order, primitive.
+     (let ((x 1) (y 2)) (+ x y))
+     (const 3))
+ 
+   (pass-if-peval
+     ;; First order, thunk.
+     (let ((x 1) (y 2))
+       (let ((f (lambda () (+ x y))))
+         (f)))
+     (const 3))
+ 
 -  (pass-if-peval resolve-primitives
++  (pass-if-peval
+     ;; First order, let-values (requires primitive expansion for
+     ;; `call-with-values'.)
+     (let ((x 0))
+       (call-with-values
+           (lambda () (if (zero? x) (values 1 2) (values 3 4)))
+         (lambda (a b)
+           (+ a b))))
+     (const 3))
+ 
 -  (pass-if-peval resolve-primitives
++  (pass-if-peval
+     ;; First order, multiple values.
+     (let ((x 1) (y 2))
+       (values x y))
 -    (apply (primitive values) (const 1) (const 2)))
++    (primcall values (const 1) (const 2)))
+ 
 -  (pass-if-peval resolve-primitives
++  (pass-if-peval
+     ;; First order, multiple values truncated.
+     (let ((x (values 1 'a)) (y 2))
+       (values x y))
 -    (apply (primitive values) (const 1) (const 2)))
++    (primcall values (const 1) (const 2)))
+ 
 -  (pass-if-peval resolve-primitives
++  (pass-if-peval
+     ;; First order, multiple values truncated.
+     (or (values 1 2) 3)
+     (const 1))
+ 
+   (pass-if-peval
+     ;; First order, coalesced, mutability preserved.
+     (cons 0 (cons 1 (cons 2 (list 3 4 5))))
 -    (apply (primitive list)
 -           (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
++    (primcall list
++              (const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
+ 
+   (pass-if-peval
+     ;; First order, coalesced, immutability preserved.
+     (cons 0 (cons 1 (cons 2 '(3 4 5))))
 -    (apply (primitive cons) (const 0)
 -           (apply (primitive cons) (const 1)
 -                  (apply (primitive cons) (const 2)
 -                         (const (3 4 5))))))
++    (primcall cons (const 0)
++              (primcall cons (const 1)
++                        (primcall cons (const 2)
++                                  (const (3 4 5))))))
+ 
+   ;; These two tests doesn't work any more because we changed the way we
+   ;; deal with constants -- now the algorithm will see a construction as
+   ;; being bound to the lexical, so it won't propagate it.  It can't
+   ;; even propagate it in the case that it is only referenced once,
+   ;; because:
+   ;;
+   ;;   (let ((x (cons 1 2))) (lambda () x))
+   ;;
+   ;; is not the same as
+   ;;
+   ;;   (lambda () (cons 1 2))
+   ;;
+   ;; Perhaps if we determined that not only was it only referenced once,
+   ;; it was not closed over by a lambda, then we could propagate it, and
+   ;; re-enable these two tests.
+   ;;
+   #;
+   (pass-if-peval
+    ;; First order, mutability preserved.
+    (let loop ((i 3) (r '()))
+      (if (zero? i)
+          r
+          (loop (1- i) (cons (cons i i) r))))
 -   (apply (primitive list)
 -          (apply (primitive cons) (const 1) (const 1))
 -          (apply (primitive cons) (const 2) (const 2))
 -          (apply (primitive cons) (const 3) (const 3))))
++   (primcall list
++             (primcall cons (const 1) (const 1))
++             (primcall cons (const 2) (const 2))
++             (primcall cons (const 3) (const 3))))
+   ;;
+   ;; See above.
+   #;
+   (pass-if-peval
+    ;; First order, evaluated.
+    (let loop ((i 7)
+               (r '()))
+      (if (<= i 0)
+          (car r)
+          (loop (1- i) (cons i r))))
+    (const 1))
+ 
+   ;; Instead here are tests for what happens for the above cases: they
+   ;; unroll but they don't fold.
+   (pass-if-peval
+    (let loop ((i 3) (r '()))
+      (if (zero? i)
+          r
+          (loop (1- i) (cons (cons i i) r))))
+    (let (r) (_)
 -        ((apply (primitive list)
 -                (apply (primitive cons) (const 3) (const 3))))
++        ((primcall list
++                   (primcall cons (const 3) (const 3))))
+         (let (r) (_)
 -             ((apply (primitive cons)
 -                     (apply (primitive cons) (const 2) (const 2))
 -                     (lexical r _)))
 -             (apply (primitive cons)
 -                    (apply (primitive cons) (const 1) (const 1))
 -                    (lexical r _)))))
++             ((primcall cons
++                        (primcall cons (const 2) (const 2))
++                        (lexical r _)))
++             (primcall cons
++                       (primcall cons (const 1) (const 1))
++                       (lexical r _)))))
+ 
+   ;; See above.
+   (pass-if-peval
+    (let loop ((i 4)
+               (r '()))
+      (if (<= i 0)
+          (car r)
+          (loop (1- i) (cons i r))))
+    (let (r) (_)
 -        ((apply (primitive list) (const 4)))
++        ((primcall list (const 4)))
+         (let (r) (_)
 -             ((apply (primitive cons)
 -                     (const 3)
 -                     (lexical r _)))
++             ((primcall cons
++                        (const 3)
++                        (lexical r _)))
+              (let (r) (_)
 -                  ((apply (primitive cons)
 -                          (const 2)
 -                          (lexical r _)))
++                  ((primcall cons
++                             (const 2)
++                             (lexical r _)))
+                   (let (r) (_)
 -                       ((apply (primitive cons)
 -                               (const 1)
 -                               (lexical r _)))
 -                       (apply (primitive car)
 -                              (lexical r _)))))))
++                       ((primcall cons
++                                  (const 1)
++                                  (lexical r _)))
++                       (primcall car
++                                 (lexical r _)))))))
+ 
+    ;; Static sums.
+   (pass-if-peval
+    (let loop ((l '(1 2 3 4)) (sum 0))
+      (if (null? l)
+          sum
+          (loop (cdr l) (+ sum (car l)))))
+    (const 10))
+ 
 -  (pass-if-peval resolve-primitives
++  (pass-if-peval
+    (let ((string->chars
+           (lambda (s)
+             (define (char-at n)
+               (string-ref s n))
+             (define (len)
+               (string-length s))
+             (let loop ((i 0))
+               (if (< i (len))
+                   (cons (char-at i)
+                         (loop (1+ i)))
+                   '())))))
+      (string->chars "yo"))
 -   (apply (primitive list) (const #\y) (const #\o)))
++   (primcall list (const #\y) (const #\o)))
+ 
+   (pass-if-peval
+     ;; Primitives in module-refs are resolved (the expansion of `pmatch'
+     ;; below leads to calls to (@@ (system base pmatch) car) and
+     ;; similar, which is what we want to be inlined.)
+     (begin
+       (use-modules (system base pmatch))
+       (pmatch '(a b c d)
+         ((a b . _)
+          #t)))
 -    (begin
 -      (apply . _)
 -      (const #t)))
++    (seq (call . _)
++         (const #t)))
+ 
+   (pass-if-peval
+    ;; Mutability preserved.
+    ((lambda (x y z) (list x y z)) 1 2 3)
 -   (apply (primitive list) (const 1) (const 2) (const 3)))
++   (primcall list (const 1) (const 2) (const 3)))
+ 
+   (pass-if-peval
+    ;; Don't propagate effect-free expressions that operate on mutable
+    ;; objects.
+    (let* ((x (list 1))
+           (y (car x)))
+      (set-car! x 0)
+      y)
 -   (let (x) (_) ((apply (primitive list) (const 1)))
 -        (let (y) (_) ((apply (primitive car) (lexical x _)))
 -             (begin
 -               (apply (toplevel set-car!) (lexical x _) (const 0))
++   (let (x) (_) ((primcall list (const 1)))
++        (let (y) (_) ((primcall car (lexical x _)))
++             (seq
++               (primcall set-car! (lexical x _) (const 0))
+                (lexical y _)))))
+   
+   (pass-if-peval
+    ;; Don't propagate effect-free expressions that operate on objects we
+    ;; don't know about.
+    (let ((y (car x)))
+      (set-car! x 0)
+      y)
 -   (let (y) (_) ((apply (primitive car) (toplevel x)))
 -        (begin
 -          (apply (toplevel set-car!) (toplevel x) (const 0))
++   (let (y) (_) ((primcall car (toplevel x)))
++        (seq
++          (primcall set-car! (toplevel x) (const 0))
+           (lexical y _))))
+   
+   (pass-if-peval
+    ;; Infinite recursion
+    ((lambda (x) (x x)) (lambda (x) (x x)))
+    (let (x) (_)
+         ((lambda _
+            (lambda-case
+             (((x) _ _ _ _ _)
 -             (apply (lexical x _) (lexical x _))))))
 -        (apply (lexical x _) (lexical x _))))
++             (call (lexical x _) (lexical x _))))))
++        (call (lexical x _) (lexical x _))))
+ 
+   (pass-if-peval
+     ;; First order, aliased primitive.
+     (let* ((x *) (y (x 1 2))) y)
+     (const 2))
+ 
+   (pass-if-peval
+     ;; First order, shadowed primitive.
+     (begin
+       (define (+ x y) (pk x y))
+       (+ 1 2))
 -    (begin
++    (seq
+       (define +
+         (lambda (_)
+           (lambda-case
+            (((x y) #f #f #f () (_ _))
 -            (apply (toplevel pk) (lexical x _) (lexical y _))))))
 -      (apply (toplevel +) (const 1) (const 2))))
++            (call (toplevel pk) (lexical x _) (lexical y _))))))
++      (call (toplevel +) (const 1) (const 2))))
+ 
+   (pass-if-peval
+     ;; First-order, effects preserved.
+     (let ((x 2))
+       (do-something!)
+       x)
 -    (begin
 -      (apply (toplevel do-something!))
++    (seq
++      (call (toplevel do-something!))
+       (const 2)))
+ 
+   (pass-if-peval
+     ;; First order, residual bindings removed.
+     (let ((x 2) (y 3))
+       (* (+ x y) z))
 -    (apply (primitive *) (const 5) (toplevel z)))
++    (primcall * (const 5) (toplevel z)))
+ 
+   (pass-if-peval
+     ;; First order, with lambda.
+     (define (foo x)
+       (define (bar z) (* z z))
+       (+ x (bar 3)))
+     (define foo
+       (lambda (_)
+         (lambda-case
+          (((x) #f #f #f () (_))
 -          (apply (primitive +) (lexical x _) (const 9)))))))
++          (primcall + (lexical x _) (const 9)))))))
+ 
+   (pass-if-peval
+     ;; First order, with lambda inlined & specialized twice.
+     (let ((f (lambda (x y)
+                (+ (* x top) y)))
+           (x 2)
+           (y 3))
+       (+ (* x (f x y))
+          (f something x)))
 -    (apply (primitive +)
 -           (apply (primitive *)
 -                  (const 2)
 -                  (apply (primitive +)  ; (f 2 3)
 -                         (apply (primitive *)
 -                                (const 2)
 -                                (toplevel top))
 -                         (const 3)))
 -           (let (x) (_) ((toplevel something))                    ; (f something 2)
 -                ;; `something' is not const, so preserve order of
 -                ;; effects with a lexical binding.
 -                (apply (primitive +)
 -                       (apply (primitive *)
 -                              (lexical x _)
 -                              (toplevel top))
 -                       (const 2)))))
++    (primcall +
++              (primcall *
++                        (const 2)
++                        (primcall +     ; (f 2 3)
++                                  (primcall *
++                                            (const 2)
++                                            (toplevel top))
++                                  (const 3)))
++              (let (x) (_) ((toplevel something)) ; (f something 2)
++                   ;; `something' is not const, so preserve order of
++                   ;; effects with a lexical binding.
++                   (primcall +
++                             (primcall *
++                                       (lexical x _)
++                                       (toplevel top))
++                             (const 2)))))
+   
+   (pass-if-peval
+    ;; First order, with lambda inlined & specialized 3 times.
+    (let ((f (lambda (x y) (if (> x 0) y x))))
+      (+ (f -1 0)
+         (f 1 0)
+         (f -1 y)
+         (f 2 y)
+         (f z y)))
 -   (apply (primitive +)
 -          (const -1)                      ; (f -1 0)
 -          (const 0)                       ; (f 1 0)
 -          (begin (toplevel y) (const -1)) ; (f -1 y)
 -          (toplevel y)                    ; (f 2 y)
 -          (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
 -               (if (apply (primitive >) (lexical x _) (const 0))
 -                   (lexical y _)
 -                   (lexical x _)))))
++   (primcall
++    +
++    (const -1)                          ; (f -1 0)
++    (primcall
++     +
++     (const 0)                          ; (f 1 0)
++     (primcall
++      +
++      (seq (toplevel y) (const -1))     ; (f -1 y)
++      (primcall
++       +
++       (toplevel y)                                 ; (f 2 y)
++       (let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
++            (if (primcall > (lexical x _) (const 0))
++                (lexical y _)
++                (lexical x _))))))))
+ 
+   (pass-if-peval
+     ;; First order, conditional.
+     (let ((y 2))
+       (lambda (x)
+         (if (> y 0)
+             (display x)
+             'never-reached)))
+     (lambda ()
+       (lambda-case
+        (((x) #f #f #f () (_))
 -        (apply (toplevel display) (lexical x _))))))
++        (call (toplevel display) (lexical x _))))))
+ 
+   (pass-if-peval
+     ;; First order, recursive procedure.
+     (letrec ((fibo (lambda (n)
+                      (if (<= n 1)
+                          n
+                          (+ (fibo (- n 1))
+                             (fibo (- n 2)))))))
+       (fibo 4))
+     (const 3))
+ 
+   (pass-if-peval
+    ;; Don't propagate toplevel references, as intervening expressions
+    ;; could alter their bindings.
+    (let ((x top))
+      (foo)
+      x)
+    (let (x) (_) ((toplevel top))
 -        (begin
 -          (apply (toplevel foo))
++        (seq
++          (call (toplevel foo))
+           (lexical x _))))
+ 
+   (pass-if-peval
+     ;; Higher order.
+     ((lambda (f x)
+        (f (* (car x) (cadr x))))
+      (lambda (x)
+        (+ x 1))
+      '(2 3))
+     (const 7))
+ 
+   (pass-if-peval
+     ;; Higher order with optional argument (default value).
+     ((lambda* (f x #:optional (y 0))
+        (+ y (f (* (car x) (cadr x)))))
+      (lambda (x)
+        (+ x 1))
+      '(2 3))
+     (const 7))
+ 
+   (pass-if-peval
+     ;; Higher order with optional argument (caller-supplied value).
+     ((lambda* (f x #:optional (y 0))
+        (+ y (f (* (car x) (cadr x)))))
+      (lambda (x)
+        (+ x 1))
+      '(2 3)
+      35)
+     (const 42))
+ 
+   (pass-if-peval
+     ;; Higher order with optional argument (side-effecting default
+     ;; value).
+     ((lambda* (f x #:optional (y (foo)))
+        (+ y (f (* (car x) (cadr x)))))
+      (lambda (x)
+        (+ x 1))
+      '(2 3))
 -    (let (y) (_) ((apply (toplevel foo)))
 -         (apply (primitive +) (lexical y _) (const 7))))
++    (let (y) (_) ((call (toplevel foo)))
++         (primcall + (lexical y _) (const 7))))
+ 
+   (pass-if-peval
+     ;; Higher order with optional argument (caller-supplied value).
+     ((lambda* (f x #:optional (y (foo)))
+        (+ y (f (* (car x) (cadr x)))))
+      (lambda (x)
+        (+ x 1))
+      '(2 3)
+      35)
+     (const 42))
+ 
+   (pass-if-peval
+     ;; Higher order.
+     ((lambda (f) (f x)) (lambda (x) x))
+     (toplevel x))
+ 
+   (pass-if-peval
+     ;; Bug reported at
+     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
+     (let ((fold (lambda (f g) (f (g top)))))
+       (fold 1+ (lambda (x) x)))
 -    (apply (primitive 1+) (toplevel top)))
++    (primcall 1+ (toplevel top)))
+   
+   (pass-if-peval
+     ;; Procedure not inlined when residual code contains recursive calls.
+     ;; <http://debbugs.gnu.org/9542>
+     (letrec ((fold (lambda (f x3 b null? car cdr)
+                      (if (null? x3)
+                          b
+                          (f (car x3) (fold f (cdr x3) b null? car cdr))))))
+       (fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
+     (letrec (fold) (_) (_)
 -            (apply (lexical fold _)
++            (call (lexical fold _)
+                    (primitive *)
+                    (toplevel x)
+                    (const 1)
+                    (primitive zero?)
+                    (lambda ()
+                      (lambda-case
+                       (((x1) #f #f #f () (_))
+                        (lexical x1 _))))
+                    (lambda ()
+                      (lambda-case
+                       (((x2) #f #f #f () (_))
 -                       (apply (primitive -) (lexical x2 _) (const 1))))))))
++                       (primcall 1- (lexical x2 _))))))))
+ 
+   (pass-if "inlined lambdas are alpha-renamed"
+     ;; In this example, `make-adder' is inlined more than once; thus,
+     ;; they should use different gensyms for their arguments, because
+     ;; the various optimization passes assume uniquely-named variables.
+     ;;
+     ;; Bug reported at
+     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
+     ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
+     (pmatch (unparse-tree-il
 -             (peval (compile
 -                     '(let ((make-adder
 -                             (lambda (x) (lambda (y) (+ x y)))))
 -                        (cons (make-adder 1) (make-adder 2)))
 -                     #:to 'tree-il)))
 -      ((apply (primitive cons)
 -              (lambda ()
 -                (lambda-case
 -                 (((y) #f #f #f () (,gensym1))
 -                  (apply (primitive +)
 -                         (const 1)
 -                         (lexical y ,ref1)))))
 -              (lambda ()
 -                (lambda-case
 -                 (((y) #f #f #f () (,gensym2))
 -                  (apply (primitive +)
 -                         (const 2)
 -                         (lexical y ,ref2))))))
++             (peval (expand-primitives!
++                     (resolve-primitives!
++                      (compile
++                       '(let ((make-adder
++                               (lambda (x) (lambda (y) (+ x y)))))
++                          (cons (make-adder 1) (make-adder 2)))
++                       #:to 'tree-il)
++                      (current-module)))))
++      ((primcall cons
++                 (lambda ()
++                   (lambda-case
++                    (((y) #f #f #f () (,gensym1))
++                     (primcall +
++                               (const 1)
++                               (lexical y ,ref1)))))
++                 (lambda ()
++                   (lambda-case
++                    (((y) #f #f #f () (,gensym2))
++                     (primcall +
++                               (const 2)
++                               (lexical y ,ref2))))))
+        (and (eq? gensym1 ref1)
+             (eq? gensym2 ref2)
+             (not (eq? gensym1 gensym2))))
+       (_ #f)))
+ 
+   (pass-if-peval
+    ;; Unused letrec bindings are pruned.
+    (letrec ((a (lambda () (b)))
+             (b (lambda () (a)))
+             (c (lambda (x) x)))
+      (c 10))
+    (const 10))
+ 
+   (pass-if-peval
+    ;; Unused letrec bindings are pruned.
+    (letrec ((a (foo!))
+             (b (lambda () (a)))
+             (c (lambda (x) x)))
+      (c 10))
 -   (begin (apply (toplevel foo!))
 -          (const 10)))
++   (seq (call (toplevel foo!))
++        (const 10)))
+ 
+   (pass-if-peval
+     ;; Higher order, mutually recursive procedures.
+     (letrec ((even? (lambda (x)
+                       (or (= 0 x)
+                           (odd? (- x 1)))))
+              (odd?  (lambda (x)
+                       (not (even? x)))))
+       (and (even? 4) (odd? 7)))
+     (const #t))
+ 
+   (pass-if-peval
+     ;; Memv with constants.
+     (memv 1 '(3 2 1))
+     (const '(1)))
+ 
+   (pass-if-peval
+     ;; Memv with non-constant list.  It could fold but doesn't
+     ;; currently.
+     (memv 1 (list 3 2 1))
 -    (apply (primitive memv)
 -           (const 1)
 -           (apply (primitive list) (const 3) (const 2) (const 1))))
++    (primcall memv
++              (const 1)
++              (primcall list (const 3) (const 2) (const 1))))
+ 
+   (pass-if-peval
+     ;; Memv with non-constant key, constant list, test context
+     (case foo
+       ((3 2 1) 'a)
+       (else 'b))
+     (let (key) (_) ((toplevel foo))
 -         (if (if (apply (primitive eqv?) (lexical key _) (const 3))
++         (if (if (primcall eqv? (lexical key _) (const 3))
+                  (const #t)
 -                 (if (apply (primitive eqv?) (lexical key _) (const 2))
++                 (if (primcall eqv? (lexical key _) (const 2))
+                      (const #t)
 -                     (apply (primitive eqv?) (lexical key _) (const 1))))
++                     (primcall eqv? (lexical key _) (const 1))))
+              (const a)
+              (const b))))
+ 
+   (pass-if-peval
 -    ;; Memv with non-constant key, empty list, test context.  Currently
 -    ;; doesn't fold entirely.
++    ;; Memv with non-constant key, empty list, test context.
+     (case foo
+       (() 'a)
+       (else 'b))
 -    (begin (toplevel foo) (const b)))
++    (seq (toplevel foo) (const 'b)))
+ 
+   ;;
+   ;; Below are cases where constant propagation should bail out.
+   ;;
+ 
+   (pass-if-peval
+     ;; Non-constant lexical is not propagated.
+     (let ((v (make-vector 6 #f)))
+       (lambda (n)
+         (vector-set! v n n)))
+     (let (v) (_)
 -         ((apply (toplevel make-vector) (const 6) (const #f)))
++         ((call (toplevel make-vector) (const 6) (const #f)))
+          (lambda ()
+            (lambda-case
+             (((n) #f #f #f () (_))
 -             (apply (toplevel vector-set!)
 -                    (lexical v _) (lexical n _) (lexical n _)))))))
++             (primcall vector-set!
++                       (lexical v _) (lexical n _) (lexical n _)))))))
+ 
+   (pass-if-peval
+     ;; Mutable lexical is not propagated.
+     (let ((v (vector 1 2 3)))
+       (lambda ()
+         v))
+     (let (v) (_)
 -         ((apply (primitive vector) (const 1) (const 2) (const 3)))
++         ((primcall vector (const 1) (const 2) (const 3)))
+          (lambda ()
+            (lambda-case
+             ((() #f #f #f () ())
+              (lexical v _))))))
+ 
+   (pass-if-peval
+     ;; Lexical that is not provably pure is not inlined nor propagated.
+     (let* ((x (if (> p q) (frob!) (display 'chbouib)))
+            (y (* x 2)))
+       (+ x x y))
 -    (let (x) (_) ((if (apply (primitive >) (toplevel p) (toplevel q))
 -                      (apply (toplevel frob!))
 -                      (apply (toplevel display) (const chbouib))))
 -         (let (y) (_) ((apply (primitive *) (lexical x _) (const 2)))
 -              (apply (primitive +)
 -                     (lexical x _) (lexical x _) (lexical y _)))))
++    (let (x) (_) ((if (primcall > (toplevel p) (toplevel q))
++                      (call (toplevel frob!))
++                      (call (toplevel display) (const chbouib))))
++         (let (y) (_) ((primcall * (lexical x _) (const 2)))
++              (primcall +
++                        (lexical x _)
++                        (primcall + (lexical x _) (lexical y _))))))
+ 
+   (pass-if-peval
+     ;; Non-constant arguments not propagated to lambdas.
+     ((lambda (x y z)
+        (vector-set! x 0 0)
+        (set-car! y 0)
+        (set-cdr! z '()))
+      (vector 1 2 3)
+      (make-list 10)
+      (list 1 2 3))
+     (let (x y z) (_ _ _)
 -         ((apply (primitive vector) (const 1) (const 2) (const 3))
 -          (apply (toplevel make-list) (const 10))
 -          (apply (primitive list) (const 1) (const 2) (const 3)))
 -         (begin
 -           (apply (toplevel vector-set!)
 -                  (lexical x _) (const 0) (const 0))
 -           (apply (toplevel set-car!)
 -                  (lexical y _) (const 0))
 -           (apply (toplevel set-cdr!)
 -                  (lexical z _) (const ())))))
++         ((primcall vector (const 1) (const 2) (const 3))
++          (call (toplevel make-list) (const 10))
++          (primcall list (const 1) (const 2) (const 3)))
++         (seq
++           (primcall vector-set!
++                     (lexical x _) (const 0) (const 0))
++           (seq (primcall set-car!
++                          (lexical y _) (const 0))
++                (primcall set-cdr!
++                          (lexical z _) (const ()))))))
+ 
+   (pass-if-peval
+    (let ((foo top-foo) (bar top-bar))
+      (let* ((g (lambda (x y) (+ x y)))
+             (f (lambda (g x) (g x x))))
+        (+ (f g foo) (f g bar))))
+    (let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
 -        (apply (primitive +)
 -               (apply (primitive +) (lexical foo _) (lexical foo _))
 -               (apply (primitive +) (lexical bar _) (lexical bar _)))))
++        (primcall +
++                  (primcall + (lexical foo _) (lexical foo _))
++                  (primcall + (lexical bar _) (lexical bar _)))))
+ 
+   (pass-if-peval
+     ;; Fresh objects are not turned into constants, nor are constants
+     ;; turned into fresh objects.
+     (let* ((c '(2 3))
+            (x (cons 1 c))
+            (y (cons 0 x)))
+       y)
 -    (let (x) (_) ((apply (primitive cons) (const 1) (const (2 3))))
 -         (apply (primitive cons) (const 0) (lexical x _))))
++    (let (x) (_) ((primcall cons (const 1) (const (2 3))))
++         (primcall cons (const 0) (lexical x _))))
+ 
+   (pass-if-peval
+     ;; Bindings mutated.
+     (let ((x 2))
+       (set! x 3)
+       x)
+     (let (x) (_) ((const 2))
 -         (begin
++         (seq
+            (set! (lexical x _) (const 3))
+            (lexical x _))))
+ 
+   (pass-if-peval
+     ;; Bindings mutated.
+     (letrec ((x 0)
+              (f (lambda ()
+                   (set! x (+ 1 x))
+                   x)))
+       (frob f) ; may mutate `x'
+       x)
+     (letrec (x) (_) ((const 0))
 -            (begin
 -              (apply (toplevel frob) (lambda _ _))
++            (seq
++              (call (toplevel frob) (lambda _ _))
+               (lexical x _))))
+ 
+   (pass-if-peval
+     ;; Bindings mutated.
+     (letrec ((f (lambda (x)
+                   (set! f (lambda (_) x))
+                   x)))
+       (f 2))
+     (letrec _ . _))
+ 
+   (pass-if-peval
+     ;; Bindings possibly mutated.
+     (let ((x (make-foo)))
+       (frob! x) ; may mutate `x'
+       x)
 -    (let (x) (_) ((apply (toplevel make-foo)))
 -         (begin
 -           (apply (toplevel frob!) (lexical x _))
++    (let (x) (_) ((call (toplevel make-foo)))
++         (seq
++           (call (toplevel frob!) (lexical x _))
+            (lexical x _))))
+ 
+   (pass-if-peval
+     ;; Inlining stops at recursive calls with dynamic arguments.
+     (let loop ((x x))
+       (if (< x 0) x (loop (1- x))))
+     (letrec (loop) (_) ((lambda (_)
+                           (lambda-case
+                            (((x) #f #f #f () (_))
+                             (if _ _
 -                                (apply (lexical loop _)
 -                                       (apply (primitive 1-)
 -                                              (lexical x _))))))))
 -            (apply (lexical loop _) (toplevel x))))
++                                (call (lexical loop _)
++                                       (primcall 1-
++                                                 (lexical x _))))))))
++            (call (lexical loop _) (toplevel x))))
+ 
+   (pass-if-peval
+     ;; Recursion on the 2nd argument is fully evaluated.
+     (let ((x (top)))
+       (let loop ((x x) (y 10))
+         (if (> y 0)
+             (loop x (1- y))
+             (foo x y))))
 -    (let (x) (_) ((apply (toplevel top)))
 -         (apply (toplevel foo) (lexical x _) (const 0))))
++    (let (x) (_) ((call (toplevel top)))
++         (call (toplevel foo) (lexical x _) (const 0))))
+ 
+   (pass-if-peval
+     ;; Inlining aborted when residual code contains recursive calls.
+     ;;
+     ;; <http://debbugs.gnu.org/9542>
+     (let loop ((x x) (y 0))
+       (if (> y 0)
+           (loop (1- x) (1- y))
+           (if (< x 0)
+               x
+               (loop (1+ x) (1+ y)))))
+     (letrec (loop) (_) ((lambda (_)
+                           (lambda-case
+                            (((x y) #f #f #f () (_ _))
 -                            (if (apply (primitive >)
 -                                       (lexical y _) (const 0))
++                            (if (primcall >
++                                          (lexical y _) (const 0))
+                                 _ _)))))
 -            (apply (lexical loop _) (toplevel x) (const 0))))
++            (call (lexical loop _) (toplevel x) (const 0))))
+ 
+   (pass-if-peval
+     ;; Infinite recursion: `peval' gives up and leaves it as is.
+     (letrec ((f (lambda (x) (g (1- x))))
+              (g (lambda (x) (h (1+ x))))
+              (h (lambda (x) (f x))))
+       (f 0))
+     (letrec _ . _))
+ 
+   (pass-if-peval
+     ;; Infinite recursion: all the arguments to `loop' are static, but
+     ;; unrolling it would lead `peval' to enter an infinite loop.
+     (let loop ((x 0))
+       (and (< x top)
+            (loop (1+ x))))
+     (letrec (loop) (_) ((lambda . _))
 -            (apply (lexical loop _) (const 0))))
++            (call (lexical loop _) (const 0))))
+ 
+   (pass-if-peval
+     ;; This test checks that the `start' binding is indeed residualized.
+     ;; See the `referenced?' procedure in peval's `prune-bindings'.
+     (let ((pos 0))
+       (set! pos 1) ;; Cause references to `pos' to residualize.
+       (let ((here (let ((start pos)) (lambda () start))))
+         (here)))
+     (let (pos) (_) ((const 0))
 -         (begin
++         (seq
+            (set! (lexical pos _) (const 1))
+            (let (here) (_) (_)
 -                (apply (lexical here _))))))
++                (call (lexical here _))))))
+   
+   (pass-if-peval
+    ;; FIXME: should this one residualize the binding?
+    (letrec ((a a))
+      1)
+    (const 1))
+ 
+   (pass-if-peval
+    ;; This is a fun one for peval to handle.
+    (letrec ((a a))
+      a)
+    (letrec (a) (_) ((lexical a _))
+            (lexical a _)))
+ 
+   (pass-if-peval
+    ;; Another interesting recursive case.
+    (letrec ((a b) (b a))
+      a)
+    (letrec (a) (_) ((lexical a _))
+            (lexical a _)))
+ 
+   (pass-if-peval
+    ;; Another pruning case, that `a' is residualized.
+    (letrec ((a (lambda () (a)))
+             (b (lambda () (a)))
+             (c (lambda (x) x)))
+      (let ((d (foo b)))
+        (c d)))
+ 
+    ;; "b c a" is the current order that we get with unordered letrec,
+    ;; but it's not important to this test, so if it changes, just adapt
+    ;; the test.
+    (letrec (b c a) (_ _ _)
+      ((lambda _
+         (lambda-case
+          ((() #f #f #f () ())
 -          (apply (lexical a _)))))
++          (call (lexical a _)))))
+       (lambda _
+         (lambda-case
+          (((x) #f #f #f () (_))
+           (lexical x _))))
+       (lambda _
+         (lambda-case
+          ((() #f #f #f () ())
 -          (apply (lexical a _))))))
++          (call (lexical a _))))))
+      (let (d)
+        (_)
 -       ((apply (toplevel foo) (lexical b _)))
 -       (apply (lexical c _)
 -              (lexical d _)))))
++       ((call (toplevel foo) (lexical b _)))
++       (call (lexical c _) (lexical d _)))))
+ 
+   (pass-if-peval
+    ;; In this case, we can prune the bindings.  `a' ends up being copied
+    ;; because it is only referenced once in the source program.  Oh
+    ;; well.
+    (letrec* ((a (lambda (x) (top x)))
+              (b (lambda () a)))
+      (foo (b) (b)))
 -   (apply (toplevel foo)
 -          (lambda _
 -            (lambda-case
 -             (((x) #f #f #f () (_))
 -              (apply (toplevel top) (lexical x _)))))
 -          (lambda _
 -            (lambda-case
 -             (((x) #f #f #f () (_))
 -              (apply (toplevel top) (lexical x _)))))))
++   (call (toplevel foo)
++         (lambda _
++           (lambda-case
++            (((x) #f #f #f () (_))
++             (call (toplevel top) (lexical x _)))))
++         (lambda _
++           (lambda-case
++            (((x) #f #f #f () (_))
++             (call (toplevel top) (lexical x _)))))))
+   
+   (pass-if-peval
+    ;; Constant folding: cons of #nil does not make list
+    (cons 1 #nil)
 -   (apply (primitive cons) (const 1) (const '#nil)))
++   (primcall cons (const 1) (const '#nil)))
+   
+   (pass-if-peval
+     ;; Constant folding: cons
+    (begin (cons 1 2) #f)
+    (const #f))
+   
+   (pass-if-peval
+     ;; Constant folding: cons
+    (begin (cons (foo) 2) #f)
 -   (begin (apply (toplevel foo)) (const #f)))
++   (seq (call (toplevel foo)) (const #f)))
+   
+   (pass-if-peval
+     ;; Constant folding: cons
+    (if (cons 0 0) 1 2)
+    (const 1))
+   
+   (pass-if-peval
+    ;; Constant folding: car+cons
+    (car (cons 1 0))
+    (const 1))
+   
+   (pass-if-peval
+    ;; Constant folding: cdr+cons
+    (cdr (cons 1 0))
+    (const 0))
+   
+   (pass-if-peval
+    ;; Constant folding: car+cons, impure
+    (car (cons 1 (bar)))
 -   (begin (apply (toplevel bar)) (const 1)))
++   (seq (call (toplevel bar)) (const 1)))
+   
+   (pass-if-peval
+    ;; Constant folding: cdr+cons, impure
+    (cdr (cons (bar) 0))
 -   (begin (apply (toplevel bar)) (const 0)))
++   (seq (call (toplevel bar)) (const 0)))
+   
+   (pass-if-peval
+    ;; Constant folding: car+list
+    (car (list 1 0))
+    (const 1))
+   
+   (pass-if-peval
+    ;; Constant folding: cdr+list
+    (cdr (list 1 0))
 -   (apply (primitive list) (const 0)))
++   (primcall list (const 0)))
+   
+   (pass-if-peval
+    ;; Constant folding: car+list, impure
+    (car (list 1 (bar)))
 -   (begin (apply (toplevel bar)) (const 1)))
++   (seq (call (toplevel bar)) (const 1)))
+   
+   (pass-if-peval
+    ;; Constant folding: cdr+list, impure
+    (cdr (list (bar) 0))
 -   (begin (apply (toplevel bar)) (apply (primitive list) (const 0))))
++   (seq (call (toplevel bar)) (primcall list (const 0))))
++
++  (pass-if-peval
++   ;; Equality primitive: same lexical
++   (let ((x (random))) (eq? x x))
++   (seq (call (toplevel random)) (const #t)))
++
++  (pass-if-peval
++   ;; Equality primitive: merge lexical identities
++   (let* ((x (random)) (y x)) (eq? x y))
++   (seq (call (toplevel random)) (const #t)))
+   
+   (pass-if-peval
 -   resolve-primitives
+    ;; Non-constant guards get lexical bindings.
+    (dynamic-wind foo (lambda () bar) baz)
 -   (let (pre post) (_ _) ((toplevel foo) (toplevel baz))
 -        (dynwind (lexical pre _) (toplevel bar) (lexical post _))))
++   (let (w u) (_ _) ((toplevel foo) (toplevel baz))
++        (dynwind (lexical w _)
++                 (call (lexical w _))
++                 (toplevel bar)
++                 (call (lexical u _))
++                 (lexical u _))))
+   
+   (pass-if-peval
 -   resolve-primitives
+    ;; Constant guards don't need lexical bindings.
+    (dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
+    (dynwind
+     (lambda ()
+       (lambda-case
+        ((() #f #f #f () ()) (toplevel foo))))
++    (toplevel foo)
+     (toplevel bar)
++    (toplevel baz)
+     (lambda ()
+       (lambda-case
+        ((() #f #f #f () ()) (toplevel baz))))))
+   
+   (pass-if-peval
 -   resolve-primitives
+    ;; Prompt is removed if tag is unreferenced
+    (let ((tag (make-prompt-tag)))
+      (call-with-prompt tag
+                        (lambda () 1)
+                        (lambda args args)))
+    (const 1))
+   
+   (pass-if-peval
 -   resolve-primitives
+    ;; Prompt is removed if tag is unreferenced, with explicit stem
+    (let ((tag (make-prompt-tag "foo")))
+      (call-with-prompt tag
+                        (lambda () 1)
+                        (lambda args args)))
+    (const 1))
+ 
+   ;; Handler lambda inlined
+   (pass-if-peval
 -   resolve-primitives
+    (call-with-prompt tag
+                      (lambda () 1)
+                      (lambda (k x) x))
+    (prompt (toplevel tag)
+            (const 1)
+            (lambda-case
+             (((k x) #f #f #f () (_ _))
+              (lexical x _)))))
+ 
+   ;; Handler toplevel not inlined
+   (pass-if-peval
 -   resolve-primitives
+    (call-with-prompt tag
+                      (lambda () 1)
+                      handler)
+    (let (handler) (_) ((toplevel handler))
+         (prompt (toplevel tag)
+                 (const 1)
+                 (lambda-case
+                  ((() #f args #f () (_))
 -                  (apply (primitive @apply)
 -                         (lexical handler _)
 -                         (lexical args _)))))))
++                  (primcall @apply
++                            (lexical handler _)
++                            (lexical args _)))))))
+ 
+   (pass-if-peval
 -   resolve-primitives
+    ;; `while' without `break' or `continue' has no prompts and gets its
+    ;; condition folded.  Unfortunately the outer `lp' does not yet get
+    ;; elided.
+    (while #t #t)
+    (letrec (lp) (_)
+            ((lambda _
+               (lambda-case
+                ((() #f #f #f () ())
+                 (letrec (loop) (_)
+                         ((lambda _
+                            (lambda-case
+                             ((() #f #f #f () ())
 -                             (apply (lexical loop _))))))
 -                        (apply (lexical loop _)))))))
 -           (apply (lexical lp _))))
++                             (call (lexical loop _))))))
++                        (call (lexical loop _)))))))
++           (call (lexical lp _))))
+ 
+   (pass-if-peval
 -   resolve-primitives
+    (lambda (a . rest)
+      (apply (lambda (x y) (+ x y))
+             a rest))
+    (lambda _
+      (lambda-case
+       (((x y) #f #f #f () (_ _))
+        _))))
+ 
 -  (pass-if-peval resolve-primitives
++  (pass-if-peval
+     (car '(1 2))
+     (const 1)))