module/language/glil/decompile-assembly.scm

   1 ;;; Guile VM code converters
   2
   3 ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
   4
   5 ;;;; This library is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU Lesser General Public
   7 ;;;; License as published by the Free Software Foundation; either
   8 ;;;; version 3 of the License, or (at your option) any later version.
   9 ;;;;
  10 ;;;; This library is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;;;; Lesser General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU Lesser General Public
  16 ;;;; License along with this library; if not, write to the Free Software
  17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Code:
  20
  21 (define-module (language glil decompile-assembly)
  22   #:use-module (system base pmatch)
  23   #:use-module (system vm program)
  24   #:use-module (language assembly)
  25   #:use-module (language glil)
  26   #:export (decompile-assembly))
  27
  28 (define (decompile-assembly x env opts)
  29   (values (decompile-toplevel x)
  30           env))
  31
  32 (define (decompile-toplevel x)
  33   (pmatch x
  34     ((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body)
  35      (decompile-load-program nargs nrest nlocs
  36                              (decompile-meta meta)
  37                              body labels #f))
  38     (else
  39      (error "invalid assembly" x))))
  40
  41 (define (decompile-meta meta)
  42   (and meta
  43       (let ((prog (decompile-toplevel meta)))
  44         (if (and (glil-program? prog)
  45                  (= (length (glil-program-body prog)) 2)
  46                  (glil-const? (car (glil-program-body prog))))
  47             (glil-const-obj (car (glil-program-body prog)))
  48             (error "metadata not a thunk returning a const" prog)))))
  49
  50 (define *placeholder* (list 'placeholder))
  51
  52 (define (emit-constants l out)
  53   (let lp ((in (reverse l)) (out out))
  54     (cond ((null? in) out)
  55           ((eq? (car in) *placeholder*) (lp (cdr in) out))
  56           ((glil-program? (car in)) (lp (cdr in) (cons (car in) out)))
  57           (else (lp (cdr in) (cons (make-glil-const (car l)) out))))))
  58
  59 (define (decompile-load-program nargs nrest nlocs meta body labels
  60                                 objects)
  61   (let ((glil-labels (sort (map (lambda (x)
  62                                   (cons (cdr x) (make-glil-label (car x))))
  63                                 labels)
  64                            (lambda (x y) (< (car x) (car y)))))
  65         (bindings (sort (if meta (car meta) '())
  66                         (lambda (x y) (< (binding:start x) (binding:start y)))))
  67         (unbindings (sort (if meta (car meta) '())
  68                           (lambda (x y) (< (binding:end x) (binding:end y)))))
  69         (sources (if meta (cadr meta) '()))
  70         (filename #f)
  71         (props (if meta (cddr meta) '())))
  72     (define (pop-bindings! addr)
  73       (let lp ((in bindings) (out '()))
  74         (if (or (null? in) (> (binding:start (car in)) addr))
  75             (begin
  76               (set! bindings in)
  77               (if (null? out) #f (reverse out)))
  78             (lp (cdr in) (cons (car in) out)))))
  79     (define (pop-unbindings! addr)
  80       (let lp ((in unbindings) (out '()))
  81         (if (or (null? in) (> (binding:end (car in)) addr))
  82             (begin
  83               (set! unbindings in)
  84               (if (null? out) #f (reverse out)))
  85             (lp (cdr in) (cons (car in) out)))))
  86     (define (pop-source! addr)
  87       ;; a fragile algorithm.
  88       (cond ((null? sources) #f)
  89             ((eq? (caar sources) 'filename)
  90              (set! filename (cdar sources))
  91              (pop-source! addr))
  92             ((eqv? (caar sources) addr)
  93              (let ((x (car sources)))
  94                (set! sources (cdr sources))
  95                `((filename . ,filename)
  96                  (line . ,(cadr x))
  97                  (column . ,(cddr x)))))
  98             (else #f)))
  99     (let lp ((in body) (stack '()) (out '()) (pos 0))
 100       (cond
 101        ((null? in)
 102         (or (null? stack) (error "leftover stack insts" stack body))
 103         (make-glil-program nargs nrest nlocs props (reverse out) #f))
 104        ((pop-bindings! pos)
 105         => (lambda (bindings)
 106              (lp in stack
 107                  (cons (make-glil-bind bindings)
 108                        out)
 109                  pos)))
 110        ((pop-unbindings! pos)
 111         => (lambda (bindings)
 112              (lp in stack (cons (make-glil-unbind) out) pos)))
 113        ((pop-source! pos)
 114         => (lambda (s)
 115              (lp in stack (cons (make-glil-source s) out) pos)))
 116        ((and (or (null? out) (not (glil-label? (car out))))
 117              (assv-ref glil-labels pos))
 118         => (lambda (label)
 119              (lp in stack (cons label out) pos)))
 120        (else
 121         (pmatch (car in)
 122           ((nop)
 123            (lp (cdr in) stack out (1+ pos)))
 124           ((make-false)
 125            (lp (cdr in) (cons #f stack) out (1+ pos)))
 126           ((load-program ,a ,b ,c ,d ,labels ,sublen ,meta . ,body)
 127            (lp (cdr in)
 128                (cons (decompile-load-program a b c d (decompile-meta meta)
 129                                              body labels (car stack))
 130                      (cdr stack))
 131                out
 132                (+ pos (byte-length (car in)))))
 133           ((load-symbol ,str)
 134            (lp (cdr in) (cons (string->symbol str) stack) out
 135                (+ pos 1 (string-length str))))
 136           ((make-int8:0)
 137            (lp (cdr in) (cons 0 stack) out (1+ pos)))
 138           ((make-int8:1)
 139            (lp (cdr in) (cons 1 stack) out (1+ pos)))
 140           ((make-int8 ,n)
 141            (lp (cdr in) (cons n stack) out (+ pos 2)))
 142           ((cons)
 143            (let ((head (list-head stack 2))
 144                  (stack (list-tail stack 2)))
 145              (if (memq *placeholder* head)
 146                  (lp (cdr in) (cons *placeholder* stack)
 147                      (cons (make-glil-call 'cons 2) (emit-constants head out))
 148                      (+ pos 1))
 149                  (lp (cdr in) (cons (cons (cadr head) (car head)) stack)
 150                      out (+ pos 3)))))
 151           ((list ,a ,b)
 152            (let* ((len (+ (ash a 8) b))
 153                   (head (list-head stack len))
 154                   (stack (list-tail stack len)))
 155              (if (memq *placeholder* head)
 156                  (lp (cdr in) (cons *placeholder* stack)
 157                      (cons (make-glil-call 'list len) (emit-constants head out))
 158                      (+ pos 3))
 159                  (lp (cdr in) (cons (reverse head) stack) out (+ pos 3)))))
 160           ((make-eol)
 161            (lp (cdr in) (cons '() stack) out (1+ pos)))
 162           ((return)
 163            (lp (cdr in) (cdr stack)
 164                (cons (make-glil-call 'return 1)
 165                      (emit-constants (list-head stack 1) out))
 166                (1+ pos)))
 167           ((local-ref ,n)
 168            (lp (cdr in) (cons *placeholder* stack)
 169                (cons (make-glil-local 'ref n)
 170                      out) (+ pos 2)))
 171           ((local-set ,n)
 172            (lp (cdr in) (cdr stack)
 173                (cons (make-glil-local 'set n)
 174                      (emit-constants (list-head stack 1) out))
 175                (+ pos 2)))
 176           ((br-if-not ,l)
 177            (lp (cdr in) (cdr stack)
 178                (cons (make-glil-branch 'br-if-not l) out)
 179                (+ pos 3)))
 180           ((mul)
 181            (lp (cdr in) (cons *placeholder* (cddr stack))
 182                (cons (make-glil-call 'mul 2)
 183                      (emit-constants (list-head stack 2) out))
 184                (+ pos 1)))
 185           ((goto/args ,n)
 186            (lp (cdr in) (list-tail stack (1+ n))
 187                (cons (make-glil-call 'goto/args n)
 188                      (emit-constants (list-head stack (1+ n)) out))
 189                (+ pos 2)))
 190           (else (error "unsupported decompilation" (car in)))))))))