diff options
author | Andy Wingo <wingo@pobox.com> | 2013-11-08 14:41:22 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2013-11-08 14:41:22 +0100 |
commit | 539eeee6ae87291dd666c0f6ff3b467f77be776a (patch) | |
tree | 684ac00f4d548fb1e1877fb3ef653cadaae93baf /test-suite/tests/tree-il.test | |
parent | 5d53070040f3e6f1d10874eebe27b8a2f215e167 (diff) | |
download | guile-539eeee6ae87291dd666c0f6ff3b467f77be776a.tar.gz |
Remove tree-il->glil test cases
* test-suite/tests/tree-il.test: Remove GLIL test cases. They have
never been helpful to me in the 2.0 series, so there is no loss.
Diffstat (limited to 'test-suite/tests/tree-il.test')
-rw-r--r-- | test-suite/tests/tree-il.test | 586 |
1 files changed, 8 insertions, 578 deletions
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 762fb591d..f6ec0b836 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -24,42 +24,8 @@ #: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)) -;; Of course, the GLIL that is emitted depends on the source info of the -;; input. Here we're not concerned about that, so we strip source -;; information from the incoming tree-il. - -(define (strip-source x) - (post-order (lambda (x) - (set! (tree-il-src x) #f) - x) - x)) - -(define-syntax assert-tree-il->glil - (syntax-rules (with-partial-evaluation without-partial-evaluation - with-options) - ((_ with-partial-evaluation in pat test ...) - (assert-tree-il->glil with-options (#:partial-eval? #t) - in pat test ...)) - ((_ without-partial-evaluation in pat test ...) - (assert-tree-il->glil with-options (#:partial-eval? #f) - in pat test ...)) - ((_ with-options opts in pat test ...) - (let ((exp 'in)) - (pass-if 'in - (let ((glil (unparse-glil - (compile (strip-source (parse-tree-il exp)) - #:from 'tree-il #:to 'glil - #:opts 'opts)))) - (pmatch glil - (pat (guard test ...) #t) - (else #f)))))) - ((_ in pat test ...) - (assert-tree-il->glil with-partial-evaluation - in pat test ...)))) - (define-syntax-rule (pass-if-primitives-resolved in expected) (pass-if (format #f "primitives-resolved in ~s" 'in) (let* ((module (let ((m (make-module))) @@ -155,557 +121,16 @@ (case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1))) (and (eq? a a1) (eq? b b1) (eq? c c1)))) -(with-test-prefix "void" - (assert-tree-il->glil - (void) - (program () (std-prelude 0 0 #f) (label _) (void) (call return 1))) - (assert-tree-il->glil - (begin (void) (const 1)) - (program () (std-prelude 0 0 #f) (label _) (const 1) (call return 1))) - (assert-tree-il->glil - (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 - (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 (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) - (label ,l4) - (void) (call return 1)) - (and (eq? l1 l3) (eq? l2 l4))) - (assert-tree-il->glil - (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)))) - -(with-test-prefix "conditional" - (assert-tree-il->glil - (if (toplevel foo) (const 1) (const 2)) - (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) - (const 1) (call return 1) - (label ,l2) (const 2) (call return 1)) - (eq? l1 l2)) - - (assert-tree-il->glil without-partial-evaluation - (begin (if (toplevel foo) (const 1) (const 2)) (const #f)) - (program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2) - (label ,l3) (label ,l4) (const #f) (call return 1)) - (eq? l1 l3) (eq? l2 l4)) - - (assert-tree-il->glil - (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) - (call null? 1) (call return 1)) - (eq? l1 l3) (eq? l2 l4))) - -(with-test-prefix "primitive-ref" - (assert-tree-il->glil - (primitive +) - (program () (std-prelude 0 0 #f) - (label _) (module private ref (guile) +) (call return 1))) - - (assert-tree-il->glil - (begin (primitive +) (const #f)) - (program () (std-prelude 0 0 #f) (label _) (const #f) (call return 1))) - - (assert-tree-il->glil - (primcall null? (primitive +)) - (program () (std-prelude 0 0 #f) (label _) - (module private ref (guile) +) (call null? 1) - (call return 1)))) - -(with-test-prefix "lexical refs" - (assert-tree-il->glil without-partial-evaluation - (let (x) (y) ((const 1)) (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 return 1) - (unbind))) - - (assert-tree-il->glil with-options (#:partial-eval? #f #:cse? #f) - (let (x) (y) ((const 1)) (begin (lexical x y) (const #f))) - (program () (std-prelude 0 1 #f) (label _) - (const 1) (bind (x #f 0)) (lexical #t #f set 0) - (const #f) (call return 1) - (unbind))) - - (assert-tree-il->glil without-partial-evaluation - (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) - (unbind)))) - -(with-test-prefix "lexical sets" - (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) (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) (call return 1) - (unbind))) - - (assert-tree-il->glil - (let (x) (y) ((const 1)) - (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) - (lexical #t #t ref 0) (call add1 1) (lexical #t #t set 0) - (lexical #t #t ref 0) (call return 1) - (unbind))) - - (assert-tree-il->glil - (let (x) (y) ((const 1)) - (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) - (call null? 1) (call return 1) - (unbind)))) - -(with-test-prefix "module refs" - (assert-tree-il->glil - (@ (foo) bar) - (program () (std-prelude 0 0 #f) (label _) - (module public ref (foo) bar) - (call return 1))) - - (assert-tree-il->glil - (begin (@ (foo) bar) (const #f)) - (program () (std-prelude 0 0 #f) (label _) - (module public ref (foo) bar) (call drop 1) - (const #f) (call return 1))) - - (assert-tree-il->glil - (primcall null? (@ (foo) bar)) - (program () (std-prelude 0 0 #f) (label _) - (module public ref (foo) bar) - (call null? 1) (call return 1))) - - (assert-tree-il->glil - (@@ (foo) bar) - (program () (std-prelude 0 0 #f) (label _) - (module private ref (foo) bar) - (call return 1))) - - (assert-tree-il->glil - (begin (@@ (foo) bar) (const #f)) - (program () (std-prelude 0 0 #f) (label _) - (module private ref (foo) bar) (call drop 1) - (const #f) (call return 1))) - - (assert-tree-il->glil - (primcall null? (@@ (foo) bar)) - (program () (std-prelude 0 0 #f) (label _) - (module private ref (foo) bar) - (call null? 1) (call return 1)))) - -(with-test-prefix "module sets" - (assert-tree-il->glil - (set! (@ (foo) bar) (const 2)) - (program () (std-prelude 0 0 #f) (label _) - (const 2) (module public set (foo) bar) - (void) (call return 1))) - - (assert-tree-il->glil - (begin (set! (@ (foo) bar) (const 2)) (const #f)) - (program () (std-prelude 0 0 #f) (label _) - (const 2) (module public set (foo) bar) - (const #f) (call return 1))) - - (assert-tree-il->glil - (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))) - - (assert-tree-il->glil - (set! (@@ (foo) bar) (const 2)) - (program () (std-prelude 0 0 #f) (label _) - (const 2) (module private set (foo) bar) - (void) (call return 1))) - - (assert-tree-il->glil - (begin (set! (@@ (foo) bar) (const 2)) (const #f)) - (program () (std-prelude 0 0 #f) (label _) - (const 2) (module private set (foo) bar) - (const #f) (call return 1))) - - (assert-tree-il->glil - (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)))) - -(with-test-prefix "toplevel refs" - (assert-tree-il->glil - (toplevel bar) - (program () (std-prelude 0 0 #f) (label _) - (toplevel ref bar) - (call return 1))) - - (assert-tree-il->glil without-partial-evaluation - (begin (toplevel bar) (const #f)) - (program () (std-prelude 0 0 #f) (label _) - (toplevel ref bar) (call drop 1) - (const #f) (call return 1))) - - (assert-tree-il->glil - (primcall null? (toplevel bar)) - (program () (std-prelude 0 0 #f) (label _) - (toplevel ref bar) - (call null? 1) (call return 1)))) - -(with-test-prefix "toplevel sets" - (assert-tree-il->glil - (set! (toplevel bar) (const 2)) - (program () (std-prelude 0 0 #f) (label _) - (const 2) (toplevel set bar) - (void) (call return 1))) - - (assert-tree-il->glil - (begin (set! (toplevel bar) (const 2)) (const #f)) - (program () (std-prelude 0 0 #f) (label _) - (const 2) (toplevel set bar) - (const #f) (call return 1))) - - (assert-tree-il->glil - (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)))) - -(with-test-prefix "toplevel defines" - (assert-tree-il->glil - (define bar (const 2)) - (program () (std-prelude 0 0 #f) (label _) - (const 2) (toplevel define bar) - (void) (call return 1))) - - (assert-tree-il->glil - (begin (define bar (const 2)) (const #f)) - (program () (std-prelude 0 0 #f) (label _) - (const 2) (toplevel define bar) - (const #f) (call return 1))) - - (assert-tree-il->glil - (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)))) - -(with-test-prefix "constants" - (assert-tree-il->glil - (const 2) - (program () (std-prelude 0 0 #f) (label _) - (const 2) (call return 1))) - - (assert-tree-il->glil - (begin (const 2) (const #f)) - (program () (std-prelude 0 0 #f) (label _) - (const #f) (call return 1))) - - (assert-tree-il->glil - ;; This gets simplified by `peval'. - (primcall null? (const 2)) - (program () (std-prelude 0 0 #f) (label _) - (const #f) (call return 1)))) - -(with-test-prefix "letrec" - ;; simple bindings -> let - (assert-tree-il->glil without-partial-evaluation - (letrec (x y) (x1 y1) ((const 10) (const 20)) - (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)) - (lexical #t #f set 1) (lexical #t #f set 0) - (toplevel ref foo) - (lexical #t #f ref 0) (lexical #t #f ref 1) - (call tail-call 2) - (unbind))) - - ;; complex bindings -> box and set! within let - (assert-tree-il->glil without-partial-evaluation - (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)) - (lexical #t #t box 1) (lexical #t #t box 0) - (call new-frame 0) (toplevel ref foo) (call call 0) - (call new-frame 0) (toplevel ref bar) (call call 0) - (bind (x #f 2) (y #f 3)) (lexical #t #f set 3) (lexical #t #f set 2) - (lexical #t #f ref 2) (lexical #t #t set 0) - (lexical #t #f ref 3) (lexical #t #t set 1) - (void) (lexical #t #f set 2) (void) (lexical #t #f set 3) ;; clear bindings - (unbind) - (lexical #t #t ref 0) (lexical #t #t ref 1) - (call add 2) (call return 1) (unbind))) - - ;; complex bindings in letrec* -> box and set! in order - (assert-tree-il->glil without-partial-evaluation - (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)) - (lexical #t #t box 1) (lexical #t #t box 0) - (call new-frame 0) (toplevel ref foo) (call call 0) - (lexical #t #t set 0) - (call new-frame 0) (toplevel ref bar) (call call 0) - (lexical #t #t set 1) - (lexical #t #t ref 0) - (lexical #t #t ref 1) - (call add 2) (call return 1) (unbind))) - - ;; simple bindings in letrec* -> equivalent to letrec - (assert-tree-il->glil without-partial-evaluation - (letrec* (x y) (xx yy) ((const 1) (const 2)) - (lexical y yy)) - (program () (std-prelude 0 1 #f) (label _) - (const 2) - (bind (y #f 0)) ;; X is removed, and Y is unboxed - (lexical #t #f set 0) - (lexical #t #f ref 0) - (call return 1) (unbind)))) - -(with-test-prefix "lambda" - (assert-tree-il->glil - (lambda () - (lambda-case (((x) #f #f #f () (y)) (const 2)) #f)) - (program () (std-prelude 0 0 #f) (label _) - (program () (std-prelude 1 1 #f) - (bind (x #f 0)) (label _) - (const 2) (call return 1) (unbind)) - (call return 1))) - - (assert-tree-il->glil - (lambda () - (lambda-case (((x y) #f #f #f () (x1 y1)) - (const 2)) - #f)) - (program () (std-prelude 0 0 #f) (label _) - (program () (std-prelude 2 2 #f) - (bind (x #f 0) (y #f 1)) (label _) - (const 2) (call return 1) - (unbind)) - (call return 1))) - - (assert-tree-il->glil - (lambda () - (lambda-case ((() #f x #f () (y)) (const 2)) - #f)) - (program () (std-prelude 0 0 #f) (label _) - (program () (opt-prelude 0 0 0 1 #f) - (bind (x #f 0)) (label _) - (const 2) (call return 1) - (unbind)) - (call return 1))) - - (assert-tree-il->glil - (lambda () - (lambda-case (((x) #f x1 #f () (y y1)) (const 2)) - #f)) - (program () (std-prelude 0 0 #f) (label _) - (program () (opt-prelude 1 0 1 2 #f) - (bind (x #f 0) (x1 #f 1)) (label _) - (const 2) (call return 1) - (unbind)) - (call return 1))) - - (assert-tree-il->glil - (lambda () - (lambda-case (((x) #f x1 #f () (y y1)) (lexical x y)) - #f)) - (program () (std-prelude 0 0 #f) (label _) - (program () (opt-prelude 1 0 1 2 #f) - (bind (x #f 0) (x1 #f 1)) (label _) - (lexical #t #f ref 0) (call return 1) - (unbind)) - (call return 1))) - - (assert-tree-il->glil - (lambda () - (lambda-case (((x) #f x1 #f () (y y1)) (lexical x1 y1)) - #f)) - (program () (std-prelude 0 0 #f) (label _) - (program () (opt-prelude 1 0 1 2 #f) - (bind (x #f 0) (x1 #f 1)) (label _) - (lexical #t #f ref 1) (call return 1) - (unbind)) - (call return 1))) - - (assert-tree-il->glil - (lambda () - (lambda-case (((x) #f #f #f () (x1)) - (lambda () - (lambda-case (((y) #f #f #f () (y1)) - (lexical x x1)) - #f))) - #f)) - (program () (std-prelude 0 0 #f) (label _) - (program () (std-prelude 1 1 #f) - (bind (x #f 0)) (label _) - (program () (std-prelude 1 1 #f) - (bind (y #f 0)) (label _) - (lexical #f #f ref 0) (call return 1) - (unbind)) - (lexical #t #f ref 0) - (call make-closure 1) - (call return 1) - (unbind)) - (call return 1)))) - -(with-test-prefix "sequence" - (assert-tree-il->glil - (begin (begin (const 2) (const #f)) (const #t)) - (program () (std-prelude 0 0 #f) (label _) - (const #t) (call return 1))) - - (assert-tree-il->glil - ;; This gets simplified by `peval'. - (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 - (primcall values - (primcall values (const 1) (const 2))) - (program () (std-prelude 0 0 #f) (label _) - (const 1) (call return 1))) - - (assert-tree-il->glil - (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 - (primcall + - (primcall values (const 1) (const 2))) - (program () (std-prelude 0 0 #f) (label _) - (const 1) (call return 1))) - - ;; Testing `(values foo)' in push context with RA. - (assert-tree-il->glil without-partial-evaluation - (primcall cdr - (letrec (lp) (#{lp ~V9KrhVD4PFEL6oCTrLg3A}#) - ((lambda ((name . lp)) - (lambda-case ((() #f #f #f () ()) - (primcall values (const (one two))))))) - (call (lexical lp #{lp ~V9KrhVD4PFEL6oCTrLg3A}#)))) - (program () (std-prelude 0 0 #f) (label _) - (branch br _) ;; entering the fix, jump to :2 - ;; :1 body of lp, jump to :3 - (label _) (bind) (const (one two)) (branch br _) (unbind) - ;; :2 initial call of lp, jump to :1 - (label _) (bind) (branch br _) (label _) (unbind) - ;; :3 the push continuation - (call cdr 1) (call return 1)))) - -;; FIXME: binding info for or-hacked locals might bork the disassembler, -;; and could be tightened in any case -(with-test-prefix "the or hack" - (assert-tree-il->glil without-partial-evaluation - (let (x) (y) ((const 1)) - (if (lexical x y) - (lexical x y) - (let (a) (b) ((const 2)) - (lexical a b)))) - (program () (std-prelude 0 1 #f) (label _) - (const 1) (bind (x #f 0)) (lexical #t #f set 0) - (lexical #t #f ref 0) (branch br-if-not ,l1) - (lexical #t #f ref 0) (call return 1) - (label ,l2) - (const 2) (bind (a #f 0)) (lexical #t #f set 0) - (lexical #t #f ref 0) (call return 1) - (unbind) - (unbind)) - (eq? l1 l2)) - - ;; second bound var is unreferenced - (assert-tree-il->glil without-partial-evaluation - (let (x) (y) ((const 1)) - (if (lexical x y) - (lexical x y) - (let (a) (b) ((const 2)) - (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) (branch br-if-not ,l1) - (lexical #t #f ref 0) (call return 1) - (label ,l2) - (lexical #t #f ref 0) (call return 1) - (unbind)) - (eq? l1 l2))) - -(with-test-prefix "apply" - (assert-tree-il->glil - (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 (primcall apply (toplevel foo) (toplevel bar)) (void)) - (program () (std-prelude 0 0 #f) (label _) - (call new-frame 0) (module private ref (guile) apply) - (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1) - (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) - (label ,l4) - (void) (call return 1)) - (and (eq? l1 l3) (eq? l2 l4))) - (assert-tree-il->glil - (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) - (call tail-call 1)))) - -(with-test-prefix "call/cc" - (assert-tree-il->glil - (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 (primcall call-with-current-continuation (toplevel foo)) (void)) - (program () (std-prelude 0 0 #f) (label _) - (call new-frame 0) - (module private ref (guile) call-with-current-continuation) - (toplevel ref foo) (mv-call 1 ,l1) - (call drop 1) (branch br ,l2) (label ,l3) (mv-bind 0 #f) - (label ,l4) - (void) (call return 1)) - (and (eq? l1 l3) (eq? l2 l4))) - (assert-tree-il->glil - (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) - (call tail-call 1)))) - -(with-test-prefix "labels allocation" +(with-test-prefix "contification" (pass-if "http://debbugs.gnu.org/9769" ((compile '(lambda () (let ((fail (lambda () #f))) (let ((test (lambda () (fail)))) (test)) #t)) - ;; Prevent inlining. We're testing analyze.scm's - ;; labels allocator here, and inlining it will - ;; reduce the entire thing to #t. + ;; Prevent inlining. We're testing contificatoin here, + ;; and inlining it will reduce the entire thing to #t. #:opts '(#:partial-eval? #f))))) @@ -754,6 +179,11 @@ (lexical x x1) (lexical y y1))) #f)))))) + (define (strip-source x) + (post-order (lambda (x) + (set! (tree-il-src x) #f) + x) + x)) (and (= result 12) (equal? (map strip-source (list-head (reverse ups) 3)) (list (make-toplevel-ref #f '+) |