From f580ec0f56c40838a1f4cb8c8b02c4b5c70729a3 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Thu, 16 Oct 2008 13:49:57 +0200
Subject: [PATCH] fix use of `binding' data abstraction

* module/system/vm/assemble.scm (make-temp-binding, btemp:name)
  (btemp:extp, btemp:index): Don't abuse program.scm's make-binding to
  make something that actually isn't a binding.
  (codegen): Do use program.scm's make-binding to make something that
  actually is a binding.

* module/system/vm/program.scm (binding:start, binding:end): New
  accessors.
  (make-binding): Expand to have the start and end arguments in the
  constructor.
---
 module/system/vm/assemble.scm | 21 ++++++++++++++++-----
 module/system/vm/program.scm  | 18 +++++++++++-------
 2 files changed, 27 insertions(+), 12 deletions(-)

diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index 0da5fe071..20ea7b5c1 100644
--- a/module/system/vm/assemble.scm
+++ b/module/system/vm/assemble.scm
@@ -100,6 +100,13 @@
          (1+ (instruction-length (car x))))
         (else (error "variable-length instruction?" x))))
 
+;; a binding that doesn't yet know its extents
+(define (make-temp-binding name ext? index)
+  (list name ext? index))
+(define btemp:name car)
+(define btemp:extp cadr)
+(define btemp:index caddr)
+
 (define (codegen glil toplevel)
   (record-case glil
     ((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars meta) ; body?
@@ -128,9 +135,9 @@
           (lambda (v)
             (let ((name (car v)) (type (cadr v)) (i (caddr v)))
               (case type
-                ((argument) (make-binding name #f i))
-                ((local) (make-binding name #f (+ nargs i)))
-                ((external) (make-binding name #t i))
+                ((argument) (make-temp-binding name #f i))
+                ((local) (make-temp-binding name #f (+ nargs i)))
+                ((external) (make-temp-binding name #t i))
                 (else (error "unknown binding type" name type)))))
           bindings))
        (define (push-bindings! bindings)
@@ -140,8 +147,12 @@
                 (start (car bindings))
                 (end (current-address)))
            (for-each
-            (lambda (binding)
-              (push `(,start ,@binding ,start ,end) closed-bindings))
+            (lambda (open)
+              ;; the cons is for dsu sort
+              (push (cons start
+                          (make-binding (btemp:name open) (btemp:extp open) 
+                                        (btemp:index open) start end))
+                    closed-bindings))
             (cdr bindings))))
        (define (finish-bindings!)
          (while (not (null? open-bindings)) (close-binding!))
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index b52f7f39c..e78a308b9 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -21,7 +21,10 @@
 
 (define-module (system vm program)
   #:export (arity:nargs arity:nrest arity:nlocs arity:nexts
-           make-binding binding:name binding:extp binding:index
+
+            make-binding binding:name binding:extp binding:index
+            binding:start binding:end
+
            source:addr source:line source:column source:file
            program-bindings program-sources
            program-properties program-property program-documentation
@@ -38,12 +41,13 @@
 (define arity:nlocs caddr)
 (define arity:nexts cadddr)
 
-(define (make-binding name extp index)
-  (list name extp index))
-
-(define binding:name car)
-(define binding:extp cadr)
-(define binding:index caddr)
+(define (make-binding name extp index start end)
+  (list name extp index start end))
+(define (binding:name b) (list-ref b 0))
+(define (binding:extp 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 (curry1 proc)
   (lambda (x) (proc (x))))