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