X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fmain.lisp;h=f99f24eda888d7a066bc80ec280ecf55e7df7620;hb=0e7a9105ae992fc4befa37846c42f298e12918c0;hp=168fe6f8656a44520e5ad7d1f7c390e76c17a373;hpb=29f0545ba7ae947489d2d5fab0faa2b499096713;p=sbcl.git

diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp
index 168fe6f..f99f24e 100644
--- a/src/compiler/main.lisp
+++ b/src/compiler/main.lisp
@@ -116,6 +116,18 @@
 (declaim (type object *compile-object*))
 
 (defvar *fopcompile-label-counter*)
+
+;; Used during compilation to map code paths to the matching
+;; instrumentation conses.
+(defvar *code-coverage-records* nil)
+;; Used during compilation to keep track of with source paths have been
+;; instrumented in which blocks.
+(defvar *code-coverage-blocks* nil)
+;; Stores the code coverage instrumentation results. Keys are namestrings,
+;; the value is a list of (CONS PATH STATE), where STATE is NIL for
+;; a path that has not been visited, and T for one that has.
+(defvar *code-coverage-info* (make-hash-table :test 'equal))
+
 
 ;;;; WITH-COMPILATION-UNIT and WITH-COMPILATION-VALUES
 
@@ -977,7 +989,9 @@
                          (funcall #'ir1-convert-lambdalike
                                   definition
                                   :source-name name)))
-           (debug-name (debug-name 'tl-xep name))
+           (debug-name (debug-name 'tl-xep
+                                   (or name
+                                       (functional-%source-name locall-fun))))
            ;; Convert the XEP using the policy of the real
            ;; function. Otherwise the wrong policy will be used for
            ;; deciding whether to type-check the parameters of the
@@ -1313,7 +1327,7 @@
 (defun compile-load-time-stuff (form for-value)
   (with-ir1-namespace
    (let* ((*lexenv* (make-null-lexenv))
-          (lambda (ir1-toplevel form *current-path* for-value)))
+          (lambda (ir1-toplevel form *current-path* for-value nil)))
      (compile-toplevel (list lambda) t)
      lambda)))
 
@@ -1476,6 +1490,8 @@
         (sb!xc:*compile-file-pathname* nil) ; really bound in
         (sb!xc:*compile-file-truename* nil) ; SUB-SUB-COMPILE-FILE
         (*policy* *policy*)
+        (*code-coverage-records* (make-hash-table :test 'equal))
+        (*code-coverage-blocks* (make-hash-table :test 'equal))
         (*handled-conditions* *handled-conditions*)
         (*disabled-package-locks* *disabled-package-locks*)
         (*lexenv* (make-null-lexenv))
@@ -1511,6 +1527,19 @@
 
                 (sub-sub-compile-file info)
 
+                (unless (zerop (hash-table-count *code-coverage-records*))
+                  ;; Dump the code coverage records into the fasl.
+                  (fopcompile `(record-code-coverage
+                                ',(namestring *compile-file-pathname*)
+                                ',(let (list)
+                                       (maphash (lambda (k v)
+                                                  (declare (ignore k))
+                                                  (push v list))
+                                                *code-coverage-records*)
+                                       list))
+                              nil
+                              nil))
+
                 (finish-block-compilation)
                 (let ((object *compile-object*))
                   (etypecase object
@@ -1527,6 +1556,7 @@
          (format *error-output*
                  "~@<compilation aborted because of fatal error: ~2I~_~A~:>"
                  condition))
+       (finish-output *error-output*)
        (values nil t t)))))
 
 ;;; Return a pathname for the named file. The file must exist.