mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

system xref maintains source mapping for nested procedures too

Browse source 
* module/system/xref.scm (*closure-sources-db*): New global, like
  *sources-db* but for nested procedures. It's a separate map because
  these procs need to be treated differently in trap handlers -- you
  match on the bytecode, not on the program object.
  (add-source, forget-source): Take the db as an argument (the normal db
  or the closures db).
  (add-sources, forget-sources): Record sources for nested procedures to
  in *closures-db*.
  (untaint-sources, ensure-sources-db): Adapt for new closures db.
  (lookup-source-procedures): Factored out.
  (source-closures): New exported procedure, returns closures at the
  given source location.
This commit is contained in:
Andy Wingo 2010-09-23 18:00:41 +02:00
parent 3b60001f1e
commit 783eeee657
1 changed files with 52 additions and 25 deletions
Download patch file Download diff file Expand all files Collapse all files

77
module/system/xref.scm
View file

@ -24,6 +24,7 @@
#:export (*xref-ignored-modules*
procedure-callees
procedure-callers
source-closures
source-procedures))
;;;
@ -207,6 +208,8 @@ pair of the form (module-name . variable-name), "
((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
@ -221,24 +224,24 @@ pair of the form (module-name . variable-name), "
(pair? name))
(set! *tainted-sources* (cons name *tainted-sources*)))))
(define (add-source proc file line)
(let ((file-table (or (hash-ref *sources-db* file)
(define (add-source proc file line db)
(let ((file-table (or (hash-ref db file)
(let ((table (make-hash-table)))
(hash-set! *sources-db* file 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)
(let ((file-table (hash-ref *sources-db* file)))
(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)
(define (add-sources proc mod-name db)
(let ((sources (procedure-sources proc)))
(if (pair? sources)
(begin
@ -253,11 +256,18 @@ pair of the form (module-name . variable-name), "
(for-each (lambda (source)
(pmatch source
((,ip ,file ,line . ,col)
(add-source proc file line))
(add-source proc file line db))
(else (error "unexpected source format" source))))
sources)))))
sources)))
;; Add source entries for nested procedures.
(for-each (lambda (obj)
(if (procedure? obj)
(add-sources obj mod-name *closure-sources-db*)))
(or (and (program? proc)
(and=> (program-objects proc) vector->list))
'()))))
(define (forget-sources proc mod-name)
(define (forget-sources proc mod-name db)
(let ((mod-table (hash-ref *module-sources-db* mod-name)))
(if mod-table
(begin
@ -265,15 +275,22 @@ pair of the form (module-name . variable-name), "
(for-each (lambda (source)
(pmatch source
((,ip ,file ,line . ,col)
(forget-source proc file line))
(forget-source proc file line db))
(else (error "unexpected source format" source))))
(hashq-ref mod-table proc '()))
;; Forget the proc.
(hashq-remove! mod-table proc)))))
(hashq-remove! mod-table proc)
;; Forget source entries for nested procedures.
(for-each (lambda (obj)
(if (procedure? obj)
(forget-sources obj mod-name *closure-sources-db*)))
(or (and (program? proc)
(and=> (program-objects proc) vector->list))
'()))))))
(define (untaint-sources)
(define (untaint m)
(for-each (lambda (proc) (forget-sources proc m))
(for-each (lambda (proc) (forget-sources proc m *sources-db*))
(cond
((hash-ref *module-sources-db* m)
=> (lambda (table)
@ -294,7 +311,7 @@ pair of the form (module-name . variable-name), "
(if (variable-bound? var)
(let ((x (variable-ref var)))
(if (procedure? x)
(add-sources x name)))))
(add-sources x name *sources-db*)))))
mod)))
(define visit-submodules
@ -311,7 +328,8 @@ pair of the form (module-name . variable-name), "
(visit-submodules sub))))
(module-submodules mod)))))
(cond ((and (not mod-name) (not *sources-db*))
(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)))))
@ -336,18 +354,27 @@ pair of the form (module-name . variable-name), "
(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))
(file-table (hash-ref *sources-db* file)))
(if file-table
(let lp ((ranges (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)))))))
(file (if port (port-filename port) file)))
(lookup-source-procedures file line *sources-db*)))