mirror of
git://git.code.sf.net/p/sbcl/sbcl
synced 2026-09-09 23:16:41 -04:00
Allow compiling the system with coverage instrumentation
To build, pass `--with-sb-cover-for-internals` to make.sh
Test running scripts have been adapted; pass `--coverage` to
run-tests.sh and/or ansi-tests.sh to generate .coverage files, then
use a script like `cover-script.lisp` to generate a report.
Things that we need to fix:
- it's pretty slow (build time roughly doubles)
- the report is fairly ugly (and doesn't sort the sources in the way
I would expect)
- it exposes some issue in combination with --with-sb-show
Can't compute fixup relative to movable object
#<code id=5419 [7] (FLET "PPRINT-BLOCK" :IN "SYS:SRC;CODE;WARM-ERROR.LISP") {1203AEC9BF..1203AED4A0}>
This commit is contained in:
Christophe Rhodes
parent
097b905ef8
commit
430495fb5f
|
|
@ -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 ...
|
||||
|
|
|
|||
14
cover-script.lisp
Normal file
14
cover-script.lisp
Normal file
|
|
@ -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/")
|
||||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))))' \
|
||||
$*
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue