X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1-translators.lisp;h=c4289ed08d058be3f73c6aa1ef962673f7396c7a;hb=6fa7b9f967304c090078b835c5419d816c017d8d;hp=bd97ac8402dbd7580d6b36ce9e48d4be44cdb7f6;hpb=f68d0f59fa6f9c448b3a147b5940937af03f940a;p=sbcl.git

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index bd97ac8..c4289ed 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
 
@@ -126,35 +152,38 @@ 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
 ;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
 ;;; tagbody into segments of non-tag statements, and explicitly
 ;;; represent the drop-through with a GO. The first segment has a
-;;; dummy NIL tag, since it represents code before the first tag. The
+;;; dummy NIL tag, since it represents code before the first tag. Note
+;;; however that NIL may appear as the tag of an inner segment. The
 ;;; last segment (which may also be the first segment) ends in NIL
 ;;; rather than a GO.
 (defun parse-tagbody (body)
   (declare (list body))
-  (collect ((segments))
-    (let ((current (cons nil body)))
+  (collect ((tags)
+            (segments))
+    (let ((current body))
       (loop
-        (let ((tag-pos (position-if (complement #'listp) current :start 1)))
-          (unless tag-pos
-            (segments `(,@current nil))
-            (return))
-          (let ((tag (elt current tag-pos)))
-            (when (assoc tag (segments))
-              (compiler-error
-               "The tag ~S appears more than once in the tagbody."
-               tag))
-            (unless (or (symbolp tag) (integerp tag))
-              (compiler-error "~S is not a legal tagbody statement." tag))
-            (segments `(,@(subseq current 0 tag-pos) (go ,tag))))
-          (setq current (nthcdr tag-pos current)))))
-    (segments)))
+       (let ((next-segment (member-if #'atom current)))
+         (unless next-segment
+           (segments `(,@current nil))
+           (return))
+         (let ((tag (car next-segment)))
+           (when (member tag (tags))
+             (compiler-error
+              "The tag ~S appears more than once in a tagbody."
+              tag))
+           (unless (or (symbolp tag) (integerp tag))
+             (compiler-error "~S is not a legal go tag." tag))
+           (tags tag)
+           (segments `(,@(ldiff current next-segment) (go ,tag))))
+         (setq current (rest next-segment))))
+      (mapcar #'cons (cons nil (tags)) (segments)))))
 
 ;;; Set up the cleanup, emitting the entry node. Then make a block for
 ;;; each tag, building up the tag list for LEXENV-TAGS as we go.
@@ -218,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,7 +478,7 @@ Return VALUE without evaluating it."
      (second thing))
     ((lambda instance-lambda)
      `(lambda ,(second thing)))
-    ((lambda-with-lexenv)'
+    ((lambda-with-lexenv)
      `(lambda ,(fifth thing)))))
 
 (defun fun-name-leaf (thing)
@@ -546,7 +575,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
@@ -556,6 +585,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*
 ;;;;
@@ -866,7 +900,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.
@@ -1007,7 +1041,9 @@ due to normal completion or a non-local exit such as THROW)."
   (ir1-convert
    start next result
    (with-unique-names (cleanup-fun drop-thru-tag exit-tag next start count)
-     `(flet ((,cleanup-fun () ,@cleanup nil))
+     `(flet ((,cleanup-fun ()
+               ,@cleanup
+               nil))
         ;; FIXME: If we ever get DYNAMIC-EXTENT working, then
         ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
         ;; and something can be done to make %ESCAPE-FUN have
@@ -1020,6 +1056,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)))))))