diff --git a/contrib/make-contrib.lisp b/contrib/make-contrib.lisp
index cdd36741c..f68f8d79e 100644
--- a/contrib/make-contrib.lisp
+++ b/contrib/make-contrib.lisp
@@ -69,6 +69,8 @@
                   (search "MPFR" s))))))
 
 (defun perform (defsystem)
+  (when (member :sb-cover-for-internals sb-impl:+internal-features+)
+    (proclaim '(optimize sb-c::store-coverage-data)))
   (let* ((specified-sources (getf defsystem :components))
          ;; This path is basically arbitrary. I wanted to avoid creating
          ;; another directory under "obj/" but alas ...
diff --git a/cover-script.lisp b/cover-script.lisp
new file mode 100644
index 000000000..1430b0c74
--- /dev/null
+++ b/cover-script.lisp
@@ -0,0 +1,14 @@
+(require :sb-cover)
+(load "src/cold/chill.lisp")
+(require :sb-grovel) ; hack
+(let* ((src (translate-logical-pathname "SYS:SRC;"))
+       (obj (merge-pathnames (make-pathname :directory '(:relative :back "obj" :wild-inferiors)
+                                            :name :wild :type :wild)
+                             src)))
+  (push (list "SYS:OBJ;**;*.*.*" obj) ; hack
+        (logical-pathname-translations "SYS")))
+(push :sb-bsd-sockets-addrinfo *features*) ; hack
+(sb-cover:reset-coverage)
+(map nil 'sb-cover:merge-coverage-from-file (directory "tests/*.coverage"))
+(sb-cover:save-coverage-in-file "all-tests.coverage")
+(sb-cover:report "/tmp/s/")
diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp
index b067b9f1f..caec49a8c 100644
--- a/src/code/cold-init.lisp
+++ b/src/code/cold-init.lisp
@@ -224,6 +224,8 @@
 
   (setq sb-pcl::*!docstrings* nil) ; needed before any documentation is set
   (setq sb-c::*queued-proclaims* nil) ; needed before any proclaims are run
+  (setq *code-coverage-info* ; needed to note / record code coverage
+        (list (make-hash-table :test 'equal :synchronized t)))
 
   (/show0 "calling cold toplevel forms and fixups")
   (let ((*package* *package*)) ; rebind to self, as if by LOAD
@@ -252,6 +254,13 @@
            (sb-fasl::named-constant-set object index name)))
         ((cons (eql :begin-file))
          (unless (!c-runtime-noinform-p) (print (cdr toplevel-thing))))
+        ((cons (eql :note-code-covered))
+         (aver (typep (cdr toplevel-thing) 'code-component))
+         (push (make-weak-pointer (cdr toplevel-thing))
+               (cdr *code-coverage-info*)))
+        ((cons (eql :record-code-coverage))
+         (setf (gethash (second toplevel-thing) (car *code-coverage-info*))
+               (mapcar #'list (third toplevel-thing))))
         (t
          (!cold-lose "bogus operation in *!COLD-TOPLEVELS*")))))
   (/show0 "done with loop over cold toplevel forms and fixups")
diff --git a/src/cold/base-target-features.lisp-expr b/src/cold/base-target-features.lisp-expr
index 71864486a..946c1a604 100644
--- a/src/cold/base-target-features.lisp-expr
+++ b/src/cold/base-target-features.lisp-expr
@@ -291,6 +291,11 @@
  ;; (Replaces use of SIG_STOP_FOR_GC.)
  ; :sb-safepoint
 
+ ;; Build the SBCL system itself with code coverage data marks (and sequences
+ ;; in the compiled code to set those marks).  Inevitably makes the system as
+ ;; a whole slower, but allows coverage of tests to be measured.
+ ; :sb-cover-for-internals
+
  ;;
  ;; miscellaneous notes on other things which could have special significance
  ;; in the *FEATURES* list
diff --git a/src/cold/compile-cold-sbcl.lisp b/src/cold/compile-cold-sbcl.lisp
index 9f2c58cc3..237e4af87 100644
--- a/src/cold/compile-cold-sbcl.lisp
+++ b/src/cold/compile-cold-sbcl.lisp
@@ -75,7 +75,10 @@
        (sb-c:insert-step-conditions 0)
        ;; save FP and PC for alien calls -- or not
        (sb-c:alien-funcall-saves-fp-and-pc
-        ,(if (find :x86 sb-xc:*features*) 3 0)))))
+        ,(if (find :x86 sb-xc:*features*) 3 0))
+       ;; store coverage data
+       (sb-c:store-coverage-data
+        ,(if (find :sb-cover-for-internals sb-xc:*features*) 3 0)))))
 
 (defun in-target-cross-compilation-mode (fun)
   "Call FUN with everything set up appropriately for cross-compiling
diff --git a/src/cold/shared.lisp b/src/cold/shared.lisp
index 671dcb36f..9a91cb4ab 100644
--- a/src/cold/shared.lisp
+++ b/src/cold/shared.lisp
@@ -305,6 +305,11 @@
           (pushnew :system-tlabs sb-xc:*features*))
         (when (target-featurep '(:and (:or :permgen :immobile-space) :x86-64))
           (pushnew :compact-instance-header sb-xc:*features*))
+        (when (target-featurep :sb-cover-for-internals)
+          ;; coverage of internals currently works substantially
+          ;; better if we preserve more information, and don't do
+          ;; various link-time optimizations.
+          (pushnew :sb-devel sb-xc:*features*))
         (when (target-featurep :immobile-space)
           (pushnew :immobile-code sb-xc:*features*))
         (when (target-featurep :64-bit)
diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp
index 06fe9467b..c941a33ae 100644
--- a/src/cold/warm.lisp
+++ b/src/cold/warm.lisp
@@ -43,7 +43,8 @@ sb-kernel::
             (safety 2) (speed 2)
             ;; never insert stepper conditions
             (sb-c:insert-step-conditions 0)
-            (sb-c:alien-funcall-saves-fp-and-pc #+x86 3 #-x86 0)))
+            (sb-c:alien-funcall-saves-fp-and-pc #+x86 3 #-x86 0)
+            (sb-c:store-coverage-data #+sb-cover-for-internals 3 #-sb-cover-for-internals 0)))
 
 (locally
     (declare (notinline find-symbol)) ; don't ask
diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp
index e7b396bb9..9662a0256 100644
--- a/src/compiler/generic/genesis.lisp
+++ b/src/compiler/generic/genesis.lisp
@@ -2835,11 +2835,22 @@ Legal values for OFFSET are -4, -8, -12, ..."
                   (ash sb-vm:simple-fun-insts-offset sb-vm:word-shift))
                (descriptor-bits fn))))) ; Store a taagged pointer to the function
       (do () ((>= header-index n-boxed-words))
-       (let ((constant (svref stack stack-index)))
-         (cond ((and (consp constant) (eq (car constant) :known-fun))
-                (push (list* (cdr constant) des header-index) *deferred-known-fun-refs*))
-               (t
-                (write-wordindexed des header-index constant))))
+        (let ((constant (svref stack stack-index)))
+          (cond ((and (consp constant) (eq (car constant) :known-fun))
+                 (push (list* (cdr constant) des header-index) *deferred-known-fun-refs*))
+                (t
+                 #+sb-cover-for-internals
+                 (when (and (= header-index (1- n-boxed-words))
+                            ;; (typep constant '(eql sb-c::coverage-map))
+                            (descriptor-p constant)
+                            (= (descriptor-lowtag constant) #.sb-vm:list-pointer-lowtag)
+                            (let ((car (cold-car constant)))
+                              (and (descriptor-p car)
+                                   (= (descriptor-lowtag car) #.sb-vm:other-pointer-lowtag)
+                                   (= (descriptor-widetag car) #.sb-vm:symbol-widetag)
+                                   (eql (warm-symbol car) 'sb-c::coverage-map))))
+                   (push (cold-cons :note-code-covered des) *!cold-toplevels*))
+                 (write-wordindexed des header-index constant))))
         (incf header-index)
         (incf stack-index)))
     des))
@@ -2927,18 +2938,31 @@ Legal values for OFFSET are -4, -8, -12, ..."
   (+ (- (descriptor-bits (car *asm-routine-vector*)) sb-vm:other-pointer-lowtag)
      (ash (+ i sb-vm:vector-data-offset) sb-vm:word-shift)))
 
-;; The partial source info is not needed during the cold load, since
-;; it can't be interrupted.
+;; The partial source info is needed only for propagation of coverage
+;; information metadata, since the load can't be interrupted.
 (define-cold-fop (fop-note-partial-source-info)
-  (pop-stack)
-  (pop-stack)
-  (pop-stack)
+  (let ((plist (pop-stack))
+        (created (pop-stack))
+        (namestring (pop-stack)))
+    (setf (%fasl-input-partial-source-info (fasl-input))
+          (sb-c::make-debug-source :namestring (host-object-from-core namestring)
+                                   :created (host-object-from-core created)
+                                   :plist (host-object-from-core plist))))
   (values))
 
 (define-cold-fop (fop-note-full-calls)
   (sb-c::accumulate-full-calls (host-object-from-core (pop-stack)))
   (values))
 
+(define-cold-fop (fop-record-code-coverage)
+  (let ((paths (pop-stack)))
+    (push (cold-list :record-code-coverage
+                     (host-constant-to-core
+                      (sb-c::debug-source-namestring
+                       (%fasl-input-partial-source-info (fasl-input))))
+                     paths)
+          *!cold-toplevels*)))
+
 ;;; Target variant of this is defined in 'target-load'
 (defun apply-fixups (code-obj fixups index count &optional asm-code
                      &aux (end (1- (+ index count)))
diff --git a/tests/ansi-tests.sh b/tests/ansi-tests.sh
index 5183cb3e7..c4130fcee 100755
--- a/tests/ansi-tests.sh
+++ b/tests/ansi-tests.sh
@@ -1,10 +1,15 @@
 #!/bin/sh -e
 
+# Usage: ansi-tests.sh [options]
+#
+# Currently the only option with any effect is `--coverage`, which
+# will collect coverage information from running the tests if the host
+# SBCL is built with :sb-cover-for-internals.
+
 if [ ! -e ansi-test ]; then
    git clone --depth 1 https://github.com/sbcl/ansi-test.git
 fi
 
-
 cd ansi-test
 rm -fr sandbox/scratch
 ../../run-sbcl.sh --disable-ldb --lose-on-corruption \
@@ -13,7 +18,9 @@ rm -fr sandbox/scratch
                   --eval '(setf *default-pathname-defaults* (truename #P"sandbox/"))' \
                   --eval '(in-package :cl-test)' \
                   --eval '(disable-note :nil-vectors-are-strings)' \
+                  --eval '(when (member "--coverage" sb-ext:*posix-argv* :test (function equal)) (require :sb-cover) (funcall (intern "RESET-COVERAGE" "SB-COVER")))' \
                   --eval '(time (do-tests))' \
+                  --eval '(when (member "--coverage" sb-ext:*posix-argv* :test (function equal)) (funcall (intern "SAVE-COVERAGE-IN-FILE" "SB-COVER") "../../ansi-tests.coverage"))' \
                   --eval '(let* ((expected (list* "APROPOS-LIST.ERROR.2" "APROPOS.ERROR.2" "COMPILE-FILE.2"
  "DEFINE-COMPILER-MACRO.8" "DESTRUCTURING-BIND.ERROR.10"
  "EXP.ERROR.10" "EXP.ERROR.11" "EXP.ERROR.8"
@@ -72,4 +79,5 @@ rm -fr sandbox/scratch
    (cond ((or diff1 diff2)
            (format t "Difference ~@[added ~a~] ~@[removed ~a~]~%" diff1 diff2)
            (sb-ext:exit :code 1))
-         ((sb-ext:exit))))'
+         ((sb-ext:exit))))' \
+                  $*
diff --git a/tests/elfcore.test.sh b/tests/elfcore.test.sh
index 8fbf4f960..e8dcbcc61 100755
--- a/tests/elfcore.test.sh
+++ b/tests/elfcore.test.sh
@@ -16,10 +16,12 @@
 . ./subr.sh
 
 run_sbcl <<EOF
+  (when (member :sb-cover-for-internals sb-impl::+internal-features+)
+    (exit :code 2)) ; breaks static linkage somehow. lp#2131956
   #+(and linux elf sb-thread)
   (let ((s (find-symbol "IMMOBILE-SPACE-OBJ-P" "SB-KERNEL")))
     (when (and s (funcall s #'car)) (exit :code 0))) ; good
- (exit :code 2) ; otherwise
+  (exit :code 2) ; otherwise
 EOF
 status=$?
 if [ $status != 0 ]; then # test can't be executed
diff --git a/tests/gc.impure.lisp b/tests/gc.impure.lisp
index 085025ff6..c752c6557 100644
--- a/tests/gc.impure.lisp
+++ b/tests/gc.impure.lisp
@@ -103,7 +103,7 @@
       (assert (= (aref a (1+ i)) (1+ (aref a i)))))))
 
 (with-test (:name :list-allocated-objects
-            :skipped-on :weak-vector-readbarrier) ; uses more weak-pointers
+            :skipped-on (or :sb-cover-for-internals :weak-vector-readbarrier)) ; uses more weak-pointers
   ;; Assert that if :COUNT is supplied as a higher number
   ;; than number of objects that exists, the output is
   ;; not COUNT many items long.
diff --git a/tests/impure-runner.lisp b/tests/impure-runner.lisp
index 57501192a..15167eb88 100644
--- a/tests/impure-runner.lisp
+++ b/tests/impure-runner.lisp
@@ -1,5 +1,6 @@
 (with-compilation-unit ()
   (let ((*evaluator-mode* :compile))
+    #+coverage (require :sb-cover)
     (load "test-util")
     (load "assertoid")))
 
@@ -42,7 +43,11 @@
                     (invoke-restart 'skip-file))))
         (let ((*package* (find-package :cl-user)))
           #+nil (sb-aprof:aprof-run test-fun :arguments (list file))
-          (funcall test-fun file)))
+          #+coverage (sb-cover:reset-coverage)
+          (funcall test-fun file)
+          #+coverage
+          (let ((name (concatenate 'string file ".coverage")))
+            (sb-cover:save-coverage-in-file name))))
     (skip-file ()
       (format t ">>>~a<<<~%"*failures*)))
   (report-test-status)
diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp
index f2aa75d03..d346c11d9 100644
--- a/tests/interface.pure.lisp
+++ b/tests/interface.pure.lisp
@@ -160,7 +160,7 @@
 (with-test (:name (disassemble :unboxed-data))
   (assert (< (sb-kernel:code-n-unboxed-data-bytes
               (sb-kernel:fun-code-header #'expt))
-             150))) ; The exact value is irrelevant.
+             300))) ; The exact value is irrelevant.
 
 #+x86-64
 ;; The labeler for LEA would choke on an illegal encoding
diff --git a/tests/jump-table.pure.lisp b/tests/jump-table.pure.lisp
index 3724de294..35bec5d39 100644
--- a/tests/jump-table.pure.lisp
+++ b/tests/jump-table.pure.lisp
@@ -1,7 +1,8 @@
 (unless (gethash 'sb-c:jump-table sb-c::*backend-template-names*)
   (invoke-restart 'run-tests::skip-file))
 
-(with-test (:name :symbol-case-as-jump-table)
+(with-test (:name :symbol-case-as-jump-table
+                  :fails-on :sb-cover-for-internals) ; lp#2131957
   ;; Assert that a prototypical example of (CASE symbol ...)
   ;; was converted to a jump table.
   (let ((c (sb-kernel:fun-code-header #'sb-debug::parse-trace-options)))
@@ -137,7 +138,8 @@
     ((#\a) 0)
     ((#\b) nil)))
 
-(with-test (:name :array-subtype-dispatch-table)
+(with-test (:name :array-subtype-dispatch-table
+                  :fails-on :sb-cover-for-internals) ; lp#2131957
   (assert (> (sb-kernel:code-jump-table-words
               (sb-kernel:fun-code-header #'sb-kernel:vector-subseq))
              20)))
diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp
index 86092d2b4..bc47c00af 100644
--- a/tests/run-tests.lisp
+++ b/tests/run-tests.lisp
@@ -4,6 +4,12 @@
   (push :slow *features*))
 (when (member "--gc-verify" *posix-argv* :test #'equal)
   (push :gc-verify *features*))
+(when (member "--coverage" *posix-argv* :test #'equal)
+  (assert (member :sb-cover-for-internals sb-impl::+internal-features+))
+  (push :coverage *features*))
+
+#+coverage
+(require :sb-cover)
 
 (load "test-util.lisp")
 (load "assertoid.lisp")
@@ -54,7 +60,8 @@
             ((string= arg "--no-color"))
             ((or (string= arg "--gc-stress")
                  (string= arg "--slow")
-                 (string= arg "--gc-verify")))
+                 (string= arg "--gc-verify")
+                 (string= arg "--coverage")))
             ((string= arg "--skip-to")
              (setf skip-to (pop remainder)))
             (t
@@ -543,7 +550,11 @@
                            (cons :interpreter *features*)
                            *features*)))
                 (let ((start (get-internal-real-time)))
+                  #+coverage (sb-cover:reset-coverage)
                   (funcall test-fun file)
+                  #+coverage
+                  (let ((name (concatenate 'string (namestring file) ".coverage")))
+                    (sb-cover:save-coverage-in-file name))
                   (log-file-elapsed-time file start log))))
             (skip-file ())))
         (sb-impl::disable-stepping)
@@ -579,6 +590,7 @@
            #+gc-stress "--eval" #+gc-stress "(push :gc-stress *features*)"
            #+gc-verify "--eval" #+gc-verify "(push :gc-verify *features*)"
            #+slow "--eval" #+slow "(push :slow *features*)"
+           #+coverage "--eval" #+coverage "(push :coverage *features*)"
            "--load" load
            "--eval" (write-to-string eval
                                      :right-margin 1000))
diff --git a/tests/run-tests.sh b/tests/run-tests.sh
index d28c143f6..6af8808ec 100755
--- a/tests/run-tests.sh
+++ b/tests/run-tests.sh
@@ -23,12 +23,14 @@ Options:
                                 value of SB-EXT:*EVALUATOR-MODE* while
                                 running tests.
   --break-on-failure            Break into the debugger when a test fails
-                                unexpectedly
-  --break-on-expected-failure   Break into the debugger when any test fails
+                                unexpectedly.
+  --break-on-expected-failure   Break into the debugger when any test fails.
   --report-skipped-tests        Include tests :skipped-on target SBCL in
                                 the test report.
   --no-color                    Disable coloring of results.
   --slow                        Enable slow tests.
+  --coverage                    Collect coverage information from running
+                                each test file.
 
 If no test files are specified, runs all tests.
 EOF