diff options
Diffstat (limited to 'test-suite/tests/tree-il.test')
-rw-r--r-- | test-suite/tests/tree-il.test | 475 |
1 files changed, 241 insertions, 234 deletions
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 5e02bd175..8d125f52b 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -74,12 +74,9 @@ (@@ (language tree-il optimize) peval)) (define-syntax pass-if-peval - (syntax-rules (resolve-primitives) + (syntax-rules () ((_ 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) @@ -116,15 +113,15 @@ (begin (void) (const 1)) (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1))) (assert-tree-il->glil - (apply (primitive +) (void) (const 1)) + (primcall + (void) (const 1)) (program () (std-prelude 0 0 #f) (label _) (void) (call add1 1) (call return 1)))) (with-test-prefix "application" (assert-tree-il->glil - (apply (toplevel foo) (const 1)) + (call (toplevel foo) (const 1)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (const 1) (call tail-call 1))) (assert-tree-il->glil - (begin (apply (toplevel foo) (const 1)) (void)) + (begin (call (toplevel foo) (const 1)) (void)) (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) @@ -132,7 +129,7 @@ (void) (call return 1)) (and (eq? l1 l3) (eq? l2 l4))) (assert-tree-il->glil - (apply (toplevel foo) (apply (toplevel bar))) + (call (toplevel foo) (call (toplevel bar))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0) (call tail-call 1)))) @@ -151,7 +148,7 @@ (eq? l1 l3) (eq? l2 l4)) (assert-tree-il->glil - (apply (primitive null?) (if (toplevel foo) (const 1) (const 2))) + (primcall null? (if (toplevel foo) (const 1) (const 2))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (const 1) (branch br ,l2) (label ,l3) (const 2) (label ,l4) @@ -168,7 +165,7 @@ (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (primitive +)) + (primcall null? (primitive +)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref +) (call null? 1) (call return 1)))) @@ -188,7 +185,7 @@ (unbind))) (assert-tree-il->glil without-partial-evaluation - (let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y))) + (let (x) (y) ((const 1)) (primcall null? (lexical x y))) (program () (std-prelude 0 1 #f) (label _) (const 1) (bind (x #f 0)) (lexical #t #f set 0) (lexical #t #f ref 0) (call null? 1) (call return 1) @@ -198,7 +195,7 @@ (assert-tree-il->glil ;; unreferenced sets may be optimized away -- make sure they are ref'd (let (x) (y) ((const 1)) - (set! (lexical x y) (apply (primitive 1+) (lexical x y)))) + (set! (lexical x y) (primcall 1+ (lexical x y)))) (program () (std-prelude 0 1 #f) (label _) (const 1) (bind (x #t 0)) (lexical #t #t box 0) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) @@ -207,7 +204,7 @@ (assert-tree-il->glil (let (x) (y) ((const 1)) - (begin (set! (lexical x y) (apply (primitive 1+) (lexical x y))) + (begin (set! (lexical x y) (primcall 1+ (lexical x y))) (lexical x y))) (program () (std-prelude 0 1 #f) (label _) (const 1) (bind (x #t 0)) (lexical #t #t box 0) @@ -217,8 +214,8 @@ (assert-tree-il->glil (let (x) (y) ((const 1)) - (apply (primitive null?) - (set! (lexical x y) (apply (primitive 1+) (lexical x y))))) + (primcall null? + (set! (lexical x y) (primcall 1+ (lexical x y))))) (program () (std-prelude 0 1 #f) (label _) (const 1) (bind (x #t 0)) (lexical #t #t box 0) (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) (void) @@ -239,7 +236,7 @@ (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (@ (foo) bar)) + (primcall null? (@ (foo) bar)) (program () (std-prelude 0 0 #f) (label _) (module public ref (foo) bar) (call null? 1) (call return 1))) @@ -257,7 +254,7 @@ (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (@@ (foo) bar)) + (primcall null? (@@ (foo) bar)) (program () (std-prelude 0 0 #f) (label _) (module private ref (foo) bar) (call null? 1) (call return 1)))) @@ -276,7 +273,7 @@ (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (set! (@ (foo) bar) (const 2))) + (primcall null? (set! (@ (foo) bar) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 2) (module public set (foo) bar) (void) (call null? 1) (call return 1))) @@ -294,7 +291,7 @@ (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (set! (@@ (foo) bar) (const 2))) + (primcall null? (set! (@@ (foo) bar) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 2) (module private set (foo) bar) (void) (call null? 1) (call return 1)))) @@ -313,7 +310,7 @@ (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (toplevel bar)) + (primcall null? (toplevel bar)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref bar) (call null? 1) (call return 1)))) @@ -332,7 +329,7 @@ (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (set! (toplevel bar) (const 2))) + (primcall null? (set! (toplevel bar) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 2) (toplevel set bar) (void) (call null? 1) (call return 1)))) @@ -351,7 +348,7 @@ (const #f) (call return 1))) (assert-tree-il->glil - (apply (primitive null?) (define bar (const 2))) + (primcall null? (define bar (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 2) (toplevel define bar) (void) (call null? 1) (call return 1)))) @@ -369,7 +366,7 @@ (assert-tree-il->glil ;; This gets simplified by `peval'. - (apply (primitive null?) (const 2)) + (primcall null? (const 2)) (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))) @@ -377,7 +374,7 @@ ;; simple bindings -> let (assert-tree-il->glil without-partial-evaluation (letrec (x y) (x1 y1) ((const 10) (const 20)) - (apply (toplevel foo) (lexical x x1) (lexical y y1))) + (call (toplevel foo) (lexical x x1) (lexical y y1))) (program () (std-prelude 0 2 #f) (label _) (const 10) (const 20) (bind (x #f 0) (y #f 1)) @@ -389,8 +386,8 @@ ;; complex bindings -> box and set! within let (assert-tree-il->glil without-partial-evaluation - (letrec (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar))) - (apply (primitive +) (lexical x x1) (lexical y y1))) + (letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar))) + (primcall + (lexical x x1) (lexical y y1))) (program () (std-prelude 0 4 #f) (label _) (void) (void) ;; what are these? (bind (x #t 0) (y #t 1)) @@ -407,8 +404,8 @@ ;; complex bindings in letrec* -> box and set! in order (assert-tree-il->glil without-partial-evaluation - (letrec* (x y) (x1 y1) ((apply (toplevel foo)) (apply (toplevel bar))) - (apply (primitive +) (lexical x x1) (lexical y y1))) + (letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar))) + (primcall + (lexical x x1) (lexical y y1))) (program () (std-prelude 0 2 #f) (label _) (void) (void) ;; what are these? (bind (x #t 0) (y #t 1)) @@ -527,27 +524,27 @@ (assert-tree-il->glil ;; This gets simplified by `peval'. - (apply (primitive null?) (begin (const #f) (const 2))) + (primcall null? (begin (const #f) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1)))) (with-test-prefix "values" (assert-tree-il->glil - (apply (primitive values) - (apply (primitive values) (const 1) (const 2))) + (primcall values + (primcall values (const 1) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1))) (assert-tree-il->glil - (apply (primitive values) - (apply (primitive values) (const 1) (const 2)) - (const 3)) + (primcall values + (primcall values (const 1) (const 2)) + (const 3)) (program () (std-prelude 0 0 #f) (label _) (const 1) (const 3) (call return/values 2))) (assert-tree-il->glil - (apply (primitive +) - (apply (primitive values) (const 1) (const 2))) + (primcall + + (primcall values (const 1) (const 2))) (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1)))) @@ -589,10 +586,10 @@ (with-test-prefix "apply" (assert-tree-il->glil - (apply (primitive @apply) (toplevel foo) (toplevel bar)) + (primcall @apply (toplevel foo) (toplevel bar)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call tail-apply 2))) (assert-tree-il->glil - (begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void)) + (begin (primcall @apply (toplevel foo) (toplevel bar)) (void)) (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) @@ -600,7 +597,7 @@ (void) (call return 1)) (and (eq? l1 l3) (eq? l2 l4))) (assert-tree-il->glil - (apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz))) + (call (toplevel foo) (call (toplevel @apply) (toplevel bar) (toplevel baz))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2) @@ -608,10 +605,10 @@ (with-test-prefix "call/cc" (assert-tree-il->glil - (apply (primitive @call-with-current-continuation) (toplevel foo)) + (primcall @call-with-current-continuation (toplevel foo)) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (call tail-call/cc 1))) (assert-tree-il->glil - (begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void)) + (begin (primcall @call-with-current-continuation (toplevel foo)) (void)) (program () (std-prelude 0 0 #f) (label _) (call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1) (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) @@ -619,8 +616,8 @@ (void) (call return 1)) (and (eq? l1 l3) (eq? l2 l4))) (assert-tree-il->glil - (apply (toplevel foo) - (apply (toplevel @call-with-current-continuation) (toplevel bar))) + (call (toplevel foo) + (call (toplevel @call-with-current-continuation) (toplevel bar))) (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (toplevel ref bar) (call call/cc 1) @@ -654,7 +651,7 @@ (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)) @@ -667,23 +664,23 @@ (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, mutability preserved. (cons 0 (cons 1 (cons 2 (list 3 4 5)))) ;; This must not be a constant. - (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 @@ -708,10 +705,10 @@ (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. #; @@ -732,15 +729,15 @@ 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 @@ -750,21 +747,21 @@ (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 @@ -774,7 +771,7 @@ (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) @@ -787,7 +784,7 @@ (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' @@ -798,14 +795,13 @@ (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 @@ -814,10 +810,10 @@ (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 @@ -826,9 +822,9 @@ (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 @@ -838,8 +834,8 @@ ((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. @@ -851,28 +847,28 @@ (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. @@ -883,7 +879,7 @@ (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. @@ -893,22 +889,22 @@ (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. @@ -918,15 +914,22 @@ (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. @@ -938,7 +941,7 @@ (lambda () (lambda-case (((x) #f #f #f () (_)) - (apply (toplevel display) (lexical x _)))))) + (call (toplevel display) (lexical x _)))))) (pass-if-peval ;; First order, recursive procedure. @@ -957,8 +960,8 @@ (foo) x) (let (x) (_) ((toplevel top)) - (begin - (apply (toplevel foo)) + (seq + (call (toplevel foo)) (lexical x _)))) (pass-if-peval @@ -997,8 +1000,8 @@ (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). @@ -1020,7 +1023,7 @@ ;; <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. @@ -1031,7 +1034,7 @@ (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) @@ -1043,7 +1046,7 @@ (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, @@ -1054,24 +1057,27 @@ ;; <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)))) @@ -1091,8 +1097,8 @@ (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. @@ -1113,9 +1119,9 @@ ;; 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 @@ -1123,11 +1129,11 @@ ((3 2 1) 'a) (else 'b)) (if (let (t) (_) ((toplevel foo)) - (if (apply (primitive eqv?) (lexical t _) (const 3)) + (if (primcall eqv? (lexical t _) (const 3)) (const #t) - (if (apply (primitive eqv?) (lexical t _) (const 2)) + (if (primcall eqv? (lexical t _) (const 2)) (const #t) - (apply (primitive eqv?) (lexical t _) (const 1))))) + (primcall eqv? (lexical t _) (const 1))))) (const a) (const b))) @@ -1137,7 +1143,7 @@ (case foo (() 'a) (else 'b)) - (if (begin (toplevel foo) (const #f)) + (if (seq (toplevel foo) (const #f)) (const a) (const b))) @@ -1151,12 +1157,12 @@ (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. @@ -1164,7 +1170,7 @@ (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 () ()) @@ -1175,12 +1181,13 @@ (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. @@ -1192,16 +1199,16 @@ (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)) @@ -1209,9 +1216,9 @@ (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 @@ -1220,8 +1227,8 @@ (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. @@ -1229,7 +1236,7 @@ (set! x 3) x) (let (x) (_) ((const 2)) - (begin + (seq (set! (lexical x _) (const 3)) (lexical x _)))) @@ -1242,8 +1249,8 @@ (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 @@ -1259,9 +1266,9 @@ (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 @@ -1272,10 +1279,10 @@ (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. @@ -1284,8 +1291,8 @@ (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. @@ -1300,10 +1307,10 @@ (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. @@ -1320,7 +1327,7 @@ (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. @@ -1330,10 +1337,10 @@ (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? @@ -1370,7 +1377,7 @@ ((lambda _ (lambda-case ((() #f #f #f () ()) - (apply (lexical a _))))) + (call (lexical a _))))) (lambda _ (lambda-case (((x) #f #f #f () (_)) @@ -1378,12 +1385,11 @@ (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 @@ -1392,15 +1398,15 @@ (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 @@ -1410,7 +1416,7 @@ (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 @@ -1430,12 +1436,12 @@ (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 @@ -1445,40 +1451,43 @@ (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 - 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 @@ -1487,7 +1496,6 @@ (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 @@ -1496,7 +1504,6 @@ (const 1)) (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. @@ -1509,9 +1516,9 @@ ((lambda _ (lambda-case ((() #f #f #f () ()) - (apply (lexical loop _)))))) - (apply (lexical loop _))))))) - (apply (lexical lp _))))) + (call (lexical loop _)))))) + (call (lexical loop _))))))) + (call (lexical lp _))))) @@ -1545,9 +1552,9 @@ '(lambda () (lambda-case (((x y) #f #f #f () (x1 y1)) - (apply (toplevel +) - (lexical x x1) - (lexical y y1))) + (call (toplevel +) + (lexical x x1) + (lexical y y1))) #f)))))) (and (equal? (map strip-source leaves) (list (make-lexical-ref #f 'y 'y1) |