remove all mentions of "external" from the compiler and related code

With this, GHIL is effectively bitrotten. I need to port the ECMAScript
compiler to tree-il, then I'll remove it.

* module/language/assembly.scm (byte-length):
* module/language/assembly/compile-bytecode.scm (write-bytecode):
* module/language/assembly/decompile-bytecode.scm (decode-load-program):
* module/language/assembly/disassemble.scm (disassemble-load-program):
  (disassemble-free-vars, code-annotation):
* module/language/glil.scm (<glil-program>, <glil-local>)
  (<glil-exteral>, parse-glil, unparse-glil):
* module/language/glil/compile-assembly.scm (make-meta):
  (compile-assembly, glil->assembly):
* module/language/glil/decompile-assembly.scm (decompile-toplevel):
  (decompile-load-program):
* module/language/objcode/spec.scm (decompile-value):
* module/language/tree-il/compile-glil.scm (flatten-lambda):
* module/system/vm/frame.scm (frame-binding-ref):
  (frame-binding-set!):
* module/system/vm/program.scm (binding:boxed?):
* module/system/vm/trace.scm (trace-next):
* test-suite/tests/asm-to-bytecode.test ("compiler"):
* test-suite/tests/tree-il.test: Remove all mentions of "external", and
  of <glil-local>. Docs updates will come soon.

module/language/assembly.scm

@@ -28,7 +28,7 @@
             assembly-pack assembly-unpack
             object->assembly assembly->object))
 
-;; nargs, nrest, nlocs, nexts, len, metalen
+;; nargs, nrest, nlocs, <unused>, len, metalen
 (define *program-header-len* (+ 1 1 1 1 4 4))
 
 ;; lengths are encoded in 3 bytes
@@ -54,7 +54,7 @@
      (+ 1 *len-len* (bytevector-length bv)))
     ((define ,str)
      (+ 1 *len-len* (string-length str)))
-    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
+    ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
      (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
     ((,inst . _) (guard (>= (instruction-length inst) 0))
      (+ 1 (instruction-length inst)))

module/language/assembly/compile-bytecode.scm

@@ -89,12 +89,11 @@
           (len (instruction-length inst)))
       (write-byte opcode)
       (pmatch asm
-        ((load-program ,nargs ,nrest ,nlocs ,nexts
+        ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)
-                       ,labels ,length ,meta . ,code)
          (write-byte nargs)
          (write-byte nrest)
          (write-byte nlocs)
-         (write-byte nexts)
+         (write-byte 0) ;; what used to be nexts
          (write-uint32 length)
          (write-uint32 (if meta (1- (byte-length meta)) 0))
          (letrec ((i 0)

module/language/assembly/decompile-bytecode.scm

@@ -1,6 +1,6 @@
 ;;; Guile VM code converters
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -49,7 +49,7 @@
         (- x (ash 1 16)))))
 
 (define (decode-load-program pop)
-  (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (nexts (pop))
+  (let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (unused (pop))
          (a (pop)) (b (pop)) (c (pop)) (d (pop))
          (e (pop)) (f (pop)) (g (pop)) (h (pop))
          (len (+ a (ash b 8) (ash c 16) (ash d 24)))
@@ -74,7 +74,7 @@
       (cond ((> i len)
              (error "error decoding program -- read too many bytes" out))
             ((= i len)
-             `(load-program ,nargs ,nrest ,nlocs ,nexts
+             `(load-program ,nargs ,nrest ,nlocs 
                             ,(map (lambda (x) (cons (cdr x) (car x)))
                                   (reverse labels))
                             ,len

module/language/assembly/disassemble.scm

@@ -1,6 +1,6 @@
 ;;; Guile VM code converters
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -35,12 +35,11 @@
 
 (define (disassemble-load-program asm env)
   (pmatch asm
-    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
+    ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
      (let ((objs  (and env (assq-ref env 'objects)))
+           (free-vars (and env (assq-ref env 'free-vars)))
            (meta  (and env (assq-ref env 'meta)))
-           (exts  (and env (assq-ref env 'exts)))
            (blocs (and env (assq-ref env 'blocs)))
-           (bexts (and env (assq-ref env 'bexts)))
            (srcs  (and env (assq-ref env 'sources))))
        (let lp ((pos 0) (code code) (programs '()))
          (cond
@@ -63,13 +62,13 @@
                       (acons sym asm programs))))
                (else
                 (print-info pos asm
-                            (code-annotation end asm objs nargs blocs bexts
+                            (code-annotation end asm objs nargs blocs
                                              labels)
                             (and=> (and srcs (assq end srcs)) source->string))
                 (lp (+ pos (byte-length asm)) (cdr code) programs)))))))
                  
-       (if (pair? exts)
+       (if (pair? free-vars)
-           (disassemble-externals exts))
+           (disassemble-free-vars free-vars))
        (if meta
            (disassemble-meta meta))
 
@@ -92,13 +91,12 @@
 	((= n len) (newline))
       (print-info n (vector-ref objs n) #f #f))))
 
-(define (disassemble-externals exts)
+(define (disassemble-free-vars free-vars)
-  (display "Externals:\n\n")
+  (display "Free variables:\n\n")
-  (let ((len (length exts)))
+  (let ((i 0))
-    (do ((n 0 (1+ n))
+    (cond ((< i (vector-length free-vars))
-	 (l exts (cdr l)))
+           (print-info i (vector-ref free-vars i) #f #f)
-	((null? l) (newline))
+           (lp (1+ i))))))
-      (print-info n (car l) #f #f))))
 
 (define-macro (unless test . body)
   `(if (not ,test) (begin ,@body)))
@@ -122,7 +120,7 @@
 (define (make-int16 byte1 byte2)
   (+ (* byte1 256) byte2))
 
-(define (code-annotation end-addr code objs nargs blocs bexts labels)
+(define (code-annotation end-addr code objs nargs blocs labels)
   (let* ((code (assembly-unpack code))
          (inst (car code))
          (args (cdr code)))
@@ -133,7 +131,7 @@
        (list "-> ~A" (assq-ref labels (car args))))
       ((object-ref)
        (and objs (list "~s" (vector-ref objs (car args)))))
-      ((local-ref local-set)
+      ((local-ref local-boxed-ref local-set local-boxed-set)
        (and blocs
             (let lp ((bindings (list-ref blocs (car args))))
               (and (pair? bindings)
@@ -143,13 +141,9 @@
                          (list "`~a'~@[ (arg)~]"
                                (binding:name b) (< (binding:index b) nargs))
                          (lp (cdr bindings))))))))
-      ((external-ref external-set)
+      ((free-ref free-boxed-ref free-boxed-set)
-       (and bexts
+       ;; FIXME: we can do better than this
-            (if (< (car args) (length bexts))
+       (list "(closure variable)"))
-                (let ((b (list-ref bexts (car args))))
-                  (list "`~a'~@[ (arg)~]"
-                        (binding:name b) (< (binding:index b) nargs)))
-                (list "(closure variable)"))))
       ((toplevel-ref toplevel-set)
        (and objs
             (let ((v (vector-ref objs (car args))))

module/language/glil.scm

@@ -24,8 +24,8 @@
   #:use-module ((srfi srfi-1) #:select (fold))
   #:export
   (<glil-program> make-glil-program glil-program?
-   glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nexts
+   glil-program-nargs glil-program-nrest glil-program-nlocs
-   glil-program-meta glil-program-body glil-program-closure-level
+   glil-program-meta glil-program-body
    
    <glil-bind> make-glil-bind glil-bind?
    glil-bind-vars
@@ -43,12 +43,6 @@
    <glil-const> make-glil-const glil-const?
    glil-const-obj
 
-   <glil-local> make-glil-local glil-local?
-   glil-local-op glil-local-index
-
-   <glil-external> make-glil-external glil-external?
-   glil-external-op glil-external-depth glil-external-index
-
    <glil-lexical> make-glil-lexical glil-lexical?
    glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index
 
@@ -77,7 +71,7 @@
 
 (define-type (<glil> #:printer print-glil)
   ;; Meta operations
-  (<glil-program> nargs nrest nlocs nexts meta body (closure-level #f))
+  (<glil-program> nargs nrest nlocs meta body)
   (<glil-bind> vars)
   (<glil-mv-bind> vars rest)
   (<glil-unbind>)
@@ -86,8 +80,6 @@
   (<glil-void>)
   (<glil-const> obj)
   ;; Variables
-  (<glil-local> op index)
-  (<glil-external> op depth index)
   (<glil-lexical> local? boxed? op index)
   (<glil-toplevel> op name)
   (<glil-module> op mod name public?)
@@ -97,35 +89,18 @@
   (<glil-call> inst nargs)
   (<glil-mv-call> nargs ra))
 
-(define (compute-closure-level body)
-  (fold (lambda (x ret)
-          (record-case x
-            ((<glil-program> closure-level) (max ret closure-level))
-            ((<glil-external> depth) (max ret depth))
-            (else ret)))
-        0 body))
-
-(define %make-glil-program make-glil-program)
-(define (make-glil-program . args)
-  (let ((prog (apply %make-glil-program args)))
-    (if (not (glil-program-closure-level prog))
-        (set! (glil-program-closure-level prog)
-              (compute-closure-level (glil-program-body prog))))
-    prog))
-
 
+
 (define (parse-glil x)
   (pmatch x
-    ((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
+    ((program ,nargs ,nrest ,nlocs ,meta . ,body)
-     (make-glil-program nargs nrest nlocs nexts meta (map parse-glil body)))
+     (make-glil-program nargs nrest nlocs meta (map parse-glil body)))
     ((bind . ,vars) (make-glil-bind vars))
     ((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
     ((unbind) (make-glil-unbind))
     ((source ,props) (make-glil-source props))
     ((void) (make-glil-void))
     ((const ,obj) (make-glil-const obj))
-    ((local ,op ,index) (make-glil-local op index))
-    ((external ,op ,depth ,index) (make-glil-external op depth index))
     ((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op index))
     ((toplevel ,op ,name) (make-glil-toplevel op name))
     ((module public ,op ,mod ,name) (make-glil-module op mod name #t))
@@ -139,8 +114,8 @@
 (define (unparse-glil glil)
   (record-case glil
     ;; meta
-    ((<glil-program> nargs nrest nlocs nexts meta body)
+    ((<glil-program> nargs nrest nlocs meta body)
-     `(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
+     `(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body)))
     ((<glil-bind> vars) `(bind ,@vars))
     ((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
     ((<glil-unbind>) `(unbind))
@@ -149,8 +124,6 @@
     ((<glil-void>) `(void))
     ((<glil-const> obj) `(const ,obj))
     ;; variables
-    ((<glil-external> op depth index)
-     `(external ,op ,depth ,index))
     ((<glil-lexical> local? boxed? op index)
      `(lexical ,local? ,boxed? ,op ,index))
     ((<glil-toplevel> op name)

module/language/glil/compile-assembly.scm

@@ -72,7 +72,7 @@
   (if (and (null? bindings) (null? sources) (null? tail))
       #f
       (compile-assembly
-       (make-glil-program 0 0 0 0 '()
+       (make-glil-program 0 0 0 '()
                           (list
                            (make-glil-const `(,bindings ,sources ,@tail))
                            (make-glil-call 'return 1))))))
@@ -128,13 +128,13 @@
 
 (define (compile-assembly glil)
   (receive (code . _)
-      (glil->assembly glil '() '(()) '() '() #f -1)
+      (glil->assembly glil #t '(()) '() '() #f -1)
     (car code)))
 (define (make-object-table objects)
   (and (not (null? objects))
        (list->vector (cons #f objects))))
 
-(define (glil->assembly glil nexts-stack bindings
+(define (glil->assembly glil toplevel? bindings
                         source-alist label-alist object-alist addr)
   (define (emit-code x)
     (values (map assembly-pack x) bindings source-alist label-alist object-alist))
@@ -142,10 +142,8 @@
     (values (map assembly-pack x) bindings source-alist label-alist object-alist))
 
   (record-case glil
-    ((<glil-program> nargs nrest nlocs nexts meta body closure-level)
+    ((<glil-program> nargs nrest nlocs meta body)
-     (let ((toplevel? (null? nexts-stack)))
      (define (process-body)
-         (let ((nexts-stack (cons nexts nexts-stack)))
        (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
                 (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
          (cond
@@ -158,15 +156,15 @@
                    addr))
           (else
            (receive (subcode bindings source-alist label-alist object-alist)
-                   (glil->assembly (car body) nexts-stack bindings
+               (glil->assembly (car body) #f bindings
                                source-alist label-alist object-alist addr)
              (lp (cdr body) (append (reverse subcode) code)
                  bindings source-alist label-alist object-alist
-                     (addr+ addr subcode))))))))
+                 (addr+ addr subcode)))))))
 
      (receive (code bindings sources labels objects len)
          (process-body)
-         (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
+       (let ((prog `(load-program ,nargs ,nrest ,nlocs ,labels
                                   ,len
                                   ,(make-meta bindings sources meta)
                                   . ,code)))
@@ -177,8 +175,7 @@
            ;; anyway)
            (emit-code (align-program prog addr)))
           (else
-             (let ((table (dump-object (make-object-table objects) addr))
+           (let ((table (dump-object (make-object-table objects) addr)))
-                   (closure  '()))
              (cond
               (object-alist
                ;; if we are being compiled from something with an object
@@ -189,13 +186,12 @@
                  (emit-code/object `(,(if (< i 256)
                                           `(object-ref ,i)
                                           `(long-object-ref ,(quotient i 256)
-                                                              ,(modulo i 256)))
+                                                            ,(modulo i 256))))
-                                       ,@closure)
                                    object-alist)))
               (else
                ;; otherwise emit a load directly
-                 (emit-code `(,@table ,@(align-program prog (addr+ addr table))
+               (emit-code `(,@table ,@(align-program prog (addr+ addr table))))))))))))
-                                      ,@closure)))))))))))
+    
     
     ((<glil-bind> vars)
      (values '()
@@ -244,19 +240,6 @@
                                                   ,(modulo i 256))))
                            object-alist)))))
 
-    ((<glil-local> op index)
-     (emit-code (if (eq? op 'ref)
-                    `((local-ref ,index))
-                    `((local-set ,index)))))
-
-    ((<glil-external> op depth index)
-     (emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
-                  (if (> d 0)
-                      (lp (1- d) (+ n (car stack)) (cdr stack))
-                      (if (eq? op 'ref)
-                          `((external-ref ,(+ n index)))
-                          `((external-set ,(+ n index))))))))
-
     ((<glil-lexical> local? boxed? op index)
      (emit-code
       `((,(if local?

module/language/glil/decompile-assembly.scm

@@ -1,6 +1,6 @@
 ;;; Guile VM code converters
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -31,8 +31,8 @@
 
 (define (decompile-toplevel x)
   (pmatch x
-    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,body)
+    ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body)
-     (decompile-load-program nargs nrest nlocs nexts
+     (decompile-load-program nargs nrest nlocs
                              (decompile-meta meta)
                              body labels #f))
     (else
@@ -56,7 +56,7 @@
           ((glil-program? (car in)) (lp (cdr in) (cons (car in) out)))
           (else (lp (cdr in) (cons (make-glil-const (car l)) out))))))
 
-(define (decompile-load-program nargs nrest nlocs nexts meta body labels
+(define (decompile-load-program nargs nrest nlocs meta body labels
                                 objects)
   (let ((glil-labels (sort (map (lambda (x)
                                   (cons (cdr x) (make-glil-label (car x))))
@@ -100,19 +100,11 @@
       (cond
        ((null? in)
         (or (null? stack) (error "leftover stack insts" stack body))
-        (make-glil-program nargs nrest nlocs nexts props (reverse out) #f))
+        (make-glil-program nargs nrest nlocs props (reverse out) #f))
        ((pop-bindings! pos)
         => (lambda (bindings)
              (lp in stack
-                 (cons (make-glil-bind
+                 (cons (make-glil-bind bindings)
-                        (map (lambda (x)
-                               (let ((name (binding:name x))
-                                     (i (binding:index x)))
-                                 (cond
-                                  ((binding:extp x) `(,name external ,i))
-                                  ((< i nargs) `(,name argument ,i))
-                                  (else `(,name local ,(- i nargs))))))
-                             bindings))
                        out)
                  pos)))
        ((pop-unbindings! pos)

module/language/objcode/spec.scm

@@ -66,23 +66,16 @@
    ((program? x)
     (let ((objs  (program-objects x))
           (meta  (program-meta x))
-          (exts  (program-external x))
+          (free-vars  (program-free-variables x))
           (binds (program-bindings x))
           (srcs  (program-sources x))
           (nargs (arity:nargs (program-arity x))))
-      (let ((blocs (and binds
+      (let ((blocs (and binds (collapse-locals binds))))
-                        (collapse-locals
-                         (append (list-head binds nargs)
-                                 (filter (lambda (x) (not (binding:extp x)))
-                                         (list-tail binds nargs))))))
-            (bexts (and binds
-                        (filter binding:extp binds))))
         (values (program-objcode x)
                 `((objects . ,objs)
                   (meta    . ,(and meta (meta)))
-                  (exts    . ,exts)
+                  (free-vars . ,free-vars)
                   (blocs   . ,blocs)
-                  (bexts   . ,bexts)
                   (sources . ,srcs))))))
    ((objcode? x)
     (values x #f))

module/language/tree-il/compile-glil.scm

@@ -172,7 +172,7 @@
                               (1+ n) 1))))
     (let ((nlocs (car (hashq-ref allocation x))))
       (make-glil-program
-       nargs nrest nlocs 0 (lambda-meta x)
+       nargs nrest nlocs (lambda-meta x)
        (with-output-to-code
         (lambda (emit-code)
           ;; write bindings and source debugging info

module/system/repl/command.scm

@@ -386,7 +386,6 @@ Trace execution.
 
   -s    Display stack
   -l    Display local variables
-  -e    Display external variables
   -b    Bytecode level trace"
   (apply vm-trace (repl-vm repl)
          (repl-compile repl (repl-parse repl form))

module/system/vm/frame.scm

@@ -1,6 +1,6 @@
 ;;; Guile VM frame functions
 
-;;; Copyright (C) 2001 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 ;;; Copyright (C) 2005 Ludovic Courtès  <ludovic.courtes@laas.fr>
 ;;;
 ;;; This program is free software; you can redistribute it and/or modify
@@ -27,18 +27,18 @@
             vm-frame-program
             vm-frame-local-ref vm-frame-local-set!
             vm-frame-return-address vm-frame-mv-return-address
-            vm-frame-dynamic-link vm-frame-external-link
+            vm-frame-dynamic-link
             vm-frame-stack
 
 
             vm-frame-number vm-frame-address
             make-frame-chain
             print-frame print-frame-chain-as-backtrace
-           frame-arguments frame-local-variables frame-external-variables
+            frame-arguments frame-local-variables
             frame-environment
             frame-variable-exists? frame-variable-ref frame-variable-set!
             frame-object-name
-           frame-local-ref frame-external-link frame-local-set!
+            frame-local-ref frame-local-set!
             frame-return-address frame-program
             frame-dynamic-link heap-frame?))
 
@@ -158,24 +158,19 @@
 	 (l '() (cons (frame-local-ref frame n) l)))
 	((< n 0) l))))
 
-(define (frame-external-variables frame)
-  (frame-external-link frame))
-
-(define (frame-external-ref frame index)
-  (list-ref (frame-external-link frame) index))
-
-(define (frame-external-set! frame index val)
-  (list-set! (frame-external-link frame) index val))
-
 (define (frame-binding-ref frame binding)
-  (if (binding:extp binding)
+  (let ((x (frame-local-ref frame (binding:index binding))))
-    (frame-external-ref frame (binding:index binding))
+    (if (and (binding:boxed? binding) (variable? x))
-    (frame-local-ref frame (binding:index binding))))
+        (variable-ref x)
+        x)))
 
 (define (frame-binding-set! frame binding val)
-  (if (binding:extp binding)
+  (if (binding:boxed? binding)
-    (frame-external-set! frame (binding:index binding) val)
+      (let ((v (frame-local-ref frame binding)))
-    (frame-local-set! frame (binding:index binding) val)))
+        (if (variable? v)
+            (variable-set! v val)
+            (frame-local-set! frame binding (make-variable val))))
+      (frame-local-set! frame binding val)))
 
 ;; FIXME handle #f program-bindings return
 (define (frame-bindings frame addr)

module/system/vm/program.scm

@@ -21,9 +21,9 @@
 (define-module (system vm program)
   #:export (make-program
 
-            arity:nargs arity:nrest arity:nlocs arity:nexts
+            arity:nargs arity:nrest arity:nlocs
 
-            make-binding binding:name binding:extp binding:index
+            make-binding binding:name binding:boxed? binding:index
             binding:start binding:end
 
             source:addr source:line source:column source:file
@@ -41,10 +41,10 @@
 (define arity:nrest cadr)
 (define arity:nlocs caddr)
 
-(define (make-binding name extp index start end)
+(define (make-binding name boxed? index start end)
-  (list name extp index start end))
+  (list name boxed? index start end))
 (define (binding:name b) (list-ref b 0))
-(define (binding:extp b) (list-ref b 1))
+(define (binding:boxed? b) (list-ref b 1))
 (define (binding:index b) (list-ref b 2))
 (define (binding:start b) (list-ref b 3))
 (define (binding:end b) (list-ref b 4))

module/system/vm/trace.scm

@@ -1,6 +1,6 @@
 ;;; Guile VM tracer
 
-;; Copyright (C) 2001 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
 
 ;;; This library is free software; you can redistribute it and/or
 ;;; modify it under the terms of the GNU Lesser General Public
@@ -54,8 +54,7 @@
       ((null? opts) (newline))
     (case (car opts)
       ((:s) (puts (truncate! (vm-fetch-stack vm) 3)))
-      ((:l) (puts (vm-fetch-locals vm)))
+      ((:l) (puts (vm-fetch-locals vm))))))
-      ((:e) (puts (vm-fetch-externals vm))))))
 
 (define (trace-apply vm)
   (if (vm-option vm 'trace-first)

test-suite/tests/asm-to-bytecode.test

@@ -85,28 +85,28 @@
                (vector 'load-keyword 0 0 3 (char->integer #\q) (char->integer #\u)
                        (char->integer #\x)))
 
-    (comp-test '(load-program 3 2 1 0 () 3 #f (make-int8 3) (return))
+    (comp-test '(load-program 3 2 1 () 3 #f (make-int8 3) (return))
                (list->vector
                 `(load-program
-                  3 2 1 0            ;; nargs, nrest, nlocs, nexts
+                  3 2 1 0            ;; nargs, nrest, nlocs, unused
                   ,@(u32->u8-list 3) ;; len
                   ,@(u32->u8-list 0) ;; metalen
                   make-int8 3
                   return)))
 
-    (comp-test '(load-program 3 2 1 0 () 3
+    (comp-test '(load-program 3 2 1 () 3
-                              (load-program 3 2 1 0 () 3
+                              (load-program 3 2 1 () 3
                                             #f
                                             (make-int8 3) (return))
                               (make-int8 3) (return))
                (list->vector
                 `(load-program
-                  3 2 1 0                   ;; nargs, nrest, nlocs, nexts
+                  3 2 1 0                   ;; nargs, nrest, nlocs, unused
                   ,@(u32->u8-list 3)        ;; len
                   ,@(u32->u8-list (+ 3 12)) ;; metalen
                   make-int8 3
                   return
-                  3 2 1 0                   ;; nargs, nrest, nlocs, nexts
+                  3 2 1 0                   ;; nargs, nrest, nlocs, unused
                   ,@(u32->u8-list 3)        ;; len
                   ,@(u32->u8-list 0)        ;; metalen
                   make-int8 3

test-suite/tests/tree-il.test

@@ -64,21 +64,21 @@
 (with-test-prefix "void"
   (assert-tree-il->glil
    (void)
-   (program 0 0 0 0 () (void) (call return 1)))
+   (program 0 0 0 () (void) (call return 1)))
   (assert-tree-il->glil
    (begin (void) (const 1))
-   (program 0 0 0 0 () (const 1) (call return 1)))
+   (program 0 0 0 () (const 1) (call return 1)))
   (assert-tree-il->glil
    (apply (primitive +) (void) (const 1))
-   (program 0 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
+   (program 0 0 0 () (void) (const 1) (call add 2) (call return 1))))
 
 (with-test-prefix "application"
   (assert-tree-il->glil
    (apply (toplevel foo) (const 1))
-   (program 0 0 0 0 () (toplevel ref foo) (const 1) (call goto/args 1)))
+   (program 0 0 0 () (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 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
+   (program 0 0 0 () (toplevel ref foo) (const 1) (mv-call 1 ,l1)
             (call drop 1) (branch br ,l2)
             (label ,l3) (mv-bind () #f) (unbind)
             (label ,l4)
@@ -86,26 +86,26 @@
    (and (eq? l1 l3) (eq? l2 l4)))
   (assert-tree-il->glil
    (apply (toplevel foo) (apply (toplevel bar)))
-   (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call call 0)
+   (program 0 0 0 () (toplevel ref foo) (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 0 () (const #t) (branch br-if-not ,l1)
+   (program 0 0 0 () (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 0 () (const #t) (branch br-if-not ,l1) (branch br ,l2)
+   (program 0 0 0 () (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 0 () (const #t) (branch br-if-not ,l1)
+   (program 0 0 0 () (const #t) (branch br-if-not ,l1)
             (const 1) (branch br ,l2)
                     (label ,l3) (const 2) (label ,l4)
                     (call null? 1) (call return 1))
@@ -114,35 +114,35 @@
 (with-test-prefix "primitive-ref"
   (assert-tree-il->glil
    (primitive +)
-   (program 0 0 0 0 () (toplevel ref +) (call return 1)))
+   (program 0 0 0 () (toplevel ref +) (call return 1)))
 
   (assert-tree-il->glil
    (begin (primitive +) (const #f))
-   (program 0 0 0 0 () (const #f) (call return 1)))
+   (program 0 0 0 () (const #f) (call return 1)))
 
   (assert-tree-il->glil
    (apply (primitive null?) (primitive +))
-   (program 0 0 0 0 () (toplevel ref +) (call null? 1)
+   (program 0 0 0 () (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 0 ()
+   (program 0 0 1 ()
             (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 0 ()
+   (program 0 0 1 ()
             (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 0 ()
+   (program 0 0 1 ()
             (const 1) (bind (x #f 0)) (lexical #t #f set 0)
             (lexical #t #f ref 0) (call null? 1) (call return 1)
             (unbind))))
@@ -150,14 +150,14 @@
 (with-test-prefix "lexical sets"
   (assert-tree-il->glil
    (let (x) (y) ((const 1)) (set! (lexical x y) (const 2)))
-   (program 0 0 1 0 ()
+   (program 0 0 1 ()
             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
             (const 2) (lexical #t #t set 0) (void) (call return 1)
             (unbind)))
 
   (assert-tree-il->glil
    (let (x) (y) ((const 1)) (begin (set! (lexical x y) (const 2)) (const #f)))
-   (program 0 0 1 0 ()
+   (program 0 0 1 ()
             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
             (const 2) (lexical #t #t set 0) (const #f) (call return 1)
             (unbind)))
@@ -165,7 +165,7 @@
   (assert-tree-il->glil
    (let (x) (y) ((const 1))
      (apply (primitive null?) (set! (lexical x y) (const 2))))
-   (program 0 0 1 0 ()
+   (program 0 0 1 ()
             (const 1) (bind (x #t 0)) (lexical #t #t box 0)
             (const 2) (lexical #t #t set 0) (void) (call null? 1) (call return 1)
             (unbind))))
@@ -173,205 +173,205 @@
 (with-test-prefix "module refs"
   (assert-tree-il->glil
    (@ (foo) bar)
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (module public ref (foo) bar)
             (call return 1)))
 
   (assert-tree-il->glil
    (begin (@ (foo) bar) (const #f))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
             (module public ref (foo) bar)
             (call null? 1) (call return 1)))
 
   (assert-tree-il->glil
    (@@ (foo) bar)
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (module private ref (foo) bar)
             (call return 1)))
 
   (assert-tree-il->glil
    (begin (@@ (foo) bar) (const #f))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
             (toplevel ref bar)
             (call return 1)))
 
   (assert-tree-il->glil
    (begin (toplevel bar) (const #f))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (toplevel ref bar) (call drop 1)
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
    (apply (primitive null?) (toplevel bar))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
             (const 2) (toplevel define bar)
             (void) (call return 1)))
 
   (assert-tree-il->glil
    (begin (define bar (const 2)) (const #f))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
             (const 2) (call return 1)))
 
   (assert-tree-il->glil
    (begin (const 2) (const #f))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const #f) (call return 1)))
 
   (assert-tree-il->glil
    (apply (primitive null?) (const 2))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (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 0 ()
+   (program 0 0 0 ()
-            (program 1 0 0 0 ()
+            (program 1 0 0 ()
                      (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 0 ()
+   (program 0 0 0 ()
-            (program 2 0 0 0 ()
+            (program 2 0 0 ()
                      (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 0 ()
+   (program 0 0 0 ()
-            (program 1 1 0 0 ()
+            (program 1 1 0 ()
                      (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 0 ()
+   (program 0 0 0 ()
-            (program 2 1 0 0 ()
+            (program 2 1 0 ()
                      (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 0 ()
+   (program 0 0 0 ()
-            (program 2 1 0 0 ()
+            (program 2 1 0 ()
                      (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 0 ()
+   (program 0 0 0 ()
-            (program 2 1 0 0 ()
+            (program 2 1 0 ()
                      (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 0 ()
+   (program 0 0 0 ()
-            (program 1 0 0 0 ()
+            (program 1 0 0 ()
                      (bind (x #f 0))
-                     (program 1 0 0 0 ()
+                     (program 1 0 0 ()
                               (bind (y #f 0))
                               (lexical #f #f ref 0) (call return 1))
                      (lexical #t #f ref 0)
@@ -383,12 +383,12 @@
 (with-test-prefix "sequence"
   (assert-tree-il->glil
    (begin (begin (const 2) (const #f)) (const #t))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const #t) (call return 1)))
 
   (assert-tree-il->glil
    (apply (primitive null?) (begin (const #f) (const 2)))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (const 2) (call null? 1) (call return 1))))
 
 ;; FIXME: binding info for or-hacked locals might bork the disassembler,
@@ -400,7 +400,7 @@
             (lexical x y)
             (let (a) (b) ((const 2))
                  (lexical a b))))
-   (program 0 0 1 0 ()
+   (program 0 0 1 ()
             (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)
@@ -417,7 +417,7 @@
             (lexical x y)
             (let (a) (b) ((const 2))
                  (lexical x y))))
-   (program 0 0 2 0 ()
+   (program 0 0 2 ()
             (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,10 +431,10 @@
 (with-test-prefix "apply"
   (assert-tree-il->glil
    (apply (primitive @apply) (toplevel foo) (toplevel bar))
-   (program 0 0 0 0 () (toplevel ref foo) (toplevel ref bar) (call goto/apply 2)))
+   (program 0 0 0 () (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 0 ()
+   (program 0 0 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)
@@ -442,7 +442,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 0 ()
+   (program 0 0 0 ()
             (toplevel ref foo)
             (toplevel ref bar) (toplevel ref baz) (call apply 2)
             (call goto/args 1))))
@@ -450,10 +450,10 @@
 (with-test-prefix "call/cc"
   (assert-tree-il->glil
    (apply (primitive @call-with-current-continuation) (toplevel foo))
-   (program 0 0 0 0 () (toplevel ref foo) (call goto/cc 1)))
+   (program 0 0 0 () (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 0 ()
+   (program 0 0 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)
@@ -462,7 +462,7 @@
   (assert-tree-il->glil
    (apply (toplevel foo)
           (apply (toplevel @call-with-current-continuation) (toplevel bar)))
-   (program 0 0 0 0 ()
+   (program 0 0 0 ()
             (toplevel ref foo)
             (toplevel ref bar) (call call/cc 1)
             (call goto/args 1))))