Commit | Line | Data |
---|---|---|
ac99cb0c KN |
1 | ;;; Guile VM frame functions |
2 | ||
bec786c1 | 3 | ;;; Copyright (C) 2001, 2005, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. |
884d46de | 4 | ;;; |
587cd3bf 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. | |
884d46de | 9 | ;;; |
587cd3bf | 10 | ;;; This library is distributed in the hope that it will be useful, |
884d46de | 11 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
587cd3bf LC |
12 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 | ;;; Lesser General Public License for more details. | |
884d46de | 14 | ;;; |
587cd3bf 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 | |
ac99cb0c KN |
18 | |
19 | ;;; Code: | |
20 | ||
21 | (define-module (system vm frame) | |
6c6a4439 | 22 | #:use-module (system base pmatch) |
c4c9bfff | 23 | #:use-module (system foreign) |
1a1a10d3 | 24 | #:use-module (system vm program) |
bec786c1 | 25 | #:use-module (system vm debug) |
c4c9bfff AW |
26 | #:use-module (system vm disassembler) |
27 | #:use-module (rnrs bytevectors) | |
c271065e | 28 | #:use-module (ice-9 match) |
1c5e8122 AW |
29 | #:export (frame-bindings |
30 | frame-lookup-binding | |
31 | frame-binding-ref frame-binding-set! | |
e15aa022 | 32 | frame-call-representation |
476e3572 | 33 | frame-environment |
c850a0ff | 34 | frame-object-binding frame-object-name)) |
ac99cb0c | 35 | |
c4c9bfff AW |
36 | (define (parse-code code) |
37 | (let ((len (bytevector-length code))) | |
38 | (let lp ((pos 0) (out '())) | |
39 | (cond | |
40 | ((< pos len) | |
41 | (let* ((inst-len (instruction-length code pos)) | |
42 | (pos (+ pos inst-len))) | |
43 | (unless (<= pos len) | |
44 | (error "Failed to parse codestream")) | |
45 | (lp pos (cons inst-len out)))) | |
46 | (else | |
47 | (list->vector (reverse out))))))) | |
48 | ||
49 | (define (compute-predecessors code parsed) | |
50 | (let ((preds (make-vector (vector-length parsed) '()))) | |
51 | (define (add-pred! from target) | |
52 | (let lp ((to from) (target target)) | |
53 | (cond | |
54 | ((negative? target) | |
55 | (lp (1- to) (+ target (vector-ref parsed to)))) | |
56 | ((positive? target) | |
57 | (lp (1+ to) (- target (vector-ref parsed to)))) | |
58 | ((= to (vector-length preds)) | |
59 | ;; This can happen when an arity fails to match. Just ignore | |
60 | ;; this case. | |
61 | #t) | |
62 | (else | |
63 | (vector-set! preds to (cons from (vector-ref preds to))))))) | |
64 | (let lp ((n 0) (pos 0)) | |
65 | (when (< n (vector-length preds)) | |
66 | (when (instruction-has-fallthrough? code pos) | |
67 | (add-pred! n (vector-ref parsed n))) | |
68 | (for-each (lambda (target) | |
69 | (add-pred! n target)) | |
70 | (instruction-relative-jump-targets code pos)) | |
71 | (lp (1+ n) (+ pos (vector-ref parsed n))))) | |
72 | preds)) | |
73 | ||
74 | (define (compute-genv parsed defs) | |
75 | (let ((genv (make-vector (vector-length parsed) '()))) | |
76 | (define (add-def! pos var) | |
77 | (vector-set! genv pos (cons var (vector-ref genv pos)))) | |
78 | (let lp ((var 0) (pos 0) (pc-offset 0)) | |
79 | (when (< var (vector-length defs)) | |
80 | (match (vector-ref defs var) | |
81 | (#(name offset slot) | |
82 | (when (< offset pc-offset) | |
83 | (error "mismatch between def offsets and parsed code")) | |
84 | (cond | |
85 | ((< pc-offset offset) | |
86 | (lp var (1+ pos) (+ pc-offset (vector-ref parsed pos)))) | |
87 | (else | |
88 | (add-def! pos var) | |
89 | (lp (1+ var) pos pc-offset))))))) | |
90 | genv)) | |
91 | ||
92 | (define (compute-defs-by-slot defs) | |
93 | (let* ((nslots (match defs | |
94 | (#(#(_ _ slot) ...) (1+ (apply max slot))))) | |
95 | (by-slot (make-vector nslots #f))) | |
96 | (let lp ((n 0)) | |
97 | (when (< n nslots) | |
98 | (vector-set! by-slot n (make-bitvector (vector-length defs) #f)) | |
99 | (lp (1+ n)))) | |
100 | (let lp ((n 0)) | |
101 | (when (< n (vector-length defs)) | |
102 | (match (vector-ref defs n) | |
103 | (#(_ _ slot) | |
104 | (bitvector-set! (vector-ref by-slot slot) n #t) | |
105 | (lp (1+ n)))))) | |
106 | by-slot)) | |
107 | ||
108 | (define (compute-killv code parsed defs) | |
109 | (let ((defs-by-slot (compute-defs-by-slot defs)) | |
110 | (killv (make-vector (vector-length parsed) #f))) | |
111 | (define (kill-slot! n slot) | |
112 | (bit-set*! (vector-ref killv n) (vector-ref defs-by-slot slot) #t)) | |
113 | (let lp ((n 0)) | |
114 | (when (< n (vector-length killv)) | |
115 | (vector-set! killv n (make-bitvector (vector-length defs) #f)) | |
116 | (lp (1+ n)))) | |
117 | ;; Some defs get into place without explicit instructions -- this is | |
118 | ;; the case if no shuffling need occur, for example. In any case, | |
119 | ;; mark them as killing any previous definitions at that slot. | |
120 | (let lp ((var 0) (pos 0) (pc-offset 0)) | |
121 | (when (< var (vector-length defs)) | |
122 | (match (vector-ref defs var) | |
123 | (#(name offset slot) | |
124 | (when (< offset pc-offset) | |
125 | (error "mismatch between def offsets and parsed code")) | |
126 | (cond | |
127 | ((< pc-offset offset) | |
128 | (lp var (1+ pos) (+ pc-offset (vector-ref parsed pos)))) | |
129 | (else | |
130 | (kill-slot! pos slot) | |
131 | (lp (1+ var) pos pc-offset))))))) | |
132 | (let lp ((n 0) (pos 0)) | |
133 | (when (< n (vector-length parsed)) | |
134 | (for-each (lambda (slot) | |
135 | (when (< slot (vector-length defs-by-slot)) | |
136 | (kill-slot! n slot))) | |
137 | (instruction-slot-clobbers code pos | |
138 | (vector-length defs-by-slot))) | |
139 | (lp (1+ n) (+ pos (vector-ref parsed n))))) | |
140 | killv)) | |
141 | ||
142 | (define (available-bindings arity ip top-frame?) | |
143 | (let* ((defs (list->vector (arity-definitions arity))) | |
144 | (code (arity-code arity)) | |
145 | (parsed (parse-code code)) | |
146 | (len (vector-length parsed)) | |
147 | (preds (compute-predecessors code parsed)) | |
148 | (genv (compute-genv parsed defs)) | |
149 | (killv (compute-killv code parsed defs)) | |
150 | (inv (make-vector len #f)) | |
151 | (outv (make-vector len #f)) | |
152 | (tmp (make-bitvector (vector-length defs) #f))) | |
153 | (define (bitvector-copy! dst src) | |
154 | (bitvector-fill! dst #f) | |
155 | (bit-set*! dst src #t)) | |
156 | (define (bitvector-meet! accum src) | |
157 | (bitvector-copy! tmp src) | |
158 | (bit-invert! tmp) | |
159 | (bit-set*! accum tmp #f)) | |
160 | ||
161 | (let lp ((n 0)) | |
162 | (when (< n len) | |
163 | (vector-set! inv n (make-bitvector (vector-length defs) #f)) | |
164 | (vector-set! outv n (make-bitvector (vector-length defs) #f)) | |
165 | (lp (1+ n)))) | |
166 | ||
167 | (let lp ((n 0) (first? #t) (changed? #f)) | |
168 | (cond | |
169 | ((< n len) | |
170 | (let ((in (vector-ref inv n)) | |
171 | (out (vector-ref outv n)) | |
172 | (kill (vector-ref killv n)) | |
173 | (gen (vector-ref genv n))) | |
174 | (let ((out-count (or changed? (bit-count #t out)))) | |
175 | (bitvector-fill! in (not (zero? n))) | |
176 | (let lp ((preds (vector-ref preds n))) | |
177 | (match preds | |
178 | (() #t) | |
179 | ((pred . preds) | |
180 | (unless (and first? (<= n pred)) | |
181 | (bitvector-meet! in (vector-ref outv pred))) | |
182 | (lp preds)))) | |
183 | (bitvector-copy! out in) | |
184 | (bit-set*! out kill #f) | |
185 | (for-each (lambda (def) | |
186 | (bitvector-set! out def #t)) | |
187 | gen) | |
188 | (lp (1+ n) first? | |
189 | (or changed? (not (eqv? out-count (bit-count #t out)))))))) | |
190 | ((or changed? first?) | |
191 | (lp 0 #f #f)))) | |
192 | ||
193 | (let lp ((n 0) (offset (- ip (arity-low-pc arity)))) | |
194 | (when (< offset 0) | |
195 | (error "ip did not correspond to an instruction boundary?")) | |
196 | (if (zero? offset) | |
197 | (let ((live (if top-frame? | |
198 | (vector-ref inv n) | |
199 | ;; If we're not at a top frame, the IP points | |
200 | ;; to the continuation -- but we haven't | |
201 | ;; returned and defined its values yet. The | |
202 | ;; set of live variables is the set that was | |
203 | ;; live going into the call, minus the set | |
204 | ;; killed by the call, but not including | |
205 | ;; values defined by the call. | |
206 | (begin | |
207 | (bitvector-copy! tmp (vector-ref inv (1- n))) | |
208 | (bit-set*! tmp (vector-ref killv (1- n)) #f) | |
209 | tmp)))) | |
210 | (let lp ((n 0)) | |
211 | (let ((n (bit-position #t live n))) | |
212 | (if n | |
213 | (match (vector-ref defs n) | |
214 | (#(name def-offset slot) | |
215 | (acons name slot (lp (1+ n))))) | |
216 | '())))) | |
217 | (lp (1+ n) (- offset (vector-ref parsed n))))))) | |
218 | ||
219 | (define* (frame-bindings frame #:optional top-frame?) | |
220 | (let ((ip (frame-instruction-pointer frame))) | |
221 | (cond | |
222 | ((find-program-arity ip) | |
223 | => (lambda (arity) | |
224 | (available-bindings arity ip top-frame?))) | |
225 | (else '())))) | |
1c5e8122 AW |
226 | |
227 | (define (frame-lookup-binding frame var) | |
228 | (let lp ((bindings (frame-bindings frame))) | |
229 | (cond ((null? bindings) | |
8470b3f4 | 230 | #f) |
1c5e8122 AW |
231 | ((eq? (binding:name (car bindings)) var) |
232 | (car bindings)) | |
233 | (else | |
234 | (lp (cdr bindings)))))) | |
6c6a4439 | 235 | |
aa3f6951 | 236 | (define (frame-binding-set! frame var val) |
1c5e8122 | 237 | (frame-local-set! frame |
8470b3f4 AW |
238 | (binding:index |
239 | (or (frame-lookup-binding frame var) | |
240 | (error "variable not bound in frame" var frame))) | |
1c5e8122 | 241 | val)) |
6c6a4439 | 242 | |
aa3f6951 | 243 | (define (frame-binding-ref frame var) |
1c5e8122 | 244 | (frame-local-ref frame |
8470b3f4 AW |
245 | (binding:index |
246 | (or (frame-lookup-binding frame var) | |
247 | (error "variable not bound in frame" var frame))))) | |
1c5e8122 | 248 | |
6c6a4439 | 249 | |
8470b3f4 AW |
250 | ;; This function is always called to get some sort of representation of the |
251 | ;; frame to present to the user, so let's do the logical thing and dispatch to | |
252 | ;; frame-call-representation. | |
253 | (define (frame-arguments frame) | |
254 | (cdr (frame-call-representation frame))) | |
255 | ||
256 | ||
257 | \f | |
258 | ;;; | |
259 | ;;; Pretty printing | |
260 | ;;; | |
261 | ||
6c6a4439 AW |
262 | ;; Basically there are two cases to deal with here: |
263 | ;; | |
264 | ;; 1. We've already parsed the arguments, and bound them to local | |
265 | ;; variables. In a standard (lambda (a b c) ...) call, this doesn't | |
266 | ;; involve any argument shuffling; but with rest, optional, or | |
267 | ;; keyword arguments, the arguments as given to the procedure may | |
268 | ;; not correspond to what's on the stack. We reconstruct the | |
269 | ;; arguments using e.g. for the case above: `(,a ,b ,c). This works | |
270 | ;; for rest arguments too: (a b . c) => `(,a ,b . ,c) | |
271 | ;; | |
272 | ;; 2. We have failed to parse the arguments. Perhaps it's the wrong | |
273 | ;; number of arguments, or perhaps we're doing a typed dispatch and | |
274 | ;; the types don't match. In that case the arguments are all on the | |
275 | ;; stack, and nothing else is on the stack. | |
d0168f3d AW |
276 | |
277 | (define (frame-call-representation frame) | |
bec786c1 AW |
278 | (let* ((ip (frame-instruction-pointer frame)) |
279 | (info (find-program-debug-info ip)) | |
280 | (nlocals (frame-num-locals frame)) | |
281 | (closure (frame-procedure frame))) | |
282 | (define (local-ref i) | |
283 | (if (< i nlocals) | |
284 | (frame-local-ref frame i) | |
285 | ;; Let's not error here, as we are called during backtraces. | |
286 | '???)) | |
c271065e AW |
287 | (define (reconstruct-arguments nreq nopt kw has-rest? local) |
288 | (cond | |
289 | ((positive? nreq) | |
290 | (cons (local-ref local) | |
291 | (reconstruct-arguments (1- nreq) nopt kw has-rest? (1+ local)))) | |
292 | ((positive? nopt) | |
293 | (cons (local-ref local) | |
294 | (reconstruct-arguments nreq (1- nopt) kw has-rest? (1+ local)))) | |
295 | ((pair? kw) | |
296 | (cons* (caar kw) (local-ref (cdar kw)) | |
297 | (reconstruct-arguments nreq nopt (cdr kw) has-rest? (1+ local)))) | |
298 | (has-rest? | |
299 | (local-ref local)) | |
300 | (else | |
301 | '()))) | |
8470b3f4 | 302 | (cons |
bec786c1 AW |
303 | (or (and=> info program-debug-info-name) |
304 | (procedure-name closure) | |
305 | (and info | |
306 | ;; No need to give source info, as backtraces will already | |
307 | ;; take care of that. | |
308 | (format #f "#<procedure ~a>" | |
309 | (number->string (program-debug-info-addr info) 16))) | |
310 | (procedure-name closure) | |
311 | closure) | |
8470b3f4 | 312 | (cond |
bec786c1 AW |
313 | ((find-program-arity ip) |
314 | => (lambda (arity) | |
315 | ;; case 1 | |
c271065e AW |
316 | (reconstruct-arguments (arity-nreq arity) |
317 | (arity-nopt arity) | |
318 | (arity-keyword-args arity) | |
319 | (arity-has-rest? arity) | |
320 | 1))) | |
321 | ((and (primitive? closure) | |
322 | (program-arguments-alist closure ip)) | |
323 | => (lambda (args) | |
324 | (match args | |
325 | ((('required . req) | |
326 | ('optional . opt) | |
327 | ('keyword . kw) | |
328 | ('allow-other-keys? . _) | |
329 | ('rest . rest)) | |
330 | ;; case 1 | |
331 | (reconstruct-arguments (length req) (length opt) kw rest 1))))) | |
8470b3f4 AW |
332 | (else |
333 | ;; case 2 | |
bec786c1 | 334 | (map local-ref |
b636cdb0 | 335 | ;; Cdr past the 0th local, which is the procedure. |
bec786c1 | 336 | (cdr (iota nlocals)))))))) |
1c5e8122 | 337 | |
07e56b27 AW |
338 | |
339 | \f | |
1c5e8122 | 340 | ;;; Misc |
07e56b27 AW |
341 | ;;; |
342 | ||
1c5e8122 | 343 | (define (frame-environment frame) |
07e56b27 AW |
344 | (map (lambda (binding) |
345 | (cons (binding:name binding) (frame-binding-ref frame binding))) | |
1c5e8122 | 346 | (frame-bindings frame))) |
07e56b27 | 347 | |
1c5e8122 AW |
348 | (define (frame-object-binding frame obj) |
349 | (do ((bs (frame-bindings frame) (cdr bs))) | |
350 | ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs)))) | |
351 | (and (pair? bs) (car bs))))) | |
07e56b27 | 352 | |
1c5e8122 AW |
353 | (define (frame-object-name frame obj) |
354 | (cond ((frame-object-binding frame obj) => binding:name) | |
07e56b27 | 355 | (else #f))) |