1.0.5.32: partial fix for DISASSEMBLE bug reported by Peter Graves

[sbcl.git] / src / compiler / ir1-translators.lisp

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 72bcd18..a6cfd96 100644 (file)
--- 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)))))
 \f
 ;;;; BLOCK and TAGBODY
 
@@ -126,7 +152,7 @@ extent of the block."
     (link-node-to-previous-ctran exit value-ctran)
     (let ((home-lambda (ctran-home-lambda-or-null start)))
       (when home-lambda
-        (push entry (lambda-calls-or-closes home-lambda))))
+        (sset-adjoin entry (lambda-calls-or-closes home-lambda))))
     (use-continuation exit exit-ctran (third found))))
 
 ;;; Return a list of the segments of a TAGBODY. Each segment looks
@@ -221,7 +247,7 @@ constrained to be used only within the dynamic extent of the TAGBODY."
     (link-node-to-previous-ctran exit start)
     (let ((home-lambda (ctran-home-lambda-or-null start)))
       (when home-lambda
-        (push entry (lambda-calls-or-closes home-lambda))))
+        (sset-adjoin entry (lambda-calls-or-closes home-lambda))))
     (use-ctran exit (second found))))
 \f
 ;;;; translators for compiler-magic special forms
@@ -869,7 +895,7 @@ other."
              (when (lambda-var-p leaf)
                (let ((home-lambda (ctran-home-lambda-or-null start)))
                  (when home-lambda
-                   (pushnew leaf (lambda-calls-or-closes home-lambda))))
+                   (sset-adjoin leaf (lambda-calls-or-closes home-lambda))))
                (when (lambda-var-ignorep leaf)
                  ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
                  ;; requires that this be a STYLE-WARNING, not a full warning.