mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
flesh out glil support for optional and keyword arguments
* libguile/vm-i-system.c (bind-rest): Renamed from push-rest-list. (reserve-locals): Change so that instead of reserving space for some additional number of locals, reserve-locals takes the absolute number of locals, including the arguments. * module/language/glil.scm (<glil-std-prelude>, <glil-opt-prelude>) (<glil-kw-prelude>): New GLIL constructs, to replace <glil-arity>. * module/language/glil/compile-assembly.scm (glil->assembly): Compile the new preludes. Some instructions are not yet implemented, though. * module/language/tree-il/analyze.scm (analyze-lexicals): The nlocs for a lambda will now be the total number of locals, including arguments. * module/language/tree-il/compile-glil.scm (flatten-lambda): Update to write the new prelude. * module/system/vm/program.scm (program-bindings-for-ip): If a given index doesn't have a binding at the ip given, don't cons it on the resulting list. * test-suite/tests/tree-il.test: Update for GLIL changes.
This commit is contained in:
Andy Wingo
parent
56164a5a6c
commit
258344b4db
6 changed files with 206 additions and 109 deletions
|
|
@ -500,7 +500,7 @@ VM_DEFINE_INSTRUCTION (39, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
|
|||
NEXT;
|
||||
}
|
||||
|
||||
VM_DEFINE_INSTRUCTION (40, push_rest_list, "push-rest-list", 2, -1, -1)
|
||||
VM_DEFINE_INSTRUCTION (40, bind_rest, "bind-rest", 2, -1, -1)
|
||||
{
|
||||
scm_t_ptrdiff n;
|
||||
SCM rest = SCM_EOL;
|
||||
|
|
@ -515,13 +515,22 @@ VM_DEFINE_INSTRUCTION (40, push_rest_list, "push-rest-list", 2, -1, -1)
|
|||
|
||||
VM_DEFINE_INSTRUCTION (41, reserve_locals, "reserve-locals", 2, -1, -1)
|
||||
{
|
||||
SCM *old_sp;
|
||||
scm_t_int32 n;
|
||||
n = FETCH () << 8;
|
||||
n += FETCH ();
|
||||
sp += n;
|
||||
CHECK_OVERFLOW ();
|
||||
while (n--)
|
||||
sp[-n] = SCM_UNDEFINED;
|
||||
old_sp = sp;
|
||||
sp = (fp - 1) + n;
|
||||
|
||||
if (old_sp < sp)
|
||||
{
|
||||
CHECK_OVERFLOW ();
|
||||
while (old_sp < sp)
|
||||
*++old_sp = SCM_UNDEFINED;
|
||||
}
|
||||
else
|
||||
NULLSTACK (old_sp - sp);
|
||||
|
||||
NEXT;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -26,8 +26,17 @@
|
|||
(<glil-program> make-glil-program glil-program?
|
||||
glil-program-meta glil-program-body
|
||||
|
||||
<glil-arity> make-glil-arity glil-arity?
|
||||
glil-arity-nargs glil-arity-nrest glil-arity-label
|
||||
<glil-std-prelude> make-glil-std-prelude glil-std-prelude?
|
||||
glil-std-prelude-nreq glil-std-prelude-nlocs glil-std-prelude-else-label
|
||||
|
||||
<glil-opt-prelude> make-glil-opt-prelude glil-opt-prelude?
|
||||
glil-opt-prelude-nreq glil-opt-prelude-nopt glil-opt-prelude-rest?
|
||||
glil-opt-prelude-nlocs glil-opt-prelude-else-label
|
||||
|
||||
<glil-kw-prelude> make-glil-kw-prelude glil-kw-prelude?
|
||||
glil-kw-prelude-nreq glil-kw-prelude-nopt glil-kw-prelude-kw
|
||||
glil-kw-prelude-allow-other-keys? glil-kw-prelude-rest?
|
||||
glil-kw-prelude-nlocs glil-kw-prelude-else-label
|
||||
|
||||
<glil-bind> make-glil-bind glil-bind?
|
||||
glil-bind-vars
|
||||
|
|
@ -74,7 +83,9 @@
|
|||
(define-type (<glil> #:printer print-glil)
|
||||
;; Meta operations
|
||||
(<glil-program> meta body)
|
||||
(<glil-arity> nargs nrest label)
|
||||
(<glil-std-prelude> nreq nlocs else-label)
|
||||
(<glil-opt-prelude> nreq nopt rest? nlocs else-label)
|
||||
(<glil-kw-prelude> nreq nopt rest? kw allow-other-keys? nlocs else-label)
|
||||
(<glil-bind> vars)
|
||||
(<glil-mv-bind> vars rest)
|
||||
(<glil-unbind>)
|
||||
|
|
@ -98,7 +109,12 @@
|
|||
(pmatch x
|
||||
((program ,meta . ,body)
|
||||
(make-glil-program meta (map parse-glil body)))
|
||||
((arity ,nargs ,nrest ,label) (make-glil-arity nargs nrest label))
|
||||
((std-prelude ,nreq ,nlocs ,else-label)
|
||||
(make-glil-std-prelude nreq nlocs else-label))
|
||||
((opt-prelude ,nreq ,nopt ,rest? ,nlocs ,else-label)
|
||||
(make-glil-opt-prelude nreq nopt rest? nlocs else-label))
|
||||
((kw-prelude ,nreq ,nopt ,rest? ,kw ,allow-other-keys? ,nlocs ,else-label)
|
||||
(make-glil-kw-prelude nreq nopt rest? kw allow-other-keys? nlocs else-label))
|
||||
((bind . ,vars) (make-glil-bind vars))
|
||||
((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
|
||||
((unbind) (make-glil-unbind))
|
||||
|
|
@ -120,7 +136,12 @@
|
|||
;; meta
|
||||
((<glil-program> meta body)
|
||||
`(program ,meta ,@(map unparse-glil body)))
|
||||
((<glil-arity> nargs nrest label) `(arity ,nargs ,nrest ,label))
|
||||
((<glil-std-prelude> nreq nlocs else-label)
|
||||
`(std-prelude ,nreq ,nlocs ,else-label))
|
||||
((<glil-opt-prelude> nreq nopt rest? nlocs else-label)
|
||||
`(opt-prelude ,nreq ,nopt ,rest? ,nlocs ,else-label))
|
||||
((<glil-kw-prelude> nreq nopt rest? kw allow-other-keys? nlocs else-label)
|
||||
`(kw-prelude ,nreq ,nopt ,rest? ,kw ,allow-other-keys? ,nlocs ,else-label))
|
||||
((<glil-bind> vars) `(bind ,@vars))
|
||||
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
|
||||
((<glil-unbind>) `(unbind))
|
||||
|
|
|
|||
|
|
@ -141,7 +141,7 @@
|
|||
(kw (list addr nreq nopt rest? kw))
|
||||
(rest? (list addr nreq nopt rest?))
|
||||
(nopt (list addr nreq nopt))
|
||||
(nreq (list addr req))
|
||||
(nreq (list addr nreq))
|
||||
(else (list addr)))
|
||||
arities))
|
||||
|
||||
|
|
@ -154,7 +154,7 @@
|
|||
(define (emit-code/arity x nreq nopt rest? kw)
|
||||
(values x bindings source-alist label-alist object-alist
|
||||
(begin-arity (addr+ addr x) nreq nopt rest? kw arities)))
|
||||
|
||||
|
||||
(record-case glil
|
||||
((<glil-program> meta body)
|
||||
(define (process-body)
|
||||
|
|
@ -218,6 +218,94 @@
|
|||
`(,@table-code
|
||||
,@(align-program prog (addr+ addr table-code)))))))))))))
|
||||
|
||||
((<glil-std-prelude> nreq nlocs else-label)
|
||||
(emit-code/arity
|
||||
`(,(if else-label
|
||||
`(br-if-nargs-ne ,(quotient nreq 256)
|
||||
,(modulo nreq 256)
|
||||
,else-label)
|
||||
`(assert-nargs-ee ,(quotient nreq 256)
|
||||
,(modulo nreq 256)))
|
||||
(reserve-locals ,(quotient nlocs 256)
|
||||
,(modulo nlocs 256)))
|
||||
nreq #f #f #f))
|
||||
|
||||
((<glil-opt-prelude> nreq nopt rest? nlocs else-label)
|
||||
(let ((bind-required
|
||||
(if else-label
|
||||
`((br-if-nargs-lt ,(quotient nreq 256)
|
||||
,(modulo nreq 256)
|
||||
,else-label))
|
||||
`((assert-nargs-ge ,(quotient nreq 256)
|
||||
,(modulo nreq 256)))))
|
||||
(bind-optionals
|
||||
(if (zero? nopt)
|
||||
'()
|
||||
`((bind-optionals ,(quotient (+ nopt nreq) 256)
|
||||
,(modulo (+ nreq nopt) 256)))))
|
||||
(bind-rest
|
||||
(cond
|
||||
(rest?
|
||||
`((bind-rest ,(quotient (+ nreq nopt) 256)
|
||||
,(modulo (+ nreq nopt) 256))))
|
||||
(else
|
||||
(if else-label
|
||||
`((br-if-nargs-ge ,(quotient (+ nreq nopt) 256)
|
||||
,(modulo (+ nreq nopt) 256)
|
||||
,else-label))
|
||||
`((assert-nargs-ee ,(quotient (+ nreq nopt) 256)
|
||||
,(modulo (+ nreq nopt) 256))))))))
|
||||
(emit-code/arity
|
||||
`(,@bind-required
|
||||
,@bind-optionals
|
||||
,@bind-rest
|
||||
(reserve-locals ,(quotient nlocs 256)
|
||||
,(modulo nlocs 256)))
|
||||
nreq nopt rest? #f)))
|
||||
|
||||
((<glil-kw-prelude> nreq nopt rest? kw allow-other-keys? nlocs else-label)
|
||||
(receive (kw-idx object-alist)
|
||||
(object-index-and-alist object-alist kw)
|
||||
(let ((bind-required
|
||||
(if else-label
|
||||
`((br-if-nargs-lt ,(quotient nreq 256)
|
||||
,(modulo nreq 256)
|
||||
,else-label))
|
||||
`((assert-nargs-ge ,(quotient nreq 256)
|
||||
,(modulo nreq 256)))))
|
||||
(bind-optionals-and-shuffle
|
||||
`((bind-optionals-and-shuffle-kwargs
|
||||
,(quotient (+ nreq nopt) 256)
|
||||
,(modulo (+ nreq nopt) 256)
|
||||
,(quotient (apply max (+ nreq nopt) (map cdr kw)) 256)
|
||||
,(modulo (apply max (+ nreq nopt) (map cdr kw)) 256))))
|
||||
(bind-kw
|
||||
;; when this code gets called, all optionals are filled
|
||||
;; in, space has been made for kwargs, and the kwargs
|
||||
;; themselves have been shuffled above the slots for all
|
||||
;; req/opt/kwargs locals.
|
||||
`((,(if allow-other-keys? 'bind-kwargs/aok 'bind-kwargs/no-aok)
|
||||
,(quotient kw-idx 256)
|
||||
,(modulo kw-idx 256)
|
||||
,(quotient (+ nreq nopt) 256)
|
||||
,(modulo (+ nreq nopt) 256)
|
||||
,(quotient (apply max (+ nreq nopt) (map cdr kw)) 256)
|
||||
,(modulo (apply max (+ nreq nopt) (map cdr kw)) 256))))
|
||||
(bind-rest
|
||||
(if rest?
|
||||
`((bind-rest ,(quotient (apply max (+ nreq nopt) (map cdr kw)) 256)
|
||||
,(modulo (apply max (+ nreq nopt) (map cdr kw)) 256)))
|
||||
'())))
|
||||
|
||||
(let ((code `(,@bind-required
|
||||
,@bind-optionals-and-shuffle
|
||||
,@bind-kw
|
||||
,@bind-rest
|
||||
(reserve-locals ,(quotient nlocs 256)
|
||||
,(modulo nlocs 256)))))
|
||||
(values code bindings source-alist label-alist object-alist
|
||||
(begin-arity (addr+ addr code) nreq nopt rest? kw arities))))))
|
||||
|
||||
((<glil-bind> vars)
|
||||
(values '()
|
||||
(open-binding bindings vars addr)
|
||||
|
|
@ -379,28 +467,6 @@
|
|||
((<glil-branch> inst label)
|
||||
(emit-code `((,inst ,label))))
|
||||
|
||||
((<glil-arity> nargs nrest label)
|
||||
(emit-code/arity
|
||||
(if label
|
||||
(if (zero? nrest)
|
||||
`((br-if-nargs-ne ,(quotient nargs 256) ,label))
|
||||
`(,@(if (> nargs 1)
|
||||
`((br-if-nargs-lt ,(quotient (1- nargs) 256)
|
||||
,(modulo (1- nargs 256))
|
||||
,label))
|
||||
'())
|
||||
(push-rest-list ,(quotient (1- nargs) 256))))
|
||||
(if (zero? nrest)
|
||||
`((assert-nargs-ee ,(quotient nargs 256)
|
||||
,(modulo nargs 256)))
|
||||
`(,@(if (> nargs 1)
|
||||
`((assert-nargs-ge ,(quotient (1- nargs) 256)
|
||||
,(modulo (1- nargs) 256)))
|
||||
'())
|
||||
(push-rest-list ,(quotient (1- nargs) 256)
|
||||
,(modulo (1- nargs) 256)))))
|
||||
(- nargs nrest) 0 (< 0 nrest) #f))
|
||||
|
||||
;; nargs is number of stack args to insn. probably should rename.
|
||||
((<glil-call> inst nargs)
|
||||
(if (not (instruction? inst))
|
||||
|
|
|
|||
|
|
@ -361,8 +361,9 @@
|
|||
(make-hashq
|
||||
x `(#t ,(hashq-ref assigned v) . ,n)))
|
||||
(lp (if (pair? vars) (cdr vars) '()) (1+ n)))
|
||||
;; allocate body, return number of additional locals
|
||||
(- (allocate! body x n) n))))
|
||||
;; allocate body, return total number of locals
|
||||
;; (including arguments)
|
||||
(allocate! body x n))))
|
||||
(free-addresses
|
||||
(map (lambda (v)
|
||||
(hashq-ref (hashq-ref allocation v) proc))
|
||||
|
|
|
|||
|
|
@ -192,15 +192,15 @@
|
|||
;; write source info for proc
|
||||
(if (lambda-src x)
|
||||
(emit-code #f (make-glil-source (lambda-src x))))
|
||||
;; check arity, potentially consing a rest list
|
||||
(emit-code #f (make-glil-arity nargs nrest #f))
|
||||
;; reserve space for locals, if necessary
|
||||
(if (not (zero? nlocs))
|
||||
(emit-code #f (make-glil-call 'reserve-locals nlocs)))
|
||||
;; the prelude, to check args & reset the stack pointer,
|
||||
;; allowing room for locals
|
||||
(if (zero? nrest)
|
||||
(emit-code #f (make-glil-std-prelude nargs nlocs #f))
|
||||
(emit-code #f (make-glil-opt-prelude (1- nargs) 0 #t nlocs #f)))
|
||||
;; write bindings info
|
||||
(if (not (null? ids))
|
||||
(emit-bindings #f ids vars allocation x emit-code))
|
||||
;; emit post-prelude label for self tail calls
|
||||
;; post-prelude label for self tail calls
|
||||
(if self-label
|
||||
(emit-code #f (make-glil-label self-label)))
|
||||
;; box args if necessary
|
||||
|
|
|
|||
|
|
@ -69,21 +69,21 @@
|
|||
(with-test-prefix "void"
|
||||
(assert-tree-il->glil
|
||||
(void)
|
||||
(program () (arity 0 0 #f) (void) (call return 1)))
|
||||
(program () (std-prelude 0 0 #f) (void) (call return 1)))
|
||||
(assert-tree-il->glil
|
||||
(begin (void) (const 1))
|
||||
(program () (arity 0 0 #f) (const 1) (call return 1)))
|
||||
(program () (std-prelude 0 0 #f) (const 1) (call return 1)))
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive +) (void) (const 1))
|
||||
(program () (arity 0 0 #f) (void) (call add1 1) (call return 1))))
|
||||
(program () (std-prelude 0 0 #f) (void) (call add1 1) (call return 1))))
|
||||
|
||||
(with-test-prefix "application"
|
||||
(assert-tree-il->glil
|
||||
(apply (toplevel foo) (const 1))
|
||||
(program () (arity 0 0 #f) (toplevel ref foo) (const 1) (call goto/args 1)))
|
||||
(program () (std-prelude 0 0 #f) (toplevel ref foo) (const 1) (call goto/args 1)))
|
||||
(assert-tree-il->glil/pmatch
|
||||
(begin (apply (toplevel foo) (const 1)) (void))
|
||||
(program () (arity 0 0 #f) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
|
||||
(program () (std-prelude 0 0 #f) (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
|
||||
(call drop 1) (branch br ,l2)
|
||||
(label ,l3) (mv-bind () #f) (unbind)
|
||||
(label ,l4)
|
||||
|
|
@ -91,26 +91,26 @@
|
|||
(and (eq? l1 l3) (eq? l2 l4)))
|
||||
(assert-tree-il->glil
|
||||
(apply (toplevel foo) (apply (toplevel bar)))
|
||||
(program () (arity 0 0 #f)(toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
|
||||
(program () (std-prelude 0 0 #f)(toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
|
||||
(call goto/args 1))))
|
||||
|
||||
(with-test-prefix "conditional"
|
||||
(assert-tree-il->glil/pmatch
|
||||
(if (const #t) (const 1) (const 2))
|
||||
(program () (arity 0 0 #f) (const #t) (branch br-if-not ,l1)
|
||||
(program () (std-prelude 0 0 #f) (const #t) (branch br-if-not ,l1)
|
||||
(const 1) (call return 1)
|
||||
(label ,l2) (const 2) (call return 1))
|
||||
(eq? l1 l2))
|
||||
|
||||
(assert-tree-il->glil/pmatch
|
||||
(begin (if (const #t) (const 1) (const 2)) (const #f))
|
||||
(program () (arity 0 0 #f) (const #t) (branch br-if-not ,l1) (branch br ,l2)
|
||||
(program () (std-prelude 0 0 #f) (const #t) (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/pmatch
|
||||
(apply (primitive null?) (if (const #t) (const 1) (const 2)))
|
||||
(program () (arity 0 0 #f) (const #t) (branch br-if-not ,l1)
|
||||
(program () (std-prelude 0 0 #f) (const #t) (branch br-if-not ,l1)
|
||||
(const 1) (branch br ,l2)
|
||||
(label ,l3) (const 2) (label ,l4)
|
||||
(call null? 1) (call return 1))
|
||||
|
|
@ -119,35 +119,35 @@
|
|||
(with-test-prefix "primitive-ref"
|
||||
(assert-tree-il->glil
|
||||
(primitive +)
|
||||
(program () (arity 0 0 #f) (toplevel ref +) (call return 1)))
|
||||
(program () (std-prelude 0 0 #f) (toplevel ref +) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (primitive +) (const #f))
|
||||
(program () (arity 0 0 #f) (const #f) (call return 1)))
|
||||
(program () (std-prelude 0 0 #f) (const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (primitive +))
|
||||
(program () (arity 0 0 #f) (toplevel ref +) (call null? 1)
|
||||
(program () (std-prelude 0 0 #f) (toplevel ref +) (call null? 1)
|
||||
(call return 1))))
|
||||
|
||||
(with-test-prefix "lexical refs"
|
||||
(assert-tree-il->glil
|
||||
(let (x) (y) ((const 1)) (lexical x y))
|
||||
(program () (arity 0 0 #f) (call reserve-locals 1)
|
||||
(program () (std-prelude 0 1 #f)
|
||||
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
|
||||
(lexical #t #f ref 0) (call return 1)
|
||||
(unbind)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
|
||||
(program () (arity 0 0 #f) (call reserve-locals 1)
|
||||
(program () (std-prelude 0 1 #f)
|
||||
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
|
||||
(const #f) (call return 1)
|
||||
(unbind)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(let (x) (y) ((const 1)) (apply (primitive null?) (lexical x y)))
|
||||
(program () (arity 0 0 #f) (call reserve-locals 1)
|
||||
(program () (std-prelude 0 1 #f)
|
||||
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
|
||||
(lexical #t #f ref 0) (call null? 1) (call return 1)
|
||||
(unbind))))
|
||||
|
|
@ -157,7 +157,7 @@
|
|||
;; unreferenced sets may be optimized away -- make sure they are ref'd
|
||||
(let (x) (y) ((const 1))
|
||||
(set! (lexical x y) (apply (primitive 1+) (lexical x y))))
|
||||
(program () (arity 0 0 #f) (call reserve-locals 1)
|
||||
(program () (std-prelude 0 1 #f)
|
||||
(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)
|
||||
|
|
@ -167,7 +167,7 @@
|
|||
(let (x) (y) ((const 1))
|
||||
(begin (set! (lexical x y) (apply (primitive 1+) (lexical x y)))
|
||||
(lexical x y)))
|
||||
(program () (arity 0 0 #f) (call reserve-locals 1)
|
||||
(program () (std-prelude 0 1 #f)
|
||||
(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)
|
||||
|
|
@ -177,7 +177,7 @@
|
|||
(let (x) (y) ((const 1))
|
||||
(apply (primitive null?)
|
||||
(set! (lexical x y) (apply (primitive 1+) (lexical x y)))))
|
||||
(program () (arity 0 0 #f) (call reserve-locals 1)
|
||||
(program () (std-prelude 0 1 #f)
|
||||
(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)
|
||||
|
|
@ -186,205 +186,205 @@
|
|||
(with-test-prefix "module refs"
|
||||
(assert-tree-il->glil
|
||||
(@ (foo) bar)
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(module public ref (foo) bar)
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (@ (foo) bar) (const #f))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(module public ref (foo) bar) (call drop 1)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (@ (foo) bar))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(module public ref (foo) bar)
|
||||
(call null? 1) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(@@ (foo) bar)
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(module private ref (foo) bar)
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (@@ (foo) bar) (const #f))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(module private ref (foo) bar) (call drop 1)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (@@ (foo) bar))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(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 () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(const 2) (module public set (foo) bar)
|
||||
(void) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (set! (@ (foo) bar) (const 2)) (const #f))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(const 2) (module public set (foo) bar)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (set! (@ (foo) bar) (const 2)))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(const 2) (module public set (foo) bar)
|
||||
(void) (call null? 1) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(set! (@@ (foo) bar) (const 2))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(const 2) (module private set (foo) bar)
|
||||
(void) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (set! (@@ (foo) bar) (const 2)) (const #f))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(const 2) (module private set (foo) bar)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (set! (@@ (foo) bar) (const 2)))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(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 () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(toplevel ref bar)
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (toplevel bar) (const #f))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(toplevel ref bar) (call drop 1)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (toplevel bar))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(toplevel ref bar)
|
||||
(call null? 1) (call return 1))))
|
||||
|
||||
(with-test-prefix "toplevel sets"
|
||||
(assert-tree-il->glil
|
||||
(set! (toplevel bar) (const 2))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(const 2) (toplevel set bar)
|
||||
(void) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (set! (toplevel bar) (const 2)) (const #f))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(const 2) (toplevel set bar)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (set! (toplevel bar) (const 2)))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(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 () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(const 2) (toplevel define bar)
|
||||
(void) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (define bar (const 2)) (const #f))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(const 2) (toplevel define bar)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (define bar (const 2)))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(const 2) (toplevel define bar)
|
||||
(void) (call null? 1) (call return 1))))
|
||||
|
||||
(with-test-prefix "constants"
|
||||
(assert-tree-il->glil
|
||||
(const 2)
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(const 2) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(begin (const 2) (const #f))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(const #f) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (const 2))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(const 2) (call null? 1) (call return 1))))
|
||||
|
||||
(with-test-prefix "lambda"
|
||||
(assert-tree-il->glil
|
||||
(lambda (x) (y) () (const 2))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (arity 1 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (std-prelude 1 1 #f)
|
||||
(bind (x #f 0))
|
||||
(const 2) (call return 1))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda (x x1) (y y1) () (const 2))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (arity 2 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (std-prelude 2 2 #f)
|
||||
(bind (x #f 0) (x1 #f 1))
|
||||
(const 2) (call return 1))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda x y () (const 2))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (arity 1 1 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (opt-prelude 0 0 #t 1 #f)
|
||||
(bind (x #f 0))
|
||||
(const 2) (call return 1))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda (x . x1) (y . y1) () (const 2))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (arity 2 1 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (opt-prelude 1 0 #t 2 #f)
|
||||
(bind (x #f 0) (x1 #f 1))
|
||||
(const 2) (call return 1))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda (x . x1) (y . y1) () (lexical x y))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (arity 2 1 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (opt-prelude 1 0 #t 2 #f)
|
||||
(bind (x #f 0) (x1 #f 1))
|
||||
(lexical #t #f ref 0) (call return 1))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda (x . x1) (y . y1) () (lexical x1 y1))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (arity 2 1 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (opt-prelude 1 0 #t 2 #f)
|
||||
(bind (x #f 0) (x1 #f 1))
|
||||
(lexical #t #f ref 1) (call return 1))
|
||||
(call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(lambda (x) (x1) () (lambda (y) (y1) () (lexical x x1)))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (arity 1 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(program () (std-prelude 1 1 #f)
|
||||
(bind (x #f 0))
|
||||
(program () (arity 1 0 #f)
|
||||
(program () (std-prelude 1 1 #f)
|
||||
(bind (y #f 0))
|
||||
(lexical #f #f ref 0) (call return 1))
|
||||
(lexical #t #f ref 0)
|
||||
|
|
@ -396,12 +396,12 @@
|
|||
(with-test-prefix "sequence"
|
||||
(assert-tree-il->glil
|
||||
(begin (begin (const 2) (const #f)) (const #t))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(const #t) (call return 1)))
|
||||
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive null?) (begin (const #f) (const 2)))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(const 2) (call null? 1) (call return 1))))
|
||||
|
||||
;; FIXME: binding info for or-hacked locals might bork the disassembler,
|
||||
|
|
@ -413,7 +413,7 @@
|
|||
(lexical x y)
|
||||
(let (a) (b) ((const 2))
|
||||
(lexical a b))))
|
||||
(program () (arity 0 0 #f) (call reserve-locals 1)
|
||||
(program () (std-prelude 0 1 #f)
|
||||
(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)
|
||||
|
|
@ -431,7 +431,7 @@
|
|||
(lexical x y)
|
||||
(let (a) (b) ((const 2))
|
||||
(lexical x y))))
|
||||
(program () (arity 0 0 #f) (call reserve-locals 1)
|
||||
(program () (std-prelude 0 1 #f)
|
||||
(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)
|
||||
|
|
@ -443,10 +443,10 @@
|
|||
(with-test-prefix "apply"
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive @apply) (toplevel foo) (toplevel bar))
|
||||
(program () (arity 0 0 #f) (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
|
||||
(program () (std-prelude 0 0 #f) (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
|
||||
(assert-tree-il->glil/pmatch
|
||||
(begin (apply (primitive @apply) (toplevel foo) (toplevel bar)) (void))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(call new-frame 0) (toplevel ref apply) (toplevel ref foo) (toplevel ref bar) (mv-call 2 ,l1)
|
||||
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
|
||||
(label ,l4)
|
||||
|
|
@ -454,7 +454,7 @@
|
|||
(and (eq? l1 l3) (eq? l2 l4)))
|
||||
(assert-tree-il->glil
|
||||
(apply (toplevel foo) (apply (toplevel @apply) (toplevel bar) (toplevel baz)))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(toplevel ref foo)
|
||||
(call new-frame 0) (toplevel ref bar) (toplevel ref baz) (call apply 2)
|
||||
(call goto/args 1))))
|
||||
|
|
@ -462,10 +462,10 @@
|
|||
(with-test-prefix "call/cc"
|
||||
(assert-tree-il->glil
|
||||
(apply (primitive @call-with-current-continuation) (toplevel foo))
|
||||
(program () (arity 0 0 #f) (toplevel ref foo) (call goto/cc 1)))
|
||||
(program () (std-prelude 0 0 #f) (toplevel ref foo) (call goto/cc 1)))
|
||||
(assert-tree-il->glil/pmatch
|
||||
(begin (apply (primitive @call-with-current-continuation) (toplevel foo)) (void))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(call new-frame 0) (toplevel ref call-with-current-continuation) (toplevel ref foo) (mv-call 1 ,l1)
|
||||
(call drop 1) (branch br ,l2) (label ,l3) (mv-bind () #f) (unbind)
|
||||
(label ,l4)
|
||||
|
|
@ -474,7 +474,7 @@
|
|||
(assert-tree-il->glil
|
||||
(apply (toplevel foo)
|
||||
(apply (toplevel @call-with-current-continuation) (toplevel bar)))
|
||||
(program () (arity 0 0 #f)
|
||||
(program () (std-prelude 0 0 #f)
|
||||
(toplevel ref foo)
|
||||
(toplevel ref bar) (call call/cc 1)
|
||||
(call goto/args 1))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue