summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-09-27 18:16:56 -0400
committerAndy Wingo <wingo@pobox.com>2009-10-23 14:51:17 +0200
commit1e2a8c266d720a5dca97a96e5cde860a9d934ad6 (patch)
tree01dfd6714e8afaa0213ea75ec9b751092c9b7f45
parent04c68c039194f33d5bd7e8b1f21eba7c8bd6adbe (diff)
downloadguile-1e2a8c266d720a5dca97a96e5cde860a9d934ad6.tar.gz
steps on the way to have the callee check the number of arguments
* 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.
-rw-r--r--libguile/_scm.h2
-rw-r--r--libguile/vm-i-system.c93
-rw-r--r--module/language/glil.scm6
-rw-r--r--module/language/glil/compile-assembly.scm20
-rw-r--r--module/language/tree-il/compile-glil.scm21
-rw-r--r--test-suite/tests/tree-il.test134
6 files changed, 172 insertions, 104 deletions
diff --git a/libguile/_scm.h b/libguile/_scm.h
index 6aedebe72..f50d4ff10 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -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 \
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index ac237e5b5..ab901e281 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -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 ();
diff --git a/module/language/glil.scm b/module/language/glil.scm
index bfe81ef94..7f326efc1 100644
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -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))
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index 1bae3213e..5de5b70cf 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -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))
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index 94e1904c5..444aa7bed 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -189,21 +189,24 @@
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)
(pmatch (hashq-ref (hashq-ref allocation v) x)
- ((#t #t . ,n)
- (emit-code #f (make-glil-lexical #t #f 'ref n))
- (emit-code #f (make-glil-lexical #t #t 'box n)))))
+ ((#t #t . ,n)
+ (emit-code #f (make-glil-lexical #t #f 'ref n))
+ (emit-code #f (make-glil-lexical #t #t 'box n)))))
vars)
;; and here, here, dear reader: we compile.
(flatten (lambda-body x) allocation x self-label
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 90dde7d00..0ac1d12ba 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -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))))