add assembly->glil decompiler

* module/language/glil/decompile-assembly.scm: A first pass at an
  assembly->glil decompiler. Works for a small subset of programs.

* module/Makefile.am (GLIL_LANG_SOURCES):
* module/language/glil/spec.scm (glil): Add the decompiler.

3 files changed, 146 insertions, 2 deletions

diff --git a/module/Makefile.am b/module/Makefile.am
index 171f9f1d2..ea6b8ccb4 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -53,7 +53,8 @@ GHIL_LANG_SOURCES =					\
   language/ghil/spec.scm language/ghil/compile-glil.scm
 
 GLIL_LANG_SOURCES =						\
-  language/glil/spec.scm language/glil/compile-assembly.scm
+  language/glil/spec.scm language/glil/compile-assembly.scm 	\
+  language/glil/decompile-assembly.scm
 
 ASSEMBLY_LANG_SOURCES =				\
   language/assembly/spec.scm			\
diff --git a/module/language/glil/decompile-assembly.scm b/module/language/glil/decompile-assembly.scm
new file mode 100644
index 000000000..a1d540390
--- /dev/null
+++ b/module/language/glil/decompile-assembly.scm
@@ -0,0 +1,142 @@
+;;; 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 glil decompile-assembly)
+  #:use-module (system base pmatch)
+  #:use-module (language assembly)
+  #:use-module (language glil)
+  #:export (decompile-assembly))
+
+(define (decompile-assembly x env opts)
+  (values (decompile-toplevel x)
+          env))
+
+(define (decompile-toplevel x)
+  (pmatch x
+    ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,body)
+     (decompile-load-program nargs nrest nlocs nexts
+                             (decompile-meta meta)
+                             body labels))
+    (else
+     (error "invalid assembly" x))))
+
+(define (decompile-meta meta)
+  (and meta
+      (let ((prog (decompile-toplevel meta)))
+        (if (and (glil-program? prog)
+                 (= (length (glil-program-body prog)) 2)
+                 (glil-const? (car (glil-program-body prog))))
+            (glil-const-obj (car (glil-program-body prog)))
+            (error "metadata not a thunk returning a const" prog)))))
+
+(define *placeholder* (list 'placeholder))
+
+(define (emit-constants l out)
+  (let lp ((in (reverse l)) (out out))
+    (cond ((null? in) out)
+          ((eq? (car in) *placeholder*) (lp (cdr in) out))
+          (else (lp (cdr in) (cons (make-glil-const (car l)) out))))))
+
+(define (decompile-load-program nargs nrest nlocs nexts meta body labels)
+  (let ((glil-labels (sort (map (lambda (x)
+                                  (cons (cdr x) (make-glil-label (car x))))
+                                labels)
+                           (lambda (x y) (< (car x) (car y)))))
+        (bindings (if meta (car meta) '()))
+        (sources (if meta (cadr meta) '()))
+        (props (if meta (cddr meta) '())))
+    (let lp ((in body) (stack '()) (out '()) (pos 0))
+      (cond
+       ((and (or (null? out) (not (glil-label? (car out))))
+             (assv-ref glil-labels pos))
+        => (lambda (label)
+             (lp in stack (cons label out) pos)))
+       ((null? in)
+        (or (null? stack) (error "leftover stack insts" stack body))
+        (make-glil-program nargs nrest nlocs nexts props (reverse out) #f))
+       (else
+        (pmatch (car in)
+          ((nop)
+           (lp (cdr in) stack out (1+ pos)))
+          ((make-false)
+           (lp (cdr in) (cons #f stack) out (1+ pos)))
+          ((load-program ,a ,b ,c ,d ,labels ,sublen ,meta . ,body)
+           (lp (cdr in) (cons *placeholder* (cdr stack))
+               (cons (decompile-load-program a b c d (decompile-meta meta)
+                                             body labels)
+                     (emit-constants (list-head stack 1) out))
+               (+ pos (byte-length (car in)))))
+          ((load-symbol ,str)
+           (lp (cdr in) (cons (string->symbol str) stack) out
+               (+ pos 1 (string-length str))))
+          ((make-int8:0)
+           (lp (cdr in) (cons 0 stack) out (1+ pos)))
+          ((make-int8:1)
+           (lp (cdr in) (cons 1 stack) out (1+ pos)))
+          ((make-int8 ,n)
+           (lp (cdr in) (cons n stack) out (+ pos 2)))
+          ((list ,a ,b)
+           (let* ((len (+ (ash a 8) b))
+                  (head (list-head stack len))
+                  (stack (list-tail stack len)))
+             (if (memq *placeholder* head)
+                 (lp (cdr in) (cons *placeholder* stack)
+                     (cons (make-glil-call 'list len) (emit-constants head out))
+                     (+ pos 3))
+                 (lp (cdr in) (cons (reverse head) stack) out (+ pos 3)))))
+          ((make-eol)
+           (lp (cdr in) (cons '() stack) out (1+ pos)))
+          ((return)
+           (lp (cdr in) (cdr stack)
+               (cons (make-glil-call 'return 1)
+                     (emit-constants (list-head stack 1) out))
+               (1+ pos)))
+          ((local-ref ,n)
+           (lp (cdr in) (cons *placeholder* stack)
+               (cons (if (< n nargs)
+                         (make-glil-argument 'ref n)
+                         (make-glil-local 'ref (- n nargs)))
+                     out) (+ pos 2)))
+          ((local-set ,n)
+           (lp (cdr in) (cdr stack)
+               (cons (if (< n nargs)
+                         (make-glil-argument 'set n)
+                         (make-glil-local 'set (- n nargs)))
+                     (emit-constants (list-head stack 1) out))
+               (+ pos 2)))
+          ((br-if-not ,l)
+           (lp (cdr in) (cdr stack)
+               (cons (make-glil-branch
+                      'br-if-not
+                      (assv-ref glil-labels (assq-ref labels l)))
+                     out)
+               (+ pos 3)))
+          ((mul)
+           (lp (cdr in) (cons *placeholder* (cddr stack))
+               (cons (make-glil-call 'mul 2)
+                     (emit-constants (list-head stack 2) out))
+               (+ pos 1)))
+          ((goto/args ,n)
+           (lp (cdr in) (list-tail stack (1+ n))
+               (cons (make-glil-call 'goto/args n)
+                     (emit-constants (list-head stack (1+ n)) out))
+               (+ pos 2)))
+          (else (error "unsupported decompilation" (car in)))))))))
diff --git a/module/language/glil/spec.scm b/module/language/glil/spec.scm
index 6f9ea175b..3e4e10c6a 100644
--- a/module/language/glil/spec.scm
+++ b/module/language/glil/spec.scm
@@ -23,6 +23,7 @@
   #:use-module (system base language)
   #:use-module (language glil)
   #:use-module (language glil compile-assembly)
+  #:use-module (language glil decompile-assembly)
   #:export (glil))
 
 (define (write-glil exp . port)
@@ -38,4 +39,4 @@
   #:printer	write-glil
   #:parser      parse-glil
   #:compilers   `((assembly . ,compile-asm))
-  )
+  #:decompilers `((assembly . ,decompile-assembly)))