(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)))
(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
(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
(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
(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)
;;; 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
(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*
;;;;
#!+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))
(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.
(%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