summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2010-09-24 15:19:49 +0200
committerLudovic Courtès <ludo@gnu.org>2010-09-24 15:39:47 +0200
commit639b2eb7107b26207d13bb8acb4c1d38d7dba3bd (patch)
tree137aee74fd4743902b190fbb3be41c4d40a1663e
parentede3d96bd675246bbe138bacb2fdbbdf2523d247 (diff)
downloadguile-639b2eb7107b26207d13bb8acb4c1d38d7dba3bd.tar.gz
Fix coverage analysis of procedures called from C.
* module/system/vm/coverage.scm (with-code-coverage): Switch current thread to VM, using `set-thread-vm!'. * test-suite/tests/coverage.test ("procedure-execution-count")["called from C"]: New test.
-rw-r--r--module/system/vm/coverage.scm9
-rw-r--r--test-suite/tests/coverage.test21
2 files changed, 26 insertions, 4 deletions
diff --git a/module/system/vm/coverage.scm b/module/system/vm/coverage.scm
index 260097491..0f4c73ec9 100644
--- a/module/system/vm/coverage.scm
+++ b/module/system/vm/coverage.scm
@@ -85,15 +85,18 @@ coverage data. Return code coverage data and the values returned by THUNK."
(loop))))))
(call-with-values (lambda ()
- (let ((level (vm-trace-level vm))
- (hook (vm-next-hook vm)))
+ (let ((level (vm-trace-level vm))
+ (hook (vm-next-hook vm))
+ (prev-vm (thread-vm (current-thread))))
(dynamic-wind
(lambda ()
(set-vm-trace-level! vm (+ level 1))
- (add-hook! hook collect!))
+ (add-hook! hook collect!)
+ (set-thread-vm! (current-thread) vm))
(lambda ()
(vm-apply vm thunk '()))
(lambda ()
+ (set-thread-vm! (current-thread) prev-vm)
(set-vm-trace-level! vm level)
(remove-hook! hook collect!)))))
(lambda args
diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test
index 52635a98a..6869a3a62 100644
--- a/test-suite/tests/coverage.test
+++ b/test-suite/tests/coverage.test
@@ -21,6 +21,7 @@
#:use-module (system vm coverage)
#:use-module (system vm vm)
#:use-module (system base compile)
+ #:use-module (system foreign)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11))
@@ -185,7 +186,25 @@
(lambda () (+ 1 2)))))
(and (coverage-data? data)
(= 3 result)
- (not (procedure-execution-count data proc)))))))
+ (not (procedure-execution-count data proc))))))
+
+ (pass-if "called from C"
+ ;; The `scm_call_N' functions use the VM returned by `the-vm'. This
+ ;; test makes sure that they get to use %TEST-VM.
+ (let ((proc (code "foo.scm" "(lambda (x y) (+ x y))"))
+ (call (pointer->procedure '*
+ (dynamic-func "scm_call_2"
+ (dynamic-link))
+ '(* * *))))
+ (let-values (((data result)
+ (with-code-coverage %test-vm
+ (lambda ()
+ (call (make-pointer (object-address proc))
+ (make-pointer (object-address 1))
+ (make-pointer (object-address 2)))))))
+ (and (coverage-data? data)
+ (= (object-address 3) (pointer-address result))
+ (= (procedure-execution-count data proc) 1))))))
(with-test-prefix "instrumented-source-files"