module/system/xref.scm

   1 ;;;;    Copyright (C) 2009 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 (define (program-callee-rev-vars prog)
  29   (define (cons-uniq x y)
  30     (if (memq x y) y (cons x y)))
  31   (cond
  32    ((program-objects prog)
  33     => (lambda (objects)
  34           (let ((n (vector-length objects))
  35                 (progv (make-vector (vector-length objects) #f))
  36                 (asm (decompile (program-objcode prog) #:to 'assembly)))
  37             (pmatch asm
  38               ((load-program _ _ _ _ _ . ,body)
  39                (for-each
  40                 (lambda (x)
  41                   (pmatch x
  42                     ((toplevel-ref ,n) (vector-set! progv n #t))
  43                     ((toplevel-set ,n) (vector-set! progv n #t))))
  44                 body)))
  45             (let lp ((i 0) (out '()))
  46               (cond
  47                ((= i n) out)
  48                ((program? (vector-ref objects i))
  49                 (lp (1+ i)
  50                     (fold cons-uniq out
  51                           (program-callee-rev-vars (vector-ref objects i)))))
  52                ((vector-ref progv i)
  53                 (let ((obj (vector-ref objects i)))
  54                   (if (variable? obj)
  55                       (lp (1+ i) (cons-uniq obj out))
  56                       ;; otherwise it's an unmemoized binding
  57                       (pmatch obj
  58                         (,sym (guard (symbol? sym))
  59                          (let ((v (module-variable (or (program-module prog)
  60                                                        the-root-module)
  61                                                    sym)))
  62                            (lp (1+ i) (if v (cons-uniq v out) out))))
  63                         ((,mod ,sym ,public?)
  64                          ;; hm, hacky.
  65                          (let* ((m (nested-ref the-root-module
  66                                                (append '(%app modules) mod)))
  67                                 (v (and m
  68                                         (module-variable
  69                                          (if public?
  70                                              (module-public-interface m)
  71                                              m)
  72                                          sym))))
  73                            (lp (1+ i)
  74                                (if v (cons-uniq v out) out))))))))
  75                (else (lp (1+ i) out)))))))
  76    (else '())))
  77
  78 (define (procedure-callee-rev-vars proc)
  79   (cond
  80    ((program? proc) (program-callee-rev-vars proc))
  81    (else '())))
  82
  83 (define (procedure-callees prog)
  84   "Evaluates to a list of the given program callees."
  85   (let lp ((in (procedure-callee-rev-vars prog)) (out '()))
  86     (cond ((null? in) out)
  87           ((variable-bound? (car in))
  88            (lp (cdr in) (cons (variable-ref (car in)) out)))
  89           (else (lp (cdr in) out)))))
  90
  91 ;; var -> ((module-name caller ...) ...)
  92 (define *callers-db* #f)
  93 ;; module-name -> (callee ...)
  94 (define *module-callees-db* (make-hash-table))
  95 ;; (module-name ...)
  96 (define *tainted-modules* '())
  97
  98 (define *xref-ignored-modules* '((value-history)))
  99 (define (on-module-modified m)
 100   (let ((name (module-name m)))
 101     (if (and (not (member name *xref-ignored-modules*))
 102              (not (member name *tainted-modules*))
 103              (pair? name))
 104         (set! *tainted-modules* (cons name *tainted-modules*)))))
 105
 106 (define (add-caller callee caller mod-name)
 107   (let ((all-callers (hashq-ref *callers-db* callee)))
 108     (if (not all-callers)
 109         (hashq-set! *callers-db* callee `((,mod-name ,caller)))
 110         (let ((callers (assoc mod-name all-callers)))
 111           (if callers
 112               (if (not (member caller callers))
 113                   (set-cdr! callers (cons caller (cdr callers))))
 114               (hashq-set! *callers-db* callee
 115                           (cons `(,mod-name ,caller) all-callers)))))))
 116
 117 (define (forget-callers callee mod-name)
 118   (hashq-set! *callers-db* callee
 119              (assoc-remove! (hashq-ref *callers-db* callee '()) mod-name)))
 120
 121 (define (add-callees callees mod-name)
 122   (hash-set! *module-callees-db* mod-name
 123              (append callees (hash-ref *module-callees-db* mod-name '()))))
 124
 125 (define (untaint-modules)
 126   (define (untaint m)
 127     (for-each (lambda (callee) (forget-callers callee m))
 128               (hash-ref *module-callees-db* m '()))
 129     (ensure-callers-db m))
 130   (ensure-callers-db #f)
 131   (for-each untaint *tainted-modules*)
 132   (set! *tainted-modules* '()))
 133
 134 (define (ensure-callers-db mod-name)
 135   (let ((mod (and mod-name (resolve-module mod-name)))
 136         (visited #f))
 137     (define (visit-variable var recurse mod-name)
 138       (if (variable-bound? var)
 139           (let ((x (variable-ref var)))
 140             (cond
 141              ((and visited (hashq-ref visited x)))
 142              ((procedure? x)
 143               (if visited (hashq-set! visited x #t))
 144               (let ((callees (filter variable-bound?
 145                                      (procedure-callee-rev-vars x))))
 146                 (for-each (lambda (callee)
 147                             (add-caller callee x mod-name))
 148                           callees)
 149                 (add-callees callees mod-name)))
 150              ((and recurse (module? x))
 151               (visit-module x #t))))))
 152
 153     (define (visit-module mod recurse)
 154       (if visited (hashq-set! visited mod #t))
 155       (if (not (memq on-module-modified (module-observers mod)))
 156           (module-observe mod on-module-modified))
 157       (let ((name (module-name mod)))
 158         (module-for-each (lambda (sym var)
 159                            (visit-variable var recurse name))
 160                          mod)))
 161
 162     (cond ((and (not mod-name) (not *callers-db*))
 163            (set! *callers-db* (make-hash-table 1000))
 164            (set! visited (make-hash-table 1000))
 165            (visit-module the-root-module #t))
 166           (mod-name (visit-module mod #f)))))
 167
 168 (define (procedure-callers var)
 169   "Returns an association list, keyed by module name, of known callers
 170 of the given procedure. The latter can specified directly as a
 171 variable, a symbol (which gets resolved in the current module) or a
 172 pair of the form (module-name . variable-name), "
 173   (let ((v (cond ((variable? var) var)
 174                  ((symbol? var) (module-variable (current-module) var))
 175                  (else
 176                   (pmatch var
 177                     ((,modname . ,sym)
 178                      (module-variable (resolve-module modname) sym))
 179                     (else
 180                      (error "expected a variable, symbol, or (modname . sym)" var)))))))
 181     (untaint-modules)
 182     (hashq-ref *callers-db* v '())))