From ef9ffe5efd341af085e9dcd5a00288a6d33e99f7 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 4 Nov 2011 13:38:28 +0100 Subject: [PATCH] peval doesn't resolve primitives * module/language/tree-il/peval.scm (peval): Don't resolve primitives, as resolve-primitives! handles that already. * test-suite/tests/tree-il.test (pass-if-peval): Always resolve and expand primitives. ("partial evaluation"): Update tests to assume expanded primitives. --- module/language/tree-il/peval.scm | 7 +-- test-suite/tests/tree-il.test | 75 ++++++++++++++++--------------- 2 files changed, 41 insertions(+), 41 deletions(-) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index fd3526ccf..f7733a5f1 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -868,12 +868,7 @@ top-level bindings from ENV and return the resulting expression." (($ src fluid exp) (make-dynset src (for-value fluid) (for-value exp))) (($ src (? effect-free-primitive? name)) - (if (local-toplevel? name) - exp - (let ((exp (resolve-primitives! exp cenv))) - (if (primitive-ref? exp) - (for-tail exp) - exp)))) + exp) (($ ) ;; todo: open private local bindings. exp) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 88317e875..3db4afd08 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -74,11 +74,8 @@ (@@ (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! @@ -652,7 +649,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)) @@ -772,7 +769,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) @@ -814,7 +811,7 @@ (let (x) (_) ((primcall list (const 1))) (let (y) (_) ((primcall car (lexical x _))) (seq - (call (toplevel set-car!) (lexical x _) (const 0)) + (primcall set-car! (lexical x _) (const 0)) (lexical y _))))) (pass-if-peval @@ -825,7 +822,7 @@ y) (let (y) (_) ((primcall car (toplevel x))) (seq - (call (toplevel set-car!) (toplevel x) (const 0)) + (primcall set-car! (toplevel x) (const 0)) (lexical y _)))) (pass-if-peval @@ -915,15 +912,22 @@ (f -1 y) (f 2 y) (f z y))) - (primcall + - (const -1) ; (f -1 0) - (const 0) ; (f 1 0) - (seq (toplevel y) (const -1)) ; (f -1 y) - (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 _))))) + (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. @@ -1040,7 +1044,7 @@ (lambda () (lambda-case (((x2) #f #f #f () (_)) - (primcall - (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, @@ -1051,11 +1055,14 @@ ;; and ;; . (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))) + (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 @@ -1152,8 +1159,8 @@ (lambda () (lambda-case (((n) #f #f #f () (_)) - (call (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. @@ -1177,7 +1184,8 @@ (call (toplevel display) (const chbouib)))) (let (y) (_) ((primcall * (lexical x _) (const 2))) (primcall + - (lexical x _) (lexical x _) (lexical y _))))) + (lexical x _) + (primcall + (lexical x _) (lexical y _)))))) (pass-if-peval ;; Non-constant arguments not propagated to lambdas. @@ -1193,12 +1201,12 @@ (call (toplevel make-list) (const 10)) (primcall list (const 1) (const 2) (const 3))) (seq - (call (toplevel vector-set!) - (lexical x _) (const 0) (const 0)) - (seq (call (toplevel set-car!) - (lexical y _) (const 0)) - (call (toplevel set-cdr!) - (lexical z _) (const ())))))) + (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)) @@ -1454,7 +1462,6 @@ (seq (call (toplevel bar)) (primcall list (const 0)))) (pass-if-peval - resolve-primitives ;; Prompt is removed if tag is unreferenced (let ((tag (make-prompt-tag))) (call-with-prompt tag @@ -1463,7 +1470,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 @@ -1472,7 +1478,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.