summaryrefslogtreecommitdiff
path: root/module/system/xref.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/xref.scm')
-rw-r--r--module/system/xref.scm119
1 files changed, 83 insertions, 36 deletions
diff --git a/module/system/xref.scm b/module/system/xref.scm
index ea419079f..906ec8e4a 100644
--- a/module/system/xref.scm
+++ b/module/system/xref.scm
@@ -1,30 +1,33 @@
;;;; 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)
#:use-module (system base pmatch)
#:use-module (system base compile)
#:use-module (system vm program)
+ #:use-module (srfi srfi-1)
#:export (*xref-ignored-modules*
procedure-callees
procedure-callers))
(define (program-callee-rev-vars prog)
+ (define (cons-uniq x y)
+ (if (memq x y) y (cons x y)))
(cond
((program-objects prog)
=> (lambda (objects)
@@ -32,7 +35,7 @@
(progv (make-vector (vector-length objects) #f))
(asm (decompile (program-objcode prog) #:to 'assembly)))
(pmatch asm
- ((load-program ,nargs ,nrest ,nlocs ,next ,labels ,len . ,body)
+ ((load-program ,nargs ,nrest ,nlocs ,labels ,len . ,body)
(for-each
(lambda (x)
(pmatch x
@@ -44,19 +47,19 @@
((= i n) out)
((program? (vector-ref objects i))
(lp (1+ i)
- (append (program-callee-rev-vars (vector-ref objects i))
- out)))
+ (fold cons-uniq out
+ (program-callee-rev-vars (vector-ref objects i)))))
((vector-ref progv i)
(let ((obj (vector-ref objects i)))
(if (variable? obj)
- (lp (1+ i) (cons obj out))
+ (lp (1+ i) (cons-uniq obj out))
;; otherwise it's an unmemoized binding
(pmatch obj
(,sym (guard (symbol? sym))
(let ((v (module-variable (or (program-module prog)
the-root-module)
sym)))
- (lp (1+ i) (if v (cons v out) out))))
+ (lp (1+ i) (if v (cons-uniq v out) out))))
((,mod ,sym ,public?)
;; hm, hacky.
(let* ((m (nested-ref the-root-module
@@ -68,7 +71,7 @@
m)
sym))))
(lp (1+ i)
- (if v (cons v out) out))))))))
+ (if v (cons-uniq v out) out))))))))
(else (lp (1+ i) out)))))))
(else '())))
@@ -78,51 +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 '())
- (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
+ ((and visited (hashq-ref visited x)))
((procedure? x)
- (for-each
- (lambda (callee)
- (if (variable-bound? callee)
- (let ((y (variable-ref callee)))
- (hashq-set! db callee (cons x (hashq-ref db callee '()))))))
- (procedure-callee-rev-vars x)))
- ((and (module? x) (not (memq x visited)))
- (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)
- (set! visited (cons mod visited))
+ (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))
- (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
@@ -130,6 +177,6 @@
((,modname . ,sym)
(module-variable (resolve-module modname) sym))
(else
- (error "expected a variable, symbol, or (modname sym)" var)))))))
- (ensure-callers-db)
+ (error "expected a variable, symbol, or (modname . sym)" var)))))))
+ (untaint-modules)
(hashq-ref *callers-db* v '())))