diff options
author | Andy Wingo <wingo@pobox.com> | 2009-03-18 00:44:26 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-03-18 00:44:26 +0100 |
commit | b190790255a44ae848b2ee3b313ae5da084e3cff (patch) | |
tree | 38885666fe7cade55fb7502341bf92f0bfcc75a0 /module/system/xref.scm | |
parent | 4f96d42b2d7a3d135f061c7096a8d6ff49881b62 (diff) | |
download | guile-b190790255a44ae848b2ee3b313ae5da084e3cff.tar.gz |
implement procedure-callers
* module/system/xref.scm: Implement procedure-callers, as the inverse of
procedure-callees, with a cache invalidated by changes in modules.
* module/ice-9/boot-9.scm (module-use!): Don't poke module observers when
module-use! is called for an already-used module.
Diffstat (limited to 'module/system/xref.scm')
-rw-r--r-- | module/system/xref.scm | 60 |
1 files changed, 54 insertions, 6 deletions
diff --git a/module/system/xref.scm b/module/system/xref.scm index aa920d645..e71cfe0f0 100644 --- a/module/system/xref.scm +++ b/module/system/xref.scm @@ -20,7 +20,7 @@ #:use-module (system base pmatch) #:use-module (system base compile) #:use-module (system vm program) - #:export (procedure-callees)) + #:export (procedure-callees procedure-callers *xref-ignored-modules*)) (define (program-callees prog) (cond @@ -47,22 +47,30 @@ ((vector-ref progv i) (let ((obj (vector-ref objects i))) (if (variable? obj) - (lp (1+ i) (cons (variable-ref obj) out)) + (lp (1+ i) (if (variable-bound? obj) + (cons (variable-ref obj) out) + out)) ;; otherwise it's an unmemoized binding (pmatch obj (,sym (guard (symbol? sym)) - (let ((v (module-variable (program-module prog) sym))) + (let ((v (module-variable (or (program-module prog) + the-root-module) + sym))) (lp (1+ i) - (if v (cons (variable-ref v) out) out)))) + (if (and v (variable-bound? v)) + (cons (variable-ref v) out) + out)))) ((,mod ,sym ,public?) ;; hm, hacky. (let ((m (nested-ref the-root-module (append '(%app modules) mod)))) (let ((v (and m (module-variable - (if public? (module-interface m) m) + (if public? (module-public-interface m) m) sym)))) (lp (1+ i) - (if v (cons (variable-ref v) out) out))))))))) + (if (and v (variable-bound? v)) + (cons (variable-ref v) out) + out))))))))) (else (lp (1+ i) out))))))) (else '()))) @@ -75,3 +83,43 @@ ((program? proc) (program-callees proc)) ((procedure-source proc) (hacky-procedure-callees proc)) (else '()))) + +(define *callers-db* #f) + +(define *xref-ignored-modules* '((value-history))) +(define (on-module-modified m) + (if (not (member (module-name m) *xref-ignored-modules*)) + (set! *callers-db* #f))) + +(define (ensure-callers-db) + (let ((visited '()) + (db #f)) + (define (visit-procedure proc) + (for-each + (lambda (x) + (hashq-set! db x (cons proc (hashq-ref db x '())))) + (procedure-callees proc))) + + (define (visit-module mod) + (set! visited (cons mod visited)) + (if (not (memq on-module-modified (module-observers mod))) + (module-observe mod on-module-modified)) + (module-for-each + (lambda (sym var) + (if (variable-bound? var) + (let ((x (variable-ref var))) + (cond + ((procedure? x) (visit-procedure x)) + ((module? x) (if (not (memq x visited)) + (visit-module x))))))) + mod)) + + (if (not *callers-db*) + (begin + (set! db (make-hash-table)) + (visit-module the-root-module) + (set! *callers-db* db))))) + +(define (procedure-callers proc) + (ensure-callers-db) + (hashq-ref *callers-db* proc #f)) |