module/language/glil/decompile-assembly.scm

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