Commit | Line | Data |
---|---|---|
07e56b27 AW |
1 | ;;; Guile VM program functions |
2 | ||
9f17d967 | 3 | ;;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc. |
07e56b27 | 4 | ;;; |
e1203ea0 LC |
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. | |
07e56b27 | 9 | ;;; |
e1203ea0 | 10 | ;;; This library is distributed in the hope that it will be useful, |
07e56b27 | 11 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
e1203ea0 LC |
12 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;;; Lesser General Public License for more details. | |
07e56b27 | 14 | ;;; |
e1203ea0 LC |
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 | |
07e56b27 AW |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (system vm program) | |
6c6a4439 | 22 | #:use-module (system base pmatch) |
b262b74b AW |
23 | #:use-module (system vm instruction) |
24 | #:use-module (system vm objcode) | |
25 | #:use-module (rnrs bytevectors) | |
f9a86f72 LC |
26 | #:use-module (srfi srfi-1) |
27 | #:use-module (srfi srfi-26) | |
53e28ed9 AW |
28 | #:export (make-program |
29 | ||
476e3572 | 30 | make-binding binding:name binding:boxed? binding:index |
f580ec0f AW |
31 | binding:start binding:end |
32 | ||
53e28ed9 | 33 | source:addr source:line source:column source:file |
e867d563 | 34 | source:line-for-user |
b262b74b | 35 | program-sources program-sources-pre-retire program-source |
6c6a4439 AW |
36 | |
37 | program-bindings program-bindings-by-index program-bindings-for-ip | |
f916cbc4 AW |
38 | program-arities program-arity arity:start arity:end |
39 | ||
40 | arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys? | |
41 | ||
8470b3f4 | 42 | program-arguments-alist program-lambda-list |
f9a86f72 | 43 | |
6c6a4439 | 44 | program-meta |
53e28ed9 | 45 | program-objcode program? program-objects |
6f16379e | 46 | program-module program-base |
f9a86f72 | 47 | program-free-variables |
6f16379e AW |
48 | program-num-free-variables |
49 | program-free-variable-ref program-free-variable-set!)) | |
07e56b27 | 50 | |
44602b08 AW |
51 | (load-extension (string-append "libguile-" (effective-version)) |
52 | "scm_init_programs") | |
07e56b27 | 53 | |
476e3572 AW |
54 | (define (make-binding name boxed? index start end) |
55 | (list name boxed? index start end)) | |
f580ec0f | 56 | (define (binding:name b) (list-ref b 0)) |
476e3572 | 57 | (define (binding:boxed? b) (list-ref b 1)) |
f580ec0f AW |
58 | (define (binding:index b) (list-ref b 2)) |
59 | (define (binding:start b) (list-ref b 3)) | |
60 | (define (binding:end b) (list-ref b 4)) | |
07e56b27 | 61 | |
d0168f3d AW |
62 | (define (source:addr source) |
63 | (car source)) | |
028e3d06 AW |
64 | (define (source:file source) |
65 | (cadr source)) | |
d0168f3d | 66 | (define (source:line source) |
028e3d06 | 67 | (caddr source)) |
d0168f3d | 68 | (define (source:column source) |
028e3d06 | 69 | (cdddr source)) |
d0168f3d | 70 | |
e867d563 AW |
71 | ;; Lines are zero-indexed inside Guile, but users expect them to be |
72 | ;; one-indexed. Columns, on the other hand, are zero-indexed to both. Go | |
73 | ;; figure. | |
74 | (define (source:line-for-user source) | |
75 | (1+ (source:line source))) | |
76 | ||
b262b74b AW |
77 | ;; FIXME: pull this definition from elsewhere. |
78 | (define *bytecode-header-len* 8) | |
79 | ||
80 | ;; We could decompile the program to get this, but that seems like a | |
81 | ;; waste. | |
82 | (define (bytecode-instruction-length bytecode ip) | |
83 | (let* ((idx (+ ip *bytecode-header-len*)) | |
84 | (inst (opcode->instruction (bytevector-u8-ref bytecode idx)))) | |
85 | ;; 1+ for the instruction itself. | |
86 | (1+ (cond | |
87 | ((eq? inst 'load-program) | |
88 | (+ (bytevector-u32-native-ref bytecode (+ idx 1)) | |
89 | (bytevector-u32-native-ref bytecode (+ idx 5)))) | |
90 | ((< (instruction-length inst) 0) | |
91 | ;; variable length instruction -- the length is encoded in the | |
92 | ;; instruction stream. | |
93 | (+ (ash (bytevector-u8-ref bytecode (+ idx 1)) 16) | |
94 | (ash (bytevector-u8-ref bytecode (+ idx 2)) 8) | |
95 | (bytevector-u8-ref bytecode (+ idx 3)))) | |
96 | (else | |
97 | ;; fixed length | |
98 | (instruction-length inst)))))) | |
99 | ||
100 | ;; Source information could in theory be correlated with the ip of the | |
101 | ;; instruction, or the ip just after the instruction is retired. Guile | |
102 | ;; does the latter, to make backtraces easy -- an error produced while | |
103 | ;; running an opcode always happens after it has retired its arguments. | |
104 | ;; | |
105 | ;; But for breakpoints and such, we need the ip before the instruction | |
106 | ;; is retired -- before it has had a chance to do anything. So here we | |
107 | ;; change from the post-retire addresses given by program-sources to | |
108 | ;; pre-retire addresses. | |
109 | ;; | |
110 | (define (program-sources-pre-retire proc) | |
111 | (let ((bv (objcode->bytecode (program-objcode proc)))) | |
112 | (let lp ((in (program-sources proc)) | |
113 | (out '()) | |
114 | (ip 0)) | |
115 | (cond | |
116 | ((null? in) | |
117 | (reverse out)) | |
118 | (else | |
119 | (pmatch (car in) | |
120 | ((,post-ip . ,source) | |
121 | (let lp2 ((ip ip) | |
122 | (next ip)) | |
123 | (if (< next post-ip) | |
124 | (lp2 next (+ next (bytecode-instruction-length bv next))) | |
125 | (lp (cdr in) | |
126 | (acons ip source out) | |
127 | next)))) | |
128 | (else | |
129 | (error "unexpected")))))))) | |
130 | ||
6c6a4439 AW |
131 | (define (collapse-locals locs) |
132 | (let lp ((ret '()) (locs locs)) | |
133 | (if (null? locs) | |
134 | (map cdr (sort! ret | |
135 | (lambda (x y) (< (car x) (car y))))) | |
136 | (let ((b (car locs))) | |
137 | (cond | |
138 | ((assv-ref ret (binding:index b)) | |
139 | => (lambda (bindings) | |
140 | (append! bindings (list b)) | |
141 | (lp ret (cdr locs)))) | |
142 | (else | |
143 | (lp (acons (binding:index b) (list b) ret) | |
144 | (cdr locs)))))))) | |
145 | ||
146 | ;; returns list of list of bindings | |
147 | ;; (list-ref ret N) == bindings bound to the Nth local slot | |
148 | (define (program-bindings-by-index prog) | |
149 | (cond ((program-bindings prog) => collapse-locals) | |
150 | (else '()))) | |
151 | ||
152 | (define (program-bindings-for-ip prog ip) | |
153 | (let lp ((in (program-bindings-by-index prog)) (out '())) | |
154 | (if (null? in) | |
155 | (reverse out) | |
156 | (lp (cdr in) | |
157 | (let inner ((binds (car in))) | |
158 | (cond ((null? binds) out) | |
159 | ((<= (binding:start (car binds)) | |
160 | ip | |
161 | (binding:end (car binds))) | |
162 | (cons (car binds) out)) | |
163 | (else (inner (cdr binds))))))))) | |
164 | ||
df435c83 AW |
165 | (define (arity:start a) |
166 | (pmatch a ((,start ,end . _) start) (else (error "bad arity" a)))) | |
167 | (define (arity:end a) | |
168 | (pmatch a ((,start ,end . _) end) (else (error "bad arity" a)))) | |
169 | (define (arity:nreq a) | |
170 | (pmatch a ((_ _ ,nreq . _) nreq) (else 0))) | |
171 | (define (arity:nopt a) | |
172 | (pmatch a ((_ _ ,nreq ,nopt . _) nopt) (else 0))) | |
173 | (define (arity:rest? a) | |
174 | (pmatch a ((_ _ ,nreq ,nopt ,rest? . _) rest?) (else #f))) | |
175 | (define (arity:kw a) | |
176 | (pmatch a ((_ _ ,nreq ,nopt ,rest? (_ . ,kw)) kw) (else '()))) | |
177 | (define (arity:allow-other-keys? a) | |
178 | (pmatch a ((_ _ ,nreq ,nopt ,rest? (,aok . ,kw)) aok) (else #f))) | |
179 | ||
6c6a4439 AW |
180 | (define (program-arity prog ip) |
181 | (let ((arities (program-arities prog))) | |
182 | (and arities | |
183 | (let lp ((arities arities)) | |
184 | (cond ((null? arities) #f) | |
08d7492c | 185 | ((not ip) (car arities)) ; take the first one |
df435c83 AW |
186 | ((and (< (arity:start (car arities)) ip) |
187 | (<= ip (arity:end (car arities)))) | |
188 | (car arities)) | |
6c6a4439 AW |
189 | (else (lp (cdr arities)))))))) |
190 | ||
8470b3f4 | 191 | (define (arglist->arguments-alist arglist) |
6c6a4439 AW |
192 | (pmatch arglist |
193 | ((,req ,opt ,keyword ,allow-other-keys? ,rest . ,extents) | |
194 | `((required . ,req) | |
195 | (optional . ,opt) | |
196 | (keyword . ,keyword) | |
197 | (allow-other-keys? . ,allow-other-keys?) | |
198 | (rest . ,rest) | |
199 | (extents . ,extents))) | |
200 | (else #f))) | |
201 | ||
8470b3f4 AW |
202 | (define* (arity->arguments-alist prog arity |
203 | #:optional | |
204 | (make-placeholder | |
205 | (lambda (i) (string->symbol "_")))) | |
6c6a4439 AW |
206 | (define var-by-index |
207 | (let ((rbinds (map (lambda (x) | |
208 | (cons (binding:index x) (binding:name x))) | |
209 | (program-bindings-for-ip prog | |
210 | (arity:start arity))))) | |
211 | (lambda (i) | |
8470b3f4 AW |
212 | (or (assv-ref rbinds i) |
213 | ;; if we don't know the name, return a placeholder | |
214 | (make-placeholder i))))) | |
6c6a4439 AW |
215 | |
216 | (let lp ((nreq (arity:nreq arity)) (req '()) | |
217 | (nopt (arity:nopt arity)) (opt '()) | |
218 | (rest? (arity:rest? arity)) (rest #f) | |
219 | (n 0)) | |
220 | (cond | |
221 | ((< 0 nreq) | |
222 | (lp (1- nreq) (cons (var-by-index n) req) | |
223 | nopt opt rest? rest (1+ n))) | |
224 | ((< 0 nopt) | |
225 | (lp nreq req | |
226 | (1- nopt) (cons (var-by-index n) opt) | |
227 | rest? rest (1+ n))) | |
228 | (rest? | |
229 | (lp nreq req nopt opt | |
9f17d967 | 230 | #f (var-by-index (+ n (length (arity:kw arity)))) |
6c6a4439 AW |
231 | (1+ n))) |
232 | (else | |
233 | `((required . ,(reverse req)) | |
234 | (optional . ,(reverse opt)) | |
235 | (keyword . ,(arity:kw arity)) | |
236 | (allow-other-keys? . ,(arity:allow-other-keys? arity)) | |
237 | (rest . ,rest)))))) | |
238 | ||
8470b3f4 AW |
239 | ;; the name "program-arguments" is taken by features.c... |
240 | (define* (program-arguments-alist prog #:optional ip) | |
6fca8730 | 241 | "Returns the signature of the given procedure in the form of an association list." |
6c6a4439 AW |
242 | (let ((arity (program-arity prog ip))) |
243 | (and arity | |
8470b3f4 | 244 | (arity->arguments-alist prog arity)))) |
6c6a4439 AW |
245 | |
246 | (define* (program-lambda-list prog #:optional ip) | |
6fca8730 | 247 | "Returns the signature of the given procedure in the form of an argument list." |
8470b3f4 | 248 | (and=> (program-arguments-alist prog ip) arguments-alist->lambda-list)) |
6c6a4439 | 249 | |
8470b3f4 AW |
250 | (define (arguments-alist->lambda-list arguments-alist) |
251 | (let ((req (or (assq-ref arguments-alist 'required) '())) | |
252 | (opt (or (assq-ref arguments-alist 'optional) '())) | |
9a5ee564 | 253 | (key (map keyword->symbol |
8470b3f4 AW |
254 | (map car (or (assq-ref arguments-alist 'keyword) '())))) |
255 | (rest (or (assq-ref arguments-alist 'rest) '()))) | |
6c6a4439 AW |
256 | `(,@req |
257 | ,@(if (pair? opt) (cons #:optional opt) '()) | |
258 | ,@(if (pair? key) (cons #:key key) '()) | |
259 | . ,rest))) | |
e6fea618 | 260 | |
f9a86f72 LC |
261 | (define (program-free-variables prog) |
262 | "Return the list of free variables of PROG." | |
263 | (let ((count (program-num-free-variables prog))) | |
264 | (unfold (lambda (i) (>= i count)) | |
265 | (cut program-free-variable-ref prog <>) | |
266 | 1+ | |
267 | 0))) | |
268 | ||
e6fea618 | 269 | (define (write-program prog port) |
136b5494 | 270 | (format port "#<procedure ~a~a>" |
1e23b461 | 271 | (or (procedure-name prog) |
028e3d06 AW |
272 | (and=> (program-source prog 0) |
273 | (lambda (s) | |
274 | (format #f "~a at ~a:~a:~a" | |
275 | (number->string (object-address prog) 16) | |
136b5494 AW |
276 | (or (source:file s) |
277 | (if s "<current input>" "<unknown port>")) | |
e867d563 | 278 | (source:line-for-user s) (source:column s)))) |
e6fea618 | 279 | (number->string (object-address prog) 16)) |
6c6a4439 | 280 | (let ((arities (program-arities prog))) |
b8187a71 | 281 | (if (or (not arities) (null? arities)) |
6c6a4439 AW |
282 | "" |
283 | (string-append | |
284 | " " (string-join (map (lambda (a) | |
285 | (object->string | |
8470b3f4 AW |
286 | (arguments-alist->lambda-list |
287 | (arity->arguments-alist prog a)))) | |
6c6a4439 AW |
288 | arities) |
289 | " | ")))))) | |
290 |