mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 12:20:26 +02:00
Code Activity

steps on the way to have the callee check the number of arguments

Browse source 
* libguile/_scm.h (SCM_OBJCODE_MINOR_VERSION): Bump.

* libguile/vm-i-system.c (assert-nargs-ee, assert-nargs-ge)
  (push-rest-list): New instructions, which for now don't actually do
  anything. Renumber the rest of the ops in this file.

* module/language/glil.scm (<glil-arity>): New GLIL type, an entity that
  checks the number of args for a block, optionally consing a rest list,
  and either branching or erroring if the arity doesn't match.

* module/language/glil/compile-assembly.scm (glil->assembly): Compile
  <glil-arity> to assembly. Some of these VM ops are not implemented --
  notably the branching case.

* module/language/tree-il/compile-glil.scm (flatten-lambda): Emit
  <glil-arity>.

* test-suite/tests/tree-il.test: Update.
This commit is contained in:
Andy Wingo 2009-09-27 18:16:56 -04:00
parent 04c68c0391
commit 1e2a8c266d
6 changed files with 172 additions and 104 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/_scm.h
View file

@ -172,7 +172,7 @@
/* Major and minor versions must be single characters. */
#define SCM_OBJCODE_MAJOR_VERSION 0
#define SCM_OBJCODE_MINOR_VERSION E
#define SCM_OBJCODE_MINOR_VERSION F
#define SCM_OBJCODE_MAJOR_VERSION_STRING \
SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
#define SCM_OBJCODE_MINOR_VERSION_STRING \

93
libguile/vm-i-system.c
View file

@ -476,7 +476,46 @@ VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 3, 0, 0)
* Subprogram call
*/
VM_DEFINE_INSTRUCTION (38, new_frame, "new-frame", 0, 0, 3)
VM_DEFINE_INSTRUCTION (38, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
n += FETCH ();
#if 0
if (sp - fp != n)
goto vm_error_wrong_num_args;
#endif
NEXT;
}
VM_DEFINE_INSTRUCTION (39, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
n += FETCH ();
#if 0
if (sp - fp < n)
goto vm_error_wrong_num_args;
#endif
NEXT;
}
VM_DEFINE_INSTRUCTION (40, push_rest_list, "push-rest-list", 2, -1, -1)
{
scm_t_ptrdiff n;
n = FETCH () << 8;
n += FETCH ();
#if 0
SCM rest = SCM_EOL;
while (sp - fp >= n)
/* No need to check for underflow. */
CONS (rest, *sp--, rest);
PUSH (rest);
#endif
NEXT;
}
VM_DEFINE_INSTRUCTION (41, new_frame, "new-frame", 0, 0, 3)
{
PUSH ((SCM)fp); /* dynamic link */
PUSH (0); /* mvra */
@ -484,7 +523,7 @@ VM_DEFINE_INSTRUCTION (38, new_frame, "new-frame", 0, 0, 3)
NEXT;
}
VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
VM_DEFINE_INSTRUCTION (42, call, "call", 1, -1, 1)
{
SCM x;
nargs = FETCH ();
@ -546,7 +585,7 @@ VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
goto vm_error_wrong_type_apply;
}
VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
VM_DEFINE_INSTRUCTION (43, goto_args, "goto/args", 1, -1, 1)
{
register SCM x;
nargs = FETCH ();
@ -625,7 +664,7 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
goto vm_error_wrong_type_apply;
}
VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
VM_DEFINE_INSTRUCTION (44, goto_nargs, "goto/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@ -634,7 +673,7 @@ VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
goto vm_goto_args;
}
VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
VM_DEFINE_INSTRUCTION (45, call_nargs, "call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@ -643,7 +682,7 @@ VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
goto vm_call;
}
VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 4, -1, 1)
VM_DEFINE_INSTRUCTION (46, mv_call, "mv-call", 4, -1, 1)
{
SCM x;
scm_t_int32 offset;
@ -706,7 +745,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 4, -1, 1)
goto vm_error_wrong_type_apply;
}
VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
VM_DEFINE_INSTRUCTION (47, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
@ -725,7 +764,7 @@ VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
goto vm_call;
}
VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
VM_DEFINE_INSTRUCTION (48, goto_apply, "goto/apply", 1, -1, 1)
{
int len;
SCM ls;
@ -744,7 +783,7 @@ VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
goto vm_goto_args;
}
VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
VM_DEFINE_INSTRUCTION (49, call_cc, "call/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@ -781,7 +820,7 @@ VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
}
}
VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
VM_DEFINE_INSTRUCTION (50, goto_cc, "goto/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@ -813,7 +852,7 @@ VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
}
}
VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
VM_DEFINE_INSTRUCTION (51, return, "return", 0, 1, 1)
{
vm_return:
EXIT_HOOK ();
@ -850,7 +889,7 @@ VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
VM_DEFINE_INSTRUCTION (52, return_values, "return/values", 1, -1, -1)
{
/* nvalues declared at top level, because for some reason gcc seems to think
that perhaps it might be used without declaration. Fooey to that, I say. */
@ -907,7 +946,7 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
NEXT;
}
VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
VM_DEFINE_INSTRUCTION (53, return_values_star, "return/values*", 1, -1, -1)
{
SCM l;
@ -930,7 +969,7 @@ VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
goto vm_return_values;
}
VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
VM_DEFINE_INSTRUCTION (54, truncate_values, "truncate-values", 2, -1, -1)
{
SCM x;
int nbinds, rest;
@ -953,7 +992,7 @@ VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
NEXT;
}
VM_DEFINE_INSTRUCTION (52, box, "box", 1, 1, 0)
VM_DEFINE_INSTRUCTION (55, box, "box", 1, 1, 0)
{
SCM val;
POP (val);
@ -967,7 +1006,7 @@ VM_DEFINE_INSTRUCTION (52, box, "box", 1, 1, 0)
(set! a (lambda () (b ...)))
...)
*/
VM_DEFINE_INSTRUCTION (53, empty_box, "empty-box", 1, 0, 0)
VM_DEFINE_INSTRUCTION (56, empty_box, "empty-box", 1, 0, 0)
{
SYNC_BEFORE_GC ();
LOCAL_SET (FETCH (),
@ -975,7 +1014,7 @@ VM_DEFINE_INSTRUCTION (53, empty_box, "empty-box", 1, 0, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (54, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
VM_DEFINE_INSTRUCTION (57, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
{
SCM v = LOCAL_REF (FETCH ());
ASSERT_BOUND_VARIABLE (v);
@ -983,7 +1022,7 @@ VM_DEFINE_INSTRUCTION (54, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (55, local_boxed_set, "local-boxed-set", 1, 1, 0)
VM_DEFINE_INSTRUCTION (58, local_boxed_set, "local-boxed-set", 1, 1, 0)
{
SCM v, val;
v = LOCAL_REF (FETCH ());
@ -993,7 +1032,7 @@ VM_DEFINE_INSTRUCTION (55, local_boxed_set, "local-boxed-set", 1, 1, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (56, free_ref, "free-ref", 1, 0, 1)
VM_DEFINE_INSTRUCTION (59, free_ref, "free-ref", 1, 0, 1)
{
scm_t_uint8 idx = FETCH ();
@ -1004,7 +1043,7 @@ VM_DEFINE_INSTRUCTION (56, free_ref, "free-ref", 1, 0, 1)
/* no free-set -- if a var is assigned, it should be in a box */
VM_DEFINE_INSTRUCTION (57, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
VM_DEFINE_INSTRUCTION (60, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
{
SCM v;
scm_t_uint8 idx = FETCH ();
@ -1015,7 +1054,7 @@ VM_DEFINE_INSTRUCTION (57, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (58, free_boxed_set, "free-boxed-set", 1, 1, 0)
VM_DEFINE_INSTRUCTION (61, free_boxed_set, "free-boxed-set", 1, 1, 0)
{
SCM v, val;
scm_t_uint8 idx = FETCH ();
@ -1027,7 +1066,7 @@ VM_DEFINE_INSTRUCTION (58, free_boxed_set, "free-boxed-set", 1, 1, 0)
NEXT;
}
VM_DEFINE_INSTRUCTION (59, make_closure, "make-closure", 0, 2, 1)
VM_DEFINE_INSTRUCTION (62, make_closure, "make-closure", 0, 2, 1)
{
SCM vect;
POP (vect);
@ -1038,7 +1077,7 @@ VM_DEFINE_INSTRUCTION (59, make_closure, "make-closure", 0, 2, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (60, make_variable, "make-variable", 0, 0, 1)
VM_DEFINE_INSTRUCTION (63, make_variable, "make-variable", 0, 0, 1)
{
SYNC_BEFORE_GC ();
/* fixme underflow */
@ -1046,7 +1085,7 @@ VM_DEFINE_INSTRUCTION (60, make_variable, "make-variable", 0, 0, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (61, fix_closure, "fix-closure", 2, 0, 1)
VM_DEFINE_INSTRUCTION (64, fix_closure, "fix-closure", 2, 0, 1)
{
SCM x, vect;
unsigned int i = FETCH ();
@ -1060,7 +1099,7 @@ VM_DEFINE_INSTRUCTION (61, fix_closure, "fix-closure", 2, 0, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (62, define, "define", 0, 0, 2)
VM_DEFINE_INSTRUCTION (65, define, "define", 0, 0, 2)
{
SCM sym, val;
POP (sym);
@ -1072,7 +1111,7 @@ VM_DEFINE_INSTRUCTION (62, define, "define", 0, 0, 2)
NEXT;
}
VM_DEFINE_INSTRUCTION (63, make_keyword, "make-keyword", 0, 1, 1)
VM_DEFINE_INSTRUCTION (66, make_keyword, "make-keyword", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();
@ -1080,7 +1119,7 @@ VM_DEFINE_INSTRUCTION (63, make_keyword, "make-keyword", 0, 1, 1)
NEXT;
}
VM_DEFINE_INSTRUCTION (64, make_symbol, "make-symbol", 0, 1, 1)
VM_DEFINE_INSTRUCTION (67, make_symbol, "make-symbol", 0, 1, 1)
{
CHECK_UNDERFLOW ();
SYNC_REGISTER ();

6
module/language/glil.scm
View file

@ -27,6 +27,9 @@
glil-program-nargs glil-program-nrest glil-program-nlocs
glil-program-meta glil-program-body
<glil-arity> make-glil-arity glil-arity?
glil-arity-nargs glil-arity-nrest glil-arity-label
<glil-bind> make-glil-bind glil-bind?
glil-bind-vars
@ -72,6 +75,7 @@
(define-type (<glil> #:printer print-glil)
;; Meta operations
(<glil-program> nargs nrest nlocs meta body)
(<glil-arity> nargs nrest label)
(<glil-bind> vars)
(<glil-mv-bind> vars rest)
(<glil-unbind>)
@ -95,6 +99,7 @@
(pmatch x
((program ,nargs ,nrest ,nlocs ,meta . ,body)
(make-glil-program nargs nrest nlocs meta (map parse-glil body)))
((arity ,nargs ,nrest ,label) (make-glil-arity nargs nrest label))
((bind . ,vars) (make-glil-bind vars))
((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
((unbind) (make-glil-unbind))
@ -116,6 +121,7 @@
;; meta
((<glil-program> nargs nrest nlocs meta body)
`(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body)))
((<glil-arity> nargs nrest label) `(arity ,nargs ,nrest ,label))
((<glil-bind> vars) `(bind ,@vars))
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
((<glil-unbind>) `(unbind))

20
module/language/glil/compile-assembly.scm
View file

@ -356,6 +356,26 @@
((<glil-branch> inst label)
(emit-code `((,inst ,label))))
((<glil-arity> nargs nrest label)
(emit-code (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 is number of stack args to insn. probably should rename.
((<glil-call> inst nargs)
(if (not (instruction? inst))

15
module/language/tree-il/compile-glil.scm
View file

@ -189,14 +189,17 @@
nargs nrest nlocs (lambda-meta x)
(with-output-to-code
(lambda (emit-code)
;; emit label for self tail calls
(if self-label
(emit-code #f (make-glil-label self-label)))
;; write bindings and source debugging info
(if (not (null? ids))
(emit-bindings #f ids vars allocation x emit-code))
;; 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))
;; write bindings info
(if (not (null? ids))
(emit-bindings #f ids vars allocation x emit-code))
;; emit post-prelude label for self tail calls
(if self-label
(emit-code #f (make-glil-label self-label)))
;; box args if necessary
(for-each
(lambda (v)

134
test-suite/tests/tree-il.test
View file

@ -69,21 +69,21 @@
(with-test-prefix "void"
(assert-tree-il->glil
(void)
(program 0 0 0 () (void) (call return 1)))
(program 0 0 0 () (arity 0 0 #f) (void) (call return 1)))
(assert-tree-il->glil
(begin (void) (const 1))
(program 0 0 0 () (const 1) (call return 1)))
(program 0 0 0 () (arity 0 0 #f) (const 1) (call return 1)))
(assert-tree-il->glil
(apply (primitive +) (void) (const 1))
(program 0 0 0 () (void) (call add1 1) (call return 1))))
(program 0 0 0 () (arity 0 0 #f) (void) (call add1 1) (call return 1))))
(with-test-prefix "application"
(assert-tree-il->glil
(apply (toplevel foo) (const 1))
(program 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
(program 0 0 0 () (arity 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 0 0 0 () (call new-frame 0) (toplevel ref foo) (const 1) (mv-call 1 ,l1)
(program 0 0 0 () (arity 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 0 0 0 () (toplevel ref foo) (call new-frame 0) (toplevel ref bar) (call call 0)
(program 0 0 0 () (arity 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 0 0 0 () (const #t) (branch br-if-not ,l1)
(program 0 0 0 () (arity 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 0 0 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2)
(program 0 0 0 () (arity 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 0 0 0 () (const #t) (branch br-if-not ,l1)
(program 0 0 0 () (arity 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 0 0 0 () (toplevel ref +) (call return 1)))
(program 0 0 0 () (arity 0 0 #f) (toplevel ref +) (call return 1)))
(assert-tree-il->glil
(begin (primitive +) (const #f))
(program 0 0 0 () (const #f) (call return 1)))
(program 0 0 0 () (arity 0 0 #f) (const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (primitive +))
(program 0 0 0 () (toplevel ref +) (call null? 1)
(program 0 0 0 () (arity 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 0 0 1 ()
(program 0 0 1 () (arity 0 0 #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 0 0 1 ()
(program 0 0 1 () (arity 0 0 #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 0 0 1 ()
(program 0 0 1 () (arity 0 0 #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 0 0 1 ()
(program 0 0 1 () (arity 0 0 #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 0 0 1 ()
(program 0 0 1 () (arity 0 0 #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 0 0 1 ()
(program 0 0 1 () (arity 0 0 #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 0 0 0 ()
(program 0 0 0 () (arity 0 0 #f)
(module public ref (foo) bar)
(call return 1)))
(assert-tree-il->glil
(begin (@ (foo) bar) (const #f))
(program 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 0 0 #f)
(module public ref (foo) bar)
(call null? 1) (call return 1)))
(assert-tree-il->glil
(@@ (foo) bar)
(program 0 0 0 ()
(program 0 0 0 () (arity 0 0 #f)
(module private ref (foo) bar)
(call return 1)))
(assert-tree-il->glil
(begin (@@ (foo) bar) (const #f))
(program 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 0 0 #f)
(toplevel ref bar)
(call return 1)))
(assert-tree-il->glil
(begin (toplevel bar) (const #f))
(program 0 0 0 ()
(program 0 0 0 () (arity 0 0 #f)
(toplevel ref bar) (call drop 1)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (toplevel bar))
(program 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 0 0 #f)
(const 2) (toplevel define bar)
(void) (call return 1)))
(assert-tree-il->glil
(begin (define bar (const 2)) (const #f))
(program 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 0 0 #f)
(const 2) (call return 1)))
(assert-tree-il->glil
(begin (const 2) (const #f))
(program 0 0 0 ()
(program 0 0 0 () (arity 0 0 #f)
(const #f) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (const 2))
(program 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 1 0 0 ()
(program 0 0 0 () (arity 0 0 #f)
(program 1 0 0 () (arity 1 0 #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 0 0 0 ()
(program 2 0 0 ()
(program 0 0 0 () (arity 0 0 #f)
(program 2 0 0 () (arity 2 0 #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 0 0 0 ()
(program 1 1 0 ()
(program 0 0 0 () (arity 0 0 #f)
(program 1 1 0 () (arity 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 0 0 0 ()
(program 2 1 0 ()
(program 0 0 0 () (arity 0 0 #f)
(program 2 1 0 () (arity 2 1 #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 0 0 0 ()
(program 2 1 0 ()
(program 0 0 0 () (arity 0 0 #f)
(program 2 1 0 () (arity 2 1 #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 0 0 0 ()
(program 2 1 0 ()
(program 0 0 0 () (arity 0 0 #f)
(program 2 1 0 () (arity 2 1 #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 0 0 0 ()
(program 1 0 0 ()
(program 0 0 0 () (arity 0 0 #f)
(program 1 0 0 () (arity 1 0 #f)
(bind (x #f 0))
(program 1 0 0 ()
(program 1 0 0 () (arity 1 0 #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 0 0 0 ()
(program 0 0 0 () (arity 0 0 #f)
(const #t) (call return 1)))
(assert-tree-il->glil
(apply (primitive null?) (begin (const #f) (const 2)))
(program 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 1 ()
(program 0 0 1 () (arity 0 0 #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 0 0 1 ()
(program 0 0 1 () (arity 0 0 #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 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 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 0 0 0 ()
(program 0 0 0 () (arity 0 0 #f)
(toplevel ref foo)
(toplevel ref bar) (call call/cc 1)
(call goto/args 1))))