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   #:export (procedure-callees procedure-callers *xref-ignored-modules*))
  24
  25 (define (program-callees prog)
  26   (cond
  27    ((program-objects prog)
  28     => (lambda (objects)
  29           (let ((n (vector-length objects))
  30                 (progv (make-vector (vector-length objects) #f))
  31                 (asm (decompile (program-objcode prog) #:to 'assembly)))
  32             (pmatch asm
  33               ((load-program ,nargs ,nrest ,nlocs ,next ,labels ,len . ,body)
  34                (for-each
  35                 (lambda (x)
  36                   (pmatch x
  37                     ((toplevel-ref ,n) (vector-set! progv n #t))
  38                     ((toplevel-set ,n) (vector-set! progv n #t))))
  39                 body)))
  40             (let lp ((i 0) (out '()))
  41               (cond
  42                ((= i n) (reverse out))
  43                ((program? (vector-ref objects i))
  44                 (lp (1+ i) (append (reverse (program-callees
  45                                              (vector-ref objects i)))
  46                                    out)))
  47                ((vector-ref progv i)
  48                 (let ((obj (vector-ref objects i)))
  49                   (if (variable? obj)
  50                       (lp (1+ i) (if (variable-bound? obj)
  51                                      (cons (variable-ref obj) out)
  52                                      out))
  53                       ;; otherwise it's an unmemoized binding
  54                       (pmatch obj
  55                         (,sym (guard (symbol? sym))
  56                          (let ((v (module-variable (or (program-module prog)
  57                                                        the-root-module)
  58                                                    sym)))
  59                            (lp (1+ i)
  60                                (if (and v (variable-bound? v))
  61                                    (cons (variable-ref v) out)
  62                                    out))))
  63                         ((,mod ,sym ,public?)
  64                          ;; hm, hacky.
  65                          (let ((m (nested-ref the-root-module
  66                                               (append '(%app modules) mod))))
  67                            (let ((v (and m (module-variable
  68                                             (if public? (module-public-interface m) m)
  69                                             sym))))
  70                              (lp (1+ i)
  71                                  (if (and v (variable-bound? v))
  72                                      (cons (variable-ref v) out)
  73                                      out)))))))))
  74               (else (lp (1+ i) out)))))))
  75    (else '())))
  76
  77 (define (hacky-procedure-callees proc)
  78   ;; we could analyze the memoized source or something
  79   '())
  80
  81 (define (procedure-callees proc)
  82   (cond
  83    ((program? proc) (program-callees proc))
  84    ((procedure-source proc) (hacky-procedure-callees proc))
  85    (else '())))
  86
  87 (define *callers-db* #f)
  88
  89 (define *xref-ignored-modules* '((value-history)))
  90 (define (on-module-modified m)
  91   (if (not (member (module-name m) *xref-ignored-modules*))
  92       (set! *callers-db* #f)))
  93
  94 (define (ensure-callers-db)
  95   (let ((visited '())
  96         (db #f))
  97     (define (visit-procedure proc)
  98       (for-each
  99        (lambda (x)
 100          (hashq-set! db x (cons proc (hashq-ref db x '()))))
 101        (procedure-callees proc)))
 102
 103     (define (visit-module mod)
 104       (set! visited (cons mod visited))
 105       (if (not (memq on-module-modified (module-observers mod)))
 106           (module-observe mod on-module-modified))
 107       (module-for-each
 108        (lambda (sym var)
 109           (if (variable-bound? var)
 110               (let ((x (variable-ref var)))
 111                 (cond
 112                  ((procedure? x) (visit-procedure x))
 113                  ((module? x) (if (not (memq x visited))
 114                                   (visit-module x)))))))
 115        mod))
 116
 117     (if (not *callers-db*)
 118         (begin
 119           (set! db (make-hash-table))
 120           (visit-module the-root-module)
 121           (set! *callers-db* db)))))
 122
 123 (define (procedure-callers proc)
 124   (ensure-callers-db)
 125   (hashq-ref *callers-db* proc #f))