mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-29 14:30:34 +02:00
Code Activity

Improved handling of callers cache in (system xref).

Browse source 
* 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.
This commit is contained in:
Jose A. Ortega Ruiz 2009-04-04 11:59:57 +02:00 • committed by Andy Wingo
parent 2c0f99a28b
commit aa49787b5e
1 changed files with 73 additions and 32 deletions
Download patch file Download diff file Expand all files Collapse all files

105
module/system/xref.scm
View file

@ -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 '())))