+
+\f
+;;;; code coverage
+
+;;; Check the policy for whether we should generate code coverage
+;;; instrumentation. If not, just return the original START
+;;; ctran. Otherwise insert code coverage instrumentation after
+;;; START, and return the new ctran.
+(defun instrument-coverage (start mode form)
+ ;; We don't actually use FORM for anything, it's just convenient to
+ ;; have around when debugging the instrumentation.
+ (declare (ignore form))
+ (if (and (policy *lexenv* (> store-coverage-data 0))
+ *code-coverage-records*
+ *allow-instrumenting*)
+ (let ((path (source-path-original-source *current-path*)))
+ (when mode
+ (push mode path))
+ (if (member (ctran-block start)
+ (gethash path *code-coverage-blocks*))
+ ;; If this source path has already been instrumented in
+ ;; this block, don't instrument it again.
+ start
+ (let ((store
+ ;; Get an interned record cons for the path. A cons
+ ;; with the same object identity must be used for
+ ;; each instrument for the same block.
+ (or (gethash path *code-coverage-records*)
+ (setf (gethash path *code-coverage-records*)
+ (cons path +code-coverage-unmarked+))))
+ (next (make-ctran))
+ (*allow-instrumenting* nil))
+ (push (ctran-block start)
+ (gethash path *code-coverage-blocks*))
+ (let ((*allow-instrumenting* nil))
+ (ir1-convert start next nil
+ `(locally
+ (declare (optimize speed
+ (safety 0)
+ (debug 0)
+ (check-constant-modification 0)))
+ ;; We're being naughty here, and
+ ;; modifying constant data. That's ok,
+ ;; we know what we're doing.
+ (%rplacd ',store t))))
+ next)))
+ start))
+
+;;; In contexts where we don't have a source location for FORM
+;;; e.g. due to it not being a cons, but where we have a source
+;;; location for the enclosing cons, use the latter source location if
+;;; available. This works pretty well in practice, since many PROGNish
+;;; macroexpansions will just directly splice a block of forms into
+;;; some enclosing form with `(progn ,@body), thus retaining the
+;;; EQness of the conses.
+(defun maybe-instrument-progn-like (start forms form)
+ (or (when (and *allow-instrumenting*
+ (not (get-source-path form)))
+ (let ((*current-path* (get-source-path forms)))
+ (when *current-path*
+ (instrument-coverage start nil form))))
+ start))
+
+(defun record-code-coverage (info cc)
+ (setf (gethash info *code-coverage-info*) cc))
+
+(defun clear-code-coverage ()
+ (clrhash *code-coverage-info*))
+
+(defun reset-code-coverage ()
+ (maphash (lambda (info cc)
+ (declare (ignore info))
+ (dolist (cc-entry cc)
+ (setf (cdr cc-entry) +code-coverage-unmarked+)))
+ *code-coverage-info*))
+
+(defun code-coverage-record-marked (record)
+ (aver (consp record))
+ (ecase (cdr record)
+ ((#.+code-coverage-unmarked+) nil)
+ ((t) t)))
+