[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-53-g25
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-12-53-g25361a8 |
|
Date: |
Thu, 23 Sep 2010 12:03:58 +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=25361a80fe3c78456e22a5fb0139d7207d472050
The branch, master has been updated
via 25361a80fe3c78456e22a5fb0139d7207d472050 (commit)
via b0e556d4d0d9fc6b33952f965697e370d3d4fbef (commit)
via 8dde88e0d64ae39e3f829031cd6cc137f13a1729 (commit)
via 2e30f3989caab60f11fd3b0e773c15499b231fd8 (commit)
via 1bc1800ffa194d9338295199e3a7ccd5e7b45d90 (commit)
from 5a6c9e7593c664b692c35191798f4e0881cf35de (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 25361a80fe3c78456e22a5fb0139d7207d472050
Author: Andy Wingo <address@hidden>
Date: Thu Sep 23 13:47:03 2010 +0200
add repl ,tracepoint command
* module/system/vm/trace.scm (print-return, print-application)
(frame-return-values): Factored out of other things.
(trace-calls-to-procedure): New proc, installs a trap tracing only
calls to the given proc.
(trace-calls-in-procedure): Refactor a bit.
* module/system/vm/trap-state.scm (add-trace-at-procedure-call!): New
proc.
* module/system/repl/command.scm (tracepoint): New command, installs a
tracepoint on a procedure.
commit b0e556d4d0d9fc6b33952f965697e370d3d4fbef
Author: Andy Wingo <address@hidden>
Date: Thu Sep 23 13:45:15 2010 +0200
avoid traps in repl except when evaluating the expression
* module/system/vm/trap-state.scm (with-default-trap-handler): Don't
enable traps if we are setting a handler of #f.
* module/system/repl/error-handling.scm (call-with-error-handling): Add
#:trap-handler arg.
* module/system/repl/repl.scm (run-repl): Only have traps enabled while
running the thunk. Otherwise we trace on procedures called as part of
the repl.
commit 8dde88e0d64ae39e3f829031cd6cc137f13a1729
Author: Andy Wingo <address@hidden>
Date: Thu Sep 23 13:42:12 2010 +0200
add trap-calls-to-procedure
* module/system/vm/traps.scm (trap-frame-finish): Use frame-address
instead of frame-dynamic-link.
(trap-calls-to-procedure): New proc, traps on procedure calls and
their corresponding returns.
commit 2e30f3989caab60f11fd3b0e773c15499b231fd8
Author: Andy Wingo <address@hidden>
Date: Thu Sep 23 13:19:49 2010 +0200
add scm_frame_address / frame-address
* libguile/frames.h:
* libguile/frames.c (scm_frame_address): New accessor, returns a frame's
fp.
commit 1bc1800ffa194d9338295199e3a7ccd5e7b45d90
Author: Andy Wingo <address@hidden>
Date: Thu Sep 23 11:56:21 2010 +0200
tracing in terms of traps
* module/system/vm/traps.scm (trap-frame-finish)
(trap-in-dynamic-extent, trap-calls-in-dynamic-extent)
(trap-instructions-in-dynamic-extent): New traps, for implementing
tracing, and the `finish' command.
* module/system/vm/trace.scm (trace-calls-in-procedure)
(trace-instructions-in-procedure): New tracing traps.
(vm-trace): Reimplement in terms of the new traps.
* module/system/vm/trap-state.scm (add-trap!): New helper; not used in
this commit, though.
-----------------------------------------------------------------------
Summary of changes:
libguile/frames.c | 10 ++
libguile/frames.h | 1 +
module/system/repl/command.scm | 14 ++-
module/system/repl/error-handling.scm | 38 ++++--
module/system/repl/repl.scm | 3 +-
module/system/vm/trace.scm | 163 ++++++++++++-------------
module/system/vm/trap-state.scm | 27 ++++-
module/system/vm/traps.scm | 211 ++++++++++++++++++++++++++++++++-
8 files changed, 362 insertions(+), 105 deletions(-)
diff --git a/libguile/frames.c b/libguile/frames.c
index f8eed86..2064ef3 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -203,6 +203,16 @@ SCM_DEFINE (scm_frame_local_set_x, "frame-local-set!", 3,
0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_frame_address, "frame-address", 1, 0, 0,
+ (SCM frame),
+ "Return the frame pointer for @var{frame}.")
+#define FUNC_NAME s_scm_frame_address
+{
+ SCM_VALIDATE_VM_FRAME (1, frame);
+ return scm_from_ulong ((unsigned long) SCM_VM_FRAME_FP (frame));
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_frame_instruction_pointer, "frame-instruction-pointer", 1, 0,
0,
(SCM frame),
"")
diff --git a/libguile/frames.h b/libguile/frames.h
index 33432eb..89d0f33 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -114,6 +114,7 @@ SCM_API SCM scm_frame_source (SCM frame);
SCM_API SCM scm_frame_num_locals (SCM frame);
SCM_API SCM scm_frame_local_ref (SCM frame, SCM index);
SCM_API SCM scm_frame_local_set_x (SCM frame, SCM index, SCM val);
+SCM_API SCM scm_frame_address (SCM frame);
SCM_API SCM scm_frame_instruction_pointer (SCM frame);
SCM_API SCM scm_frame_return_address (SCM frame);
SCM_API SCM scm_frame_mv_return_address (SCM frame);
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index cb467ce..4973b91 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -57,7 +57,7 @@
(profile (time t) (profile pr) (trace tr))
(debug (backtrace bt) (up) (down) (frame fr)
(procedure proc) (locals) (error-message error)
- (break br)
+ (break br bp) (tracepoint tp)
(traps) (delete del) (disable) (enable))
(inspect (inspect i) (pretty-print pp))
(system (gc) (statistics stat) (option o)
@@ -580,6 +580,18 @@ Starts a recursive prompt when PROCEDURE is called."
(let ((idx (add-trap-at-procedure-call! proc)))
(format #t "Added breakpoint ~a at ~a.~%" idx proc)))))
+(define-meta-command (tracepoint repl (form))
+ "tracepoint PROCEDURE
+Add a tracepoint to PROCEDURE.
+
+A tracepoint will print out the procedure and its arguments, when it is
+called, and its return value(s) when it returns."
+ (let ((proc (repl-eval repl (repl-parse repl form))))
+ (if (not (procedure? proc))
+ (error "Not a procedure: ~a" proc)
+ (let ((idx (add-trace-at-procedure-call! proc)))
+ (format #t "Added tracepoint ~a at ~a.~%" idx proc)))))
+
(define-meta-command (traps repl)
"traps
Show the set of currently attached traps.
diff --git a/module/system/repl/error-handling.scm
b/module/system/repl/error-handling.scm
index dc2367b..72193a8 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -45,7 +45,7 @@
(define* (call-with-error-handling thunk #:key
(on-error 'debug) (post-error 'catch)
- (pass-keys '(quit)))
+ (pass-keys '(quit)) (trap-handler 'debug))
(let ((in (current-input-port))
(out (current-output-port))
(err (current-error-port)))
@@ -81,9 +81,19 @@
(format #t "Type `,bt' for a backtrace or `,q' to continue.\n")
((@ (system repl repl) start-repl) #:debug debug)))))
+ (define (null-trap-handler frame trap-idx trap-name)
+ #t)
+
+ (define le-trap-handler
+ (case trap-handler
+ ((debug) debug-trap-handler)
+ ((pass) null-trap-handler)
+ ((disabled) #f)
+ (else (error "Unknown trap-handler strategy" trap-handler))))
+
(catch #t
(lambda ()
- (with-default-trap-handler debug-trap-handler
+ (with-default-trap-handler le-trap-handler
(lambda () (%start-stack #t thunk))))
(case post-error
@@ -93,16 +103,16 @@
(apply throw key args)
(begin
(pmatch args
- ((,subr ,msg ,args . ,rest)
- (with-saved-ports
- (lambda ()
- (run-hook before-error-hook)
- (display-error #f err subr msg args rest)
- (run-hook after-error-hook)
- (force-output err))))
- (else
- (format err "\nERROR: uncaught throw to `~a', args: ~a\n"
- key args)))
+ ((,subr ,msg ,args . ,rest)
+ (with-saved-ports
+ (lambda ()
+ (run-hook before-error-hook)
+ (display-error #f err subr msg args rest)
+ (run-hook after-error-hook)
+ (force-output err))))
+ (else
+ (format err "\nERROR: uncaught throw to `~a', args: ~a\n"
+ key args)))
(if #f #f)))))
((catch)
(lambda (key . args)
@@ -110,7 +120,7 @@
(apply throw key args))))
(else
(if (procedure? post-error)
- post-error ; a handler proc
+ post-error ; a handler proc
(error "Unknown post-error strategy" post-error))))
(case on-error
@@ -143,7 +153,7 @@
#t))
(else
(if (procedure? on-error)
- on-error ; pre-unwind handler
+ on-error ; pre-unwind handler
(error "Unknown on-error strategy" on-error)))))))
(define-syntax with-error-handling
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm
index 8711e1d..efe29ac 100644
--- a/module/system/repl/repl.scm
+++ b/module/system/repl/repl.scm
@@ -163,7 +163,8 @@
(repl-print repl v))
l))))
(lambda (k . args)
- (abort args)))))))
+ (abort args))))
+ #:trap-handler 'disabled)))
(next-char #f) ;; consume trailing whitespace
(prompt-loop))))
(lambda (k status)
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index 17f6e83..097e3e8 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -24,102 +24,95 @@
#:use-module (system vm frame)
#:use-module (system vm program)
#:use-module (system vm objcode)
+ #:use-module (system vm traps)
#:use-module (rnrs bytevectors)
#:use-module (system vm instruction)
#:use-module (ice-9 format)
- #:export (vm-trace))
+ #:export (trace-calls-in-procedure
+ trace-calls-to-procedure
+ trace-instructions-in-procedure
+ vm-trace))
;; FIXME: this constant needs to go in system vm objcode
(define *objcode-header-len* 8)
-(define* (vm-trace vm thunk #:key (calls? #t) (instructions? #f) (width 80))
- (define *call-depth* #f)
- (define *saved-call-depth* #f)
-
- (define (print-application frame depth)
- (format (current-error-port) "~a~v:@y\n"
- (make-string depth #\|)
- (max (- width depth) 1)
- (frame-call-representation frame)))
-
- (define (print-return frame depth)
- (let* ((len (frame-num-locals frame))
- (nvalues (frame-local-ref frame (1- len))))
- (cond
- ((= nvalues 1)
- (format (current-error-port) "~a~v:@y\n"
- (make-string depth #\|)
- width (frame-local-ref frame (- len 2))))
- (else
- ;; this should work, but there appears to be a bug
- ;; "~a~d values:~:{ ~v:@y~}\n"
- (format (current-error-port) "~a~d values:~{ ~a~}\n"
- (make-string depth #\|)
- nvalues
- (let lp ((vals '()) (i 0))
- (if (= i nvalues)
- vals
- (lp (cons (format #f "~v:@y" width
- (frame-local-ref frame (- len 2 i)))
- vals)
- (1+ i)))))))))
-
- (define (trace-push frame)
- (if *call-depth*
- (set! *call-depth* (1+ *call-depth*))))
-
- (define (trace-pop frame)
- (if *call-depth*
- (begin
- (print-return frame *call-depth*)
- (set! *call-depth*
- (if (zero? *call-depth*)
- #f
- (1- *call-depth*))))))
+(define (frame-return-values frame)
+ (let* ((len (frame-num-locals frame))
+ (nvalues (frame-local-ref frame (1- len))))
+ (map (lambda (i)
+ (frame-local-ref frame (+ (- len nvalues) i)))
+ (iota nvalues))))
- (define (trace-apply frame)
- (cond
- (*call-depth*
- (print-application frame *call-depth*))
- ((eq? (frame-procedure frame) thunk)
- (set! *call-depth* 0))))
+(define (print-application frame depth width)
+ (format (current-error-port) "~a~v:@y\n"
+ (make-string depth #\|)
+ (max (- width depth) 1)
+ (frame-call-representation frame)))
- (define (trace-next frame)
- (if *call-depth*
- (let* ((ip (frame-instruction-pointer frame))
- (objcode (program-objcode (frame-procedure frame)))
- (opcode (bytevector-u8-ref (objcode->bytecode objcode)
- (+ ip *objcode-header-len*))))
- (format #t "~8d: ~a\n" ip (opcode->instruction opcode)))))
+(define (print-return frame depth width)
+ (let* ((len (frame-num-locals frame))
+ (nvalues (frame-local-ref frame (1- len))))
+ (cond
+ ((= nvalues 1)
+ (format (current-error-port) "~a~v:@y\n"
+ (make-string depth #\|)
+ width (frame-local-ref frame (- len 2))))
+ (else
+ ;; this should work, but there appears to be a bug
+ ;; "~a~d values:~:{ ~v:@y~}\n"
+ (format (current-error-port) "~a~d values:~{ ~a~}\n"
+ (make-string depth #\|)
+ nvalues
+ (map (lambda (val)
+ (format #f "~v:@y" width val))
+ (frame-return-values frame)))))))
- (define (vm-trace-on!)
- (if calls?
- (begin
- (add-hook! (vm-push-continuation-hook vm) trace-push)
- (add-hook! (vm-pop-continuation-hook vm) trace-pop)
- (add-hook! (vm-apply-hook vm) trace-apply)))
+(define* (trace-calls-to-procedure proc #:key (width 80) (vm (the-vm)))
+ (define (apply-handler frame depth)
+ (print-application frame depth width))
+ (define (return-handler frame depth)
+ (print-return frame depth width))
+ (trap-calls-to-procedure proc apply-handler return-handler
+ #:vm vm))
- (if instructions?
- (add-hook! (vm-next-hook vm) trace-next))
+(define* (trace-calls-in-procedure proc #:key (width 80) (vm (the-vm)))
+ (define (apply-handler frame depth)
+ (print-application frame depth width))
+ (define (return-handler frame depth)
+ (print-return frame depth width))
+ (trap-calls-in-dynamic-extent proc apply-handler return-handler
+ #:vm vm))
- (set-vm-trace-level! vm (1+ (vm-trace-level vm)))
- (set! *call-depth* *saved-call-depth*))
+(define* (trace-instructions-in-procedure proc #:key (width 80) (vm (the-vm)))
+ (define (trace-next frame)
+ (let* ((ip (frame-instruction-pointer frame))
+ (objcode (program-objcode (frame-procedure frame)))
+ (opcode (bytevector-u8-ref (objcode->bytecode objcode)
+ (+ ip *objcode-header-len*))))
+ (format #t "~8d: ~a\n" ip (opcode->instruction opcode))))
- (define (vm-trace-off!)
- (set! *saved-call-depth* *call-depth*)
- (set! *call-depth* #f)
- (set-vm-trace-level! vm (1- (vm-trace-level vm)))
+ (trap-instructions-in-dynamic-extent proc trace-next
+ #:vm vm))
- (if calls?
- (begin
- (remove-hook! (vm-push-continuation-hook vm) trace-push)
- (remove-hook! (vm-pop-continuation-hook vm) trace-pop)
- (remove-hook! (vm-apply-hook vm) trace-apply)))
-
- (if instructions?
- (remove-hook! (vm-next-hook vm) trace-next)))
-
- (dynamic-wind
- vm-trace-on!
- (lambda () (vm-apply vm thunk '()))
- vm-trace-off!))
+;; Note that because this procedure manipulates the VM trace level
+;; directly, it doesn't compose well with traps at the REPL.
+;;
+(define* (vm-trace vm thunk #:key (calls? #t) (instructions? #f) (width 80))
+ (let ((call-trap #f)
+ (inst-trap #f))
+ (dynamic-wind
+ (lambda ()
+ (if calls?
+ (set! call-trap
+ (trace-calls-in-procedure thunk #:vm vm #:width width)))
+ (if instructions?
+ (set! inst-trap
+ (trace-instructions-in-procedure thunk #:vm vm #:width
width)))
+ (set-vm-trace-level! vm (1+ (vm-trace-level vm))))
+ thunk
+ (lambda ()
+ (set-vm-trace-level! vm (1- (vm-trace-level vm)))
+ (if call-trap (call-trap))
+ (if inst-trap (inst-trap))
+ (set! call-trap #f)
+ (set! inst-trap #f)))))
diff --git a/module/system/vm/trap-state.scm b/module/system/vm/trap-state.scm
index 3264500..fea46d2 100644
--- a/module/system/vm/trap-state.scm
+++ b/module/system/vm/trap-state.scm
@@ -25,6 +25,7 @@
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (system vm vm)
#:use-module (system vm traps)
+ #:use-module (system vm trace)
#:export (list-traps
trap-enabled?
enable-trap!
@@ -34,7 +35,8 @@
with-default-trap-handler
install-trap-handler!
- add-trap-at-procedure-call!))
+ add-trap-at-procedure-call!
+ add-trace-at-procedure-call!))
(define %default-trap-handler (make-fluid))
@@ -145,10 +147,13 @@
(with-fluids ((%default-trap-handler handler))
(dynamic-wind
(lambda ()
- (set-vm-trace-level! (the-vm) (trap-state->trace-level trap-state)))
+ ;; Don't enable hooks if the handler is #f.
+ (if handler
+ (set-vm-trace-level! (the-vm) (trap-state->trace-level
trap-state))))
thunk
(lambda ()
- (set-vm-trace-level! (the-vm) 0)))))
+ (if handler
+ (set-vm-trace-level! (the-vm) 0))))))
(define* (list-traps #:optional (trap-state (the-trap-state)))
(map (lambda (wrapper)
@@ -188,3 +193,19 @@
(make-trap-wrapper
idx #t trap
(format #f "breakpoint at ~a" proc)))))
+
+(define* (add-trace-at-procedure-call! proc
+ #:optional (trap-state
(the-trap-state)))
+ (let* ((idx (next-index! trap-state))
+ (trap (trace-calls-to-procedure proc)))
+ (add-trap-wrapper!
+ trap-state
+ (make-trap-wrapper
+ idx #t trap
+ (format #f "tracepoint at ~a" proc)))))
+
+(define* (add-trap! trap name #:optional (trap-state (the-trap-state)))
+ (let* ((idx (next-index! trap-state)))
+ (add-trap-wrapper!
+ trap-state
+ (make-trap-wrapper idx #t trap name))))
diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm
index e568ad8..fe4ecd9 100644
--- a/module/system/vm/traps.scm
+++ b/module/system/vm/traps.scm
@@ -66,7 +66,12 @@
trap-in-procedure
trap-instructions-in-procedure
trap-at-procedure-ip-in-range
- trap-at-source-location))
+ trap-at-source-location
+ trap-frame-finish
+ trap-in-dynamic-extent
+ trap-calls-in-dynamic-extent
+ trap-instructions-in-dynamic-extent
+ trap-calls-to-procedure))
(define-syntax arg-check
(syntax-rules ()
@@ -334,3 +339,207 @@
(lambda (frame)
(for-each (lambda (trap) (trap frame)) traps)
(set! traps #f)))))
+
+
+
+;; On a different tack, now we're going to build up a set of traps that
+;; do useful things during the dynamic extent of a procedure's
+;; application. First, a trap for when a frame returns.
+;;
+(define* (trap-frame-finish frame return-handler abort-handler
+ #:key (vm (the-vm)))
+ (arg-check frame frame?)
+ (arg-check return-handler procedure?)
+ (arg-check abort-handler procedure?)
+ (let ((fp (frame-address frame)))
+ (define (pop-cont-hook frame)
+ (if (and fp (eq? (frame-address frame) fp))
+ (begin
+ (set! fp #f)
+ (return-handler frame))))
+
+ (define (abort-hook frame)
+ (if (and fp (< (frame-address frame) fp))
+ (begin
+ (set! fp #f)
+ (abort-handler frame))))
+
+ (new-enabled-trap
+ vm frame
+ (lambda (frame)
+ (if (not fp)
+ (error "return-or-abort traps may only be enabled once"))
+ (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) abort-hook))
+ (lambda (frame)
+ (set! fp #f)
+ (remove-hook! (vm-pop-continuation-hook vm) pop-cont-hook)
+ (remove-hook! (vm-abort-continuation-hook vm) abort-hook)
+ (remove-hook! (vm-restore-continuation-hook vm) abort-hook)))))
+
+;; A more traditional dynamic-wind trap. Perhaps this should not be
+;; 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)))
+ (arg-check proc procedure?)
+ (arg-check enter-handler procedure?)
+ (arg-check return-handler procedure?)
+ (arg-check abort-handler procedure?)
+ (let ((exit-trap #f))
+ (define (return-hook frame)
+ (exit-trap frame) ; disable the return/abort trap.
+ (set! exit-trap #f)
+ (return-handler frame))
+
+ (define (abort-hook frame)
+ (exit-trap frame) ; disable the return/abort trap.
+ (set! exit-trap #f)
+ (abort-handler frame))
+
+ (define (apply-hook frame)
+ (if (and (not exit-trap)
+ (eq? (frame-procedure frame) proc))
+ (begin
+ (enter-handler frame)
+ (set! exit-trap
+ (trap-frame-finish frame return-hook abort-hook
+ #:vm vm)))))
+
+ (new-enabled-trap
+ vm current-frame
+ (lambda (frame)
+ (add-hook! (vm-apply-hook vm) apply-hook))
+ (lambda (frame)
+ (if exit-trap
+ (abort-hook frame))
+ (set! exit-trap #f)
+ (remove-hook! (vm-apply-hook vm) apply-hook)))))
+
+;; Trapping all procedure calls within a dynamic extent, recording the
+;; 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)))
+ (arg-check proc procedure?)
+ (arg-check apply-handler procedure?)
+ (arg-check return-handler procedure?)
+ (let ((*call-depth* 0))
+ (define (trace-push frame)
+ (set! *call-depth* (1+ *call-depth*)))
+
+ (define (trace-pop frame)
+ (return-handler frame *call-depth*)
+ (set! *call-depth* (1- *call-depth*)))
+
+ (define (trace-apply frame)
+ (apply-handler frame *call-depth*))
+
+ ;; FIXME: recalc depth on abort
+
+ (define (enter frame)
+ (add-hook! (vm-push-continuation-hook vm) trace-push)
+ (add-hook! (vm-pop-continuation-hook vm) trace-pop)
+ (add-hook! (vm-apply-hook vm) trace-apply))
+
+ (define (leave frame)
+ (remove-hook! (vm-push-continuation-hook vm) trace-push)
+ (remove-hook! (vm-pop-continuation-hook vm) trace-pop)
+ (remove-hook! (vm-apply-hook vm) trace-apply))
+
+ (define (return frame)
+ (leave frame))
+
+ (define (abort frame)
+ (leave frame))
+
+ (trap-in-dynamic-extent proc enter return abort
+ #:current-frame current-frame #:vm vm)))
+
+;; Trapping all retired intructions within a dynamic extent.
+;;
+(define* (trap-instructions-in-dynamic-extent proc next-handler
+ #:key current-frame (vm
(the-vm)))
+ (arg-check proc procedure?)
+ (arg-check next-handler procedure?)
+ (let ()
+ (define (trace-next frame)
+ (next-handler frame))
+
+ (define (enter frame)
+ (add-hook! (vm-next-hook vm) trace-next))
+
+ (define (leave frame)
+ (remove-hook! (vm-next-hook vm) trace-next))
+
+ (define (return frame)
+ (leave frame))
+
+ (define (abort frame)
+ (leave frame))
+
+ (trap-in-dynamic-extent proc enter return abort
+ #:current-frame current-frame #:vm vm)))
+
+;; Traps calls and returns for a given procedure, keeping track of the call
depth.
+;;
+(define* (trap-calls-to-procedure proc apply-handler return-handler
+ #:key (width 80) (vm (the-vm)))
+ (arg-check proc procedure?)
+ (arg-check apply-handler procedure?)
+ (arg-check return-handler procedure?)
+ (let ((pending-finish-traps '())
+ (last-fp #f))
+ (define (apply-hook frame)
+ (let ((depth (length pending-finish-traps)))
+
+ (apply-handler frame depth)
+
+ (if (not (eq? (frame-address frame) last-fp))
+ (let ((finish-trap #f))
+ (define (frame-finished frame)
+ (finish-trap frame) ;; disables the trap.
+ (set! pending-finish-traps
+ (delq finish-trap pending-finish-traps))
+ (set! finish-trap #f))
+
+ (define (return-hook frame)
+ (frame-finished frame)
+ (return-handler frame depth))
+
+ ;; FIXME: abort handler?
+ (define (abort-hook frame)
+ (frame-finished frame))
+
+ (set! finish-trap
+ (trap-frame-finish frame return-hook abort-hook #:vm vm))
+ (set! pending-finish-traps
+ (cons finish-trap pending-finish-traps))))))
+
+ ;; The basic idea is that we install one trap that fires for calls,
+ ;; but that each call installs its own finish trap. Those finish
+ ;; traps remove themselves as their frames finish or abort.
+ ;;
+ ;; However since to the outside world we present the interface of
+ ;; just being one trap, disabling this calls-to-procedure trap
+ ;; should take care of disabling all of the pending finish traps. We
+ ;; keep track of pending traps through the pending-finish-traps
+ ;; list.
+ ;;
+ ;; So since we know that the trap-at-procedure will be enabled, and
+ ;; thus returning a disable closure, we make sure to wrap that
+ ;; closure in something that will disable pending finish traps.
+ (define (with-pending-finish-disablers trap)
+ (define (with-pending-finish-enablers trap)
+ (lambda* (#:optional frame)
+ (with-pending-finish-disablers (trap frame))))
+
+ (lambda* (#:optional frame)
+ (for-each (lambda (disable) (disable frame))
+ pending-finish-traps)
+ (set! pending-finish-traps '())
+ (with-pending-finish-enablers (trap frame))))
+
+ (with-pending-finish-disablers
+ (trap-at-procedure-call proc apply-hook #:vm vm))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-12-53-g25361a8,
Andy Wingo <=