module/system/xref.scm

   1 ;;;;    Copyright (C) 2009, 2010, 2013 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 compile)
  21   #:use-module (system vm program)
  22   #:use-module (system vm disassembler)
  23   #:use-module (ice-9 match)
  24   #:use-module (srfi srfi-1)
  25   #:export (*xref-ignored-modules*
  26             procedure-callees
  27             procedure-callers
  28             source-closures
  29             source-procedures))
  30
  31 ;;;
  32 ;;; The cross-reference database: who calls whom.
  33 ;;;
  34
  35 (define (nested-procedures prog)
  36   (define (cons-uniq x y)
  37     (if (memq x y) y (cons x y)))
  38   (if (program? prog)
  39       (reverse
  40        (fold-program-code (lambda (elt out)
  41                             (match elt
  42                               (('static-ref dst proc)
  43                                (if (program? proc)
  44                                    (fold cons-uniq
  45                                          (cons proc out)
  46                                          (nested-procedures prog))
  47                                    out))
  48                               (_ out)))
  49                           (list prog)
  50                           prog))
  51       (list prog)))
  52
  53 (define (program-callee-rev-vars prog)
  54   (define (cons-uniq x y)
  55     (if (memq x y) y (cons x y)))
  56   (fold (lambda (prog out)
  57           (fold-program-code
  58            (lambda (elt out)
  59              (match elt
  60                (('toplevel-box dst var mod sym bound?)
  61                 (let ((var (or var (and mod (module-variable mod sym)))))
  62                   (if var
  63                       (cons-uniq var out)
  64                       out)))
  65                (('module-box dst var public? mod-name sym bound?)
  66                 (let ((var (or var
  67                                (module-variable (if public?
  68                                                     (resolve-interface mod-name)
  69                                                     (resolve-module mod-name))
  70                                                 sym))))
  71                   (if var
  72                       (cons-uniq var out)
  73                       out)))
  74                (_ out)))
  75            out
  76            prog))
  77         '()
  78         (nested-procedures prog)))
  79
  80 (define (procedure-callee-rev-vars proc)
  81   (cond
  82    ((program? proc) (program-callee-rev-vars proc))
  83    (else '())))
  84
  85 (define (procedure-callees prog)
  86   "Evaluates to a list of the given program callees."
  87   (let lp ((in (procedure-callee-rev-vars prog)) (out '()))
  88     (cond ((null? in) out)
  89           ((variable-bound? (car in))
  90            (lp (cdr in) (cons (variable-ref (car in)) out)))
  91           (else (lp (cdr in) out)))))
  92
  93 ;; var -> ((module-name caller ...) ...)
  94 (define *callers-db* #f)
  95 ;; module-name -> (callee ...)
  96 (define *module-callees-db* (make-hash-table))
  97 ;; (module-name ...)
  98 (define *tainted-modules* '())
  99
 100 (define *xref-ignored-modules* '((value-history)))
 101 (define (on-module-modified m)
 102   (let ((name (module-name m)))
 103     (if (and (not (member name *xref-ignored-modules*))
 104              (not (member name *tainted-modules*))
 105              (pair? name))
 106         (set! *tainted-modules* (cons name *tainted-modules*)))))
 107
 108 (define (add-caller callee caller mod-name)
 109   (let ((all-callers (hashq-ref *callers-db* callee)))
 110     (if (not all-callers)
 111         (hashq-set! *callers-db* callee `((,mod-name ,caller)))
 112         (let ((callers (assoc mod-name all-callers)))
 113           (if callers
 114               (if (not (member caller callers))
 115                   (set-cdr! callers (cons caller (cdr callers))))
 116               (hashq-set! *callers-db* callee
 117                           (cons `(,mod-name ,caller) all-callers)))))))
 118
 119 (define (forget-callers callee mod-name)
 120   (hashq-set! *callers-db* callee
 121              (assoc-remove! (hashq-ref *callers-db* callee '()) mod-name)))
 122
 123 (define (add-callees callees mod-name)
 124   (hash-set! *module-callees-db* mod-name
 125              (append callees (hash-ref *module-callees-db* mod-name '()))))
 126
 127 (define (untaint-modules)
 128   (define (untaint m)
 129     (for-each (lambda (callee) (forget-callers callee m))
 130               (hash-ref *module-callees-db* m '()))
 131     (ensure-callers-db m))
 132   (ensure-callers-db #f)
 133   (for-each untaint *tainted-modules*)
 134   (set! *tainted-modules* '()))
 135
 136 (define (ensure-callers-db mod-name)
 137   (let ((mod (and mod-name (resolve-module mod-name)))
 138         (visited #f))
 139     (define (visit-variable var mod-name)
 140       (if (variable-bound? var)
 141           (let ((x (variable-ref var)))
 142             (cond
 143              ((and visited (hashq-ref visited x)))
 144              ((procedure? x)
 145               (if visited (hashq-set! visited x #t))
 146               (let ((callees (filter variable-bound?
 147                                      (procedure-callee-rev-vars x))))
 148                 (for-each (lambda (callee)
 149                             (add-caller callee x mod-name))
 150                           callees)
 151                 (add-callees callees mod-name)))))))
 152
 153     (define (visit-module mod)
 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 name))
 160                          mod)))
 161
 162     (define (visit-submodules mod)
 163       (hash-for-each
 164        (lambda (name sub)
 165          (if (not (and visited (hashq-ref visited sub)))
 166              (begin
 167                (visit-module sub)
 168                (visit-submodules sub))))
 169        (module-submodules mod)))
 170
 171     (cond ((and (not mod-name) (not *callers-db*))
 172            (set! *callers-db* (make-hash-table 1000))
 173            (set! visited (make-hash-table 1000))
 174            (visit-submodules (resolve-module '() #f)))
 175           (mod-name (visit-module mod)))))
 176
 177 (define (procedure-callers var)
 178   "Returns an association list, keyed by module name, of known callers
 179 of the given procedure. The latter can specified directly as a
 180 variable, a symbol (which gets resolved in the current module) or a
 181 pair of the form (module-name . variable-name), "
 182   (let ((v (cond ((variable? var) var)
 183                  ((symbol? var) (module-variable (current-module) var))
 184                  (else
 185                   (match var
 186                     ((modname . sym)
 187                      (module-variable (resolve-module modname) sym))
 188                     (_
 189                      (error "expected a variable, symbol, or (modname . sym)" var)))))))
 190     (untaint-modules)
 191     (hashq-ref *callers-db* v '())))
 192
 193 \f
 194
 195 ;;;
 196 ;;; The source database: procedures defined at a given source location.
 197 ;;;
 198
 199 ;; FIXME: refactor to share code with the xref database.
 200
 201 ;; ((ip file line . col) ...)
 202 (define (procedure-sources proc)
 203   (cond
 204    ((program? proc) (program-sources proc))
 205    (else '())))
 206
 207 ;; file -> line -> (proc ...)
 208 (define *closure-sources-db* #f)
 209 ;; file -> line -> (proc ...)
 210 (define *sources-db* #f)
 211 ;; module-name -> proc -> sources
 212 (define *module-sources-db* (make-hash-table))
 213 ;; (module-name ...)
 214 (define *tainted-sources* '())
 215
 216 (define (on-source-modified m)
 217   (let ((name (module-name m)))
 218     (if (and (not (member name *xref-ignored-modules*))
 219              (not (member name *tainted-sources*))
 220              (pair? name))
 221         (set! *tainted-sources* (cons name *tainted-sources*)))))
 222
 223 (define (add-source proc file line db)
 224   (let ((file-table (or (hash-ref db file)
 225                         (let ((table (make-hash-table)))
 226                           (hash-set! db file table)
 227                           table))))
 228     (hashv-set! file-table
 229                 line
 230                 (cons proc (hashv-ref file-table line '())))))
 231
 232 (define (forget-source proc file line db)
 233   (let ((file-table (hash-ref db file)))
 234     (if file-table
 235         (let ((procs (delq proc (hashv-ref file-table line '()))))
 236           (if (pair? procs)
 237               (hashv-set! file-table line procs)
 238               (hashv-remove! file-table line))))))
 239
 240 (define (add-sources proc mod-name db)
 241   (let ((sources (procedure-sources proc)))
 242     (if (pair? sources)
 243         (begin
 244           ;; Add proc to *module-sources-db*, for book-keeping.
 245           (hashq-set! (or (hash-ref *module-sources-db* mod-name)
 246                           (let ((table (make-hash-table)))
 247                             (hash-set! *module-sources-db* mod-name table)
 248                             table))
 249                       proc
 250                       sources)
 251           ;; Actually add the source entries.
 252           (for-each (lambda (source)
 253                       (match source
 254                         ((ip file line . col)
 255                          (add-source proc file line db))
 256                         (_ (error "unexpected source format" source))))
 257                     sources)))
 258     ;; Add source entries for nested procedures.
 259     (for-each (lambda (obj)
 260                 (add-sources obj mod-name *closure-sources-db*))
 261               (cdr (nested-procedures proc)))))
 262
 263 (define (forget-sources proc mod-name db)
 264   (let ((mod-table (hash-ref *module-sources-db* mod-name)))
 265     (when mod-table
 266       ;; Forget source entries.
 267       (for-each (lambda (source)
 268                   (match source
 269                     ((ip file line . col)
 270                      (forget-source proc file line db))
 271                     (_ (error "unexpected source format" source))))
 272                 (hashq-ref mod-table proc '()))
 273       ;; Forget the proc.
 274       (hashq-remove! mod-table proc)
 275       ;; Forget source entries for nested procedures.
 276       (for-each (lambda (obj)
 277                   (forget-sources obj mod-name *closure-sources-db*))
 278                 (cdr (nested-procedures proc))))))
 279
 280 (define (untaint-sources)
 281   (define (untaint m)
 282     (for-each (lambda (proc) (forget-sources proc m *sources-db*))
 283               (cond
 284                ((hash-ref *module-sources-db* m)
 285                 => (lambda (table)
 286                      (hash-for-each (lambda (proc sources) proc) table)))
 287                (else '())))
 288     (ensure-sources-db m))
 289   (ensure-sources-db #f)
 290   (for-each untaint *tainted-sources*)
 291   (set! *tainted-sources* '()))
 292
 293 (define (ensure-sources-db mod-name)
 294   (define (visit-module mod)
 295     (if (not (memq on-source-modified (module-observers mod)))
 296         (module-observe mod on-source-modified))
 297     (let ((name (module-name mod)))
 298       (module-for-each
 299        (lambda (sym var)
 300          (if (variable-bound? var)
 301              (let ((x (variable-ref var)))
 302                (if (procedure? x)
 303                    (add-sources x name *sources-db*)))))
 304        mod)))
 305
 306   (define visit-submodules
 307     (let ((visited #f))
 308       (lambda (mod)
 309         (if (not visited)
 310             (set! visited (make-hash-table)))
 311         (hash-for-each
 312          (lambda (name sub)
 313            (if (not (hashq-ref visited sub))
 314                (begin
 315                  (hashq-set! visited sub #t)
 316                  (visit-module sub)
 317                  (visit-submodules sub))))
 318          (module-submodules mod)))))
 319
 320   (cond ((and (not mod-name) (not *sources-db*) (not *closure-sources-db*))
 321          (set! *closure-sources-db* (make-hash-table 1000))
 322          (set! *sources-db* (make-hash-table 1000))
 323          (visit-submodules (resolve-module '() #f)))
 324         (mod-name (visit-module (resolve-module mod-name)))))
 325
 326 (define (lines->ranges file-table)
 327   (let ((ranges (make-hash-table)))
 328     (hash-for-each
 329      (lambda (line procs)
 330        (for-each
 331         (lambda (proc)
 332           (cond
 333            ((hashq-ref ranges proc)
 334             => (lambda (pair)
 335                  (if (< line (car pair))
 336                      (set-car! pair line))
 337                  (if (> line (cdr pair))
 338                      (set-cdr! pair line))))
 339            (else
 340             (hashq-set! ranges proc (cons line line)))))
 341         procs))
 342      file-table)
 343     (sort! (hash-map->list cons ranges)
 344            (lambda (x y) (< (cadr x) (cadr y))))))
 345
 346 (define* (lookup-source-procedures canon-file line db)
 347   (let ((file-table (hash-ref db canon-file)))
 348     (let lp ((ranges (if file-table (lines->ranges file-table) '()))
 349              (procs '()))
 350       (cond
 351        ((null? ranges) (reverse procs))
 352        ((<= (cadar ranges) line (cddar ranges))
 353         (lp (cdr ranges) (cons (caar ranges) procs)))
 354        (else
 355         (lp (cdr ranges) procs))))))
 356
 357 (define* (source-closures file line #:key (canonicalization 'relative))
 358   (ensure-sources-db #f)
 359   (let* ((port (with-fluids ((%file-port-name-canonicalization canonicalization))
 360                  (false-if-exception (open-input-file file))))
 361          (file (if port (port-filename port) file)))
 362     (lookup-source-procedures file line *closure-sources-db*)))
 363
 364 (define* (source-procedures file line #:key (canonicalization 'relative))
 365   (ensure-sources-db #f)
 366   (let* ((port (with-fluids ((%file-port-name-canonicalization canonicalization))
 367                  (false-if-exception (open-input-file file))))
 368          (file (if port (port-filename port) file)))
 369     (lookup-source-procedures file line *sources-db*)))