diff options
author | Jose A. Ortega Ruiz <jao@gnu.org> | 2009-04-04 11:59:57 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-04-04 11:55:50 -0700 |
commit | aa49787b5eb500807e82ce2698651515a7bdc743 (patch) | |
tree | d88c1850e7d86dcb6e79c60a511e89dbb1a39562 /module/system/xref.scm | |
parent | 2c0f99a28bc5a289bead58983da1510867162745 (diff) | |
download | guile-aa49787b5eb500807e82ce2698651515a7bdc743.tar.gz |
Improved handling of callers cache in (system xref).
* We cache callees in each module, and keep a list of modified
('tainted') modules, which is used to reconstruct the callers
database incrementally.
* `procedure-callers' now returns an a-list, keyed by module name.
Diffstat (limited to 'module/system/xref.scm')
-rw-r--r-- | module/system/xref.scm | 105 |
1 files changed, 73 insertions, 32 deletions
diff --git a/module/system/xref.scm b/module/system/xref.scm index be44225f3..0613754ab 100644 --- a/module/system/xref.scm +++ b/module/system/xref.scm @@ -1,19 +1,19 @@ ;;;; Copyright (C) 2009 Free Software Foundation, Inc. -;;;; +;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License as published by the Free Software Foundation; either ;;;; version 2.1 of the License, or (at your option) any later version. -;;;; +;;;; ;;;; This library is distributed in the hope that it will be useful, ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;;; Lesser General Public License for more details. -;;;; +;;;; ;;;; You should have received a copy of the GNU Lesser General Public ;;;; License along with this library; if not, write to the Free Software ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -;;;; +;;;; (define-module (system xref) @@ -81,54 +81,95 @@ (else '()))) (define (procedure-callees prog) + "Evaluates to a list of the given program callees." (let lp ((in (procedure-callee-rev-vars prog)) (out '())) (cond ((null? in) out) ((variable-bound? (car in)) (lp (cdr in) (cons (variable-ref (car in)) out))) (else (lp (cdr in) out))))) +;; var -> ((module-name caller ...) ...) (define *callers-db* #f) +;; module-name -> (callee ...) +(define *module-callees-db* (make-hash-table)) +;; (module-name ...) +(define *tainted-modules* '()) (define *xref-ignored-modules* '((value-history))) (define (on-module-modified m) - (if (not (member (module-name m) *xref-ignored-modules*)) - (set! *callers-db* #f))) + (let ((name (module-name m))) + (if (and (not (member name *xref-ignored-modules*)) + (not (member name *tainted-modules*)) + (pair? name)) + (set! *tainted-modules* (cons name *tainted-modules*))))) -(define (ensure-callers-db) - (let ((visited #f) - (db #f)) - (define (visit-variable var) +(define (add-caller callee caller mod-name) + (let ((all-callers (hashq-ref *callers-db* callee))) + (if (not all-callers) + (hashq-set! *callers-db* callee `((,mod-name ,caller))) + (let ((callers (assoc mod-name all-callers))) + (if callers + (if (not (member caller callers)) + (set-cdr! callers (cons caller (cdr callers)))) + (hashq-set! *callers-db* callee + (cons `(,mod-name ,caller) all-callers))))))) + +(define (forget-callers callee mod-name) + (hashq-set! *callers-db* callee + (assoc-remove! (hashq-ref *callers-db* callee '()) mod-name))) + +(define (add-callees callees mod-name) + (hash-set! *module-callees-db* mod-name + (append callees (hash-ref *module-callees-db* mod-name '())))) + +(define (untaint-modules) + (define (untaint m) + (for-each (lambda (callee) (forget-callers callee m)) + (hash-ref *module-callees-db* m '())) + (ensure-callers-db m)) + (ensure-callers-db #f) + (for-each untaint *tainted-modules*) + (set! *tainted-modules* '())) + +(define (ensure-callers-db mod-name) + (let ((mod (and mod-name (resolve-module mod-name))) + (visited #f)) + (define (visit-variable var recurse mod-name) (if (variable-bound? var) (let ((x (variable-ref var))) (cond - ((hashq-ref visited x)) + ((and visited (hashq-ref visited x))) ((procedure? x) - (hashq-set! visited x #t) - (for-each - (lambda (callee) - (if (variable-bound? callee) - (hashq-set! db callee - (cons x (hashq-ref db callee '()))))) - (procedure-callee-rev-vars x))) - ((module? x) - (visit-module x)))))) + (if visited (hashq-set! visited x #t)) + (let ((callees (filter variable-bound? + (procedure-callee-rev-vars x)))) + (for-each (lambda (callee) + (add-caller callee x mod-name)) + callees) + (add-callees callees mod-name))) + ((and recurse (module? x)) + (visit-module x #t)))))) - (define (visit-module mod) - (hashq-set! visited mod #t) + (define (visit-module mod recurse) + (if visited (hashq-set! visited mod #t)) (if (not (memq on-module-modified (module-observers mod))) (module-observe mod on-module-modified)) - (module-for-each (lambda (sym var) - (visit-variable var)) - mod)) + (let ((name (module-name mod))) + (module-for-each (lambda (sym var) + (visit-variable var recurse name)) + mod))) - (if (not *callers-db*) - (begin - (set! db (make-hash-table 1000)) - (set! visited (make-hash-table 1000)) - (visit-module the-root-module) - (set! *callers-db* db))))) + (cond ((and (not mod-name) (not *callers-db*)) + (set! *callers-db* (make-hash-table 1000)) + (set! visited (make-hash-table 1000)) + (visit-module the-root-module #t)) + (mod-name (visit-module mod #f))))) (define (procedure-callers var) + "Returns an association list, keyed by module name, of known callers +of the given procedure. The latter can specified directly as a +variable, a symbol (which gets resolved in the current module) or a +pair of the form (module-name . variable-name), " (let ((v (cond ((variable? var) var) ((symbol? var) (module-variable (current-module) var)) (else @@ -137,5 +178,5 @@ (module-variable (resolve-module modname) sym)) (else (error "expected a variable, symbol, or (modname . sym)" var))))))) - (ensure-callers-db) + (untaint-modules) (hashq-ref *callers-db* v '()))) |