mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-25 22:20:28 +02:00
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.
This commit is contained in:
Andy Wingo
parent
5d53070040
commit
539eeee6ae
1 changed files with 8 additions and 578 deletions
|
|
@ -24,42 +24,8 @@
|
||||||
#:use-module (system base message)
|
#:use-module (system base message)
|
||||||
#:use-module (language tree-il)
|
#:use-module (language tree-il)
|
||||||
#:use-module (language tree-il primitives)
|
#:use-module (language tree-il primitives)
|
||||||
#:use-module (language glil)
|
|
||||||
#:use-module (srfi srfi-13))
|
#: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)
|
(define-syntax-rule (pass-if-primitives-resolved in expected)
|
||||||
(pass-if (format #f "primitives-resolved in ~s" 'in)
|
(pass-if (format #f "primitives-resolved in ~s" 'in)
|
||||||
(let* ((module (let ((m (make-module)))
|
(let* ((module (let ((m (make-module)))
|
||||||
|
|
@ -155,557 +121,16 @@
|
||||||
(case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
|
(case-lambda ((,a) ,a1) ((,b ,c) (list ,b1 ,c1)))
|
||||||
(and (eq? a a1) (eq? b b1) (eq? c 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"
|
(pass-if "http://debbugs.gnu.org/9769"
|
||||||
((compile '(lambda ()
|
((compile '(lambda ()
|
||||||
(let ((fail (lambda () #f)))
|
(let ((fail (lambda () #f)))
|
||||||
(let ((test (lambda () (fail))))
|
(let ((test (lambda () (fail))))
|
||||||
(test))
|
(test))
|
||||||
#t))
|
#t))
|
||||||
;; Prevent inlining. We're testing analyze.scm's
|
;; Prevent inlining. We're testing contificatoin here,
|
||||||
;; labels allocator here, and inlining it will
|
;; and inlining it will reduce the entire thing to #t.
|
||||||
;; reduce the entire thing to #t.
|
|
||||||
#:opts '(#:partial-eval? #f)))))
|
#:opts '(#:partial-eval? #f)))))
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -754,6 +179,11 @@
|
||||||
(lexical x x1)
|
(lexical x x1)
|
||||||
(lexical y y1)))
|
(lexical y y1)))
|
||||||
#f))))))
|
#f))))))
|
||||||
|
(define (strip-source x)
|
||||||
|
(post-order (lambda (x)
|
||||||
|
(set! (tree-il-src x) #f)
|
||||||
|
x)
|
||||||
|
x))
|
||||||
(and (= result 12)
|
(and (= result 12)
|
||||||
(equal? (map strip-source (list-head (reverse ups) 3))
|
(equal? (map strip-source (list-head (reverse ups) 3))
|
||||||
(list (make-toplevel-ref #f '+)
|
(list (make-toplevel-ref #f '+)
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue