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.

diff --git a/module/language/assembly.scm b/module/language/assembly.scm
index 3a0b387..0ad94be 100644 (file)
--- a/module/language/assembly.scm
+++ b/module/language/assembly.scm
@@ -28,7 +28,7 @@
             assembly-pack assembly-unpack
             object->assembly assembly->object))
 
             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
 (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)))
      (+ 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)))
      (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
     ((,inst . _) (guard (>= (instruction-length inst) 0))
      (+ 1 (instruction-length inst)))

diff --git a/module/language/assembly/compile-bytecode.scm b/module/language/assembly/compile-bytecode.scm
index 4b9f7b7..0a14898 100644 (file)
--- a/module/language/assembly/compile-bytecode.scm
+++ b/module/language/assembly/compile-bytecode.scm
@@ -89,12 +89,11 @@
           (len (instruction-length inst)))
       (write-byte opcode)
       (pmatch asm
           (len (instruction-length inst)))
       (write-byte opcode)
       (pmatch asm

-        ((load-program ,nargs ,nrest ,nlocs ,nexts
-                       ,labels ,length ,meta . ,code)
+        ((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)

          (write-byte nargs)
          (write-byte nrest)
          (write-byte nlocs)
          (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)
          (write-uint32 length)
          (write-uint32 (if meta (1- (byte-length meta)) 0))
          (letrec ((i 0)

diff --git a/module/language/assembly/decompile-bytecode.scm b/module/language/assembly/decompile-bytecode.scm
index fdf27ec..56f58f7 100644 (file)
--- a/module/language/assembly/decompile-bytecode.scm
+++ b/module/language/assembly/decompile-bytecode.scm
@@ -1,6 +1,6 @@
 ;;; Guile VM code converters
 
 ;;; 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
 
 ;;;; 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)
         (- 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)))
          (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)
       (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
                             ,(map (lambda (x) (cons (cdr x) (car x)))
                                   (reverse labels))
                             ,len

diff --git a/module/language/assembly/disassemble.scm b/module/language/assembly/disassemble.scm
index 0a35050..d41c816 100644 (file)
--- a/module/language/assembly/disassemble.scm
+++ b/module/language/assembly/disassemble.scm
@@ -1,6 +1,6 @@
 ;;; Guile VM code converters
 
 ;;; 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
 
 ;;;; 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
 
 (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)))
      (let ((objs  (and env (assq-ref env 'objects)))

+           (free-vars (and env (assq-ref env 'free-vars)))

            (meta  (and env (assq-ref env 'meta)))
            (meta  (and env (assq-ref env 'meta)))

-           (exts  (and env (assq-ref env 'exts)))

            (blocs (and env (assq-ref env 'blocs)))
            (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
            (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
                       (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)))))))
                  
                                              labels)
                             (and=> (and srcs (assq end srcs)) source->string))
                 (lp (+ pos (byte-length asm)) (cdr code) programs)))))))
                  

-       (if (pair? exts)
-           (disassemble-externals exts))
+       (if (pair? free-vars)
+           (disassemble-free-vars free-vars))

        (if meta
            (disassemble-meta meta))
 
        (if meta
            (disassemble-meta meta))
 


@@ -92,13 +91,12 @@
        ((= n len) (newline))
       (print-info n (vector-ref objs n) #f #f))))
 
        ((= n len) (newline))
       (print-info n (vector-ref objs n) #f #f))))
 

-(define (disassemble-externals exts)
-  (display "Externals:\n\n")
-  (let ((len (length exts)))
-    (do ((n 0 (1+ n))
-        (l exts (cdr l)))
-       ((null? l) (newline))
-      (print-info n (car l) #f #f))))
+(define (disassemble-free-vars free-vars)
+  (display "Free variables:\n\n")
+  (let ((i 0))
+    (cond ((< i (vector-length free-vars))
+           (print-info i (vector-ref free-vars i) #f #f)
+           (lp (1+ i))))))

 
 (define-macro (unless test . body)
   `(if (not ,test) (begin ,@body)))
 
 (define-macro (unless test . body)
   `(if (not ,test) (begin ,@body)))


@@ -122,7 +120,7 @@
 (define (make-int16 byte1 byte2)
   (+ (* byte1 256) byte2))
 
 (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)))
   (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)))))
        (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)
        (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))))))))
                          (list "`~a'~@[ (arg)~]"
                                (binding:name b) (< (binding:index b) nargs))
                          (lp (cdr bindings))))))))

-      ((external-ref external-set)
-       (and bexts
-            (if (< (car args) (length bexts))
-                (let ((b (list-ref bexts (car args))))
-                  (list "`~a'~@[ (arg)~]"
-                        (binding:name b) (< (binding:index b) nargs)))
-                (list "(closure variable)"))))
+      ((free-ref free-boxed-ref free-boxed-set)
+       ;; FIXME: we can do better than this
+       (list "(closure variable)"))

       ((toplevel-ref toplevel-set)
        (and objs
             (let ((v (vector-ref objs (car args))))
       ((toplevel-ref toplevel-set)
        (and objs
             (let ((v (vector-ref objs (car args))))

diff --git a/module/language/glil.scm b/module/language/glil.scm
index 4dff817..0777073 100644 (file)
--- a/module/language/glil.scm
+++ b/module/language/glil.scm
@@ -24,9 +24,9 @@
   #:use-module ((srfi srfi-1) #:select (fold))
   #:export
   (<glil-program> make-glil-program glil-program?
   #: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-meta glil-program-body glil-program-closure-level
-
+   glil-program-nargs glil-program-nrest glil-program-nlocs
+   glil-program-meta glil-program-body
+   

    <glil-bind> make-glil-bind glil-bind?
    glil-bind-vars
 
    <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-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
 
    <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
 
 (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>)
   (<glil-bind> vars)
   (<glil-mv-bind> vars rest)
   (<glil-unbind>)


@@ -86,8 +80,6 @@
   (<glil-void>)
   (<glil-const> obj)
   ;; Variables
   (<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?)
   (<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))
 
   (<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))
-

 \f
 \f

+

 (define (parse-glil x)
   (pmatch x
 (define (parse-glil x)
   (pmatch x

-    ((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
-     (make-glil-program nargs nrest nlocs nexts meta (map parse-glil body)))
+    ((program ,nargs ,nrest ,nlocs ,meta . ,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))
     ((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))
     ((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
 (define (unparse-glil glil)
   (record-case glil
     ;; meta

-    ((<glil-program> nargs nrest nlocs nexts meta body)
-     `(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
+    ((<glil-program> nargs nrest nlocs meta 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))
     ((<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-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)
     ((<glil-lexical> local? boxed? op index)
      `(lexical ,local? ,boxed? ,op ,index))
     ((<glil-toplevel> op name)

diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index cecfd86..c7e26a8 100644 (file)
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -72,7 +72,7 @@
   (if (and (null? bindings) (null? sources) (null? tail))
       #f
       (compile-assembly
   (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))))))
                           (list
                            (make-glil-const `(,bindings ,sources ,@tail))
                            (make-glil-call 'return 1))))))


@@ -128,13 +128,13 @@
 
 (define (compile-assembly glil)
   (receive (code . _)
 
 (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))))
 
     (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))
                         source-alist label-alist object-alist addr)
   (define (emit-code x)
     (values (map assembly-pack x) bindings source-alist label-alist object-alist))


@@ -142,60 +142,56 @@
     (values (map assembly-pack x) bindings source-alist label-alist object-alist))
 
   (record-case glil
     (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)
-     (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))
+    ((<glil-program> nargs nrest nlocs meta body)
+     (define (process-body)
+       (let lp ((body body) (code '()) (bindings '(())) (source-alist '())
+                (label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
+         (cond
+          ((null? body)
+           (values (reverse code)
+                   (close-all-bindings bindings addr)
+                   (limn-sources (reverse! source-alist))
+                   (reverse label-alist)
+                   (and object-alist (map car (reverse object-alist)))
+                   addr))
+          (else
+           (receive (subcode bindings source-alist label-alist object-alist)
+               (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)))))))
+
+     (receive (code bindings sources labels objects len)
+         (process-body)
+       (let ((prog `(load-program ,nargs ,nrest ,nlocs ,labels
+                                  ,len
+                                  ,(make-meta bindings sources meta)
+                                  . ,code)))
+         (cond
+          (toplevel?
+           ;; toplevel bytecode isn't loaded by the vm, no way to do
+           ;; object table or closure capture (not in the bytecode,
+           ;; anyway)
+           (emit-code (align-program prog addr)))
+          (else
+           (let ((table (dump-object (make-object-table objects) addr)))

              (cond
              (cond

-              ((null? body)
-               (values (reverse code)
-                       (close-all-bindings bindings addr)
-                       (limn-sources (reverse! source-alist))
-                       (reverse label-alist)
-                       (and object-alist (map car (reverse object-alist)))
-                       addr))
+              (object-alist
+               ;; if we are being compiled from something with an object
+               ;; table, cache the program there
+               (receive (i object-alist)
+                   (object-index-and-alist (make-subprogram table prog)
+                                           object-alist)
+                 (emit-code/object `(,(if (< i 256)
+                                          `(object-ref ,i)
+                                          `(long-object-ref ,(quotient i 256)
+                                                            ,(modulo i 256))))
+                                   object-alist)))

               (else
               (else

-               (receive (subcode bindings source-alist label-alist object-alist)
-                   (glil->assembly (car body) nexts-stack 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))))))))
-
-       (receive (code bindings sources labels objects len)
-           (process-body)
-         (let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
-                                    ,len
-                                    ,(make-meta bindings sources meta)
-                                    . ,code)))
-           (cond
-            (toplevel?
-             ;; toplevel bytecode isn't loaded by the vm, no way to do
-             ;; object table or closure capture (not in the bytecode,
-             ;; anyway)
-             (emit-code (align-program prog addr)))
-            (else
-             (let ((table (dump-object (make-object-table objects) addr))
-                   (closure  '()))
-               (cond
-                (object-alist
-                 ;; if we are being compiled from something with an object
-                 ;; table, cache the program there
-                 (receive (i object-alist)
-                     (object-index-and-alist (make-subprogram table prog)
-                                             object-alist)
-                   (emit-code/object `(,(if (< i 256)
-                                            `(object-ref ,i)
-                                            `(long-object-ref ,(quotient i 256)
-                                                              ,(modulo i 256)))
-                                       ,@closure)
-                                     object-alist)))
-                (else
-                 ;; otherwise emit a load directly
-                 (emit-code `(,@table ,@(align-program prog (addr+ addr table))
-                                      ,@closure)))))))))))
+               ;; otherwise emit a load directly
+               (emit-code `(,@table ,@(align-program prog (addr+ addr table))))))))))))
+    

     
     ((<glil-bind> vars)
      (values '()
     
     ((<glil-bind> vars)
      (values '()


@@ -244,19 +240,6 @@
                                                   ,(modulo i 256))))
                            object-alist)))))
 
                                                   ,(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?
     ((<glil-lexical> local? boxed? op index)
      (emit-code
       `((,(if local?

diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm
index 502ef80..3cb887d 100644 (file)
--- a/module/language/glil/decompile-assembly.scm
+++ b/module/language/glil/decompile-assembly.scm
@@ -1,6 +1,6 @@
 ;;; Guile VM code converters
 
 ;;; 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
 
 ;;;; 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
 
 (define (decompile-toplevel x)
   (pmatch x

-    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,body)
-     (decompile-load-program nargs nrest nlocs nexts
+    ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body)
+     (decompile-load-program nargs nrest nlocs

                              (decompile-meta meta)
                              body labels #f))
     (else
                              (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))))))
 
           ((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))))
                                 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))
       (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
        ((pop-bindings! pos)
         => (lambda (bindings)
              (lp in stack

-                 (cons (make-glil-bind
-                        (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))
+                 (cons (make-glil-bind bindings)

                        out)
                  pos)))
        ((pop-unbindings! pos)
                        out)
                  pos)))
        ((pop-unbindings! pos)

diff --git a/module/language/objcode/spec.scm b/module/language/objcode/spec.scm
index a783a4e..4cb600f 100644 (file)
--- a/module/language/objcode/spec.scm
+++ b/module/language/objcode/spec.scm
@@ -66,23 +66,16 @@
    ((program? x)
     (let ((objs  (program-objects x))
           (meta  (program-meta x))
    ((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))))
           (binds (program-bindings x))
           (srcs  (program-sources x))
           (nargs (arity:nargs (program-arity x))))

-      (let ((blocs (and 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))))
+      (let ((blocs (and binds (collapse-locals binds))))

         (values (program-objcode x)
                 `((objects . ,objs)
                   (meta    . ,(and meta (meta)))
         (values (program-objcode x)
                 `((objects . ,objs)
                   (meta    . ,(and meta (meta)))

-                  (exts    . ,exts)
+                  (free-vars . ,free-vars)

                   (blocs   . ,blocs)
                   (blocs   . ,blocs)

-                  (bexts   . ,bexts)

                   (sources . ,srcs))))))
    ((objcode? x)
     (values x #f))
                   (sources . ,srcs))))))
    ((objcode? x)
     (values x #f))

diff --git a/module/language/tree-il/compile-glil.scm b/module/language/tree-il/compile-glil.scm
index f8410a5..f1d86e3 100644 (file)
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -172,7 +172,7 @@
                               (1+ n) 1))))
     (let ((nlocs (car (hashq-ref allocation x))))
       (make-glil-program
                               (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
        (with-output-to-code
         (lambda (emit-code)
           ;; write bindings and source debugging info

diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 6f45bd7..a99e1ba 100644 (file)
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -386,7 +386,6 @@ Trace execution.
 
   -s    Display stack
   -l    Display local variables
 
   -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))
   -b    Bytecode level trace"
   (apply vm-trace (repl-vm repl)
          (repl-compile repl (repl-parse repl form))

diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index 33a1e1b..332cd61 100644 (file)
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -1,6 +1,6 @@
 ;;; Guile VM frame functions
 
 ;;; 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
 ;;; Copyright (C) 2005 Ludovic Courtès  <ludovic.courtes@laas.fr>
 ;;;
 ;;; This program is free software; you can redistribute it and/or modify


@@ -27,20 +27,20 @@
             vm-frame-program
             vm-frame-local-ref vm-frame-local-set!
             vm-frame-return-address vm-frame-mv-return-address
             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
             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-environment
-           frame-variable-exists? frame-variable-ref frame-variable-set!
-           frame-object-name
-           frame-local-ref frame-external-link frame-local-set!
-           frame-return-address frame-program
-           frame-dynamic-link heap-frame?))
+            make-frame-chain
+            print-frame print-frame-chain-as-backtrace
+            frame-arguments frame-local-variables
+            frame-environment
+            frame-variable-exists? frame-variable-ref frame-variable-set!
+            frame-object-name
+            frame-local-ref frame-local-set!
+            frame-return-address frame-program
+            frame-dynamic-link heap-frame?))

 
 (load-extension "libguile" "scm_init_frames")
 
 
 (load-extension "libguile" "scm_init_frames")
 


@@ -158,24 +158,19 @@
         (l '() (cons (frame-local-ref frame n) l)))
        ((< n 0) l))))
 
         (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)
 (define (frame-binding-ref frame binding)

-  (if (binding:extp binding)
-    (frame-external-ref frame (binding:index binding))
-    (frame-local-ref frame (binding:index binding))))
+  (let ((x (frame-local-ref frame (binding:index binding))))
+    (if (and (binding:boxed? binding) (variable? x))
+        (variable-ref x)
+        x)))

 
 (define (frame-binding-set! frame binding val)
 
 (define (frame-binding-set! frame binding val)

-  (if (binding:extp binding)
-    (frame-external-set! frame (binding:index binding) val)
-    (frame-local-set! frame (binding:index binding) val)))
+  (if (binding:boxed? binding)
+      (let ((v (frame-local-ref frame binding)))
+        (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)
 
 ;; FIXME handle #f program-bindings return
 (define (frame-bindings frame addr)

diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index 5fd81b4..755c606 100644 (file)
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -21,9 +21,9 @@
 (define-module (system vm program)
   #:export (make-program
 
 (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
             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 arity:nrest cadr)
 (define arity:nlocs caddr)
 

-(define (make-binding name extp index start end)
-  (list name extp index start end))
+(define (make-binding name boxed? index start end)
+  (list name boxed? index start end))

 (define (binding:name b) (list-ref b 0))
 (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))
 (define (binding:index b) (list-ref b 2))
 (define (binding:start b) (list-ref b 3))
 (define (binding:end b) (list-ref b 4))

diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 6ff09a7..d8165f2 100644 (file)
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -1,6 +1,6 @@
 ;;; Guile VM tracer
 
 ;;; 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
 
 ;;; 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)))
       ((null? opts) (newline))
     (case (car opts)
       ((:s) (puts (truncate! (vm-fetch-stack vm) 3)))

-      ((:l) (puts (vm-fetch-locals vm)))
-      ((:e) (puts (vm-fetch-externals vm))))))
+      ((:l) (puts (vm-fetch-locals vm))))))

 
 (define (trace-apply vm)
   (if (vm-option vm 'trace-first)
 
 (define (trace-apply vm)
   (if (vm-option vm 'trace-first)

diff --git a/test-suite/tests/asm-to-bytecode.test b/test-suite/tests/asm-to-bytecode.test
index 01ba846..d819a3b 100644 (file)
--- a/test-suite/tests/asm-to-bytecode.test
+++ b/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)))
 
                (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
                (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)))
 
                   ,@(u32->u8-list 3) ;; len
                   ,@(u32->u8-list 0) ;; metalen
                   make-int8 3
                   return)))
 

-    (comp-test '(load-program 3 2 1 0 () 3
-                              (load-program 3 2 1 0 () 3
+    (comp-test '(load-program 3 2 1 () 3
+                              (load-program 3 2 1 () 3

                                             #f
                                             (make-int8 3) (return))
                               (make-int8 3) (return))
                (list->vector
                 `(load-program
                                             #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
                   ,@(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
                   ,@(u32->u8-list 3)        ;; len
                   ,@(u32->u8-list 0)        ;; metalen
                   make-int8 3

diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index e4979c1..6634dcd 100644 (file)
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -64,21 +64,21 @@
 (with-test-prefix "void"
   (assert-tree-il->glil
    (void)
 (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))
   (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))
   (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))
 
 (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))
   (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)
             (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)))
    (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))
             (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))
             (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)))
             (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))
             (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 +)
 (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))
 
   (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 +))
 
   (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))
             (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)))
             (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)))
             (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))))
             (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)))
 (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)))
             (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)))
             (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))))
   (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))))
             (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)
 (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))
             (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))
             (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)
             (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))
             (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))
             (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))
             (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))
             (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)))
             (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))
             (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))
             (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)))
             (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)
             (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))
             (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))
             (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))
             (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))
             (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)))
             (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))
             (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))
             (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)))
             (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)
             (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))
             (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))
             (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))
             (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 1 0 0 0 ()
+   (program 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))
                      (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 2 0 0 0 ()
+   (program 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))
                      (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 1 1 0 0 ()
+   (program 0 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))
                      (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 2 1 0 0 ()
+   (program 0 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))
                      (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 2 1 0 0 ()
+   (program 0 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))
                      (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 2 1 0 0 ()
+   (program 0 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)))
                      (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 1 0 0 0 ()
+   (program 0 0 0 ()
+            (program 1 0 0 ()

                      (bind (x #f 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)
                               (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))
 (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)))
             (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,
             (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))))
             (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)
             (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))))
             (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)
             (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))
 (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))
   (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)
             (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)))
    (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))))
             (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))
 (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))
   (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)
             (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)))
   (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))))
             (toplevel ref foo)
             (toplevel ref bar) (call call/cc 1)
             (call goto/args 1))))