add disassembler that fits in with old compiler tower

* module/language/assembly/Makefile.am:
* module/language/assembly/disassemble.scm: Add a disassembler, based on
  the old one but fitting in with the decompiler tower.

* module/language/objcode/spec.scm (decompile-value): When decompiling
  programs, shove all the metadata that we know about into the "env".

* module/system/base/compile.scm (decompile-fold, decompile): Return the
  env from `decompile' as a second value. Not sure if `compile' should do
  this too.

module/language/assembly/Makefile.am

@@ -1,3 +1,3 @@
-SOURCES = spec.scm compile-bytecode.scm decompile-bytecode.scm
+SOURCES = spec.scm compile-bytecode.scm decompile-bytecode.scm disassemble.scm
 modpath = language/assembly
 include $(top_srcdir)/am/guilec

module/language/assembly/disassemble.scm

@@ -0,0 +1,171 @@
+;;; Guile VM code converters
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;; 
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;; 
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language assembly disassemble)
+  #:use-module (ice-9 format)
+  #:use-module (system vm instruction)
+  #:use-module (system vm program)
+  #:use-module (system base pmatch)
+  #:use-module (language assembly)
+  #:use-module (system base compile)
+  #:export (disassemble))
+
+(define (disassemble x)
+  (format #t "Disassembly of ~A:\n\n" x)
+  (call-with-values
+      (lambda () (decompile x #:from 'value #:to 'assembly))
+    disassemble-load-program))
+
+(define (disassemble-load-program asm env)
+  (pmatch asm
+    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len . ,code)
+     (let ((objs  (and env (assq-ref env 'objects)))
+           (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
+          ((null? code)
+           (newline)
+           (for-each
+            (lambda (sym+asm)
+              (format #t "Embedded program ~A:\n\n" (car sym+asm))
+              (disassemble-load-program (cdr sym+asm) '()))
+            (reverse! programs)))
+          (else
+           (let* ((asm (car code))
+                  (len (byte-length asm))
+                  (end (+ pos len)))
+             (pmatch asm
+               ((load-program . _)
+                (let ((sym (gensym "")))
+                  (print-info pos `(load-program ,sym) #f #f)
+                  (lp (+ pos (byte-length asm)) (cdr code)
+                      (acons sym asm programs))))
+               (else
+                (print-info pos asm
+                            (code-annotation end asm objs nargs blocs bexts)
+                            (and=> (and srcs (assq end srcs)) source->string))
+                (lp (+ pos (byte-length asm)) (cdr code) programs)))))))
+                 
+       (if (pair? exts)
+           (disassemble-externals exts))
+       (if meta
+           (disassemble-meta meta))
+
+       ;; Disassemble other bytecode in it
+       ;; FIXME: something about the module.
+       (if objs
+           (for-each
+            (lambda (x)
+              (if (program? x)
+                  (begin (display "----------------------------------------\n")
+                         (disassemble x))))
+            (cddr (vector->list objs))))))
+    (else
+     (error "bad load-program form" asm))))
+
+(define (disassemble-objects objs)
+  (display "Objects:\n\n")
+  (let ((len (vector-length objs)))
+    (do ((n 0 (1+ n)))
+	((= 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-macro (unless test . body)
+  `(if (not ,test) (begin ,@body)))
+
+(define *uninteresting-props* '(name))
+
+(define (disassemble-meta meta)
+  (let ((sources (cadr meta))
+        (props (filter (lambda (x)
+                         (not (memq (car x) *uninteresting-props*)))
+                       (cddr meta))))
+    (unless (null? props)
+      (display "Properties:\n\n")
+      (for-each (lambda (x) (print-info #f x #f #f)) props)
+      (newline))))
+
+(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 (assembly-unpack code))
+         (inst (car code))
+         (args (cdr code)))
+    (case inst
+      ((list vector) 
+       (list "~a element~:p" (apply make-int16 args)))
+      ((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null)
+       (list "-> ~A" (+ end-addr (apply make-int16 args))))
+      ((object-ref)
+       (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
+            (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)"))))
+      ((toplevel-ref toplevel-set)
+       (and objs
+            (let ((v (vector-ref objs (car args))))
+              (if (and (variable? v) (variable-bound? v))
+                  (list "~s" (variable-ref v))
+                  (list "`~s'" v)))))
+      ((mv-call)
+       (list "MV -> ~A" (+ end-addr (apply make-int16 (cdr args)))))
+      (else
+       (and=> (assembly->object code)
+              (lambda (obj) (list "~s" obj)))))))
+
+;; i am format's daddy.
+(define (print-info addr info extra src)
+  (format #t "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" addr info extra src))
+
+(define (simplify x)
+  (cond ((string? x)
+	 (cond ((string-index x #\newline) =>
+		(lambda (i) (set! x (substring x 0 i)))))
+	 (cond ((> (string-length x) 16)
+		(set! x (string-append (substring x 0 13) "..."))))))
+  x)
+

module/language/objcode/spec.scm

@@ -46,8 +46,25 @@
 (define (decompile-value x env opts)
   (cond
    ((program? x)
-    (values (program-objcode x)
-            (cons (program-objects x) (program-externals x))))
+    (let ((objs  (program-objects x))
+          (meta  (program-meta x))
+          (exts  (program-external x))
+          (binds (program-bindings x))
+          (srcs  (program-sources x))
+          (nargs (arity:nargs (program-arity x))))
+      (let ((blocs (and binds
+                        (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)
+                  (blocs   . ,blocs)
+                  (bexts   . ,bexts)
+                  (sources . ,srcs))))))
    ((objcode? x)
     (values x #f))
    (else

module/system/base/compile.scm

@@ -181,12 +181,18 @@ time. Useful for supporting some forms of dynamic compilation. Returns
        (or (lookup-decompilation-order from to)
            (error "no way to decompile" from "to" to))))
 
+(define (decompile-fold passes exp env opts)
+  (if (null? passes)
+      (values exp env)
+      (receive (exp env) ((car passes) exp env opts)
+        (decompile-fold (cdr passes) exp env opts))))
+
 (define* (decompile x #:key
                     (env #f)
                     (from 'value)
                     (to 'assembly)
                     (opts '()))
-  (compile-fold (decompile-passes from to opts)
-                x
-                env
-                opts))
+  (decompile-fold (decompile-passes from to opts)
+                  x
+                  env
+                  opts))