module/language/glil/decompile-assembly.scm

   1 ;;; Guile VM code converters
   2
   3 ;; Copyright (C) 2001 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 ,nexts ,labels ,len ,meta . ,body)
  35      (decompile-load-program nargs nrest nlocs nexts
  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 nexts 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 nexts props (reverse out) #f))
 104        ((pop-bindings! pos)
 105         => (lambda (bindings)
 106              (lp in stack
 107                  (cons (make-glil-bind
 108                         (map (lambda (x)
 109                                (let ((name (binding:name x))
 110                                      (i (binding:index x)))
 111                                  (cond
 112                                   ((binding:extp x) `(,name external ,i))
 113                                   ((< i nargs) `(,name argument ,i))
 114                                   (else `(,name local ,(- i nargs))))))
 115                              bindings))
 116                        out)
 117                  pos)))
 118        ((pop-unbindings! pos)
 119         => (lambda (bindings)
 120              (lp in stack (cons (make-glil-unbind) out) pos)))
 121        ((pop-source! pos)
 122         => (lambda (s)
 123              (lp in stack (cons (make-glil-source s) out) pos)))
 124        ((and (or (null? out) (not (glil-label? (car out))))
 125              (assv-ref glil-labels pos))
 126         => (lambda (label)
 127              (lp in stack (cons label out) pos)))
 128        (else
 129         (pmatch (car in)
 130           ((nop)
 131            (lp (cdr in) stack out (1+ pos)))
 132           ((make-false)
 133            (lp (cdr in) (cons #f stack) out (1+ pos)))
 134           ((load-program ,a ,b ,c ,d ,labels ,sublen ,meta . ,body)
 135            (lp (cdr in)
 136                (cons (decompile-load-program a b c d (decompile-meta meta)
 137                                              body labels (car stack))
 138                      (cdr stack))
 139                out
 140                (+ pos (byte-length (car in)))))
 141           ((load-symbol ,str)
 142            (lp (cdr in) (cons (string->symbol str) stack) out
 143                (+ pos 1 (string-length str))))
 144           ((make-int8:0)
 145            (lp (cdr in) (cons 0 stack) out (1+ pos)))
 146           ((make-int8:1)
 147            (lp (cdr in) (cons 1 stack) out (1+ pos)))
 148           ((make-int8 ,n)
 149            (lp (cdr in) (cons n stack) out (+ pos 2)))
 150           ((cons)
 151            (let ((head (list-head stack 2))
 152                  (stack (list-tail stack 2)))
 153              (if (memq *placeholder* head)
 154                  (lp (cdr in) (cons *placeholder* stack)
 155                      (cons (make-glil-call 'cons 2) (emit-constants head out))
 156                      (+ pos 1))
 157                  (lp (cdr in) (cons (cons (cadr head) (car head)) stack)
 158                      out (+ pos 3)))))
 159           ((list ,a ,b)
 160            (let* ((len (+ (ash a 8) b))
 161                   (head (list-head stack len))
 162                   (stack (list-tail stack len)))
 163              (if (memq *placeholder* head)
 164                  (lp (cdr in) (cons *placeholder* stack)
 165                      (cons (make-glil-call 'list len) (emit-constants head out))
 166                      (+ pos 3))
 167                  (lp (cdr in) (cons (reverse head) stack) out (+ pos 3)))))
 168           ((make-eol)
 169            (lp (cdr in) (cons '() stack) out (1+ pos)))
 170           ((return)
 171            (lp (cdr in) (cdr stack)
 172                (cons (make-glil-call 'return 1)
 173                      (emit-constants (list-head stack 1) out))
 174                (1+ pos)))
 175           ((local-ref ,n)
 176            (lp (cdr in) (cons *placeholder* stack)
 177                (cons (make-glil-local 'ref n)
 178                      out) (+ pos 2)))
 179           ((local-set ,n)
 180            (lp (cdr in) (cdr stack)
 181                (cons (make-glil-local 'set n)
 182                      (emit-constants (list-head stack 1) out))
 183                (+ pos 2)))
 184           ((br-if-not ,l)
 185            (lp (cdr in) (cdr stack)
 186                (cons (make-glil-branch 'br-if-not l) out)
 187                (+ pos 3)))
 188           ((mul)
 189            (lp (cdr in) (cons *placeholder* (cddr stack))
 190                (cons (make-glil-call 'mul 2)
 191                      (emit-constants (list-head stack 2) out))
 192                (+ pos 1)))
 193           ((goto/args ,n)
 194            (lp (cdr in) (list-tail stack (1+ n))
 195                (cons (make-glil-call 'goto/args n)
 196                      (emit-constants (list-head stack (1+ n)) out))
 197                (+ pos 2)))
 198           (else (error "unsupported decompilation" (car in)))))))))