Commit | Line | Data |
---|---|---|
342370bd | 1 | ;;;; Copyright (C) 2009, 2010, 2013 Free Software Foundation, Inc. |
aa49787b | 2 | ;;;; |
e04894e1 AW |
3 | ;;;; This library is free software; you can redistribute it and/or |
4 | ;;;; modify it under the terms of the GNU Lesser General Public | |
5 | ;;;; License as published by the Free Software Foundation; either | |
6 | ;;;; version 2.1 of the License, or (at your option) any later version. | |
aa49787b | 7 | ;;;; |
e04894e1 AW |
8 | ;;;; This library is distributed in the hope that it will be useful, |
9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
11 | ;;;; Lesser General Public License for more details. | |
aa49787b | 12 | ;;;; |
e04894e1 AW |
13 | ;;;; You should have received a copy of the GNU Lesser General Public |
14 | ;;;; License along with this library; if not, write to the Free Software | |
15 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
aa49787b | 16 | ;;;; |
e04894e1 AW |
17 | \f |
18 | ||
19 | (define-module (system xref) | |
e04894e1 AW |
20 | #:use-module (system base compile) |
21 | #:use-module (system vm program) | |
147f9978 AW |
22 | #:use-module (system vm disassembler) |
23 | #:use-module (ice-9 match) | |
154a6116 | 24 | #:use-module (srfi srfi-1) |
e0a3ad67 AW |
25 | #:export (*xref-ignored-modules* |
26 | procedure-callees | |
664a8b0d | 27 | procedure-callers |
783eeee6 | 28 | source-closures |
664a8b0d | 29 | source-procedures)) |
e04894e1 | 30 | |
348fb704 AW |
31 | ;;; |
32 | ;;; The cross-reference database: who calls whom. | |
33 | ;;; | |
34 | ||
147f9978 AW |
35 | (define (nested-procedures prog) |
36 | (define (cons-uniq x y) | |
37 | (if (memq x y) y (cons x y))) | |
0bd1e9c6 | 38 | (if (program? prog) |
147f9978 AW |
39 | (reverse |
40 | (fold-program-code (lambda (elt out) | |
41 | (match elt | |
42 | (('static-ref dst proc) | |
0bd1e9c6 | 43 | (if (program? proc) |
147f9978 AW |
44 | (fold cons-uniq |
45 | (cons proc out) | |
46 | (nested-procedures prog)) | |
47 | out)) | |
48 | (_ out))) | |
49 | (list prog) | |
50 | prog)) | |
51 | (list prog))) | |
52 | ||
e0a3ad67 | 53 | (define (program-callee-rev-vars prog) |
154a6116 AW |
54 | (define (cons-uniq x y) |
55 | (if (memq x y) y (cons x y))) | |
147f9978 AW |
56 | (fold (lambda (prog out) |
57 | (fold-program-code | |
58 | (lambda (elt out) | |
59 | (match elt | |
60 | (('toplevel-box dst var mod sym bound?) | |
61 | (let ((var (or var (and mod (module-variable mod sym))))) | |
62 | (if var | |
63 | (cons-uniq var out) | |
64 | out))) | |
65 | (('module-box dst var public? mod-name sym bound?) | |
66 | (let ((var (or var | |
67 | (module-variable (if public? | |
68 | (resolve-interface mod-name) | |
69 | (resolve-module mod-name)) | |
70 | sym)))) | |
71 | (if var | |
72 | (cons-uniq var out) | |
73 | out))) | |
74 | (_ out))) | |
75 | out | |
76 | prog)) | |
77 | '() | |
78 | (nested-procedures prog))) | |
e04894e1 | 79 | |
e0a3ad67 | 80 | (define (procedure-callee-rev-vars proc) |
e04894e1 | 81 | (cond |
0bd1e9c6 | 82 | ((program? proc) (program-callee-rev-vars proc)) |
4f96d42b | 83 | (else '()))) |
b1907902 | 84 | |
e0a3ad67 | 85 | (define (procedure-callees prog) |
aa49787b | 86 | "Evaluates to a list of the given program callees." |
e0a3ad67 AW |
87 | (let lp ((in (procedure-callee-rev-vars prog)) (out '())) |
88 | (cond ((null? in) out) | |
89 | ((variable-bound? (car in)) | |
90 | (lp (cdr in) (cons (variable-ref (car in)) out))) | |
91 | (else (lp (cdr in) out))))) | |
92 | ||
aa49787b | 93 | ;; var -> ((module-name caller ...) ...) |
b1907902 | 94 | (define *callers-db* #f) |
aa49787b JOR |
95 | ;; module-name -> (callee ...) |
96 | (define *module-callees-db* (make-hash-table)) | |
97 | ;; (module-name ...) | |
98 | (define *tainted-modules* '()) | |
b1907902 AW |
99 | |
100 | (define *xref-ignored-modules* '((value-history))) | |
101 | (define (on-module-modified m) | |
aa49787b JOR |
102 | (let ((name (module-name m))) |
103 | (if (and (not (member name *xref-ignored-modules*)) | |
104 | (not (member name *tainted-modules*)) | |
105 | (pair? name)) | |
106 | (set! *tainted-modules* (cons name *tainted-modules*))))) | |
b1907902 | 107 | |
aa49787b JOR |
108 | (define (add-caller callee caller mod-name) |
109 | (let ((all-callers (hashq-ref *callers-db* callee))) | |
110 | (if (not all-callers) | |
111 | (hashq-set! *callers-db* callee `((,mod-name ,caller))) | |
112 | (let ((callers (assoc mod-name all-callers))) | |
113 | (if callers | |
114 | (if (not (member caller callers)) | |
115 | (set-cdr! callers (cons caller (cdr callers)))) | |
116 | (hashq-set! *callers-db* callee | |
117 | (cons `(,mod-name ,caller) all-callers))))))) | |
118 | ||
119 | (define (forget-callers callee mod-name) | |
120 | (hashq-set! *callers-db* callee | |
121 | (assoc-remove! (hashq-ref *callers-db* callee '()) mod-name))) | |
122 | ||
123 | (define (add-callees callees mod-name) | |
124 | (hash-set! *module-callees-db* mod-name | |
125 | (append callees (hash-ref *module-callees-db* mod-name '())))) | |
126 | ||
127 | (define (untaint-modules) | |
128 | (define (untaint m) | |
129 | (for-each (lambda (callee) (forget-callers callee m)) | |
130 | (hash-ref *module-callees-db* m '())) | |
131 | (ensure-callers-db m)) | |
132 | (ensure-callers-db #f) | |
133 | (for-each untaint *tainted-modules*) | |
134 | (set! *tainted-modules* '())) | |
135 | ||
136 | (define (ensure-callers-db mod-name) | |
137 | (let ((mod (and mod-name (resolve-module mod-name))) | |
138 | (visited #f)) | |
348fb704 | 139 | (define (visit-variable var mod-name) |
e0a3ad67 AW |
140 | (if (variable-bound? var) |
141 | (let ((x (variable-ref var))) | |
142 | (cond | |
aa49787b | 143 | ((and visited (hashq-ref visited x))) |
e0a3ad67 | 144 | ((procedure? x) |
aa49787b JOR |
145 | (if visited (hashq-set! visited x #t)) |
146 | (let ((callees (filter variable-bound? | |
147 | (procedure-callee-rev-vars x)))) | |
148 | (for-each (lambda (callee) | |
149 | (add-caller callee x mod-name)) | |
150 | callees) | |
348fb704 | 151 | (add-callees callees mod-name))))))) |
b1907902 | 152 | |
348fb704 | 153 | (define (visit-module mod) |
aa49787b | 154 | (if visited (hashq-set! visited mod #t)) |
b1907902 AW |
155 | (if (not (memq on-module-modified (module-observers mod))) |
156 | (module-observe mod on-module-modified)) | |
aa49787b JOR |
157 | (let ((name (module-name mod))) |
158 | (module-for-each (lambda (sym var) | |
348fb704 | 159 | (visit-variable var name)) |
aa49787b | 160 | mod))) |
b1907902 | 161 | |
348fb704 AW |
162 | (define (visit-submodules mod) |
163 | (hash-for-each | |
164 | (lambda (name sub) | |
165 | (if (not (and visited (hashq-ref visited sub))) | |
166 | (begin | |
167 | (visit-module sub) | |
168 | (visit-submodules sub)))) | |
169 | (module-submodules mod))) | |
170 | ||
aa49787b JOR |
171 | (cond ((and (not mod-name) (not *callers-db*)) |
172 | (set! *callers-db* (make-hash-table 1000)) | |
173 | (set! visited (make-hash-table 1000)) | |
348fb704 AW |
174 | (visit-submodules (resolve-module '() #f))) |
175 | (mod-name (visit-module mod))))) | |
b1907902 | 176 | |
e0a3ad67 | 177 | (define (procedure-callers var) |
aa49787b JOR |
178 | "Returns an association list, keyed by module name, of known callers |
179 | of the given procedure. The latter can specified directly as a | |
180 | variable, a symbol (which gets resolved in the current module) or a | |
181 | pair of the form (module-name . variable-name), " | |
e0a3ad67 AW |
182 | (let ((v (cond ((variable? var) var) |
183 | ((symbol? var) (module-variable (current-module) var)) | |
184 | (else | |
147f9978 AW |
185 | (match var |
186 | ((modname . sym) | |
e0a3ad67 | 187 | (module-variable (resolve-module modname) sym)) |
147f9978 | 188 | (_ |
154a6116 | 189 | (error "expected a variable, symbol, or (modname . sym)" var))))))) |
aa49787b | 190 | (untaint-modules) |
e0a3ad67 | 191 | (hashq-ref *callers-db* v '()))) |
664a8b0d AW |
192 | |
193 | \f | |
194 | ||
195 | ;;; | |
196 | ;;; The source database: procedures defined at a given source location. | |
197 | ;;; | |
198 | ||
199 | ;; FIXME: refactor to share code with the xref database. | |
200 | ||
201 | ;; ((ip file line . col) ...) | |
202 | (define (procedure-sources proc) | |
203 | (cond | |
0bd1e9c6 | 204 | ((program? proc) (program-sources proc)) |
664a8b0d AW |
205 | (else '()))) |
206 | ||
783eeee6 AW |
207 | ;; file -> line -> (proc ...) |
208 | (define *closure-sources-db* #f) | |
664a8b0d AW |
209 | ;; file -> line -> (proc ...) |
210 | (define *sources-db* #f) | |
211 | ;; module-name -> proc -> sources | |
212 | (define *module-sources-db* (make-hash-table)) | |
213 | ;; (module-name ...) | |
214 | (define *tainted-sources* '()) | |
215 | ||
216 | (define (on-source-modified m) | |
217 | (let ((name (module-name m))) | |
218 | (if (and (not (member name *xref-ignored-modules*)) | |
219 | (not (member name *tainted-sources*)) | |
220 | (pair? name)) | |
221 | (set! *tainted-sources* (cons name *tainted-sources*))))) | |
222 | ||
783eeee6 AW |
223 | (define (add-source proc file line db) |
224 | (let ((file-table (or (hash-ref db file) | |
664a8b0d | 225 | (let ((table (make-hash-table))) |
783eeee6 | 226 | (hash-set! db file table) |
664a8b0d AW |
227 | table)))) |
228 | (hashv-set! file-table | |
229 | line | |
230 | (cons proc (hashv-ref file-table line '()))))) | |
231 | ||
783eeee6 AW |
232 | (define (forget-source proc file line db) |
233 | (let ((file-table (hash-ref db file))) | |
664a8b0d AW |
234 | (if file-table |
235 | (let ((procs (delq proc (hashv-ref file-table line '())))) | |
236 | (if (pair? procs) | |
237 | (hashv-set! file-table line procs) | |
238 | (hashv-remove! file-table line)))))) | |
239 | ||
783eeee6 | 240 | (define (add-sources proc mod-name db) |
664a8b0d AW |
241 | (let ((sources (procedure-sources proc))) |
242 | (if (pair? sources) | |
243 | (begin | |
244 | ;; Add proc to *module-sources-db*, for book-keeping. | |
245 | (hashq-set! (or (hash-ref *module-sources-db* mod-name) | |
246 | (let ((table (make-hash-table))) | |
247 | (hash-set! *module-sources-db* mod-name table) | |
248 | table)) | |
249 | proc | |
250 | sources) | |
251 | ;; Actually add the source entries. | |
252 | (for-each (lambda (source) | |
147f9978 AW |
253 | (match source |
254 | ((ip file line . col) | |
783eeee6 | 255 | (add-source proc file line db)) |
147f9978 | 256 | (_ (error "unexpected source format" source)))) |
783eeee6 AW |
257 | sources))) |
258 | ;; Add source entries for nested procedures. | |
259 | (for-each (lambda (obj) | |
147f9978 AW |
260 | (add-sources obj mod-name *closure-sources-db*)) |
261 | (cdr (nested-procedures proc))))) | |
783eeee6 AW |
262 | |
263 | (define (forget-sources proc mod-name db) | |
664a8b0d | 264 | (let ((mod-table (hash-ref *module-sources-db* mod-name))) |
147f9978 AW |
265 | (when mod-table |
266 | ;; Forget source entries. | |
267 | (for-each (lambda (source) | |
268 | (match source | |
269 | ((ip file line . col) | |
270 | (forget-source proc file line db)) | |
271 | (_ (error "unexpected source format" source)))) | |
272 | (hashq-ref mod-table proc '())) | |
273 | ;; Forget the proc. | |
274 | (hashq-remove! mod-table proc) | |
275 | ;; Forget source entries for nested procedures. | |
276 | (for-each (lambda (obj) | |
277 | (forget-sources obj mod-name *closure-sources-db*)) | |
278 | (cdr (nested-procedures proc)))))) | |
664a8b0d AW |
279 | |
280 | (define (untaint-sources) | |
281 | (define (untaint m) | |
783eeee6 | 282 | (for-each (lambda (proc) (forget-sources proc m *sources-db*)) |
664a8b0d AW |
283 | (cond |
284 | ((hash-ref *module-sources-db* m) | |
285 | => (lambda (table) | |
286 | (hash-for-each (lambda (proc sources) proc) table))) | |
287 | (else '()))) | |
288 | (ensure-sources-db m)) | |
289 | (ensure-sources-db #f) | |
290 | (for-each untaint *tainted-sources*) | |
291 | (set! *tainted-sources* '())) | |
292 | ||
293 | (define (ensure-sources-db mod-name) | |
294 | (define (visit-module mod) | |
295 | (if (not (memq on-source-modified (module-observers mod))) | |
296 | (module-observe mod on-source-modified)) | |
297 | (let ((name (module-name mod))) | |
298 | (module-for-each | |
299 | (lambda (sym var) | |
300 | (if (variable-bound? var) | |
301 | (let ((x (variable-ref var))) | |
302 | (if (procedure? x) | |
783eeee6 | 303 | (add-sources x name *sources-db*))))) |
664a8b0d AW |
304 | mod))) |
305 | ||
306 | (define visit-submodules | |
307 | (let ((visited #f)) | |
308 | (lambda (mod) | |
309 | (if (not visited) | |
310 | (set! visited (make-hash-table))) | |
311 | (hash-for-each | |
312 | (lambda (name sub) | |
313 | (if (not (hashq-ref visited sub)) | |
314 | (begin | |
315 | (hashq-set! visited sub #t) | |
316 | (visit-module sub) | |
317 | (visit-submodules sub)))) | |
318 | (module-submodules mod))))) | |
319 | ||
783eeee6 AW |
320 | (cond ((and (not mod-name) (not *sources-db*) (not *closure-sources-db*)) |
321 | (set! *closure-sources-db* (make-hash-table 1000)) | |
664a8b0d AW |
322 | (set! *sources-db* (make-hash-table 1000)) |
323 | (visit-submodules (resolve-module '() #f))) | |
324 | (mod-name (visit-module (resolve-module mod-name))))) | |
325 | ||
326 | (define (lines->ranges file-table) | |
327 | (let ((ranges (make-hash-table))) | |
328 | (hash-for-each | |
329 | (lambda (line procs) | |
330 | (for-each | |
331 | (lambda (proc) | |
332 | (cond | |
333 | ((hashq-ref ranges proc) | |
334 | => (lambda (pair) | |
335 | (if (< line (car pair)) | |
336 | (set-car! pair line)) | |
337 | (if (> line (cdr pair)) | |
338 | (set-cdr! pair line)))) | |
339 | (else | |
340 | (hashq-set! ranges proc (cons line line))))) | |
341 | procs)) | |
342 | file-table) | |
343 | (sort! (hash-map->list cons ranges) | |
344 | (lambda (x y) (< (cadr x) (cadr y)))))) | |
345 | ||
783eeee6 AW |
346 | (define* (lookup-source-procedures canon-file line db) |
347 | (let ((file-table (hash-ref db canon-file))) | |
348 | (let lp ((ranges (if file-table (lines->ranges file-table) '())) | |
349 | (procs '())) | |
350 | (cond | |
351 | ((null? ranges) (reverse procs)) | |
352 | ((<= (cadar ranges) line (cddar ranges)) | |
353 | (lp (cdr ranges) (cons (caar ranges) procs))) | |
354 | (else | |
355 | (lp (cdr ranges) procs)))))) | |
356 | ||
357 | (define* (source-closures file line #:key (canonicalization 'relative)) | |
358 | (ensure-sources-db #f) | |
359 | (let* ((port (with-fluids ((%file-port-name-canonicalization canonicalization)) | |
360 | (false-if-exception (open-input-file file)))) | |
361 | (file (if port (port-filename port) file))) | |
362 | (lookup-source-procedures file line *closure-sources-db*))) | |
363 | ||
664a8b0d AW |
364 | (define* (source-procedures file line #:key (canonicalization 'relative)) |
365 | (ensure-sources-db #f) | |
366 | (let* ((port (with-fluids ((%file-port-name-canonicalization canonicalization)) | |
367 | (false-if-exception (open-input-file file)))) | |
783eeee6 AW |
368 | (file (if port (port-filename port) file))) |
369 | (lookup-source-procedures file line *sources-db*))) |