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