1 ;;; Guile VM frame functions
3 ;;; Copyright (C) 2001 Free Software Foundation, Inc.
4 ;;; Copyright (C) 2005 Ludovic Courtès <ludovic.courtes@laas.fr>
6 ;;; This program is free software; you can redistribute it and/or modify
7 ;;; it under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 2 of the License, or
9 ;;; (at your option) any later version.
11 ;;; This program is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with this program; if not, write to the Free Software
18 ;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
22 (define-module (system vm frame)
23 #:use-module (system vm program)
24 #:use-module (system vm instruction)
25 #:use-module ((srfi srfi-1) #:select (fold))
28 vm-frame-local-ref vm-frame-local-set!
29 vm-frame-return-address vm-frame-mv-return-address
30 vm-frame-dynamic-link vm-frame-external-link
34 vm-frame-number vm-frame-address
36 print-frame print-frame-chain-as-backtrace
37 frame-arguments frame-local-variables frame-external-variables
39 frame-variable-exists? frame-variable-ref frame-variable-set!
41 frame-local-ref frame-external-link frame-local-set!
42 frame-return-address frame-program
43 frame-dynamic-link heap-frame?))
45 ;; fixme: avoid the dynamic-call?
46 (dynamic-call "scm_init_frames" (dynamic-link "libguile"))
52 (define vm-frame-number (make-object-property))
53 (define vm-frame-address (make-object-property))
55 (define (bootstrap-frame? frame)
56 (let ((code (program-bytecode (frame-program frame))))
57 (and (= (uniform-vector-length code) 6)
58 (= (uniform-vector-ref code 5)
59 (instruction->opcode 'halt)))))
61 (define (make-frame-chain frame addr)
63 (make-frame-chain (frame-dynamic-link frame)
64 (frame-return-address frame)))
66 ((or (eq? frame #t) (eq? frame #f))
67 ;; handle #f or #t dynamic links
69 ((bootstrap-frame? frame)
72 (let ((chain (make-rest)))
73 (set! (frame-number frame) (length chain))
74 (set! (frame-address frame)
75 (- addr (program-base (frame-program frame))))
76 (cons frame chain)))))
83 (define (frame-line-number frame)
84 (let ((addr (frame-address frame)))
85 (cond ((assv addr (program-sources (frame-program frame)))
87 (else (format #f "@~a" addr)))))
89 (define (frame-file frame prev)
90 (let ((sources (program-sources (frame-program frame))))
93 (or (source:file (car sources))
96 (define (print-frame frame)
97 (format #t "~4@a: ~a ~s\n" (frame-line-number frame) (frame-number frame)
98 (frame-call-representation frame)))
101 (define (frame-call-representation frame)
105 (list (abbrev (car x)) (abbrev (cadr x)) '...)
108 (cons (abbrev (car x)) (abbrev (cdr x))))
110 (case (vector-length x)
112 ((1) (vector (abbrev (vector-ref x 0))))
113 (else (vector (abbrev (vector-ref x 0)) '...))))
115 (abbrev (cons (frame-program-name frame) (frame-arguments frame))))
117 (define (print-frame-chain-as-backtrace frames)
119 (format #t "No backtrace available.\n")
121 (format #t "VM backtrace:\n")
122 (fold (lambda (frame file)
123 (let ((new-file (frame-file frame file)))
124 (if (not (equal? new-file file))
125 (format #t "In ~a:\n" new-file))
131 (define (frame-program-name frame)
132 (let ((prog (frame-program frame))
133 (link (frame-dynamic-link frame)))
134 (or (program-name prog)
135 (object-property prog 'name)
136 (and (heap-frame? link) (frame-address link)
137 (frame-object-name link (1- (frame-address link)) prog))
138 (hash-fold (lambda (s v d) (if (and (variable-bound? v)
139 (eq? prog (variable-ref v)))
141 prog (module-obarray (current-module))))))
148 (define (frame-arguments frame)
149 (let* ((prog (frame-program frame))
150 (arity (program-arity prog)))
151 (do ((n (+ (arity:nargs arity) -1) (1- n))
152 (l '() (cons (frame-local-ref frame n) l)))
155 (define (frame-local-variables frame)
156 (let* ((prog (frame-program frame))
157 (arity (program-arity prog)))
158 (do ((n (+ (arity:nargs arity) (arity:nlocs arity) -1) (1- n))
159 (l '() (cons (frame-local-ref frame n) l)))
162 (define (frame-external-variables frame)
163 (frame-external-link frame))
165 (define (frame-external-ref frame index)
166 (list-ref (frame-external-link frame) index))
168 (define (frame-external-set! frame index val)
169 (list-set! (frame-external-link frame) index val))
171 (define (frame-binding-ref frame binding)
172 (if (binding:extp binding)
173 (frame-external-ref frame (binding:index binding))
174 (frame-local-ref frame (binding:index binding))))
176 (define (frame-binding-set! frame binding val)
177 (if (binding:extp binding)
178 (frame-external-set! frame (binding:index binding) val)
179 (frame-local-set! frame (binding:index binding) val)))
181 ;; FIXME handle #f program-bindings return
182 (define (frame-bindings frame addr)
183 (filter (lambda (b) (and (>= addr (binding:start b))
184 (<= addr (binding:end b))))
185 (program-bindings (frame-program frame))))
187 (define (frame-lookup-binding frame addr sym)
188 (assq sym (reverse (frame-bindings frame addr))))
190 (define (frame-object-binding frame addr obj)
191 (do ((bs (frame-bindings frame addr) (cdr bs)))
192 ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs))))
193 (and (pair? bs) (car bs)))))
195 (define (frame-environment frame addr)
196 (map (lambda (binding)
197 (cons (binding:name binding) (frame-binding-ref frame binding)))
198 (frame-bindings frame addr)))
200 (define (frame-variable-exists? frame addr sym)
201 (if (frame-lookup-binding frame addr sym) #t #f))
203 (define (frame-variable-ref frame addr sym)
204 (cond ((frame-lookup-binding frame addr sym) =>
205 (lambda (binding) (frame-binding-ref frame binding)))
206 (else (error "Unknown variable:" sym))))
208 (define (frame-variable-set! frame addr sym val)
209 (cond ((frame-lookup-binding frame addr sym) =>
210 (lambda (binding) (frame-binding-set! frame binding val)))
211 (else (error "Unknown variable:" sym))))
213 (define (frame-object-name frame addr obj)
214 (cond ((frame-object-binding frame addr obj) => binding:name)