1 ;;; Guile VM program functions
3 ;;; Copyright (C) 2001, 2009, 2010, 2013 Free Software Foundation, Inc.
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.
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.
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
21 (define-module (system vm program)
22 #:use-module (ice-9 match)
23 #:use-module (system vm instruction)
24 #:use-module (system vm objcode)
25 #:use-module (system vm debug)
26 #:use-module (rnrs bytevectors)
27 #:use-module (srfi srfi-1)
28 #:use-module (srfi srfi-26)
29 #:export (make-program
32 make-binding binding:name binding:boxed? binding:index
33 binding:start binding:end
35 source:addr source:line source:column source:file
37 program-sources program-sources-pre-retire program-source
39 program-bindings program-bindings-by-index program-bindings-for-ip
40 program-arities program-arity arity:start arity:end
42 arity:nreq arity:nopt arity:rest? arity:kw arity:allow-other-keys?
44 program-arguments-alist program-lambda-list
47 program-objcode program? program-objects
48 rtl-program? rtl-program-code
49 program-module program-base
50 program-free-variables
51 program-num-free-variables
52 program-free-variable-ref program-free-variable-set!))
54 (load-extension (string-append "libguile-" (effective-version))
57 ;; These procedures are called by programs.c.
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))
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)))
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)))
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)))
76 (define (make-binding name boxed? index start end)
77 (list name boxed? index start end))
78 (define (binding:name b) (list-ref b 0))
79 (define (binding:boxed? b) (list-ref b 1))
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))
84 (define (source:addr source)
86 (define (source:file source)
88 (define (source:line source)
90 (define (source:column source)
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
96 (define (source:line-for-user source)
97 (1+ (source:line source)))
99 ;; FIXME: pull this definition from elsewhere.
100 (define *bytecode-header-len* 8)
102 ;; We could decompile the program to get this, but that seems like a
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.
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))))
120 (instruction-length inst))))))
122 (define (program-sources proc)
125 (map (lambda (source)
126 (cons* (- (source-post-pc source) (rtl-program-code proc))
129 (source-column source)))
130 (find-program-sources (rtl-program-code proc))))
132 (%program-sources proc))))
134 (define* (program-source proc ip #:optional (sources (program-sources proc)))
135 (let lp ((source #f) (sources sources))
138 (((and s (pc . _)) . sources)
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.
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.
153 (define (program-sources-pre-retire proc)
156 (map (lambda (source)
157 (cons* (- (source-pre-pc source) (rtl-program-code proc))
160 (source-column source)))
161 (find-program-sources (rtl-program-code proc))))
163 (let ((bv (objcode->bytecode (program-objcode proc))))
164 (let lp ((in (program-sources proc))
176 (lp2 next (+ next (bytecode-instruction-length bv next)))
178 (acons ip source out)
181 (error "unexpected"))))))))))
183 (define (collapse-locals locs)
184 (let lp ((ret '()) (locs locs))
187 (lambda (x y) (< (car x) (car y)))))
188 (let ((b (car locs)))
190 ((assv-ref ret (binding:index b))
191 => (lambda (bindings)
192 (append! bindings (list b))
193 (lp ret (cdr locs))))
195 (lp (acons (binding:index b) (list b) ret)
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)
201 (cond ((rtl-program? prog) '())
202 ((program-bindings prog) => collapse-locals)
205 (define (program-bindings-for-ip prog ip)
206 (let lp ((in (program-bindings-by-index prog)) (out '()))
210 (let inner ((binds (car in)))
211 (cond ((null? binds) out)
212 ((<= (binding:start (car binds))
214 (binding:end (car binds)))
215 (cons (car binds) out))
216 (else (inner (cdr binds)))))))))
218 (define (arity:start a)
219 (match a ((start end . _) start) (_ (error "bad arity" a))))
220 (define (arity:end a)
221 (match a ((start end . _) end) (_ (error "bad arity" a))))
222 (define (arity:nreq a)
223 (match a ((_ _ nreq . _) nreq) (_ 0)))
224 (define (arity:nopt a)
225 (match a ((_ _ nreq nopt . _) nopt) (_ 0)))
226 (define (arity:rest? a)
227 (match a ((_ _ nreq nopt rest? . _) rest?) (_ #f)))
229 (match a ((_ _ nreq nopt rest? (_ . kw)) kw) (_ '())))
230 (define (arity:allow-other-keys? a)
231 (match a ((_ _ nreq nopt rest? (aok . kw)) aok) (_ #f)))
233 (define (program-arity prog ip)
234 (let ((arities (program-arities prog)))
236 (let lp ((arities arities))
237 (cond ((null? arities) #f)
238 ((not ip) (car arities)) ; take the first one
239 ((and (< (arity:start (car arities)) ip)
240 (<= ip (arity:end (car arities))))
242 (else (lp (cdr arities))))))))
244 (define (arglist->arguments-alist arglist)
246 ((req opt keyword allow-other-keys? rest . extents)
250 (allow-other-keys? . ,allow-other-keys?)
252 (extents . ,extents)))
255 (define* (arity->arguments-alist prog arity
258 (lambda (i) (string->symbol "_"))))
260 (let ((rbinds (map (lambda (x)
261 (cons (binding:index x) (binding:name x)))
262 (program-bindings-for-ip prog
263 (arity:start arity)))))
265 (or (assv-ref rbinds i)
266 ;; if we don't know the name, return a placeholder
267 (make-placeholder i)))))
269 (let lp ((nreq (arity:nreq arity)) (req '())
270 (nopt (arity:nopt arity)) (opt '())
271 (rest? (arity:rest? arity)) (rest #f)
275 (lp (1- nreq) (cons (var-by-index n) req)
276 nopt opt rest? rest (1+ n)))
279 (1- nopt) (cons (var-by-index n) opt)
282 (lp nreq req nopt opt
283 #f (var-by-index (+ n (length (arity:kw arity))))
286 `((required . ,(reverse req))
287 (optional . ,(reverse opt))
288 (keyword . ,(arity:kw arity))
289 (allow-other-keys? . ,(arity:allow-other-keys? arity))
292 ;; the name "program-arguments" is taken by features.c...
293 (define* (program-arguments-alist prog #:optional ip)
294 "Returns the signature of the given procedure in the form of an association list."
297 (match (procedure-minimum-arity prog)
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
305 (list 0 0 nreq nopt rest? '(#f . ()))))))))
307 (let ((pc (and ip (+ (rtl-program-code prog) ip))))
308 (or-map (lambda (arity)
310 (and (<= (arity-low-pc arity) pc)
311 (< pc (arity-high-pc arity))))
312 (arity-arguments-alist arity)))
313 (or (find-program-arities (rtl-program-code prog)) '()))))
315 (let ((arity (program-arity prog ip)))
317 (arity->arguments-alist prog arity))))))
319 (define* (program-lambda-list prog #:optional ip)
320 "Returns the signature of the given procedure in the form of an argument list."
321 (and=> (program-arguments-alist prog ip) arguments-alist->lambda-list))
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) '()))
326 (key (map keyword->symbol
327 (map car (or (assq-ref arguments-alist 'keyword) '()))))
328 (rest (or (assq-ref arguments-alist 'rest) '())))
330 ,@(if (pair? opt) (cons #:optional opt) '())
331 ,@(if (pair? key) (cons #:key key) '())
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 <>)
342 (define (program-arguments-alists prog)
345 (match (procedure-minimum-arity prog)
349 (arity->arguments-alist
351 (list 0 0 nreq nopt rest? '(#f . ())))))))
353 (map arity-arguments-alist
354 (or (find-program-arities (rtl-program-code prog)) '())))
356 (map (lambda (arity) (arity->arguments-alist prog arity))
357 (or (program-arities prog) '())))
358 (else (error "expected a program" prog))))
360 (define (write-program prog port)
361 (define (program-identity-string)
362 (or (procedure-name prog)
363 (and=> (program-source prog 0)
365 (format #f "~a at ~a:~a:~a"
366 (number->string (object-address prog) 16)
368 (if s "<current input>" "<unknown port>"))
369 (source:line-for-user s) (source:column s))))
370 (number->string (object-address prog) 16)))
372 (define (program-formals-string)
373 (let ((arguments (program-arguments-alists prog)))
374 (if (null? arguments)
377 " " (string-join (map (lambda (a)
379 (arguments-alist->lambda-list a)))
383 (format port "#<procedure ~a~a>"
384 (program-identity-string) (program-formals-string)))