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.

diff --git a/module/system/vm/coverage.scm b/module/system/vm/coverage.scm
index 2600974..0f4c73e 100644 (file)
--- 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 52635a9..6869a3a 100644 (file)
--- 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))))))
 
 \f
 (with-test-prefix "instrumented-source-files"