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