mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 05:50:26 +02:00
Code Activity

peval doesn't resolve primitives

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2011-11-04 13:38:28 +01:00
parent 14b208185c
commit ef9ffe5efd
2 changed files with 41 additions and 41 deletions
Download patch file Download diff file Expand all files Collapse all files

7
module/language/tree-il/peval.scm
View file

@ -868,12 +868,7 @@ top-level bindings from ENV and return the resulting expression."
(($ <dynset> src fluid exp) (($ <dynset> src fluid exp)
(make-dynset src (for-value fluid) (for-value exp))) (make-dynset src (for-value fluid) (for-value exp)))
(($ <toplevel-ref> src (? effect-free-primitive? name)) (($ <toplevel-ref> src (? effect-free-primitive? name))
(if (local-toplevel? name) exp)
exp
(let ((exp (resolve-primitives! exp cenv)))
(if (primitive-ref? exp)
(for-tail exp)
exp))))
(($ <toplevel-ref>) (($ <toplevel-ref>)
;; todo: open private local bindings. ;; todo: open private local bindings.
exp) exp)

75
test-suite/tests/tree-il.test
View file

@ -74,11 +74,8 @@
(@@ (language tree-il optimize) peval)) (@@ (language tree-il optimize) peval))
(define-syntax pass-if-peval (define-syntax pass-if-peval
(syntax-rules (resolve-primitives) (syntax-rules ()
((_ in pat) ((_ in pat)
(pass-if-peval in pat
(compile 'in #:from 'scheme #:to 'tree-il)))
((_ resolve-primitives in pat)
(pass-if-peval in pat (pass-if-peval in pat
(expand-primitives! (expand-primitives!
(resolve-primitives! (resolve-primitives!
@ -652,7 +649,7 @@
(f))) (f)))
(const 3)) (const 3))
(pass-if-peval resolve-primitives (pass-if-peval
;; First order, let-values (requires primitive expansion for ;; First order, let-values (requires primitive expansion for
;; `call-with-values'.) ;; `call-with-values'.)
(let ((x 0)) (let ((x 0))
@ -772,7 +769,7 @@
(loop (cdr l) (+ sum (car l))))) (loop (cdr l) (+ sum (car l)))))
(const 10)) (const 10))
(pass-if-peval resolve-primitives (pass-if-peval
(let ((string->chars (let ((string->chars
(lambda (s) (lambda (s)
(define (char-at n) (define (char-at n)
@ -814,7 +811,7 @@
(let (x) (_) ((primcall list (const 1))) (let (x) (_) ((primcall list (const 1)))
(let (y) (_) ((primcall car (lexical x _))) (let (y) (_) ((primcall car (lexical x _)))
(seq (seq
(call (toplevel set-car!) (lexical x _) (const 0)) (primcall set-car! (lexical x _) (const 0))
(lexical y _))))) (lexical y _)))))
(pass-if-peval (pass-if-peval
@ -825,7 +822,7 @@
y) y)
(let (y) (_) ((primcall car (toplevel x))) (let (y) (_) ((primcall car (toplevel x)))
(seq (seq
(call (toplevel set-car!) (toplevel x) (const 0)) (primcall set-car! (toplevel x) (const 0))
(lexical y _)))) (lexical y _))))
(pass-if-peval (pass-if-peval
@ -915,15 +912,22 @@
(f -1 y) (f -1 y)
(f 2 y) (f 2 y)
(f z y))) (f z y)))
(primcall + (primcall
(const -1) ; (f -1 0) +
(const 0) ; (f 1 0) (const -1) ; (f -1 0)
(seq (toplevel y) (const -1)) ; (f -1 y) (primcall
(toplevel y) ; (f 2 y) +
(let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y) (const 0) ; (f 1 0)
(if (primcall > (lexical x _) (const 0)) (primcall
(lexical y _) +
(lexical x _))))) (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 (pass-if-peval
;; First order, conditional. ;; First order, conditional.
@ -1040,7 +1044,7 @@
(lambda () (lambda ()
(lambda-case (lambda-case
(((x2) #f #f #f () (_)) (((x2) #f #f #f () (_))
(primcall - (lexical x2 _) (const 1)))))))) (primcall 1- (lexical x2 _))))))))
(pass-if "inlined lambdas are alpha-renamed" (pass-if "inlined lambdas are alpha-renamed"
;; In this example, `make-adder' is inlined more than once; thus, ;; In this example, `make-adder' is inlined more than once; thus,
@ -1051,11 +1055,14 @@
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and ;; <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>. ;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
(pmatch (unparse-tree-il (pmatch (unparse-tree-il
(peval (compile (peval (expand-primitives!
'(let ((make-adder (resolve-primitives!
(lambda (x) (lambda (y) (+ x y))))) (compile
(cons (make-adder 1) (make-adder 2))) '(let ((make-adder
#:to 'tree-il))) (lambda (x) (lambda (y) (+ x y)))))
(cons (make-adder 1) (make-adder 2)))
#:to 'tree-il)
(current-module)))))
((primcall cons ((primcall cons
(lambda () (lambda ()
(lambda-case (lambda-case
@ -1152,8 +1159,8 @@
(lambda () (lambda ()
(lambda-case (lambda-case
(((n) #f #f #f () (_)) (((n) #f #f #f () (_))
(call (toplevel vector-set!) (primcall vector-set!
(lexical v _) (lexical n _) (lexical n _))))))) (lexical v _) (lexical n _) (lexical n _)))))))
(pass-if-peval (pass-if-peval
;; Mutable lexical is not propagated. ;; Mutable lexical is not propagated.
@ -1177,7 +1184,8 @@
(call (toplevel display) (const chbouib)))) (call (toplevel display) (const chbouib))))
(let (y) (_) ((primcall * (lexical x _) (const 2))) (let (y) (_) ((primcall * (lexical x _) (const 2)))
(primcall + (primcall +
(lexical x _) (lexical x _) (lexical y _))))) (lexical x _)
(primcall + (lexical x _) (lexical y _))))))
(pass-if-peval (pass-if-peval
;; Non-constant arguments not propagated to lambdas. ;; Non-constant arguments not propagated to lambdas.
@ -1193,12 +1201,12 @@
(call (toplevel make-list) (const 10)) (call (toplevel make-list) (const 10))
(primcall list (const 1) (const 2) (const 3))) (primcall list (const 1) (const 2) (const 3)))
(seq (seq
(call (toplevel vector-set!) (primcall vector-set!
(lexical x _) (const 0) (const 0)) (lexical x _) (const 0) (const 0))
(seq (call (toplevel set-car!) (seq (primcall set-car!
(lexical y _) (const 0)) (lexical y _) (const 0))
(call (toplevel set-cdr!) (primcall set-cdr!
(lexical z _) (const ())))))) (lexical z _) (const ()))))))
(pass-if-peval (pass-if-peval
(let ((foo top-foo) (bar top-bar)) (let ((foo top-foo) (bar top-bar))
@ -1454,7 +1462,6 @@
(seq (call (toplevel bar)) (primcall list (const 0)))) (seq (call (toplevel bar)) (primcall list (const 0))))
(pass-if-peval (pass-if-peval
resolve-primitives
;; Prompt is removed if tag is unreferenced ;; Prompt is removed if tag is unreferenced
(let ((tag (make-prompt-tag))) (let ((tag (make-prompt-tag)))
(call-with-prompt tag (call-with-prompt tag
@ -1463,7 +1470,6 @@
(const 1)) (const 1))
(pass-if-peval (pass-if-peval
resolve-primitives
;; Prompt is removed if tag is unreferenced, with explicit stem ;; Prompt is removed if tag is unreferenced, with explicit stem
(let ((tag (make-prompt-tag "foo"))) (let ((tag (make-prompt-tag "foo")))
(call-with-prompt tag (call-with-prompt tag
@ -1472,7 +1478,6 @@
(const 1)) (const 1))
(pass-if-peval (pass-if-peval
resolve-primitives
;; `while' without `break' or `continue' has no prompts and gets its ;; `while' without `break' or `continue' has no prompts and gets its
;; condition folded. Unfortunately the outer `lp' does not yet get ;; condition folded. Unfortunately the outer `lp' does not yet get
;; elided. ;; elided.