Commit | Line | Data |
---|---|---|
e04894e1 AW |
1 | ;;;; Copyright (C) 2009 Free Software Foundation, Inc. |
2 | ;;;; | |
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. | |
7 | ;;;; | |
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. | |
12 | ;;;; | |
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 | |
16 | ;;;; | |
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) | |
b1907902 | 23 | #:export (procedure-callees procedure-callers *xref-ignored-modules*)) |
e04894e1 AW |
24 | |
25 | (define (program-callees prog) | |
26 | (cond | |
27 | ((program-objects prog) | |
28 | => (lambda (objects) | |
29 | (let ((n (vector-length objects)) | |
30 | (progv (make-vector (vector-length objects) #f)) | |
31 | (asm (decompile (program-objcode prog) #:to 'assembly))) | |
32 | (pmatch asm | |
33 | ((load-program ,nargs ,nrest ,nlocs ,next ,labels ,len . ,body) | |
34 | (for-each | |
35 | (lambda (x) | |
36 | (pmatch x | |
37 | ((toplevel-ref ,n) (vector-set! progv n #t)) | |
38 | ((toplevel-set ,n) (vector-set! progv n #t)))) | |
39 | body))) | |
40 | (let lp ((i 0) (out '())) | |
41 | (cond | |
42 | ((= i n) (reverse out)) | |
43 | ((program? (vector-ref objects i)) | |
44 | (lp (1+ i) (append (reverse (program-callees | |
45 | (vector-ref objects i))) | |
46 | out))) | |
47 | ((vector-ref progv i) | |
48 | (let ((obj (vector-ref objects i))) | |
49 | (if (variable? obj) | |
b1907902 AW |
50 | (lp (1+ i) (if (variable-bound? obj) |
51 | (cons (variable-ref obj) out) | |
52 | out)) | |
e04894e1 AW |
53 | ;; otherwise it's an unmemoized binding |
54 | (pmatch obj | |
55 | (,sym (guard (symbol? sym)) | |
b1907902 AW |
56 | (let ((v (module-variable (or (program-module prog) |
57 | the-root-module) | |
58 | sym))) | |
e04894e1 | 59 | (lp (1+ i) |
b1907902 AW |
60 | (if (and v (variable-bound? v)) |
61 | (cons (variable-ref v) out) | |
62 | out)))) | |
e04894e1 AW |
63 | ((,mod ,sym ,public?) |
64 | ;; hm, hacky. | |
65 | (let ((m (nested-ref the-root-module | |
66 | (append '(%app modules) mod)))) | |
67 | (let ((v (and m (module-variable | |
b1907902 | 68 | (if public? (module-public-interface m) m) |
e04894e1 AW |
69 | sym)))) |
70 | (lp (1+ i) | |
b1907902 AW |
71 | (if (and v (variable-bound? v)) |
72 | (cons (variable-ref v) out) | |
73 | out))))))))) | |
e04894e1 AW |
74 | (else (lp (1+ i) out))))))) |
75 | (else '()))) | |
76 | ||
4f96d42b AW |
77 | (define (hacky-procedure-callees proc) |
78 | ;; we could analyze the memoized source or something | |
79 | '()) | |
80 | ||
e04894e1 AW |
81 | (define (procedure-callees proc) |
82 | (cond | |
83 | ((program? proc) (program-callees proc)) | |
84 | ((procedure-source proc) (hacky-procedure-callees proc)) | |
4f96d42b | 85 | (else '()))) |
b1907902 AW |
86 | |
87 | (define *callers-db* #f) | |
88 | ||
89 | (define *xref-ignored-modules* '((value-history))) | |
90 | (define (on-module-modified m) | |
91 | (if (not (member (module-name m) *xref-ignored-modules*)) | |
92 | (set! *callers-db* #f))) | |
93 | ||
94 | (define (ensure-callers-db) | |
95 | (let ((visited '()) | |
96 | (db #f)) | |
97 | (define (visit-procedure proc) | |
98 | (for-each | |
99 | (lambda (x) | |
100 | (hashq-set! db x (cons proc (hashq-ref db x '())))) | |
101 | (procedure-callees proc))) | |
102 | ||
103 | (define (visit-module mod) | |
104 | (set! visited (cons mod visited)) | |
105 | (if (not (memq on-module-modified (module-observers mod))) | |
106 | (module-observe mod on-module-modified)) | |
107 | (module-for-each | |
108 | (lambda (sym var) | |
109 | (if (variable-bound? var) | |
110 | (let ((x (variable-ref var))) | |
111 | (cond | |
112 | ((procedure? x) (visit-procedure x)) | |
113 | ((module? x) (if (not (memq x visited)) | |
114 | (visit-module x))))))) | |
115 | mod)) | |
116 | ||
117 | (if (not *callers-db*) | |
118 | (begin | |
119 | (set! db (make-hash-table)) | |
120 | (visit-module the-root-module) | |
121 | (set! *callers-db* db))))) | |
122 | ||
123 | (define (procedure-callers proc) | |
124 | (ensure-callers-db) | |
125 | (hashq-ref *callers-db* proc #f)) |