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.

diff --git a/module/system/xref.scm b/module/system/xref.scm
index be44225..0613754 100644 (file)
--- 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
-;;;; 
+;;;;
 \f
 
 (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 '())))