Commit | Line | Data |
---|---|---|
b0b180d5 AW |
1 | ;;; Guile Lowlevel Intermediate Language |
2 | ||
fb6df3ea | 3 | ;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc. |
b0b180d5 | 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 | |
b0b180d5 AW |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (language objcode spec) | |
22 | #:use-module (system base language) | |
b0b180d5 | 23 | #:use-module (system vm objcode) |
53e28ed9 | 24 | #:use-module (system vm program) |
b8bc86bc | 25 | #:use-module (language objcode elf) |
f95f82f8 | 26 | #:export (objcode)) |
b0b180d5 AW |
27 | |
28 | (define (objcode->value x e opts) | |
f95f82f8 AW |
29 | (let ((thunk (make-program x #f #f))) |
30 | (if (eq? e (current-module)) | |
31 | ;; save a cons in this case | |
32 | (values (thunk) e e) | |
b0b180d5 AW |
33 | (save-module-excursion |
34 | (lambda () | |
f95f82f8 AW |
35 | (set-current-module e) |
36 | (values (thunk) e e)))))) | |
b0b180d5 | 37 | |
594d9d4c AW |
38 | ;; since locals are allocated on the stack and can have limited scope, |
39 | ;; in many cases we use one local for more than one lexical variable. so | |
40 | ;; the returned locals set is a list, where element N of the list is | |
41 | ;; itself a list of bindings for local variable N. | |
42 | (define (collapse-locals locs) | |
43 | (let lp ((ret '()) (locs locs)) | |
44 | (if (null? locs) | |
45 | (map cdr (sort! ret | |
46 | (lambda (x y) (< (car x) (car y))))) | |
47 | (let ((b (car locs))) | |
48 | (cond | |
49 | ((assv-ref ret (binding:index b)) | |
50 | => (lambda (bindings) | |
51 | (append! bindings (list b)) | |
52 | (lp ret (cdr locs)))) | |
53 | (else | |
54 | (lp (acons (binding:index b) (list b) ret) | |
55 | (cdr locs)))))))) | |
56 | ||
7b107cce AW |
57 | (define (decompile-value x env opts) |
58 | (cond | |
59 | ((program? x) | |
d7236899 AW |
60 | (let ((objs (program-objects x)) |
61 | (meta (program-meta x)) | |
476e3572 | 62 | (free-vars (program-free-variables x)) |
d7236899 | 63 | (binds (program-bindings x)) |
e5f5113c | 64 | (srcs (program-sources x))) |
476e3572 | 65 | (let ((blocs (and binds (collapse-locals binds)))) |
d7236899 AW |
66 | (values (program-objcode x) |
67 | `((objects . ,objs) | |
68 | (meta . ,(and meta (meta))) | |
476e3572 | 69 | (free-vars . ,free-vars) |
d7236899 | 70 | (blocs . ,blocs) |
d7236899 | 71 | (sources . ,srcs)))))) |
7b107cce AW |
72 | ((objcode? x) |
73 | (values x #f)) | |
74 | (else | |
fb6df3ea | 75 | (error "Object for disassembly not a program or objcode" x)))) |
7b107cce | 76 | |
b0b180d5 AW |
77 | (define-language objcode |
78 | #:title "Guile Object Code" | |
b0b180d5 | 79 | #:reader #f |
53e28ed9 | 80 | #:printer write-objcode |
5d6fb8bb | 81 | #:compilers `((value . ,objcode->value)) |
7b107cce | 82 | #:decompilers `((value . ,decompile-value)) |
b0b180d5 | 83 | ) |