1.0.12.4: delete bad ROOM test

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

diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp
index a1437e1..affa00f 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 (get-source-path form)
+                     (and (consp form)
+                          (some #'sub form)))))
+        (or (sub form)))))
 \f
 ;;;; BLOCK and TAGBODY
 
@@ -452,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)
@@ -549,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
@@ -559,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)))
 \f
 ;;;; LET and LET*
 ;;;;
@@ -674,7 +705,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))
@@ -1025,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)))))))
 \f