From: Andy Wingo <wingo@pobox.com>
Date: Tue, 13 Oct 2009 21:55:58 +0000 (+0200)
Subject: flesh out glil support for optional and keyword arguments
X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/258344b4db4b9dab1979bbef53606c0cd34b4095

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.
---

diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 71d066667..b1a261a68 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -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;
 }
 
diff --git a/module/language/glil.scm b/module/language/glil.scm
index 7e8d73d94..1202dbe25 100644
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -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))
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index 48d747453..14ecfcba7 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -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))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index d6895591c..656c18752 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -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))
diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index f80ff0378..a641ceda0 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -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
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index 06e2a3e27..c094a3306 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 () (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))))