[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-68-gf4
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-68-gf4a23f9 |
|
Date: |
Fri, 24 Sep 2010 12:52:36 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=f4a23f910f8ce4c8e656fe6c050a30ea39ac0fcf
The branch, master has been updated
via f4a23f910f8ce4c8e656fe6c050a30ea39ac0fcf (commit)
via 783eeee65757039880a0fe875c18fa101c554f6e (commit)
from 3b60001f1ed74050461ee485ccc0e477c2ea30ae (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit f4a23f910f8ce4c8e656fe6c050a30ea39ac0fcf
Author: Andy Wingo <address@hidden>
Date: Thu Sep 23 18:09:50 2010 +0200
procedure traps can fire on nested procedures
* module/system/vm/traps.scm (frame-matcher): New helper.
(trap-at-procedure-call, trap-in-procedure, trap-in-dynamic-extent)
(trap-calls-in-dynamic-extent, trap-instructions-in-dynamic-extent)
(trap-instructions-in-procedure, trap-at-procedure-ip-in-range): Add
ability to trap on procedures that are closures.
(trap-at-source-location): Check source-closures first, to catch
source locations that are in nested procedures.
commit 783eeee65757039880a0fe875c18fa101c554f6e
Author: Andy Wingo <address@hidden>
Date: Thu Sep 23 18:00:41 2010 +0200
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.
-----------------------------------------------------------------------
Summary of changes:
module/system/vm/traps.scm | 113 ++++++++++++++++++++++++++++++--------------
module/system/xref.scm | 79 ++++++++++++++++++++----------
2 files changed, 131 insertions(+), 61 deletions(-)
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index fe4ecd9..e31df85 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -106,14 +106,27 @@
(define (new-enabled-trap vm frame enable disable)
((new-disabled-trap vm enable disable) frame))
+(define (frame-matcher proc match-objcode?)
+ (if match-objcode?
+ (lambda (frame)
+ (let ((frame-proc (frame-procedure frame)))
+ (or (eq? frame-proc proc)
+ (and (program? frame-proc)
+ (eq? (program-objcode frame-proc)
+ (program-objcode proc))))))
+ (lambda (frame)
+ (eq? (frame-procedure frame) proc))))
+
;; A basic trap, fires when a procedure is called.
;;
-(define* (trap-at-procedure-call proc handler #:key (vm (the-vm)))
+(define* (trap-at-procedure-call proc handler #:key (vm (the-vm))
+ (closure? #f)
+ (our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check handler procedure?)
(let ()
(define (apply-hook frame)
- (if (eq? (frame-procedure frame) proc)
+ (if (our-frame? frame)
(handler frame)))
(new-enabled-trap
@@ -138,7 +151,9 @@
;; * An abort.
;;
(define* (trap-in-procedure proc enter-handler exit-handler
- #:key current-frame (vm (the-vm)))
+ #:key current-frame (vm (the-vm))
+ (closure? #f)
+ (our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check enter-handler procedure?)
(arg-check exit-handler procedure?)
@@ -160,7 +175,7 @@
(define (apply-hook frame)
(if in-proc?
(exit-proc frame))
- (if (eq? (frame-procedure frame) proc)
+ (if (our-frame? frame)
(enter-proc frame)))
(define (push-cont-hook frame)
@@ -170,19 +185,19 @@
(define (pop-cont-hook frame)
(if in-proc?
(exit-proc frame))
- (if (eq? (frame-procedure (frame-previous frame)) proc)
+ (if (our-frame? (frame-previous frame))
(enter-proc frame)))
(define (abort-hook frame)
(if in-proc?
(exit-proc frame))
- (if (eq? (frame-procedure frame) proc)
+ (if (our-frame? frame)
(enter-proc frame)))
(define (restore-hook frame)
(if in-proc?
(exit-proc frame))
- (if (eq? (frame-procedure frame) proc)
+ (if (our-frame? frame)
(enter-proc frame)))
(new-enabled-trap
@@ -193,7 +208,7 @@
(add-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
(add-hook! (vm-abort-continuation-hook vm) abort-hook)
(add-hook! (vm-restore-continuation-hook vm) restore-hook)
- (if (and frame (eq? (frame-procedure frame) proc))
+ (if (and frame (our-frame? frame))
(enter-proc frame)))
(lambda (frame)
(if in-proc?
@@ -207,13 +222,16 @@
;; Building on trap-in-procedure, we have trap-instructions-in-procedure
;;
(define* (trap-instructions-in-procedure proc next-handler exit-handler
- #:key current-frame (vm (the-vm)))
+ #:key current-frame (vm (the-vm))
+ (closure? #f)
+ (our-frame?
+ (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check next-handler procedure?)
(arg-check exit-handler procedure?)
(let ()
(define (next-hook frame)
- (if (eq? (frame-procedure frame) proc)
+ (if (our-frame? frame)
(next-handler frame)))
(define (enter frame)
@@ -225,7 +243,8 @@
(remove-hook! (vm-next-hook vm) next-hook))
(trap-in-procedure proc enter exit
- #:current-frame current-frame #:vm vm)))
+ #:current-frame current-frame #:vm vm
+ #:our-frame? our-frame?)))
(define (non-negative-integer? x)
(and (number? x) (integer? x) (exact? x) (not (negative? x))))
@@ -247,7 +266,10 @@
;; trap-instructions-in-procedure.
;;
(define* (trap-at-procedure-ip-in-range proc range handler
- #:key current-frame (vm (the-vm)))
+ #:key current-frame (vm (the-vm))
+ (closure? #f)
+ (our-frame?
+ (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check range range?)
(arg-check handler procedure?)
@@ -262,7 +284,8 @@
(set! was-in-range? #f))
(trap-instructions-in-procedure proc next-handler exit-handler
- #:current-frame current-frame #:vm vm)))
+ #:current-frame current-frame #:vm vm
+ #:our-frame? our-frame?)))
;; FIXME: define this in objcode somehow. We are reffing the first
;; uint32 in the objcode, which is the length of the program (without
@@ -315,6 +338,12 @@
(warn "no instructions found for" file ":" line)
'())))
+(define (source-closures-or-procedures file line)
+ (let ((closures (source-closures file line)))
+ (if (pair? closures)
+ (values closures #t)
+ (values (source-procedures file line) #f))))
+
;; Building on trap-on-instructions-in-procedure, we have
;; trap-at-source-location.
;;
@@ -324,21 +353,26 @@
(arg-check line non-negative-integer?)
(arg-check handler procedure?)
(let ((traps #f))
- (new-enabled-trap
- vm current-frame
- (lambda (frame)
- (set! traps (map
- (lambda (proc)
- (let ((range (source->ip-range proc file line)))
- (trap-at-procedure-ip-in-range proc range handler
- #:current-frame
current-frame
- #:vm vm)))
- (source-procedures file line)))
- (if (null? traps)
- (error "No procedures found at ~a:~a." file line)))
- (lambda (frame)
- (for-each (lambda (trap) (trap frame)) traps)
- (set! traps #f)))))
+ (call-with-values
+ (lambda () (source-closures-or-procedures file line))
+ (lambda (procs closures?)
+ (new-enabled-trap
+ vm current-frame
+ (lambda (frame)
+ (set! traps
+ (map
+ (lambda (proc)
+ (let ((range (source->ip-range proc file line)))
+ (trap-at-procedure-ip-in-range proc range handler
+ #:current-frame
current-frame
+ #:vm vm
+ #:closure? closures?)))
+ procs))
+ (if (null? traps)
+ (error "No procedures found at ~a:~a." file line)))
+ (lambda (frame)
+ (for-each (lambda (trap) (trap frame)) traps)
+ (set! traps #f)))))))
@@ -382,7 +416,9 @@
;; based on the above trap-frame-finish?
;;
(define* (trap-in-dynamic-extent proc enter-handler return-handler
abort-handler
- #:key current-frame (vm (the-vm)))
+ #:key current-frame (vm (the-vm))
+ (closure? #f)
+ (our-frame? (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check enter-handler procedure?)
(arg-check return-handler procedure?)
@@ -399,8 +435,7 @@
(abort-handler frame))
(define (apply-hook frame)
- (if (and (not exit-trap)
- (eq? (frame-procedure frame) proc))
+ (if (and (not exit-trap) (our-frame? frame))
(begin
(enter-handler frame)
(set! exit-trap
@@ -421,7 +456,10 @@
;; depth of the call stack relative to the original procedure.
;;
(define* (trap-calls-in-dynamic-extent proc apply-handler return-handler
- #:key current-frame (vm (the-vm)))
+ #:key current-frame (vm (the-vm))
+ (closure? #f)
+ (our-frame?
+ (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check apply-handler procedure?)
(arg-check return-handler procedure?)
@@ -455,12 +493,16 @@
(leave frame))
(trap-in-dynamic-extent proc enter return abort
- #:current-frame current-frame #:vm vm)))
+ #:current-frame current-frame #:vm vm
+ #:our-frame? our-frame?)))
;; Trapping all retired intructions within a dynamic extent.
;;
(define* (trap-instructions-in-dynamic-extent proc next-handler
- #:key current-frame (vm
(the-vm)))
+ #:key current-frame (vm (the-vm))
+ (closure? #f)
+ (our-frame?
+ (frame-matcher proc closure?)))
(arg-check proc procedure?)
(arg-check next-handler procedure?)
(let ()
@@ -480,7 +522,8 @@
(leave frame))
(trap-in-dynamic-extent proc enter return abort
- #:current-frame current-frame #:vm vm)))
+ #:current-frame current-frame #:vm vm
+ #:our-frame? our-frame?)))
;; Traps calls and returns for a given procedure, keeping track of the call
depth.
;;
diff --git a/module/system/xref.scm b/module/system/xref.scm
index 199413e..922d17f 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*)))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-12-68-gf4a23f9,
Andy Wingo <=