summaryrefslogtreecommitdiff
path: root/module/system/xref.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/xref.scm')
-rw-r--r--module/system/xref.scm373
1 files changed, 373 insertions, 0 deletions
diff --git a/module/system/xref.scm b/module/system/xref.scm
new file mode 100644
index 000000000..e335f9481
--- /dev/null
+++ b/module/system/xref.scm
@@ -0,0 +1,373 @@
+;;;; Copyright (C) 2009, 2010, 2013, 2018 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 2.1 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+
+(define-module (system xref)
+ #:use-module (system base compile)
+ #:use-module (system vm program)
+ #:use-module (system vm disassembler)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:export (*xref-ignored-modules*
+ procedure-callees
+ procedure-callers
+ source-closures
+ source-procedures))
+
+;;;
+;;; The cross-reference database: who calls whom.
+;;;
+
+(define (nested-procedures prog)
+ (define (cons-uniq x y)
+ (if (memq x y) y (cons x y)))
+ (if (program? prog)
+ (reverse
+ (fold-program-code (lambda (elt out)
+ (match elt
+ (('static-ref dst proc)
+ (if (program? proc)
+ (fold cons-uniq
+ (cons proc out)
+ (nested-procedures prog))
+ out))
+ (_ out)))
+ (list prog)
+ prog))
+ (list prog)))
+
+(define (program-callee-rev-vars prog)
+ (define (cons-uniq x y)
+ (if (memq x y) y (cons x y)))
+ (fold (lambda (prog out)
+ (fold-program-code
+ (lambda (elt out)
+ ;; FIXME: Update for change to top-level variable
+ ;; resolution. Need to build a per-program map of
+ ;; IP->SLOT->CONSTANT to be able to resolve operands to
+ ;; resolve-module and lookup intrinsic calls.
+ (match elt
+ (('toplevel-box dst var mod sym bound?)
+ (let ((var (or var (and mod (module-variable mod sym)))))
+ (if var
+ (cons-uniq var out)
+ out)))
+ (('module-box dst var public? mod-name sym bound?)
+ (let ((var (or var
+ (module-variable (if public?
+ (resolve-interface mod-name)
+ (resolve-module mod-name))
+ sym))))
+ (if var
+ (cons-uniq var out)
+ out)))
+ (_ out)))
+ out
+ prog))
+ '()
+ (nested-procedures prog)))
+
+(define (procedure-callee-rev-vars proc)
+ (cond
+ ((program? proc) (program-callee-rev-vars proc))
+ (else '())))
+
+(define (procedure-callees prog)
+ "Evaluates to a list of the given program callees."
+ (let lp ((in (procedure-callee-rev-vars prog)) (out '()))
+ (cond ((null? in) out)
+ ((variable-bound? (car in))
+ (lp (cdr in) (cons (variable-ref (car in)) out)))
+ (else (lp (cdr in) out)))))
+
+;; var -> ((module-name caller ...) ...)
+(define *callers-db* #f)
+;; module-name -> (callee ...)
+(define *module-callees-db* (make-hash-table))
+;; (module-name ...)
+(define *tainted-modules* '())
+
+(define *xref-ignored-modules* '((value-history)))
+(define (on-module-modified m)
+ (let ((name (module-name m)))
+ (if (and (not (member name *xref-ignored-modules*))
+ (not (member name *tainted-modules*))
+ (pair? name))
+ (set! *tainted-modules* (cons name *tainted-modules*)))))
+
+(define (add-caller callee caller mod-name)
+ (let ((all-callers (hashq-ref *callers-db* callee)))
+ (if (not all-callers)
+ (hashq-set! *callers-db* callee `((,mod-name ,caller)))
+ (let ((callers (assoc mod-name all-callers)))
+ (if callers
+ (if (not (member caller callers))
+ (set-cdr! callers (cons caller (cdr callers))))
+ (hashq-set! *callers-db* callee
+ (cons `(,mod-name ,caller) all-callers)))))))
+
+(define (forget-callers callee mod-name)
+ (hashq-set! *callers-db* callee
+ (assoc-remove! (hashq-ref *callers-db* callee '()) mod-name)))
+
+(define (add-callees callees mod-name)
+ (hash-set! *module-callees-db* mod-name
+ (append callees (hash-ref *module-callees-db* mod-name '()))))
+
+(define (untaint-modules)
+ (define (untaint m)
+ (for-each (lambda (callee) (forget-callers callee m))
+ (hash-ref *module-callees-db* m '()))
+ (ensure-callers-db m))
+ (ensure-callers-db #f)
+ (for-each untaint *tainted-modules*)
+ (set! *tainted-modules* '()))
+
+(define (ensure-callers-db mod-name)
+ (let ((mod (and mod-name (resolve-module mod-name)))
+ (visited #f))
+ (define (visit-variable var mod-name)
+ (if (variable-bound? var)
+ (let ((x (variable-ref var)))
+ (cond
+ ((and visited (hashq-ref visited x)))
+ ((procedure? x)
+ (if visited (hashq-set! visited x #t))
+ (let ((callees (filter variable-bound?
+ (procedure-callee-rev-vars x))))
+ (for-each (lambda (callee)
+ (add-caller callee x mod-name))
+ callees)
+ (add-callees callees mod-name)))))))
+
+ (define (visit-module mod)
+ (if visited (hashq-set! visited mod #t))
+ (if (not (memq on-module-modified (module-observers mod)))
+ (module-observe mod on-module-modified))
+ (let ((name (module-name mod)))
+ (module-for-each (lambda (sym var)
+ (visit-variable var name))
+ mod)))
+
+ (define (visit-submodules mod)
+ (hash-for-each
+ (lambda (name sub)
+ (if (not (and visited (hashq-ref visited sub)))
+ (begin
+ (visit-module sub)
+ (visit-submodules sub))))
+ (module-submodules mod)))
+
+ (cond ((and (not mod-name) (not *callers-db*))
+ (set! *callers-db* (make-hash-table 1000))
+ (set! visited (make-hash-table 1000))
+ (visit-submodules (resolve-module '() #f)))
+ (mod-name (visit-module mod)))))
+
+(define (procedure-callers var)
+ "Returns an association list, keyed by module name, of known callers
+of the given procedure. The latter can specified directly as a
+variable, a symbol (which gets resolved in the current module) or a
+pair of the form (module-name . variable-name), "
+ (let ((v (cond ((variable? var) var)
+ ((symbol? var) (module-variable (current-module) var))
+ (else
+ (match var
+ ((modname . sym)
+ (module-variable (resolve-module modname) sym))
+ (_
+ (error "expected a variable, symbol, or (modname . sym)" var)))))))
+ (untaint-modules)
+ (hashq-ref *callers-db* v '())))
+
+
+
+;;;
+;;; The source database: procedures defined at a given source location.
+;;;
+
+;; FIXME: refactor to share code with the xref database.
+
+;; ((ip file line . col) ...)
+(define (procedure-sources proc)
+ (cond
+ ((program? proc) (program-sources proc))
+ (else '())))
+
+;; file -> line -> (proc ...)
+(define *closure-sources-db* #f)
+;; file -> line -> (proc ...)
+(define *sources-db* #f)
+;; module-name -> proc -> sources
+(define *module-sources-db* (make-hash-table))
+;; (module-name ...)
+(define *tainted-sources* '())
+
+(define (on-source-modified m)
+ (let ((name (module-name m)))
+ (if (and (not (member name *xref-ignored-modules*))
+ (not (member name *tainted-sources*))
+ (pair? name))
+ (set! *tainted-sources* (cons name *tainted-sources*)))))
+
+(define (add-source proc file line db)
+ (let ((file-table (or (hash-ref db file)
+ (let ((table (make-hash-table)))
+ (hash-set! db file table)
+ table))))
+ (hashv-set! file-table
+ line
+ (cons proc (hashv-ref file-table line '())))))
+
+(define (forget-source proc file line db)
+ (let ((file-table (hash-ref db file)))
+ (if file-table
+ (let ((procs (delq proc (hashv-ref file-table line '()))))
+ (if (pair? procs)
+ (hashv-set! file-table line procs)
+ (hashv-remove! file-table line))))))
+
+(define (add-sources proc mod-name db)
+ (let ((sources (procedure-sources proc)))
+ (if (pair? sources)
+ (begin
+ ;; Add proc to *module-sources-db*, for book-keeping.
+ (hashq-set! (or (hash-ref *module-sources-db* mod-name)
+ (let ((table (make-hash-table)))
+ (hash-set! *module-sources-db* mod-name table)
+ table))
+ proc
+ sources)
+ ;; Actually add the source entries.
+ (for-each (lambda (source)
+ (match source
+ ((ip file line . col)
+ (add-source proc file line db))
+ (_ (error "unexpected source format" source))))
+ sources)))
+ ;; Add source entries for nested procedures.
+ (for-each (lambda (obj)
+ (add-sources obj mod-name *closure-sources-db*))
+ (cdr (nested-procedures proc)))))
+
+(define (forget-sources proc mod-name db)
+ (let ((mod-table (hash-ref *module-sources-db* mod-name)))
+ (when mod-table
+ ;; Forget source entries.
+ (for-each (lambda (source)
+ (match source
+ ((ip file line . col)
+ (forget-source proc file line db))
+ (_ (error "unexpected source format" source))))
+ (hashq-ref mod-table proc '()))
+ ;; Forget the proc.
+ (hashq-remove! mod-table proc)
+ ;; Forget source entries for nested procedures.
+ (for-each (lambda (obj)
+ (forget-sources obj mod-name *closure-sources-db*))
+ (cdr (nested-procedures proc))))))
+
+(define (untaint-sources)
+ (define (untaint m)
+ (for-each (lambda (proc) (forget-sources proc m *sources-db*))
+ (cond
+ ((hash-ref *module-sources-db* m)
+ => (lambda (table)
+ (hash-for-each (lambda (proc sources) proc) table)))
+ (else '())))
+ (ensure-sources-db m))
+ (ensure-sources-db #f)
+ (for-each untaint *tainted-sources*)
+ (set! *tainted-sources* '()))
+
+(define (ensure-sources-db mod-name)
+ (define (visit-module mod)
+ (if (not (memq on-source-modified (module-observers mod)))
+ (module-observe mod on-source-modified))
+ (let ((name (module-name mod)))
+ (module-for-each
+ (lambda (sym var)
+ (if (variable-bound? var)
+ (let ((x (variable-ref var)))
+ (if (procedure? x)
+ (add-sources x name *sources-db*)))))
+ mod)))
+
+ (define visit-submodules
+ (let ((visited #f))
+ (lambda (mod)
+ (if (not visited)
+ (set! visited (make-hash-table)))
+ (hash-for-each
+ (lambda (name sub)
+ (if (not (hashq-ref visited sub))
+ (begin
+ (hashq-set! visited sub #t)
+ (visit-module sub)
+ (visit-submodules sub))))
+ (module-submodules mod)))))
+
+ (cond ((and (not mod-name) (not *sources-db*) (not *closure-sources-db*))
+ (set! *closure-sources-db* (make-hash-table 1000))
+ (set! *sources-db* (make-hash-table 1000))
+ (visit-submodules (resolve-module '() #f)))
+ (mod-name (visit-module (resolve-module mod-name)))))
+
+(define (lines->ranges file-table)
+ (let ((ranges (make-hash-table)))
+ (hash-for-each
+ (lambda (line procs)
+ (for-each
+ (lambda (proc)
+ (cond
+ ((hashq-ref ranges proc)
+ => (lambda (pair)
+ (if (< line (car pair))
+ (set-car! pair line))
+ (if (> line (cdr pair))
+ (set-cdr! pair line))))
+ (else
+ (hashq-set! ranges proc (cons line line)))))
+ procs))
+ file-table)
+ (sort! (hash-map->list cons ranges)
+ (lambda (x y) (< (cadr x) (cadr y))))))
+
+(define* (lookup-source-procedures canon-file line db)
+ (let ((file-table (hash-ref db canon-file)))
+ (let lp ((ranges (if file-table (lines->ranges file-table) '()))
+ (procs '()))
+ (cond
+ ((null? ranges) (reverse procs))
+ ((<= (cadar ranges) line (cddar ranges))
+ (lp (cdr ranges) (cons (caar ranges) procs)))
+ (else
+ (lp (cdr ranges) procs))))))
+
+(define* (source-closures file line #:key (canonicalization 'relative))
+ (ensure-sources-db #f)
+ (let* ((port (with-fluids ((%file-port-name-canonicalization canonicalization))
+ (false-if-exception (open-input-file file))))
+ (file (if port (port-filename port) file)))
+ (lookup-source-procedures file line *closure-sources-db*)))
+
+(define* (source-procedures file line #:key (canonicalization 'relative))
+ (ensure-sources-db #f)
+ (let* ((port (with-fluids ((%file-port-name-canonicalization canonicalization))
+ (false-if-exception (open-input-file file))))
+ (file (if port (port-filename port) file)))
+ (lookup-source-procedures file line *sources-db*)))