Commit | Line | Data |
---|---|---|
7b107cce AW |
1 | ;;; Guile VM code converters |
2 | ||
476e3572 | 3 | ;; Copyright (C) 2001, 2009 Free Software Foundation, Inc. |
7b107cce | 4 | |
53befeb7 NJ |
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 | |
7b107cce AW |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (language assembly decompile-bytecode) | |
22 | #:use-module (system vm instruction) | |
23 | #:use-module (system base pmatch) | |
24 | #:use-module (srfi srfi-4) | |
15939985 | 25 | #:use-module (rnrs bytevector) |
7b107cce AW |
26 | #:use-module (language assembly) |
27 | #:export (decompile-bytecode)) | |
28 | ||
29 | (define (decompile-bytecode x env opts) | |
30 | (let ((i 0) (size (u8vector-length x))) | |
31 | (define (pop) | |
32 | (let ((b (cond ((< i size) (u8vector-ref x i)) | |
33 | ((= i size) #f) | |
34 | (else (error "tried to decode too many bytes"))))) | |
35 | (if b (set! i (1+ i))) | |
36 | b)) | |
37 | (let ((ret (decode-load-program pop))) | |
38 | (if (= i size) | |
39 | (values ret env) | |
40 | (error "bad bytecode: only decoded ~a out of ~a bytes" i size))))) | |
41 | ||
6fe6a2a2 AW |
42 | (define (br-instruction? x) |
43 | (memq x '(br br-if br-if-not br-if-eq br-if-not-eq br-if-null br-if-not-null))) | |
44 | ||
45 | (define (bytes->s16 a b) | |
46 | (let ((x (+ (ash a 8) b))) | |
47 | (if (zero? (logand (ash 1 15) x)) | |
48 | x | |
49 | (- x (ash 1 16))))) | |
50 | ||
ccf77d95 | 51 | ;; FIXME: this is a little-endian disassembly!!! |
7b107cce | 52 | (define (decode-load-program pop) |
ccf77d95 AW |
53 | (let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop)) |
54 | (nlocs (+ nlocs0 (ash nlocs1 8))) | |
7b107cce | 55 | (a (pop)) (b (pop)) (c (pop)) (d (pop)) |
9aeaabdc | 56 | (e (pop)) (f (pop)) (g (pop)) (h (pop)) |
7b107cce | 57 | (len (+ a (ash b 8) (ash c 16) (ash d 24))) |
9aeaabdc AW |
58 | (metalen (+ e (ash f 8) (ash g 16) (ash h 24))) |
59 | (totlen (+ len metalen)) | |
28b119ee | 60 | (pad0 (pop)) (pad1 (pop)) (pad2 (pop)) (pad3 (pop)) |
6fe6a2a2 | 61 | (labels '()) |
7b107cce | 62 | (i 0)) |
6fe6a2a2 | 63 | (define (ensure-label rel1 rel2) |
e5dc27b8 AW |
64 | (let ((where (+ (logand i (lognot #x7)) |
65 | (* (bytes->s16 rel1 rel2) 8)))) | |
6fe6a2a2 AW |
66 | (or (assv-ref labels where) |
67 | (begin | |
68 | (let ((l (gensym ":L"))) | |
69 | (set! labels (acons where l labels)) | |
70 | l))))) | |
7b107cce | 71 | (define (sub-pop) ;; ...records. ha. ha. |
1f1ec13b AW |
72 | (let ((b (cond ((< i len) (pop)) |
73 | ((= i len) #f) | |
7b107cce AW |
74 | (else (error "tried to decode too many bytes"))))) |
75 | (if b (set! i (1+ i))) | |
76 | b)) | |
77 | (let lp ((out '())) | |
1f1ec13b | 78 | (cond ((> i len) |
7b107cce | 79 | (error "error decoding program -- read too many bytes" out)) |
1f1ec13b | 80 | ((= i len) |
476e3572 | 81 | `(load-program ,nargs ,nrest ,nlocs |
6fe6a2a2 AW |
82 | ,(map (lambda (x) (cons (cdr x) (car x))) |
83 | (reverse labels)) | |
84 | ,len | |
1f1ec13b | 85 | ,(if (zero? metalen) #f (decode-load-program pop)) |
7b107cce AW |
86 | ,@(reverse! out))) |
87 | (else | |
88 | (let ((exp (decode-bytecode sub-pop))) | |
6fe6a2a2 AW |
89 | (pmatch exp |
90 | ((,br ,rel1 ,rel2) (guard (br-instruction? br)) | |
91 | (lp (cons `(,br ,(ensure-label rel1 rel2)) out))) | |
92 | ((mv-call ,n ,rel1 ,rel2) | |
93 | (lp (cons `(mv-call ,n ,(ensure-label rel1 rel2)) out))) | |
94 | (else | |
95 | (lp (cons exp out)))))))))) | |
7b107cce AW |
96 | |
97 | (define (decode-bytecode pop) | |
98 | (and=> (pop) | |
99 | (lambda (opcode) | |
100 | (let ((inst (opcode->instruction opcode))) | |
101 | (cond | |
102 | ((eq? inst 'load-program) | |
103 | (decode-load-program pop)) | |
104 | ((< (instruction-length inst) 0) | |
15939985 LC |
105 | (let* ((make-sequence |
106 | (if (eq? inst 'load-array) | |
107 | make-bytevector | |
108 | make-string)) | |
109 | (sequence-set! | |
110 | (if (eq? inst 'load-array) | |
111 | bytevector-u8-set! | |
112 | (lambda (str pos value) | |
113 | (string-set! str pos (integer->char value))))) | |
114 | ||
115 | (len (let* ((a (pop)) (b (pop)) (c (pop))) | |
8403b9f5 | 116 | (+ (ash a 16) (ash b 8) c))) |
15939985 | 117 | (seq (make-sequence len))) |
7b107cce AW |
118 | (let lp ((i 0)) |
119 | (if (= i len) | |
15939985 | 120 | `(,inst ,seq) |
7b107cce | 121 | (begin |
15939985 | 122 | (sequence-set! seq i (pop)) |
7b107cce AW |
123 | (lp (1+ i))))))) |
124 | (else | |
125 | ;; fixed length | |
126 | (let lp ((n (instruction-length inst)) (out (list inst))) | |
127 | (if (zero? n) | |
128 | (reverse! out) | |
129 | (lp (1- n) (cons (pop) out)))))))))) |