mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 22:10:21 +02:00
Code Activity

add assembly->glil decompiler

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2009-03-14 13:59:57 +01:00 • committed by Andy Wingo
parent a3f0ff0faf
commit 860f569a6a
3 changed files with 146 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

3
module/Makefile.am
View file

@ -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 \

142
module/language/glil/decompile-assembly.scm Normal file
View file

@ -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)))))))))

3
module/language/glil/spec.scm
View file

@ -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)))