diff options
author | Andy Wingo <wingo@pobox.com> | 2010-09-23 18:00:41 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-09-24 13:24:48 +0200 |
commit | 783eeee65757039880a0fe875c18fa101c554f6e (patch) | |
tree | daa35d874e63448fc1c04e40037a3f160a7ff6b1 /module/system/xref.scm | |
parent | 3b60001f1ed74050461ee485ccc0e477c2ea30ae (diff) | |
download | guile-783eeee65757039880a0fe875c18fa101c554f6e.tar.gz |
system xref maintains source mapping for nested procedures too
* 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.
Diffstat (limited to 'module/system/xref.scm')
-rw-r--r-- | module/system/xref.scm | 79 |
1 files changed, 53 insertions, 26 deletions
diff --git a/module/system/xref.scm b/module/system/xref.scm index 199413eb6..922d17fa9 100644 --- a/module/system/xref.scm +++ b/module/system/xref.scm @@ -24,6 +24,7 @@ #:export (*xref-ignored-modules* procedure-callees procedure-callers + source-closures source-procedures)) ;;; @@ -208,6 +209,8 @@ pair of the form (module-name . variable-name), " (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)) @@ -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))))) - -(define (forget-sources proc mod-name) + 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 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*))) |