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