mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-30 00:40:20 +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

73
module/system/xref.scm
View file

@ -24,6 +24,7 @@
#:export (*xref-ignored-modules* #:export (*xref-ignored-modules*
procedure-callees procedure-callees
procedure-callers procedure-callers
source-closures
source-procedures)) source-procedures))
;;; ;;;
@ -207,6 +208,8 @@ pair of the form (module-name . variable-name), "
((program? proc) (program-sources proc)) ((program? proc) (program-sources proc))
(else '()))) (else '())))
;; file -> line -> (proc ...)
(define *closure-sources-db* #f)
;; file -> line -> (proc ...) ;; file -> line -> (proc ...)
(define *sources-db* #f) (define *sources-db* #f)
;; module-name -> proc -> sources ;; module-name -> proc -> sources
@ -221,24 +224,24 @@ pair of the form (module-name . variable-name), "
(pair? name)) (pair? name))
(set! *tainted-sources* (cons name *tainted-sources*))))) (set! *tainted-sources* (cons name *tainted-sources*)))))
(define (add-source proc file line) (define (add-source proc file line db)
(let ((file-table (or (hash-ref *sources-db* file) (let ((file-table (or (hash-ref db file)
(let ((table (make-hash-table))) (let ((table (make-hash-table)))
(hash-set! *sources-db* file table) (hash-set! db file table)
table)))) table))))
(hashv-set! file-table (hashv-set! file-table
line line
(cons proc (hashv-ref file-table line '()))))) (cons proc (hashv-ref file-table line '())))))
(define (forget-source proc file line) (define (forget-source proc file line db)
(let ((file-table (hash-ref *sources-db* file))) (let ((file-table (hash-ref db file)))
(if file-table (if file-table
(let ((procs (delq proc (hashv-ref file-table line '())))) (let ((procs (delq proc (hashv-ref file-table line '()))))
(if (pair? procs) (if (pair? procs)
(hashv-set! file-table line procs) (hashv-set! file-table line procs)
(hashv-remove! file-table line)))))) (hashv-remove! file-table line))))))
(define (add-sources proc mod-name) (define (add-sources proc mod-name db)
(let ((sources (procedure-sources proc))) (let ((sources (procedure-sources proc)))
(if (pair? sources) (if (pair? sources)
(begin (begin
@ -253,11 +256,18 @@ pair of the form (module-name . variable-name), "
(for-each (lambda (source) (for-each (lambda (source)
(pmatch source (pmatch source
((,ip ,file ,line . ,col) ((,ip ,file ,line . ,col)
(add-source proc file line)) (add-source proc file line db))
(else (error "unexpected source format" source)))) (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))) (let ((mod-table (hash-ref *module-sources-db* mod-name)))
(if mod-table (if mod-table
(begin (begin
@ -265,15 +275,22 @@ pair of the form (module-name . variable-name), "
(for-each (lambda (source) (for-each (lambda (source)
(pmatch source (pmatch source
((,ip ,file ,line . ,col) ((,ip ,file ,line . ,col)
(forget-source proc file line)) (forget-source proc file line db))
(else (error "unexpected source format" source)))) (else (error "unexpected source format" source))))
(hashq-ref mod-table proc '())) (hashq-ref mod-table proc '()))
;; Forget the 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-sources)
(define (untaint m) (define (untaint m)
(for-each (lambda (proc) (forget-sources proc m)) (for-each (lambda (proc) (forget-sources proc m *sources-db*))
(cond (cond
((hash-ref *module-sources-db* m) ((hash-ref *module-sources-db* m)
=> (lambda (table) => (lambda (table)
@ -294,7 +311,7 @@ pair of the form (module-name . variable-name), "
(if (variable-bound? var) (if (variable-bound? var)
(let ((x (variable-ref var))) (let ((x (variable-ref var)))
(if (procedure? x) (if (procedure? x)
(add-sources x name))))) (add-sources x name *sources-db*)))))
mod))) mod)))
(define visit-submodules (define visit-submodules
@ -311,7 +328,8 @@ pair of the form (module-name . variable-name), "
(visit-submodules sub)))) (visit-submodules sub))))
(module-submodules mod))))) (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)) (set! *sources-db* (make-hash-table 1000))
(visit-submodules (resolve-module '() #f))) (visit-submodules (resolve-module '() #f)))
(mod-name (visit-module (resolve-module mod-name))))) (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) (sort! (hash-map->list cons ranges)
(lambda (x y) (< (cadr x) (cadr y)))))) (lambda (x y) (< (cadr x) (cadr y))))))
(define* (source-procedures file line #:key (canonicalization 'relative)) (define* (lookup-source-procedures canon-file line db)
(ensure-sources-db #f) (let ((file-table (hash-ref db canon-file)))
(let* ((port (with-fluids ((%file-port-name-canonicalization canonicalization)) (let lp ((ranges (if file-table (lines->ranges file-table) '()))
(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 '())) (procs '()))
(cond (cond
((null? ranges) (reverse procs)) ((null? ranges) (reverse procs))
((<= (cadar ranges) line (cddar ranges)) ((<= (cadar ranges) line (cddar ranges))
(lp (cdr ranges) (cons (caar ranges) procs))) (lp (cdr ranges) (cons (caar ranges) procs)))
(else (else
(lp (cdr ranges) procs))))))) (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*)))