X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=d68a632c7266364207bc21f5050a9d28b5ad3fc6;hb=6bbc22725d3bf663726ed9adca544e39316364a6;hp=72bcd1852fb4bc9dffe6ce7ad8c73cb6b7d7013e;hpb=37b5fc474cf0b4d739c12fc0356667a16006d217;p=sbcl.git

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index 72bcd18..d68a632 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 (get-source-path form)
+                     (and (consp form)
+                          (some #'sub form)))))
+        (or (sub form)))))
 
 ;;;; 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))))
 
 ;;;; translators for compiler-magic special forms
@@ -449,10 +475,11 @@ Return VALUE without evaluating it."
 (defun name-lambdalike (thing)
   (ecase (car thing)
     ((named-lambda)
-     (second thing))
+     (or (second thing)
+         `(lambda ,(third thing))))
     ((lambda instance-lambda)
      `(lambda ,(second thing)))
-    ((lambda-with-lexenv)'
+    ((lambda-with-lexenv)
      `(lambda ,(fifth thing)))))
 
 (defun fun-name-leaf (thing)
@@ -549,7 +576,7 @@ be a lambda expression."
 ;;; directly to %FUNCALL, instead of waiting around for type
 ;;; inference.
 (define-source-transform funcall (function &rest args)
-  (if (and (consp function) (eq (car function) 'function))
+  (if (and (consp function) (member (car function) '(function lambda)))
       `(%funcall ,function ,@args)
       (let ((name (constant-global-fun-name function)))
         (if name
@@ -559,6 +586,11 @@ be a lambda expression."
 (deftransform %coerce-callable-to-fun ((thing) (function) *)
   "optimize away possible call to FDEFINITION at runtime"
   'thing)
+
+(define-source-transform %coerce-callable-to-fun (thing)
+  (if (and (consp thing) (member (car thing) '(function lambda)))
+      thing
+      (values nil t)))
 
 ;;;; LET and LET*
 ;;;;
@@ -674,7 +706,7 @@ form to reference any of the previous VARS."
   #!+sb-doc
   "LOCALLY declaration* form*
 
-Sequentially evaluate the FORMS in a lexical environment where the the
+Sequentially evaluate the FORMS in a lexical environment where the
 DECLARATIONS have effect. If LOCALLY is a top level form, then the FORMS are
 also processed as top level forms."
   (ir1-translate-locally body start next result))
@@ -869,7 +901,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.
@@ -1025,6 +1057,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)))))))