;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
-;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2014 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
#:use-module (system base message)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
- #:use-module (language glil)
#:use-module (rnrs bytevectors) ;; for the bytevector primitives
#:use-module (srfi srfi-13))
(f z y)))
(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 _))))))))
+ (const -1) ; (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 _)))))
(pass-if-peval
;; First order, conditional.
'(2 3))
(const 7))
+ (pass-if-peval
+ ;; Higher order with optional argument (default uses earlier argument).
+ ;; <http://bugs.gnu.org/17634>
+ ((lambda* (f x #:optional (y (+ 3 (car x))))
+ (+ y (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
+ (const 12))
+
+ (pass-if-peval
+ ;; Higher order with optional arguments
+ ;; (default uses earlier optional argument).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+ (+ y z (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3))
+ (const 20))
+
+ (pass-if-peval
+ ;; Higher order with optional arguments (one caller-supplied value,
+ ;; one default that uses earlier optional argument).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+ (+ y z (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ -3)
+ (const 4))
+
+ (pass-if-peval
+ ;; Higher order with optional arguments (caller-supplied values).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y)))
+ (+ y z (f (* (car x) (cadr x)))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ -3
+ 17)
+ (const 21))
+
+ (pass-if-peval
+ ;; Higher order with optional and rest arguments (one
+ ;; caller-supplied value, one default that uses earlier optional
+ ;; argument).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+ #:rest r)
+ (list r (+ y z (f (* (car x) (cadr x))))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ -3)
+ (primcall list (const ()) (const 4)))
+
+ (pass-if-peval
+ ;; Higher order with optional and rest arguments
+ ;; (caller-supplied values for optionals).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+ #:rest r)
+ (list r (+ y z (f (* (car x) (cadr x))))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ -3
+ 17)
+ (primcall list (const ()) (const 21)))
+
+ (pass-if-peval
+ ;; Higher order with optional and rest arguments
+ ;; (caller-supplied values for optionals and rest).
+ ((lambda* (f x #:optional (y (+ 3 (car x))) (z (+ (cadr x) y))
+ #:rest r)
+ (list r (+ y z (f (* (car x) (cadr x))))))
+ (lambda (x)
+ (+ x 1))
+ '(2 3)
+ -3
+ 17
+ 8
+ 3)
+ (let (r) (_) ((primcall list (const 8) (const 3)))
+ (primcall list (lexical r _) (const 21))))
+
(pass-if-peval
;; Higher order with optional argument (caller-supplied value).
((lambda* (f x #:optional (y 0))
(lambda (n)
(vector-set! v n n)))
(let (v) (_)
- ((call (toplevel make-vector) (const 6) (const #f)))
+ ((primcall make-vector (const 6) (const #f)))
(lambda ()
(lambda-case
(((n) #f #f #f () (_))
(call (toplevel display) (const chbouib))))
(let (y) (_) ((primcall * (lexical x _) (const 2)))
(primcall +
- (lexical x _)
- (primcall + (lexical x _) (lexical y _))))))
+ (primcall + (lexical x _) (lexical x _))
+ (lexical y _)))))
(pass-if-peval
;; Non-constant arguments not propagated to lambdas.
;; "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 () ())
- (call (lexical a _)))))
- (lambda _
- (lambda-case
- (((x) #f #f #f () (_))
- (lexical x _))))
- (lambda _
- (lambda-case
- ((() #f #f #f () ())
- (call (lexical a _))))))
- (let (d)
- (_)
- ((call (toplevel foo) (lexical b _)))
- (call (lexical c _) (lexical d _)))))
+ (letrec (b a) (_ _)
+ ((lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (call (lexical a _)))))
+ (lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (call (lexical a _))))))
+ (call (toplevel foo) (lexical b _))))
(pass-if-peval
;; In this case, we can prune the bindings. `a' ends up being copied
(let (args) (_) ((primcall list (const 2) (const 3)))
(seq
(call (toplevel foo!) (lexical args _))
- (primcall @apply
+ (primcall apply
(lambda ()
(lambda-case
(((x y z w) #f #f #f () (_ _ _ _))
bv
(+ offset 4))))
(let ((args (list x y)))
- (@apply
+ (apply
(lambda (bv offset x y)
(bytevector-ieee-single-native-set!
bv
;; Here we ensure that non-constant expressions are not copied.
(lambda ()
(let ((args (list (foo!))))
- (@apply
+ (apply
(lambda (z x)
(list z x))
;; This toplevel ref might raise an unbound variable exception.
(lambda ()
(let ((args (list 'foo)))
(set-car! args 'bar)
- (@apply
+ (apply
(lambda (z x)
(list z x))
z
((primcall list (const foo)))
(seq
(primcall set-car! (lexical args _) (const bar))
- (primcall @apply
+ (primcall apply
(lambda . _)
(toplevel z)
(lexical args _))))))))
;; the dynwind; alack.
(dynamic-wind foo (lambda () bar) baz)
(let (tmp tmp) (_ _) ((toplevel foo) (toplevel baz))
- (seq (call (lexical tmp _))
- (let (tmp) (_) ((dynwind (lexical tmp _)
- (toplevel bar)
- (lexical tmp _)))
- (seq (call (lexical tmp _))
+ (seq (seq (if (primcall thunk? (lexical tmp _))
+ (call (lexical tmp _))
+ (primcall scm-error . _))
+ (primcall wind (lexical tmp _) (lexical tmp _)))
+ (let (tmp) (_) ((toplevel bar))
+ (seq (seq (primcall unwind)
+ (call (lexical tmp _)))
(lexical tmp _))))))
(pass-if-peval
- ;; Constant guards don't need lexical bindings.
+ ;; Constant guards don't need lexical bindings or thunk? checks.
(dynamic-wind (lambda () foo) (lambda () bar) (lambda () baz))
- (seq (toplevel foo)
- (let (tmp) (_) ((dynwind (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel foo))))
- (toplevel bar)
- (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel baz))))))
- (seq (toplevel baz)
+ (seq (seq (toplevel foo)
+ (primcall wind
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel foo))))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel baz))))))
+ (let (tmp) (_) ((toplevel bar))
+ (seq (seq (primcall unwind)
+ (toplevel baz))
(lexical tmp _)))))
(pass-if-peval
;; Dynwind bodies that return an unknown number of values need a
;; let-values.
(dynamic-wind (lambda () foo) (lambda () (bar)) (lambda () baz))
- (seq (toplevel foo)
- (let-values (dynwind (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel foo))))
- (call (toplevel bar))
- (lambda ()
- (lambda-case
- ((() #f #f #f () ()) (toplevel baz)))))
+ (seq (seq (toplevel foo)
+ (primcall wind
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel foo))))
+ (lambda ()
+ (lambda-case
+ ((() #f #f #f () ()) (toplevel baz))))))
+ (let-values (call (toplevel bar))
(lambda-case
((() #f vals #f () (_))
- (seq (toplevel baz)
- (primcall @apply (primitive values) (lexical vals _))))))))
+ (seq (seq (primcall unwind)
+ (toplevel baz))
+ (primcall apply (primitive values) (lexical vals _))))))))
(pass-if-peval
;; Prompt is removed if tag is unreferenced
(call-with-prompt tag
(lambda () 1)
(lambda (k x) x))
- (prompt (toplevel tag)
+ (prompt #t
+ (toplevel tag)
(const 1)
- (lambda-case
- (((k x) #f #f #f () (_ _))
- (lexical x _)))))
+ (lambda _
+ (lambda-case
+ (((k x) #f #f #f () (_ _))
+ (lexical x _))))))
;; Handler toplevel not inlined
(pass-if-peval
- (call-with-prompt tag
- (lambda () 1)
- handler)
- (let (handler) (_) ((toplevel handler))
- (prompt (toplevel tag)
- (const 1)
- (lambda-case
- ((() #f args #f () (_))
- (primcall @apply
- (lexical handler _)
- (lexical args _)))))))
+ (call-with-prompt tag
+ (lambda () 1)
+ handler)
+ (prompt #f
+ (toplevel tag)
+ (lambda _
+ (lambda-case
+ ((() #f #f #f () ())
+ (const 1))))
+ (toplevel handler)))
(pass-if-peval
;; `while' without `break' or `continue' has no prompts and gets its
(apply (lambda (x y) (cons x y)) (list 1 2))
(primcall cons (const 1) (const 2)))
+ ;; Disable after removal of abort-in-tail-position optimization, in
+ ;; hopes that CPS does a uniformly better job.
+ #;
(pass-if-peval
(let ((t (make-prompt-tag)))
(call-with-prompt t
(pass-if-peval
(call-with-values foo (lambda (x) (bar x)))
(let (x) (_) ((call (toplevel foo)))
- (call (toplevel bar) (lexical x _)))))
+ (call (toplevel bar) (lexical x _))))
+
+ (pass-if-peval
+ ((lambda (foo)
+ (define* (bar a #:optional (b (1+ a)))
+ (list a b))
+ (bar 1))
+ 1)
+ (primcall list (const 1) (const 2)))
+
+ (pass-if-peval
+ ;; Should not inline tail list to apply if it is mutable.
+ ;; <http://debbugs.gnu.org/15533>
+ (let ((l '()))
+ (if (pair? arg)
+ (set! l arg))
+ (apply f l))
+ (let (l) (_) ((const ()))
+ (seq
+ (if (primcall pair? (toplevel arg))
+ (set! (lexical l _) (toplevel arg))
+ (void))
+ (primcall apply (toplevel f) (lexical l _))))))
HCoop / bpt / guile.git / blobdiff