X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=48bc62a3e97c4fa4569e90c0ff25826be3c344d0;hb=411c3cae7ab69dc023912d87d891e75d9aa083b4;hp=a1437e1c0f492357aae33f0e8d493b3a8e81f2a2;hpb=1840d888d2ef13fe0ea5aaa06f1fef3300da682b;p=sbcl.git

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index a1437e1..48bc62a 100644
--- a/src/compiler/ir1-translators.lisp
+++ b/src/compiler/ir1-translators.lisp
@@ -34,6 +34,8 @@ otherwise evaluate ELSE and return its values. ELSE defaults to NIL."
          (then-block (ctran-starts-block then-ctran))
          (else-ctran (make-ctran))
          (else-block (ctran-starts-block else-ctran))
+         (maybe-instrument *instrument-if-for-code-coverage*)
+         (*instrument-if-for-code-coverage* t)
          (node (make-if :test pred-lvar
                         :consequent then-block
                         :alternative else-block)))
@@ -50,8 +52,32 @@ otherwise evaluate ELSE and return its values. ELSE defaults to NIL."
       (link-blocks start-block then-block)
       (link-blocks start-block else-block))
 
-    (ir1-convert then-ctran next result then)
-    (ir1-convert else-ctran next result else)))
+    (let ((path (best-sub-source-path test)))
+      (ir1-convert (if (and path maybe-instrument)
+                       (let ((*current-path* path))
+                         (instrument-coverage then-ctran :then test))
+                       then-ctran)
+                   next result then)
+      (ir1-convert (if (and path maybe-instrument)
+                       (let ((*current-path* path))
+                         (instrument-coverage else-ctran :else test))
+                       else-ctran)
+                   next result else))))
+
+;;; To get even remotely sensible results for branch coverage
+;;; tracking, we need good source paths. If the macroexpansions
+;;; interfere enough the TEST of the conditional doesn't actually have
+;;; an original source location (e.g. (UNLESS FOO ...) -> (IF (NOT
+;;; FOO) ...). Look through the form, and try to find some subform
+;;; that has one.
+(defun best-sub-source-path (form)
+  (if (policy *lexenv* (= store-coverage-data 0))
+      nil
+      (labels ((sub (form)
+                 (or (gethash form *source-paths*)
+                     (and (consp form)
+                          (some #'sub form)))))
+        (or (sub form)))))
 
 ;;;; BLOCK and TAGBODY
 
@@ -1025,6 +1051,7 @@ due to normal completion or a non-local exit such as THROW)."
                     (%unwind-protect (%escape-fun ,exit-tag)
                                      (%cleanup-fun ,cleanup-fun))
                   (return-from ,drop-thru-tag ,protected)))
+            (declare (optimize (insert-debug-catch 0)))
             (,cleanup-fun)
             (%continue-unwind ,next ,start ,count)))))))