make disassembly better -- a more woven text.

* module/system/vm/assemble.scm (pop): Define a pop here too.
  (codegen): Rework how bindings are represented in a program's
  meta-info, so they declare their range in the binding list instead of
  you having to figure out when they end.

* module/system/vm/conv.scm (make-byte-decoder): Return the end-address
  as well; requires a change to callers.

* module/system/vm/disasm.scm (disassemble-objcode, disassemble-program)
  (disassemble-bytecode, disassemble-objects, disassemble-externals)
  (disassemble-meta, source->string, make-int16, code-annotation)
  (print-info): Rework to display my domination of `format', and, more
  seriously, start to integrate the "subsections" of the disassembly into
  the main disassembly text.

* module/system/vm/program.scm (program-bindings-as-lambda-list): Update
  for new bindings format; should be more correct.

module/system/vm/assemble.scm

@@ -74,6 +74,8 @@
 
 (define-macro (push x loc)
   `(set! ,loc (cons ,x ,loc)))
+(define-macro (pop loc)
+  `(let ((_x (car ,loc))) (set! ,loc (cdr ,loc)) _x))
 
 ;; this is to avoid glil-const's desire to put constants in the object
 ;; array -- instead we explicitly want them in the code, because meta
@@ -102,7 +104,8 @@
   (record-case glil
     ((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars meta) ; body?
      (let ((stack '())
-	   (binding-alist '())
+	   (open-bindings '())
+	   (closed-bindings '())
 	   (source-alist '())
 	   (label-alist '())
 	   (object-alist '()))
@@ -120,6 +123,32 @@
 				  (set! object-alist (acons x i object-alist))
 				  i)))))
 		  (push-code! `(object-ref ,i))))))
+       (define (munge-bindings bindings nargs)
+         (map
+          (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))
+                (else (error "unknown binding type" name type)))))
+          bindings))
+       (define (push-bindings! bindings)
+         (push (cons (current-address) bindings) open-bindings))
+       (define (close-binding!)
+         (let* ((bindings (pop open-bindings))
+                (start (car bindings))
+                (end (current-address)))
+           (for-each
+            (lambda (binding)
+              (push `(,start ,@binding ,start ,end) closed-bindings))
+            (cdr bindings))))
+       (define (finish-bindings!)
+         (while (not (null? open-bindings)) (close-binding!))
+         (set! closed-bindings
+               (stable-sort! (reverse! closed-bindings)
+                             (lambda (x y) (< (car x) (car y)))))
+         (set! closed-bindings (map cdr closed-bindings)))
        (define (current-address)
 	 (apply + (map byte-length stack)))
        (define (generate-code x)
@@ -129,32 +158,14 @@
 	    (if (venv-closure? venv) (push-code! `(make-closure))))
 
 	   ((<glil-bind> (binds vars))
-	    (let ((bindings
+            (push-bindings! (munge-bindings binds (glil-vars-nargs vars))))
-		   (map (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 (+ (glil-vars-nargs vars) i)))
-			      ((external) (make-binding name #t i)))))
-			binds)))
-	      (set! binding-alist
-		    (acons (current-address) bindings binding-alist))))
 
 	   ((<glil-mv-bind> (binds vars) rest)
-	    (let ((bindings
+            (push-bindings! (munge-bindings binds (glil-vars-nargs vars)))
-		   (map (lambda (v)
+            (push-code! `(truncate-values ,(length binds) ,(if rest 1 0))))
-			  (let ((name (car v)) (type (cadr v)) (i (caddr v)))
-			    (case type
-			      ((argument) (make-binding name #f i))
-			      ((local) (make-binding name #f (+ (glil-vars-nargs vars) i)))
-			      ((external) (make-binding name #t i)))))
-			binds)))
-	      (set! binding-alist
-		    (acons (current-address) bindings binding-alist))
-              (push-code! `(truncate-values ,(length binds) ,(if rest 1 0)))))
 
 	   ((<glil-unbind>)
-	    (set! binding-alist (acons (current-address) #f binding-alist)))
+            (close-binding!))
 
 	   ((<glil-source> loc)
 	    (set! source-alist (acons (current-address) loc source-alist)))
@@ -255,14 +266,15 @@
        ;;
        ;; main
        (for-each generate-code body)
+       (finish-bindings!)
 ;       (format #t "codegen: stack = ~a~%" (reverse stack))
        (let ((bytes (stack->bytes (reverse! stack) label-alist)))
 	 (if toplevel
 	     (bytecode->objcode bytes (glil-vars-nlocs vars) (glil-vars-nexts vars))
 	     (make-bytespec #:vars vars #:bytes bytes
-                            #:meta (make-meta (reverse! binding-alist)
+                            #:meta (make-meta closed-bindings
-                                             (reverse! source-alist)
+                                              (reverse! source-alist)
-                                             meta)
+                                              meta)
                             #:objs (let ((objs (map car (reverse! object-alist))))
                                     (if (null? objs) #f (list->vector objs)))
                             #:closure? (venv-closure? venv))))))))))

module/system/vm/conv.scm

@@ -162,8 +162,8 @@
 			   (do ((n n (1- n))
 				(l '() (cons (pop) l)))
 			       ((= n 0) (cons* inst (reverse! l)))))))
-	    (values start code))
+	    (values start addr code))
-	  (values #f #f)))))
+	  (values #f #f #f)))))
 
 
 ;;;

module/system/vm/disasm.scm

@@ -37,7 +37,7 @@
 	 (bytes (program-bytecode prog)))
     (format #t "Disassembly of ~A:\n\n" objcode)
     (format #t "nlocs = ~A  nexts = ~A\n\n" nlocs nexts)
-    (disassemble-bytecode bytes #f)))
+    (disassemble-bytecode bytes #f 0 #f #f '())))
 
 (define (disassemble-program prog . opts)
   (let* ((arity (program-arity prog))
@@ -48,13 +48,19 @@
 	 (bytes (program-bytecode prog))
 	 (objs  (program-objects prog))
 	 (meta  (program-meta prog))
-	 (exts  (program-external prog)))
+	 (exts  (program-external prog))
+         (binds (program-bindings prog))
+         (blocs (and binds
+                     (filter (lambda (x) (not (binding:extp x))) binds)))
+         (bexts (and binds
+                     (filter binding:extp binds)))
+         (srcs  (program-sources prog)))
     ;; Disassemble this bytecode
     (format #t "Disassembly of ~A:\n\n" prog)
     (format #t "nargs = ~A  nrest = ~A  nlocs = ~A  nexts = ~A\n\n"
 	    nargs nrest nlocs nexts)
     (format #t "Bytecode:\n\n")
-    (disassemble-bytecode bytes objs)
+    (disassemble-bytecode bytes objs nargs blocs bexts srcs)
     (if (> (vector-length objs) 0)
 	(disassemble-objects objs))
     (if (pair? exts)
@@ -69,24 +75,25 @@
 		  (apply disassemble-program x opts))))
      (vector->list objs))))
 
-(define (disassemble-bytecode bytes objs)
+(define (disassemble-bytecode bytes objs nargs blocs bexts sources)
   (let ((decode (make-byte-decoder bytes))
         (programs '()))
-    (define (lp addr code)
+    (define (lp start end code)
       (pmatch code
        (#f (newline))
        ((load-program ,x)
         (let ((sym (gensym "")))
           (set! programs (acons sym x programs))
-          (print-info addr (format #f "(load-program #~A)" sym) #f)))
+          (print-info start `(load-program ,sym) #f #f)))
        (else
-        (print-info addr (list->info code)
+        (print-info start code
-                    (original-value addr code objs))))
+                    (code-annotation end code objs nargs blocs bexts)
+                    (and=> (assq end sources) source->string))))
       (if code (call-with-values decode lp)))
     (call-with-values decode lp)
     (for-each (lambda (sym+bytes)
                 (format #t "Bytecode #~A:\n\n" (car sym+bytes))
-                (disassemble-bytecode (cdr sym+bytes) #f))
+                (disassemble-bytecode (cdr sym+bytes) #f 0 #f #f '()))
               (reverse! programs))))
 
 (define (disassemble-objects objs)
@@ -94,8 +101,7 @@
   (let ((len (vector-length objs)))
     (do ((n 0 (1+ n)))
 	((= n len) (newline))
-      (let ((info (object->string (vector-ref objs n))))
+      (print-info n (vector-ref objs n) #f #f))))
-	(print-info n info #f)))))
 
 (define (disassemble-externals exts)
   (display "Externals:\n\n")
@@ -103,94 +109,60 @@
     (do ((n 0 (1+ n))
 	 (l exts (cdr l)))
 	((null? l) (newline))
-      (let ((info (object->string (car l))))
+      (print-info n (car l) #f))))
-	(print-info n info #f)))))
 
 (define-macro (unless test . body)
   `(if (not ,test) (begin ,@body)))
 
-(define (disassemble-bindings prog bindings)
+(define *uninteresting-props* '(name))
-  (let* ((nargs (arity:nargs (program-arity prog)))
-         (args (if (zero? nargs) '() (cdar bindings)))
-         (nonargs (if (zero? nargs) bindings (cdr bindings))))
-    (unless (null? args)
-            (display "Arguments:\n\n")
-            (for-each (lambda (bind n)
-                        (print-info n
-                                    (format #f "~a[~a]: ~a"
-                                            (if (cadr bind) 'external 'local)
-                                            (caddr bind) (car bind))
-                                    #f))
-                      args
-                      (iota nargs))
-            (newline))
-    (unless (null? nonargs)
-            (display "Bindings:\n\n")
-            (for-each (lambda (start binds end)
-                        (for-each (lambda (bind)
-                                    (print-info (format #f "~a-~a" start end)
-                                                (format #f "~a[~a]: ~a"
-                                                        (if (cadr bind) 'external 'local)
-                                                        (caddr bind) (car bind))
-                                                #f))
-                                  binds))
-                      (map car (filter cdr nonargs))
-                      (map cdr (filter cdr nonargs))
-                      (map car (filter (lambda (x) (not (cdr x))) nonargs)))
-            (newline))))
 
 (define (disassemble-meta program meta)
-  (let ((bindings (car meta))
+  (let ((sources (cadr meta))
-        (sources (cadr meta))
+        (props (filter (lambda (x)
-        (props (cddr meta)))
+                         (not (memq (car x) *uninteresting-props*)))
-    (unless (null? bindings)
+                       (cddr meta))))
-            (disassemble-bindings program bindings))
-    (unless (null? sources)
-            (display "Sources:\n\n")
-            (for-each (lambda (x)
-                        (print-info (car x) (list->info (cdr x)) #f))
-                      sources)
-            (newline))
     (unless (null? props)
             (display "Properties:\n\n")
-            (for-each (lambda (x) (print-info #f x #f)) props)
+            (for-each (lambda (x) (print-info #f x #f #f)) props)
             (newline))))
 
-(define (original-value addr code objs)
+(define (source->string src)
+  (format #f "~a:~a:~a" (or (source:file src) "(unknown file)")
+          (source:line src) (source:column src)))
+
+(define (make-int16 byte1 byte2)
+  (+ (* byte1 256) byte2))
+
+(define (code-annotation end-addr code objs nargs blocs bexts)
   (let* ((code (code-unpack code))
          (inst (car code))
          (args (cdr code)))
     (case inst
       ((list vector) 
-       (let ((len (+ (* (cadr code) 256) (caddr code))))
+       (list "~a element~:p" (apply make-int16 args)))
-         (format #f "~a element~a" len (if (> len 1) "s" ""))))
       ((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null)
-       (let ((offset (+ (* (car args) 256) (cadr args))))
+       (list "-> ~A" (+ end-addr (apply make-int16 args))))
-         (format #f "-> ~A" (+ addr offset 3))))
       ((object-ref)
-       (if objs (object->string (vector-ref objs (car args))) #f))
+       (and objs (list "~s" (vector-ref objs (car args)))))
+      ((local-ref local-set)
+       (and blocs
+            (let ((b (list-ref blocs (car args))))
+              (list "`~a'~@[ (arg)~]"
+                    (binding:name b) (< (binding:index b) nargs)))))
+      ((external-ref external-set)
+       (and bexts
+            (let ((b (list-ref bexts (car args))))
+              (list "`~a'~@[ (arg)~]"
+                    (binding:name b) (< (binding:index b) nargs)))))
       ((mv-call)
-       (let ((offset (+ (* (caddr code) 256) (cadddr code))))
+       (list "MV -> ~A" (+ end-addr (apply make-int16 args))))
-         (format #f "MV -> ~A" (+ addr offset 4))))
       (else
-       (and=> (code->object code) object->string)))))
+       (and=> (code->object code)
+              (lambda (obj) (list "~s" obj)))))))
 
-(define (list->info list)
+;; i am format's daddy.
-  (object->string list))
+(define (print-info addr info extra src)
-
+  (format #t "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" addr info extra src))
-;   (define (u8vector->string vec)
-;     (list->string (map integer->char (u8vector->list vec))))
-
-;   (case (car list)
-;     ((link)
-;      (object->string `(link ,(u8vector->string (cadr list)))))
-;     (else
-;      (object->string list))))
-
-(define (print-info addr info extra)
-  (if extra
-      (format #t "~4@A    ~32A;; ~A\n" addr info extra)
-      (format #t "~4@A    ~A\n" addr info)))
 
 (define (simplify x)
   (cond ((string? x)

module/system/vm/program.scm

@@ -84,10 +84,10 @@
         (rest? (not (zero? (arity:nrest (program-arity prog))))))
     (if (or (null? bindings) (not bindings))
         (if rest? (cons (1- nargs) 1) (list nargs))
-        (let ((arg-names (map binding:name (cdar bindings))))
+        (let ((args (map binding:name (list-head bindings nargs))))
           (if rest?
-              (apply cons* arg-names)
+              (apply cons* args)
-              arg-names)))))
+              args)))))
 
 (define (write-program prog port)
   (format port "#<program ~a ~a>"