module/system/xref.scm

   1 ;;;;    Copyright (C) 2009, 2010 Free Software Foundation, Inc.
   2 ;;;;
   3 ;;;; This library is free software; you can redistribute it and/or
   4 ;;;; modify it under the terms of the GNU Lesser General Public
   5 ;;;; License as published by the Free Software Foundation; either
   6 ;;;; version 2.1 of the License, or (at your option) any later version.
   7 ;;;;
   8 ;;;; This library is distributed in the hope that it will be useful,
   9 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11 ;;;; Lesser General Public License for more details.
  12 ;;;;
  13 ;;;; You should have received a copy of the GNU Lesser General Public
  14 ;;;; License along with this library; if not, write to the Free Software
  15 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16 ;;;;
  17 \f
  18
  19 (define-module (system xref)
  20   #:use-module (system base pmatch)
  21   #:use-module (system base compile)
  22   #:use-module (system vm program)
  23   #:use-module (srfi srfi-1)
  24   #:export (*xref-ignored-modules*
  25             procedure-callees
  26             procedure-callers))
  27
  28 ;;;
  29 ;;; The cross-reference database: who calls whom.
  30 ;;;
  31
  32 (define (program-callee-rev-vars prog)
  33   (define (cons-uniq x y)
  34     (if (memq x y) y (cons x y)))
  35   (cond
  36    ((program-objects prog)
  37     => (lambda (objects)
  38           (let ((n (vector-length objects))
  39                 (progv (make-vector (vector-length objects) #f))
  40                 (asm (decompile (program-objcode prog) #:to 'assembly)))
  41             (pmatch asm
  42               ((load-program ,labels ,len . ,body)
  43                (for-each
  44                 (lambda (x)
  45                   (pmatch x
  46                     ((toplevel-ref ,n) (vector-set! progv n #t))
  47                     ((toplevel-set ,n) (vector-set! progv n #t))))
  48                 body)))
  49             (let lp ((i 0) (out '()))
  50               (cond
  51                ((= i n) out)
  52                ((program? (vector-ref objects i))
  53                 (lp (1+ i)
  54                     (fold cons-uniq out
  55                           (program-callee-rev-vars (vector-ref objects i)))))
  56                ((vector-ref progv i)
  57                 (let ((obj (vector-ref objects i)))
  58                   (if (variable? obj)
  59                       (lp (1+ i) (cons-uniq obj out))
  60                       ;; otherwise it's an unmemoized binding
  61                       (pmatch obj
  62                         (,sym (guard (symbol? sym))
  63                          (let ((v (module-variable (or (program-module prog)
  64                                                        the-root-module)
  65                                                    sym)))
  66                            (lp (1+ i) (if v (cons-uniq v out) out))))
  67                         ((,mod ,sym ,public?)
  68                          ;; hm, hacky.
  69                          (let* ((m (nested-ref-module (resolve-module '() #f)
  70                                                       mod))
  71                                 (v (and m
  72                                         (module-variable
  73                                          (if public?
  74                                              (module-public-interface m)
  75                                              m)
  76                                          sym))))
  77                            (lp (1+ i)
  78                                (if v (cons-uniq v out) out))))))))
  79                (else (lp (1+ i) out)))))))
  80    (else '())))
  81
  82 (define (procedure-callee-rev-vars proc)
  83   (cond
  84    ((program? proc) (program-callee-rev-vars proc))
  85    (else '())))
  86
  87 (define (procedure-callees prog)
  88   "Evaluates to a list of the given program callees."
  89   (let lp ((in (procedure-callee-rev-vars prog)) (out '()))
  90     (cond ((null? in) out)
  91           ((variable-bound? (car in))
  92            (lp (cdr in) (cons (variable-ref (car in)) out)))
  93           (else (lp (cdr in) out)))))
  94
  95 ;; var -> ((module-name caller ...) ...)
  96 (define *callers-db* #f)
  97 ;; module-name -> (callee ...)
  98 (define *module-callees-db* (make-hash-table))
  99 ;; (module-name ...)
 100 (define *tainted-modules* '())
 101
 102 (define *xref-ignored-modules* '((value-history)))
 103 (define (on-module-modified m)
 104   (let ((name (module-name m)))
 105     (if (and (not (member name *xref-ignored-modules*))
 106              (not (member name *tainted-modules*))
 107              (pair? name))
 108         (set! *tainted-modules* (cons name *tainted-modules*)))))
 109
 110 (define (add-caller callee caller mod-name)
 111   (let ((all-callers (hashq-ref *callers-db* callee)))
 112     (if (not all-callers)
 113         (hashq-set! *callers-db* callee `((,mod-name ,caller)))
 114         (let ((callers (assoc mod-name all-callers)))
 115           (if callers
 116               (if (not (member caller callers))
 117                   (set-cdr! callers (cons caller (cdr callers))))
 118               (hashq-set! *callers-db* callee
 119                           (cons `(,mod-name ,caller) all-callers)))))))
 120
 121 (define (forget-callers callee mod-name)
 122   (hashq-set! *callers-db* callee
 123              (assoc-remove! (hashq-ref *callers-db* callee '()) mod-name)))
 124
 125 (define (add-callees callees mod-name)
 126   (hash-set! *module-callees-db* mod-name
 127              (append callees (hash-ref *module-callees-db* mod-name '()))))
 128
 129 (define (untaint-modules)
 130   (define (untaint m)
 131     (for-each (lambda (callee) (forget-callers callee m))
 132               (hash-ref *module-callees-db* m '()))
 133     (ensure-callers-db m))
 134   (ensure-callers-db #f)
 135   (for-each untaint *tainted-modules*)
 136   (set! *tainted-modules* '()))
 137
 138 (define (ensure-callers-db mod-name)
 139   (let ((mod (and mod-name (resolve-module mod-name)))
 140         (visited #f))
 141     (define (visit-variable var mod-name)
 142       (if (variable-bound? var)
 143           (let ((x (variable-ref var)))
 144             (cond
 145              ((and visited (hashq-ref visited x)))
 146              ((procedure? x)
 147               (if visited (hashq-set! visited x #t))
 148               (let ((callees (filter variable-bound?
 149                                      (procedure-callee-rev-vars x))))
 150                 (for-each (lambda (callee)
 151                             (add-caller callee x mod-name))
 152                           callees)
 153                 (add-callees callees mod-name)))))))
 154
 155     (define (visit-module mod)
 156       (if visited (hashq-set! visited mod #t))
 157       (if (not (memq on-module-modified (module-observers mod)))
 158           (module-observe mod on-module-modified))
 159       (let ((name (module-name mod)))
 160         (module-for-each (lambda (sym var)
 161                            (visit-variable var name))
 162                          mod)))
 163
 164     (define (visit-submodules mod)
 165       (hash-for-each
 166        (lambda (name sub)
 167          (if (not (and visited (hashq-ref visited sub)))
 168              (begin
 169                (visit-module sub)
 170                (visit-submodules sub))))
 171        (module-submodules mod)))
 172
 173     (cond ((and (not mod-name) (not *callers-db*))
 174            (set! *callers-db* (make-hash-table 1000))
 175            (set! visited (make-hash-table 1000))
 176            (visit-submodules (resolve-module '() #f)))
 177           (mod-name (visit-module mod)))))
 178
 179 (define (procedure-callers var)
 180   "Returns an association list, keyed by module name, of known callers
 181 of the given procedure. The latter can specified directly as a
 182 variable, a symbol (which gets resolved in the current module) or a
 183 pair of the form (module-name . variable-name), "
 184   (let ((v (cond ((variable? var) var)
 185                  ((symbol? var) (module-variable (current-module) var))
 186                  (else
 187                   (pmatch var
 188                     ((,modname . ,sym)
 189                      (module-variable (resolve-module modname) sym))
 190                     (else
 191                      (error "expected a variable, symbol, or (modname . sym)" var)))))))
 192     (untaint-modules)
 193     (hashq-ref *callers-db* v '())))