mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 11:40:18 +02:00
peval tests into separate file
* test-suite/tests/tree-il.test ("partial evaluation"):
* test-suite/tests/peval.test ("partial evaluation"): Separate peval
* tests.
* test-suite/Makefile.am: Adapt.
This commit is contained in:
Andy Wingo
parent
5deea34d0e
commit
de1eb420a5
3 changed files with 989 additions and 965 deletions
|
|
@ -75,6 +75,7 @@ SCM_TESTS = tests/00-initial-env.test \
|
|||
tests/optargs.test \
|
||||
tests/options.test \
|
||||
tests/parameters.test \
|
||||
tests/peval.test \
|
||||
tests/print.test \
|
||||
tests/procprop.test \
|
||||
tests/procs.test \
|
||||
|
|
|
|||
988
test-suite/tests/peval.test
Normal file
988
test-suite/tests/peval.test
Normal file
|
|
@ -0,0 +1,988 @@
|
|||
;;;; 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
|
||||
;; 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
|
||||
;; First order, multiple values.
|
||||
(let ((x 1) (y 2))
|
||||
(values x y))
|
||||
(apply (primitive values) (const 1) (const 2)))
|
||||
|
||||
(pass-if-peval resolve-primitives
|
||||
;; First order, multiple values truncated.
|
||||
(let ((x (values 1 'a)) (y 2))
|
||||
(values x y))
|
||||
(apply (primitive values) (const 1) (const 2)))
|
||||
|
||||
(pass-if-peval resolve-primitives
|
||||
;; 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)))
|
||||
|
||||
(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))))))
|
||||
|
||||
;; 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))))
|
||||
;;
|
||||
;; 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))))
|
||||
(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 _)))))
|
||||
|
||||
;; 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)))
|
||||
(let (r) (_)
|
||||
((apply (primitive cons)
|
||||
(const 3)
|
||||
(lexical r _)))
|
||||
(let (r) (_)
|
||||
((apply (primitive cons)
|
||||
(const 2)
|
||||
(lexical r _)))
|
||||
(let (r) (_)
|
||||
((apply (primitive cons)
|
||||
(const 1)
|
||||
(lexical r _)))
|
||||
(apply (primitive 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
|
||||
(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)))
|
||||
|
||||
(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)))
|
||||
|
||||
(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)))
|
||||
|
||||
(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))
|
||||
(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))
|
||||
(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 _))))
|
||||
|
||||
(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
|
||||
(define +
|
||||
(lambda (_)
|
||||
(lambda-case
|
||||
(((x y) #f #f #f () (_ _))
|
||||
(apply (toplevel pk) (lexical x _) (lexical y _))))))
|
||||
(apply (toplevel +) (const 1) (const 2))))
|
||||
|
||||
(pass-if-peval
|
||||
;; First-order, effects preserved.
|
||||
(let ((x 2))
|
||||
(do-something!)
|
||||
x)
|
||||
(begin
|
||||
(apply (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)))
|
||||
|
||||
(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)))))))
|
||||
|
||||
(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)))))
|
||||
|
||||
(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 _)))))
|
||||
|
||||
(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 _))))))
|
||||
|
||||
(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))
|
||||
(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))))
|
||||
|
||||
(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)))
|
||||
|
||||
(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 _)
|
||||
(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))))))))
|
||||
|
||||
(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))))))
|
||||
(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)))
|
||||
|
||||
(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))))
|
||||
|
||||
(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))
|
||||
(const #t)
|
||||
(if (apply (primitive eqv?) (lexical key _) (const 2))
|
||||
(const #t)
|
||||
(apply (primitive 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.
|
||||
(case foo
|
||||
(() 'a)
|
||||
(else 'b))
|
||||
(begin (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)))
|
||||
(lambda ()
|
||||
(lambda-case
|
||||
(((n) #f #f #f () (_))
|
||||
(apply (toplevel 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)))
|
||||
(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 _)))))
|
||||
|
||||
(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 ())))))
|
||||
|
||||
(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 _)))))
|
||||
|
||||
(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 _))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Bindings mutated.
|
||||
(let ((x 2))
|
||||
(set! x 3)
|
||||
x)
|
||||
(let (x) (_) ((const 2))
|
||||
(begin
|
||||
(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 _ _))
|
||||
(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 _))
|
||||
(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))))
|
||||
|
||||
(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))))
|
||||
|
||||
(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))
|
||||
_ _)))))
|
||||
(apply (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))))
|
||||
|
||||
(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
|
||||
(set! (lexical pos _) (const 1))
|
||||
(let (here) (_) (_)
|
||||
(apply (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 _)))))
|
||||
(lambda _
|
||||
(lambda-case
|
||||
(((x) #f #f #f () (_))
|
||||
(lexical x _))))
|
||||
(lambda _
|
||||
(lambda-case
|
||||
((() #f #f #f () ())
|
||||
(apply (lexical a _))))))
|
||||
(let (d)
|
||||
(_)
|
||||
((apply (toplevel foo) (lexical b _)))
|
||||
(apply (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 _)))))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: cons of #nil does not make list
|
||||
(cons 1 #nil)
|
||||
(apply (primitive 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)))
|
||||
|
||||
(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)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: cdr+cons, impure
|
||||
(cdr (cons (bar) 0))
|
||||
(begin (apply (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)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: car+list, impure
|
||||
(car (list 1 (bar)))
|
||||
(begin (apply (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))))
|
||||
|
||||
(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 _))))
|
||||
|
||||
(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 bar)
|
||||
(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 _)))))))
|
||||
|
||||
(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 _))))
|
||||
|
||||
(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
|
||||
(car '(1 2))
|
||||
(const 1)))
|
||||
|
|
@ -69,38 +69,6 @@
|
|||
(pat (guard guard-exp) #t)
|
||||
(_ #f))))))
|
||||
|
||||
(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 "tree-il->scheme"
|
||||
(pass-if-tree-il->scheme
|
||||
|
|
@ -656,939 +624,6 @@
|
|||
;; reduce the entire thing to #t.
|
||||
#:opts '(#:partial-eval? #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
|
||||
;; 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
|
||||
;; First order, multiple values.
|
||||
(let ((x 1) (y 2))
|
||||
(values x y))
|
||||
(apply (primitive values) (const 1) (const 2)))
|
||||
|
||||
(pass-if-peval resolve-primitives
|
||||
;; First order, multiple values truncated.
|
||||
(let ((x (values 1 'a)) (y 2))
|
||||
(values x y))
|
||||
(apply (primitive values) (const 1) (const 2)))
|
||||
|
||||
(pass-if-peval resolve-primitives
|
||||
;; 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)))
|
||||
|
||||
(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))))))
|
||||
|
||||
;; 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))))
|
||||
;;
|
||||
;; 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))))
|
||||
(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 _)))))
|
||||
|
||||
;; 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)))
|
||||
(let (r) (_)
|
||||
((apply (primitive cons)
|
||||
(const 3)
|
||||
(lexical r _)))
|
||||
(let (r) (_)
|
||||
((apply (primitive cons)
|
||||
(const 2)
|
||||
(lexical r _)))
|
||||
(let (r) (_)
|
||||
((apply (primitive cons)
|
||||
(const 1)
|
||||
(lexical r _)))
|
||||
(apply (primitive 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
|
||||
(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)))
|
||||
|
||||
(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)))
|
||||
|
||||
(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)))
|
||||
|
||||
(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))
|
||||
(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))
|
||||
(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 _))))
|
||||
|
||||
(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
|
||||
(define +
|
||||
(lambda (_)
|
||||
(lambda-case
|
||||
(((x y) #f #f #f () (_ _))
|
||||
(apply (toplevel pk) (lexical x _) (lexical y _))))))
|
||||
(apply (toplevel +) (const 1) (const 2))))
|
||||
|
||||
(pass-if-peval
|
||||
;; First-order, effects preserved.
|
||||
(let ((x 2))
|
||||
(do-something!)
|
||||
x)
|
||||
(begin
|
||||
(apply (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)))
|
||||
|
||||
(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)))))))
|
||||
|
||||
(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)))))
|
||||
|
||||
(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 _)))))
|
||||
|
||||
(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 _))))))
|
||||
|
||||
(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))
|
||||
(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))))
|
||||
|
||||
(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)))
|
||||
|
||||
(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 _)
|
||||
(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))))))))
|
||||
|
||||
(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))))))
|
||||
(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)))
|
||||
|
||||
(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))))
|
||||
|
||||
(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))
|
||||
(const #t)
|
||||
(if (apply (primitive eqv?) (lexical key _) (const 2))
|
||||
(const #t)
|
||||
(apply (primitive 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.
|
||||
(case foo
|
||||
(() 'a)
|
||||
(else 'b))
|
||||
(begin (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)))
|
||||
(lambda ()
|
||||
(lambda-case
|
||||
(((n) #f #f #f () (_))
|
||||
(apply (toplevel 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)))
|
||||
(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 _)))))
|
||||
|
||||
(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 ())))))
|
||||
|
||||
(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 _)))))
|
||||
|
||||
(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 _))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Bindings mutated.
|
||||
(let ((x 2))
|
||||
(set! x 3)
|
||||
x)
|
||||
(let (x) (_) ((const 2))
|
||||
(begin
|
||||
(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 _ _))
|
||||
(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 _))
|
||||
(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))))
|
||||
|
||||
(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))))
|
||||
|
||||
(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))
|
||||
_ _)))))
|
||||
(apply (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))))
|
||||
|
||||
(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
|
||||
(set! (lexical pos _) (const 1))
|
||||
(let (here) (_) (_)
|
||||
(apply (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 _)))))
|
||||
(lambda _
|
||||
(lambda-case
|
||||
(((x) #f #f #f () (_))
|
||||
(lexical x _))))
|
||||
(lambda _
|
||||
(lambda-case
|
||||
((() #f #f #f () ())
|
||||
(apply (lexical a _))))))
|
||||
(let (d)
|
||||
(_)
|
||||
((apply (toplevel foo) (lexical b _)))
|
||||
(apply (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 _)))))))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: cons of #nil does not make list
|
||||
(cons 1 #nil)
|
||||
(apply (primitive 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)))
|
||||
|
||||
(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)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: cdr+cons, impure
|
||||
(cdr (cons (bar) 0))
|
||||
(begin (apply (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)))
|
||||
|
||||
(pass-if-peval
|
||||
;; Constant folding: car+list, impure
|
||||
(car (list 1 (bar)))
|
||||
(begin (apply (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))))
|
||||
|
||||
(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 _))))
|
||||
|
||||
(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 bar)
|
||||
(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 _)))))))
|
||||
|
||||
(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 _))))
|
||||
|
||||
(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
|
||||
((@ (guile) car) '(1 2))
|
||||
(const 1))
|
||||
|
||||
(pass-if-peval resolve-primitives
|
||||
((@@ (guile) car) '(1 2))
|
||||
(const 1)))
|
||||
|
||||
|
||||
|
||||
(with-test-prefix "tree-il-fold"
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue