| 1 | ;;;; Copyright (C) 2009, 2010 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) |
| 23 | #:use-module (srfi srfi-1) |
| 24 | #:export (*xref-ignored-modules* |
| 25 | procedure-callees |
| 26 | procedure-callers |
| 27 | source-closures |
| 28 | source-procedures)) |
| 29 | |
| 30 | ;;; |
| 31 | ;;; The cross-reference database: who calls whom. |
| 32 | ;;; |
| 33 | |
| 34 | (define (program-callee-rev-vars prog) |
| 35 | (define (cons-uniq x y) |
| 36 | (if (memq x y) y (cons x y))) |
| 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 |
| 44 | ((load-program ,labels ,len . ,body) |
| 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 |
| 53 | ((= i n) out) |
| 54 | ((program? (vector-ref objects i)) |
| 55 | (lp (1+ i) |
| 56 | (fold cons-uniq out |
| 57 | (program-callee-rev-vars (vector-ref objects i))))) |
| 58 | ((vector-ref progv i) |
| 59 | (let ((obj (vector-ref objects i))) |
| 60 | (if (variable? obj) |
| 61 | (lp (1+ i) (cons-uniq obj out)) |
| 62 | ;; otherwise it's an unmemoized binding |
| 63 | (pmatch obj |
| 64 | (,sym (guard (symbol? sym)) |
| 65 | (let ((v (module-variable (or (program-module prog) |
| 66 | the-root-module) |
| 67 | sym))) |
| 68 | (lp (1+ i) (if v (cons-uniq v out) out)))) |
| 69 | ((,mod ,sym ,public?) |
| 70 | ;; hm, hacky. |
| 71 | (let* ((m (nested-ref-module (resolve-module '() #f) |
| 72 | mod)) |
| 73 | (v (and m |
| 74 | (module-variable |
| 75 | (if public? |
| 76 | (module-public-interface m) |
| 77 | m) |
| 78 | sym)))) |
| 79 | (lp (1+ i) |
| 80 | (if v (cons-uniq v out) out)))))))) |
| 81 | (else (lp (1+ i) out))))))) |
| 82 | (else '()))) |
| 83 | |
| 84 | (define (procedure-callee-rev-vars proc) |
| 85 | (cond |
| 86 | ((program? proc) (program-callee-rev-vars proc)) |
| 87 | (else '()))) |
| 88 | |
| 89 | (define (procedure-callees prog) |
| 90 | "Evaluates to a list of the given program callees." |
| 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 | |
| 97 | ;; var -> ((module-name caller ...) ...) |
| 98 | (define *callers-db* #f) |
| 99 | ;; module-name -> (callee ...) |
| 100 | (define *module-callees-db* (make-hash-table)) |
| 101 | ;; (module-name ...) |
| 102 | (define *tainted-modules* '()) |
| 103 | |
| 104 | (define *xref-ignored-modules* '((value-history))) |
| 105 | (define (on-module-modified m) |
| 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*))))) |
| 111 | |
| 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)) |
| 143 | (define (visit-variable var mod-name) |
| 144 | (if (variable-bound? var) |
| 145 | (let ((x (variable-ref var))) |
| 146 | (cond |
| 147 | ((and visited (hashq-ref visited x))) |
| 148 | ((procedure? x) |
| 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) |
| 155 | (add-callees callees mod-name))))))) |
| 156 | |
| 157 | (define (visit-module mod) |
| 158 | (if visited (hashq-set! visited mod #t)) |
| 159 | (if (not (memq on-module-modified (module-observers mod))) |
| 160 | (module-observe mod on-module-modified)) |
| 161 | (let ((name (module-name mod))) |
| 162 | (module-for-each (lambda (sym var) |
| 163 | (visit-variable var name)) |
| 164 | mod))) |
| 165 | |
| 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 | |
| 175 | (cond ((and (not mod-name) (not *callers-db*)) |
| 176 | (set! *callers-db* (make-hash-table 1000)) |
| 177 | (set! visited (make-hash-table 1000)) |
| 178 | (visit-submodules (resolve-module '() #f))) |
| 179 | (mod-name (visit-module mod))))) |
| 180 | |
| 181 | (define (procedure-callers var) |
| 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), " |
| 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 |
| 193 | (error "expected a variable, symbol, or (modname . sym)" var))))))) |
| 194 | (untaint-modules) |
| 195 | (hashq-ref *callers-db* v '()))) |
| 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 | |
| 211 | ;; file -> line -> (proc ...) |
| 212 | (define *closure-sources-db* #f) |
| 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 | |
| 227 | (define (add-source proc file line db) |
| 228 | (let ((file-table (or (hash-ref db file) |
| 229 | (let ((table (make-hash-table))) |
| 230 | (hash-set! db file table) |
| 231 | table)))) |
| 232 | (hashv-set! file-table |
| 233 | line |
| 234 | (cons proc (hashv-ref file-table line '()))))) |
| 235 | |
| 236 | (define (forget-source proc file line db) |
| 237 | (let ((file-table (hash-ref db file))) |
| 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 | |
| 244 | (define (add-sources proc mod-name db) |
| 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) |
| 259 | (add-source proc file line db)) |
| 260 | (else (error "unexpected source format" source)))) |
| 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) |
| 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) |
| 278 | (forget-source proc file line db)) |
| 279 | (else (error "unexpected source format" source)))) |
| 280 | (hashq-ref mod-table proc '())) |
| 281 | ;; Forget the proc. |
| 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 | '())))))) |
| 290 | |
| 291 | (define (untaint-sources) |
| 292 | (define (untaint m) |
| 293 | (for-each (lambda (proc) (forget-sources proc m *sources-db*)) |
| 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) |
| 314 | (add-sources x name *sources-db*))))) |
| 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 | |
| 331 | (cond ((and (not mod-name) (not *sources-db*) (not *closure-sources-db*)) |
| 332 | (set! *closure-sources-db* (make-hash-table 1000)) |
| 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 | |
| 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 | |
| 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)))) |
| 379 | (file (if port (port-filename port) file))) |
| 380 | (lookup-source-procedures file line *sources-db*))) |