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) | |
7c540297 | 22 | #:use-module (ice-9 match) |
b262b74b AW |
23 | #:use-module (system vm instruction) |
24 | #:use-module (system vm objcode) | |
e65f80af | 25 | #:use-module (system vm debug) |
b262b74b | 26 | #:use-module (rnrs bytevectors) |
f9a86f72 LC |
27 | #:use-module (srfi srfi-1) |
28 | #:use-module (srfi srfi-26) | |
53e28ed9 | 29 | #:export (make-program |
510ca126 | 30 | make-rtl-program |
53e28ed9 | 31 | |
476e3572 | 32 | make-binding binding:name binding:boxed? binding:index |
f580ec0f AW |
33 | binding:start binding:end |
34 | ||
53e28ed9 | 35 | source:addr source:line source:column source:file |
e867d563 | 36 | source:line-for-user |
b262b74b | 37 | program-sources program-sources-pre-retire program-source |
6c6a4439 AW |
38 | |
39 | program-bindings program-bindings-by-index program-bindings-for-ip | |
f916cbc4 AW |
40 | program-arities program-arity arity:start arity:end |
41 | ||
42 | arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys? | |
43 | ||
8470b3f4 | 44 | program-arguments-alist program-lambda-list |
f9a86f72 | 45 | |
6c6a4439 | 46 | program-meta |
53e28ed9 | 47 | program-objcode program? program-objects |
510ca126 | 48 | rtl-program? rtl-program-code |
6f16379e | 49 | program-module program-base |
f9a86f72 | 50 | program-free-variables |
6f16379e AW |
51 | program-num-free-variables |
52 | program-free-variable-ref program-free-variable-set!)) | |
07e56b27 | 53 | |
44602b08 AW |
54 | (load-extension (string-append "libguile-" (effective-version)) |
55 | "scm_init_programs") | |
07e56b27 | 56 | |
c4c098e3 | 57 | ;; These procedures are called by programs.c. |
e65f80af AW |
58 | (define (rtl-program-name program) |
59 | (unless (rtl-program? program) | |
60 | (error "shouldn't get here")) | |
61 | (and=> (find-program-debug-info (rtl-program-code program)) | |
62 | program-debug-info-name)) | |
bf8328ec AW |
63 | (define (rtl-program-documentation program) |
64 | (unless (rtl-program? program) | |
65 | (error "shouldn't get here")) | |
66 | (find-program-docstring (rtl-program-code program))) | |
eb2bc00f AW |
67 | (define (rtl-program-minimum-arity program) |
68 | (unless (rtl-program? program) | |
69 | (error "shouldn't get here")) | |
70 | (program-minimum-arity (rtl-program-code program))) | |
c4c098e3 AW |
71 | (define (rtl-program-properties program) |
72 | (unless (rtl-program? program) | |
73 | (error "shouldn't get here")) | |
74 | (find-program-properties (rtl-program-code program))) | |
eb2bc00f | 75 | |
476e3572 AW |
76 | (define (make-binding name boxed? index start end) |
77 | (list name boxed? index start end)) | |
f580ec0f | 78 | (define (binding:name b) (list-ref b 0)) |
476e3572 | 79 | (define (binding:boxed? b) (list-ref b 1)) |
f580ec0f AW |
80 | (define (binding:index b) (list-ref b 2)) |
81 | (define (binding:start b) (list-ref b 3)) | |
82 | (define (binding:end b) (list-ref b 4)) | |
07e56b27 | 83 | |
d0168f3d AW |
84 | (define (source:addr source) |
85 | (car source)) | |
028e3d06 AW |
86 | (define (source:file source) |
87 | (cadr source)) | |
d0168f3d | 88 | (define (source:line source) |
028e3d06 | 89 | (caddr source)) |
d0168f3d | 90 | (define (source:column source) |
028e3d06 | 91 | (cdddr source)) |
d0168f3d | 92 | |
e867d563 AW |
93 | ;; Lines are zero-indexed inside Guile, but users expect them to be |
94 | ;; one-indexed. Columns, on the other hand, are zero-indexed to both. Go | |
95 | ;; figure. | |
96 | (define (source:line-for-user source) | |
97 | (1+ (source:line source))) | |
98 | ||
b262b74b AW |
99 | ;; FIXME: pull this definition from elsewhere. |
100 | (define *bytecode-header-len* 8) | |
101 | ||
102 | ;; We could decompile the program to get this, but that seems like a | |
103 | ;; waste. | |
104 | (define (bytecode-instruction-length bytecode ip) | |
105 | (let* ((idx (+ ip *bytecode-header-len*)) | |
106 | (inst (opcode->instruction (bytevector-u8-ref bytecode idx)))) | |
107 | ;; 1+ for the instruction itself. | |
108 | (1+ (cond | |
109 | ((eq? inst 'load-program) | |
110 | (+ (bytevector-u32-native-ref bytecode (+ idx 1)) | |
111 | (bytevector-u32-native-ref bytecode (+ idx 5)))) | |
112 | ((< (instruction-length inst) 0) | |
113 | ;; variable length instruction -- the length is encoded in the | |
114 | ;; instruction stream. | |
115 | (+ (ash (bytevector-u8-ref bytecode (+ idx 1)) 16) | |
116 | (ash (bytevector-u8-ref bytecode (+ idx 2)) 8) | |
117 | (bytevector-u8-ref bytecode (+ idx 3)))) | |
118 | (else | |
119 | ;; fixed length | |
120 | (instruction-length inst)))))) | |
121 | ||
7c540297 AW |
122 | (define (program-sources proc) |
123 | (cond | |
124 | ((rtl-program? proc) | |
125 | (map (lambda (source) | |
b43e81dc | 126 | (cons* (- (source-post-pc source) (rtl-program-code proc)) |
7c540297 AW |
127 | (source-file source) |
128 | (source-line source) | |
129 | (source-column source))) | |
130 | (find-program-sources (rtl-program-code proc)))) | |
131 | (else | |
132 | (%program-sources proc)))) | |
133 | ||
134 | (define* (program-source proc ip #:optional (sources (program-sources proc))) | |
135 | (let lp ((source #f) (sources sources)) | |
136 | (match sources | |
137 | (() source) | |
138 | (((and s (pc . _)) . sources) | |
139 | (if (<= pc ip) | |
140 | (lp s sources) | |
141 | source))))) | |
142 | ||
b262b74b AW |
143 | ;; Source information could in theory be correlated with the ip of the |
144 | ;; instruction, or the ip just after the instruction is retired. Guile | |
145 | ;; does the latter, to make backtraces easy -- an error produced while | |
146 | ;; running an opcode always happens after it has retired its arguments. | |
147 | ;; | |
148 | ;; But for breakpoints and such, we need the ip before the instruction | |
149 | ;; is retired -- before it has had a chance to do anything. So here we | |
150 | ;; change from the post-retire addresses given by program-sources to | |
151 | ;; pre-retire addresses. | |
152 | ;; | |
153 | (define (program-sources-pre-retire proc) | |
7c540297 AW |
154 | (cond |
155 | ((rtl-program? proc) | |
156 | (map (lambda (source) | |
b43e81dc | 157 | (cons* (- (source-pre-pc source) (rtl-program-code proc)) |
7c540297 AW |
158 | (source-file source) |
159 | (source-line source) | |
160 | (source-column source))) | |
161 | (find-program-sources (rtl-program-code proc)))) | |
162 | (else | |
163 | (let ((bv (objcode->bytecode (program-objcode proc)))) | |
164 | (let lp ((in (program-sources proc)) | |
165 | (out '()) | |
166 | (ip 0)) | |
167 | (cond | |
168 | ((null? in) | |
169 | (reverse out)) | |
170 | (else | |
171 | (match (car in) | |
172 | ((post-ip . source) | |
173 | (let lp2 ((ip ip) | |
174 | (next ip)) | |
175 | (if (< next post-ip) | |
176 | (lp2 next (+ next (bytecode-instruction-length bv next))) | |
177 | (lp (cdr in) | |
178 | (acons ip source out) | |
179 | next)))) | |
180 | (_ | |
181 | (error "unexpected")))))))))) | |
b262b74b | 182 | |
6c6a4439 AW |
183 | (define (collapse-locals locs) |
184 | (let lp ((ret '()) (locs locs)) | |
185 | (if (null? locs) | |
186 | (map cdr (sort! ret | |
187 | (lambda (x y) (< (car x) (car y))))) | |
188 | (let ((b (car locs))) | |
189 | (cond | |
190 | ((assv-ref ret (binding:index b)) | |
191 | => (lambda (bindings) | |
192 | (append! bindings (list b)) | |
193 | (lp ret (cdr locs)))) | |
194 | (else | |
195 | (lp (acons (binding:index b) (list b) ret) | |
196 | (cdr locs)))))))) | |
197 | ||
198 | ;; returns list of list of bindings | |
199 | ;; (list-ref ret N) == bindings bound to the Nth local slot | |
200 | (define (program-bindings-by-index prog) | |
27337b63 AW |
201 | (cond ((rtl-program? prog) '()) |
202 | ((program-bindings prog) => collapse-locals) | |
6c6a4439 AW |
203 | (else '()))) |
204 | ||
205 | (define (program-bindings-for-ip prog ip) | |
206 | (let lp ((in (program-bindings-by-index prog)) (out '())) | |
207 | (if (null? in) | |
208 | (reverse out) | |
209 | (lp (cdr in) | |
210 | (let inner ((binds (car in))) | |
211 | (cond ((null? binds) out) | |
212 | ((<= (binding:start (car binds)) | |
213 | ip | |
214 | (binding:end (car binds))) | |
215 | (cons (car binds) out)) | |
216 | (else (inner (cdr binds))))))))) | |
217 | ||
df435c83 | 218 | (define (arity:start a) |
7c540297 | 219 | (match a ((start end . _) start) (_ (error "bad arity" a)))) |
df435c83 | 220 | (define (arity:end a) |
7c540297 | 221 | (match a ((start end . _) end) (_ (error "bad arity" a)))) |
df435c83 | 222 | (define (arity:nreq a) |
7c540297 | 223 | (match a ((_ _ nreq . _) nreq) (_ 0))) |
df435c83 | 224 | (define (arity:nopt a) |
7c540297 | 225 | (match a ((_ _ nreq nopt . _) nopt) (_ 0))) |
df435c83 | 226 | (define (arity:rest? a) |
7c540297 | 227 | (match a ((_ _ nreq nopt rest? . _) rest?) (_ #f))) |
df435c83 | 228 | (define (arity:kw a) |
7c540297 | 229 | (match a ((_ _ nreq nopt rest? (_ . kw)) kw) (_ '()))) |
df435c83 | 230 | (define (arity:allow-other-keys? a) |
7c540297 | 231 | (match a ((_ _ nreq nopt rest? (aok . kw)) aok) (_ #f))) |
df435c83 | 232 | |
6c6a4439 AW |
233 | (define (program-arity prog ip) |
234 | (let ((arities (program-arities prog))) | |
235 | (and arities | |
236 | (let lp ((arities arities)) | |
237 | (cond ((null? arities) #f) | |
08d7492c | 238 | ((not ip) (car arities)) ; take the first one |
df435c83 AW |
239 | ((and (< (arity:start (car arities)) ip) |
240 | (<= ip (arity:end (car arities)))) | |
241 | (car arities)) | |
6c6a4439 AW |
242 | (else (lp (cdr arities)))))))) |
243 | ||
8470b3f4 | 244 | (define (arglist->arguments-alist arglist) |
7c540297 AW |
245 | (match arglist |
246 | ((req opt keyword allow-other-keys? rest . extents) | |
6c6a4439 AW |
247 | `((required . ,req) |
248 | (optional . ,opt) | |
249 | (keyword . ,keyword) | |
250 | (allow-other-keys? . ,allow-other-keys?) | |
251 | (rest . ,rest) | |
252 | (extents . ,extents))) | |
7c540297 | 253 | (_ #f))) |
6c6a4439 | 254 | |
8470b3f4 AW |
255 | (define* (arity->arguments-alist prog arity |
256 | #:optional | |
257 | (make-placeholder | |
258 | (lambda (i) (string->symbol "_")))) | |
6c6a4439 AW |
259 | (define var-by-index |
260 | (let ((rbinds (map (lambda (x) | |
261 | (cons (binding:index x) (binding:name x))) | |
262 | (program-bindings-for-ip prog | |
263 | (arity:start arity))))) | |
264 | (lambda (i) | |
8470b3f4 AW |
265 | (or (assv-ref rbinds i) |
266 | ;; if we don't know the name, return a placeholder | |
267 | (make-placeholder i))))) | |
6c6a4439 AW |
268 | |
269 | (let lp ((nreq (arity:nreq arity)) (req '()) | |
270 | (nopt (arity:nopt arity)) (opt '()) | |
271 | (rest? (arity:rest? arity)) (rest #f) | |
272 | (n 0)) | |
273 | (cond | |
274 | ((< 0 nreq) | |
275 | (lp (1- nreq) (cons (var-by-index n) req) | |
276 | nopt opt rest? rest (1+ n))) | |
277 | ((< 0 nopt) | |
278 | (lp nreq req | |
279 | (1- nopt) (cons (var-by-index n) opt) | |
280 | rest? rest (1+ n))) | |
281 | (rest? | |
282 | (lp nreq req nopt opt | |
9f17d967 | 283 | #f (var-by-index (+ n (length (arity:kw arity)))) |
6c6a4439 AW |
284 | (1+ n))) |
285 | (else | |
286 | `((required . ,(reverse req)) | |
287 | (optional . ,(reverse opt)) | |
288 | (keyword . ,(arity:kw arity)) | |
289 | (allow-other-keys? . ,(arity:allow-other-keys? arity)) | |
290 | (rest . ,rest)))))) | |
291 | ||
8470b3f4 AW |
292 | ;; the name "program-arguments" is taken by features.c... |
293 | (define* (program-arguments-alist prog #:optional ip) | |
6fca8730 | 294 | "Returns the signature of the given procedure in the form of an association list." |
27337b63 AW |
295 | (cond |
296 | ((primitive? prog) | |
297 | (match (procedure-minimum-arity prog) | |
298 | (#f #f) | |
299 | ((nreq nopt rest?) | |
300 | (let ((start (primitive-call-ip prog))) | |
301 | ;; Assume that there is only one IP for the call. | |
302 | (and (or (not ip) (= start ip)) | |
303 | (arity->arguments-alist | |
304 | prog | |
305 | (list 0 0 nreq nopt rest? '(#f . ())))))))) | |
306 | ((rtl-program? prog) | |
307 | (let ((pc (and ip (+ (rtl-program-code prog) ip)))) | |
f8fb13ef | 308 | (or-map (lambda (arity) |
27337b63 AW |
309 | (and (or (not pc) |
310 | (and (<= (arity-low-pc arity) pc) | |
311 | (< pc (arity-high-pc arity)))) | |
f8fb13ef | 312 | (arity-arguments-alist arity))) |
27337b63 AW |
313 | (or (find-program-arities (rtl-program-code prog)) '())))) |
314 | (else | |
315 | (let ((arity (program-arity prog ip))) | |
316 | (and arity | |
317 | (arity->arguments-alist prog arity)))))) | |
6c6a4439 AW |
318 | |
319 | (define* (program-lambda-list prog #:optional ip) | |
6fca8730 | 320 | "Returns the signature of the given procedure in the form of an argument list." |
8470b3f4 | 321 | (and=> (program-arguments-alist prog ip) arguments-alist->lambda-list)) |
6c6a4439 | 322 | |
8470b3f4 AW |
323 | (define (arguments-alist->lambda-list arguments-alist) |
324 | (let ((req (or (assq-ref arguments-alist 'required) '())) | |
325 | (opt (or (assq-ref arguments-alist 'optional) '())) | |
9a5ee564 | 326 | (key (map keyword->symbol |
8470b3f4 AW |
327 | (map car (or (assq-ref arguments-alist 'keyword) '())))) |
328 | (rest (or (assq-ref arguments-alist 'rest) '()))) | |
6c6a4439 AW |
329 | `(,@req |
330 | ,@(if (pair? opt) (cons #:optional opt) '()) | |
331 | ,@(if (pair? key) (cons #:key key) '()) | |
332 | . ,rest))) | |
e6fea618 | 333 | |
f9a86f72 LC |
334 | (define (program-free-variables prog) |
335 | "Return the list of free variables of PROG." | |
336 | (let ((count (program-num-free-variables prog))) | |
337 | (unfold (lambda (i) (>= i count)) | |
338 | (cut program-free-variable-ref prog <>) | |
339 | 1+ | |
340 | 0))) | |
341 | ||
eb2bc00f AW |
342 | (define (program-arguments-alists prog) |
343 | (cond | |
27337b63 AW |
344 | ((primitive? prog) |
345 | (match (procedure-minimum-arity prog) | |
346 | (#f '()) | |
347 | ((nreq nopt rest?) | |
348 | (list | |
349 | (arity->arguments-alist | |
350 | prog | |
351 | (list 0 0 nreq nopt rest? '(#f . ()))))))) | |
eb2bc00f AW |
352 | ((rtl-program? prog) |
353 | (map arity-arguments-alist | |
f8fb13ef | 354 | (or (find-program-arities (rtl-program-code prog)) '()))) |
eb2bc00f AW |
355 | ((program? prog) |
356 | (map (lambda (arity) (arity->arguments-alist prog arity)) | |
357 | (or (program-arities prog) '()))) | |
358 | (else (error "expected a program" prog)))) | |
359 | ||
e6fea618 | 360 | (define (write-program prog port) |
eb2bc00f AW |
361 | (define (program-identity-string) |
362 | (or (procedure-name prog) | |
b43e81dc | 363 | (and=> (program-source prog 0) |
eb2bc00f AW |
364 | (lambda (s) |
365 | (format #f "~a at ~a:~a:~a" | |
366 | (number->string (object-address prog) 16) | |
367 | (or (source:file s) | |
368 | (if s "<current input>" "<unknown port>")) | |
369 | (source:line-for-user s) (source:column s)))) | |
370 | (number->string (object-address prog) 16))) | |
6c6a4439 | 371 | |
eb2bc00f AW |
372 | (define (program-formals-string) |
373 | (let ((arguments (program-arguments-alists prog))) | |
374 | (if (null? arguments) | |
375 | "" | |
376 | (string-append | |
377 | " " (string-join (map (lambda (a) | |
378 | (object->string | |
379 | (arguments-alist->lambda-list a))) | |
380 | arguments) | |
381 | " | "))))) | |
382 | ||
383 | (format port "#<procedure ~a~a>" | |
384 | (program-identity-string) (program-formals-string))) |