He creates binary packages of SBCL releases for Red Hat and other
(which?) platforms.
+Helmut Eller:
+ A lot of the code in the SB-INTROSPECT and SB-COVER contrib modules
+ was originally written by him for Slime/Swank.
+
Lutz Euler:
He made a large number of improvements to the x86-64 disassembler.
He added support for SunOS on x86 processors.
ITA Software:
- They hired Juho Snellman as a consultant to work on improvements to
+ They hired Juho Snellman as a consultant to work on improvements to
SBCL, to be released into the public domain. The work they've funded
- includes faster compilation speeds, the interpreter-based evaluator
- and the IR2-based single-stepper.
+ includes faster compilation, various improvements to the statistical
+ profiler, the SB-COVER code coverage tool, the interpreter-based
+ evaluator and the IR2-based single-stepper.
Espen S Johnsen:
He provided an ANSI-compliant version of CHANGE-CLASS for PCL.
;;;; -*- coding: utf-8; -*-
changes in sbcl-1.0.6 relative to sbcl-1.0.5:
+ * new contrib: sb-cover, an experimental code coverage tool, is included
+ as a contrib module.
* enhancement: a new, experimental synchronous timeout facility is
provided. Refer to SB-SYS:WITH-DEADLINE for details.
* enhancement: when a symbol name conflict error arises, the
--- /dev/null
+SYSTEM=sb-cover
+include ../asdf-module.mk
--- /dev/null
+;;; A frontend for the SBCL code coverage facility. Written by Juho
+;;; Snellman, and placed under public domain.
+
+;;; This module includes a modified version of the source path parsing
+;;; routines from Swank. That code was written by Helmut Eller, and
+;;; was placed under Public Domain
+
+(defpackage #:sb-cover
+ (:use #:cl #:sb-c)
+ (:export #:report
+ #:reset-coverage #:clear-coverage
+ #:store-coverage-data))
+
+(in-package #:sb-cover)
+
+(defclass sample-count ()
+ ((mode :accessor mode-of :initarg :mode)
+ (all :accessor all-of :initform 0)
+ (ok :accessor ok-of :initform 0)))
+
+(defun clear-coverage ()
+ "Clear all files from the coverage database. The files will be re-entered
+into the database when the FASL files (produced by compiling
+STORE-COVERAGE-DATA optimization policy set to 3) are loaded again into the
+image."
+ (sb-c::clear-code-coverage))
+
+(defun reset-coverage ()
+ "Reset all coverage data back to the `Not executed` state."
+ (sb-c::reset-code-coverage))
+
+(defun report (directory &key (external-format :default))
+ "Print a code coverage report of all instrumented files into DIRECTORY.
+If DIRECTORY does not exist, it will be created. The main report will be
+printed to the file cover-index.html. The external format of the source
+files can be specified with the EXTERNAL-FORMAT parameter."
+ (let ((paths)
+ (*default-pathname-defaults* (merge-pathnames (pathname directory))))
+ (ensure-directories-exist *default-pathname-defaults*)
+ (maphash (lambda (k v)
+ (declare (ignore v))
+ (let* ((n (substitute #\_ #\. (substitute #\_ #\/ k)))
+ (path (make-pathname :name n :type "html")))
+ (when (probe-file k)
+ (with-open-file (stream path
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (push (list* k n (report-file k stream external-format))
+ paths)))))
+ *code-coverage-info*)
+ (let ((report-file (make-pathname :name "cover-index" :type "html")))
+ (with-open-file (stream report-file
+ :direction :output :if-exists :supersede
+ :if-does-not-exist :create)
+ (write-styles stream)
+ (unless paths
+ (warn "No coverage data found for any file, producing an empty report. Maybe you~%forgot to (DECLAIM (OPTIMIZE SB-COVER:STORE-COVERAGE-DATA))?")
+ (format stream "<h3>No code coverage data found.</h3>")
+ (close stream)
+ (return-from report))
+ (format stream "<table class='summary'>")
+ (format stream "<tr class='head-row'><td></td><td class='main-head' colspan='3'>Expression</td><td class='main-head' colspan='3'>Branch</td></tr>")
+ (format stream "<tr class='head-row'>~{<td width='80px'>~A</td>~}</tr>"
+ (list "Source file"
+ "Covered" "Total" "%"
+ "Covered" "Total" "%"))
+ (setf paths (sort paths #'string< :key #'car))
+ (loop for prev = nil then source-file
+ for (source-file report-file expression branch) in paths
+ for even = nil then (not even)
+ do (when (or (null prev)
+ (not (equal (pathname-directory (pathname source-file))
+ (pathname-directory (pathname prev)))))
+ (format stream "<tr class='subheading'><td colspan='7'>~A</td></tr>~%"
+ (namestring (make-pathname :directory (pathname-directory (pathname source-file))))))
+ do (format stream "<tr class='~:[odd~;even~]'><td class='text-cell'><a href='~a.html'>~a</a></td>~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f~]</td>~}</tr>"
+ even
+ report-file
+ (enough-namestring (pathname source-file)
+ (pathname source-file))
+ (list (ok-of expression)
+ (all-of expression)
+ (percent expression)
+ (ok-of branch)
+ (all-of branch)
+ (percent branch))))
+ (format stream "</table>"))
+ report-file)))
+
+(defun percent (count)
+ (unless (zerop (all-of count))
+ (* 100
+ (/ (ok-of count) (all-of count)))))
+
+(defun report-file (file html-stream external-format)
+ "Print a code coverage report of FILE into the stream HTML-STREAM."
+ (format html-stream "<html><head>")
+ (write-styles html-stream)
+ (format html-stream "</head><body>")
+ (let* ((source (detabify (read-file file external-format)))
+ (states (make-array (length source)
+ :initial-element 0
+ :element-type '(unsigned-byte 4)))
+ ;; Convert the code coverage records to a more suitable format
+ ;; for this function.
+ (expr-records (convert-records (gethash file *code-coverage-info*)
+ :expression))
+ (branch-records (convert-records (gethash file *code-coverage-info*)
+ :branch))
+ ;; Cache the source-maps
+ (maps (with-input-from-string (stream source)
+ (loop with map = nil
+ with form = nil
+ with eof = nil
+ do (setf (values form map)
+ (handler-case
+ (read-and-record-source-map stream)
+ (end-of-file ()
+ (setf eof t))
+ (error ()
+ (values nil nil))))
+ until eof
+ when map
+ collect (cons form map)))))
+ (mapcar (lambda (map)
+ (maphash (lambda (k locations)
+ (declare (ignore k))
+ (dolist (location locations)
+ (destructuring-bind (start end suppress) location
+ (when suppress
+ (fill-with-state source states 15 (1- start)
+ end)))))
+ (cdr map)))
+ maps)
+ ;; Go through all records, find the matching source in the file,
+ ;; and update STATES to contain the state of the record in the
+ ;; indexes matching the source location. Process the longest paths
+ ;; first, so that the state of each index will reflect the state
+ ;; of the innermost containing form. Processes branch-records
+ ;; before expr-records of the same length, for the same reason.
+ (let ((counts (list :branch (make-instance 'sample-count :mode :branch)
+ :expression (make-instance 'sample-count
+ :mode :expression))))
+ (let ((records (append branch-records expr-records)))
+ (dolist (record (stable-sort records #'>
+ :key (lambda (e) (length (second e)))))
+ (destructuring-bind (mode path state) record
+ (let* ((path (reverse path))
+ (tlf (car path))
+ (source-form (car (nth tlf maps)))
+ (source-map (cdr (nth tlf maps)))
+ (source-path (cdr path)))
+ (cond ((eql mode :branch)
+ (let ((count (getf counts :branch)))
+ ;; For branches mode each record accounts for two paths
+ (incf (ok-of count)
+ (ecase state
+ (5 2)
+ ((6 9) 1)
+ (10 0)))
+ (incf (all-of count) 2)))
+ (t
+ (let ((count (getf counts :expression)))
+ (when (eql state 1)
+ (incf (ok-of count)))
+ (incf (all-of count)))))
+ (if source-map
+ (handler-case
+ (multiple-value-bind (start end)
+ (source-path-source-position (cons 0 source-path)
+ source-form
+ source-map)
+ (fill-with-state source states state start end))
+ (error ()
+ (warn "Error finding source location for source path ~A in file ~A~%" source-path file)))
+ (warn "Unable to find a source map for toplevel form ~A in file ~A~%" tlf file))))))
+ (print-report html-stream file counts states source)
+ (format html-stream "</body></html>")
+ (list (getf counts :expression)
+ (getf counts :branch)))))
+
+(defun fill-with-state (source states state start end)
+ (let* ((pos (position #\Newline source
+ :end start
+ :from-end t))
+ (start-column (if pos
+ (- start 1 pos)
+ 0))
+ (end-column 0))
+ (loop for i from start below end
+ for col from start-column
+ for char = (aref source i)
+ do (cond ((eql char #\Newline)
+ (setf col -1))
+ ((not (eql char #\Space))
+ (setf end-column (max end-column col)))))
+ (loop for i from start below end
+ for col from start-column
+ for char = (aref source i)
+ do (if (eql char #\Newline)
+ (setf col -1)
+ (when (and (zerop (aref states i))
+ #+nil (<= col end-column)
+ (>= col start-column))
+ (setf (aref states i) state))))))
+
+;;; Convert tabs to spaces
+(defun detabify (source)
+ (with-output-to-string (stream)
+ (loop for char across source
+ for col from 0
+ for i from 0
+ do (if (eql char #\Tab)
+ (loop repeat (- 8 (mod col 8))
+ do (write-char #\Space stream)
+ do (incf col)
+ finally (decf col))
+ (progn
+ (when (eql char #\Newline)
+ ;; Filter out empty last line
+ (when (eql i (1- (length source)))
+ (return))
+ (setf col -1))
+ (write-char char stream))))))
+
+(defvar *counts* nil)
+
+(defun print-report (html-stream file counts states source)
+ ;; Just used for testing
+ (setf *counts* counts)
+ (let ((*print-case* :downcase))
+ (format html-stream
+ "<h3>Coverage report: ~a <br />~%</h3>~%" file)
+ (when (zerop (all-of (getf counts :expression)))
+ (format html-stream "<b>File has no instrumented forms</b>")
+ (return-from print-report))
+ (format html-stream "<table class='summary'><tr class='head-row'>~{<td width='80px'>~a</td>~}"
+ (list "Kind" "Covered" "All" "%"))
+ (dolist (mode '(:expression :branch))
+ (let ((count (getf counts mode)))
+ (format html-stream "<tr class='~:[odd~;even~]'><td>~A</td><td>~a</td><td>~a</td><td>~5,1F</td></tr>~%"
+ (eql mode :branch)
+ mode
+ (ok-of count)
+ (all-of count)
+ (percent count))))
+ (format html-stream "</table>"))
+ (format html-stream "<div class='key'><b>Key</b><br />~%")
+ (format html-stream "<div class='state-0'>Not instrumented</div>")
+ (format html-stream "<div class='state-15'>Conditionalized out</div>")
+ (format html-stream "<div class='state-1'>Executed</div>")
+ (format html-stream "<div class='state-2'>Not executed</div>")
+ (format html-stream "<div> </div>")
+ (format html-stream "<div class='state-5'>Both branches taken</div>")
+ (format html-stream "<div class='state-6'>One branch taken</div>")
+ (format html-stream "<div class='state-10''>Neither branch taken</div>")
+ (format html-stream "</div>")
+ (format html-stream "<nobr><div><code>~%")
+ (flet ((line (line)
+ (format html-stream "</code></div></nobr>~%<nobr><div class='source'><div class='line-number'><code>~A</code></div><code> " line)
+ line))
+ (loop for last-state = nil then state
+ with line = (line 1)
+ for col from 1
+ for char across source
+ for state across states
+ do (unless (eq state last-state)
+ (when last-state
+ (format html-stream "</span>"))
+ (format html-stream "<span class='state-~a'>" state))
+ do (case char
+ ((#\Newline)
+ (setf state nil)
+ (setf col 0)
+ (format html-stream "</span>")
+ (line (incf line)))
+ ((#\Space)
+ (format html-stream " "))
+ ((#\Tab)
+ (error "tab"))
+ (t
+ (if (alphanumericp char)
+ (write-char char html-stream)
+ (format html-stream "&#~A;" (char-code char))))))
+ (format html-stream "</code></div>")))
+
+(defun write-styles (html-stream)
+ (format html-stream "<style type='text/css'>
+*.state-0 { background-color: #eeeeee }
+*.state-1 { background-color: #aaffaa }
+*.state-5 { background-color: #44dd44 }
+*.state-2 { background-color: #ffaaaa }
+*.state-10 { background-color: #ee6666 }
+*.state-15 { color: #aaaaaa; background-color: #eeeeee }
+*.state-9,*.state-6 { background-color: #ffffaa }
+div.key { margin: 20px; width: 200px }
+div.source { width: 88ex; background-color: #eeeeee; padding-left: 5px;
+ /* border-style: solid none none none; border-width: 1px;
+ border-color: #dddddd */ }
+
+*.line-number { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; }
+
+table.summary tr.head-row { background-color: #aaaaff }
+table.summary tr td.text-cell { text-align: left }
+table.summary tr td.main-head { text-align: center }
+table.summary tr td { text-align: right }
+table.summary tr.even { background-color: #eeeeff }
+table.summary tr.subheading { background-color: #aaaaff}
+table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; }
+</style>"))
+
+(defun convert-records (records mode)
+ (ecase mode
+ (:expression
+ (loop for record in records
+ unless (member (caar record) '(:then :else))
+ collect (list mode
+ (car record)
+ (ecase (cdr record)
+ ((t) 1)
+ ((nil) 2)))))
+ (:branch
+ (let ((hash (make-hash-table :test 'equal)))
+ (dolist (record records)
+ (let ((path (car record)))
+ (when (member (car path) '(:then :else))
+ (setf (gethash (cdr path) hash)
+ (logior (gethash (cdr path) hash 0)
+ (ash (if (cdr record)
+ 1
+ 2)
+ (if (eql (car path) :then)
+ 0
+ 2)))))))
+ (let ((list nil))
+ (maphash (lambda (k v)
+ (push (list mode k v) list))
+ hash)
+ list)))))
+
+;;;; A mutant version of swank-source-path-parser from Swank/Slime.
+
+(defun read-file (filename external-format)
+ "Return the entire contents of FILENAME as a string."
+ (with-open-file (s filename :direction :input
+ :external-format external-format)
+ (let ((string (make-string (file-length s))))
+ (read-sequence string s)
+ string)))
+
+(defun make-source-recorder (fn source-map)
+ "Return a macro character function that does the same as FN, but
+additionally stores the result together with the stream positions
+before and after of calling FN in the hashtable SOURCE-MAP."
+ (declare (type function fn))
+ (lambda (stream char)
+ (declare (optimize debug safety))
+ (let ((start (file-position stream))
+ (values (multiple-value-list (funcall fn stream char)))
+ (end (file-position stream)))
+ (unless (null values)
+ (push (list start end *read-suppress*)
+ (gethash (car values) source-map)))
+ (values-list values))))
+
+(defun make-source-recording-readtable (readtable source-map)
+ "Return a source position recording copy of READTABLE.
+The source locations are stored in SOURCE-MAP."
+ (let* ((tab (copy-readtable readtable))
+ (*readtable* tab))
+ (dotimes (code 128)
+ (let ((char (code-char code)))
+ (multiple-value-bind (fn term) (get-macro-character char tab)
+ (when fn
+ (set-macro-character char (make-source-recorder fn source-map)
+ term tab)))))
+ (suppress-sharp-dot tab)
+ (set-macro-character #\(
+ (make-source-recorder
+ (make-recording-read-list source-map)
+ source-map))
+ tab))
+
+;;; Ripped from SB-IMPL, since location recording on a cons-cell level
+;;; can't be done just by simple read-table tricks.
+(defun make-recording-read-list (source-map)
+ (lambda (stream ignore)
+ (block return
+ (when (eql *package* (find-package :keyword))
+ (return-from return
+ (sb-impl::read-list stream ignore)))
+ (let* ((thelist (list nil))
+ (listtail thelist))
+ (do ((firstchar (sb-impl::flush-whitespace stream)
+ (sb-impl::flush-whitespace stream)))
+ ((char= firstchar #\) ) (cdr thelist))
+ (when (char= firstchar #\.)
+ (let ((nextchar (read-char stream t)))
+ (cond ((sb-impl::token-delimiterp nextchar)
+ (cond ((eq listtail thelist)
+ (unless *read-suppress*
+ (sb-impl::%reader-error
+ stream
+ "Nothing appears before . in list.")))
+ ((sb-impl::whitespace[2]p nextchar)
+ (setq nextchar (sb-impl::flush-whitespace stream))))
+ (rplacd listtail
+ ;; Return list containing last thing.
+ (car (sb-impl::read-after-dot stream nextchar)))
+ (return (cdr thelist)))
+ ;; Put back NEXTCHAR so that we can read it normally.
+ (t (unread-char nextchar stream)))))
+ ;; Next thing is not an isolated dot.
+ (let ((start (file-position stream))
+ (listobj (sb-impl::read-maybe-nothing stream firstchar))
+ (end (file-position stream)))
+ ;; allows the possibility that a comment was read
+ (when listobj
+ (unless (consp (car listobj))
+ (setf (car listobj) (gensym))
+ (push (list start end *read-suppress*)
+ (gethash (car listobj) source-map)))
+ (rplacd listtail listobj)
+ (setq listtail listobj))))))))
+
+(defun suppress-sharp-dot (readtable)
+ (when (get-macro-character #\# readtable)
+ (let ((sharp-dot (get-dispatch-macro-character #\# #\. readtable)))
+ (set-dispatch-macro-character #\# #\. (lambda (&rest args)
+ (let ((*read-suppress* t))
+ (apply sharp-dot args))
+ (if *read-suppress*
+ (values)
+ (list (gensym "#."))))
+ readtable))))
+
+(defun read-and-record-source-map (stream)
+ "Read the next object from STREAM.
+Return the object together with a hashtable that maps
+subexpressions of the object to stream positions."
+ (let* ((source-map (make-hash-table :test #'eq))
+ (*readtable* (make-source-recording-readtable *readtable* source-map))
+ (start (file-position stream))
+ (form (read stream))
+ (end (file-position stream)))
+ ;; ensure that at least FORM is in the source-map
+ (unless (gethash form source-map)
+ (push (list start end nil)
+ (gethash form source-map)))
+ (values form source-map)))
+
+(defun read-source-form (n stream)
+ "Read the Nth toplevel form number with source location recording.
+Return the form and the source-map."
+ (let ((*read-suppress* t))
+ (dotimes (i n)
+ (read stream)))
+ (let ((*read-suppress* nil)
+ (*read-eval* nil))
+ (read-and-record-source-map stream)))
+
+(defun source-path-stream-position (path stream)
+ "Search the source-path PATH in STREAM and return its position."
+ (check-source-path path)
+ (destructuring-bind (tlf-number . path) path
+ (multiple-value-bind (form source-map) (read-source-form tlf-number stream)
+ (source-path-source-position (cons 0 path) form source-map))))
+
+(defun check-source-path (path)
+ (unless (and (consp path)
+ (every #'integerp path))
+ (error "The source-path ~S is not valid." path)))
+
+(defun source-path-string-position (path string)
+ (with-input-from-string (s string)
+ (source-path-stream-position path s)))
+
+(defun source-path-file-position (path filename)
+ (with-open-file (file filename)
+ (source-path-stream-position path file)))
+
+(defun source-path-source-position (path form source-map)
+ "Return the start position of PATH from FORM and SOURCE-MAP. All
+subforms along the path are considered and the start and end position
+of the deepest (i.e. smallest) possible form is returned."
+ ;; compute all subforms along path
+ (let ((forms (loop for n in path
+ for m on path
+ for dummy = (when (eql n :progn)
+ (return forms))
+ for f = form then (nth n f)
+ unless (null (cdr m))
+ collect f into forms
+ finally (return forms))))
+ ;; select the first subform present in source-map
+ (loop for form in (reverse forms)
+ for positions = (gethash form source-map)
+ until (and positions (null (cdr positions)))
+ finally (destructuring-bind ((start end suppress)) positions
+ (declare (ignore suppress))
+ (return (values (1- start) end))))))
--- /dev/null
+;;; -*- Lisp -*-
+
+(defsystem sb-cover
+ #+sb-building-contrib :pathname
+ #+sb-building-contrib "SYS:CONTRIB;SB-COVER;"
+ :components ((:file "cover")))
+
+(defsystem sb-cover-tests
+ :components ((:file "tests")))
+
+(defmethod perform :after ((o load-op) (c (eql (find-system :sb-cover))))
+ (provide 'sb-cover))
+
+(defmethod perform ((o test-op) (c (eql (find-system :sb-cover))))
+ (operate 'load-op 'sb-cover-tests)
+ (operate 'test-op 'sb-cover-tests))
--- /dev/null
+@node sb-cover
+@section sb-cover
+@cindex Code Coverage
+
+The @code{sb-cover} module provides a code coverage tool for SBCL. The
+tool has support for expression coverage, and for some branch coverage.
+Coverage reports are only generated for code compiled using
+@code{compile-file} with the value of the
+@code{sb-cover:store-coverage-data} optimization quality set to 3.
+
+As of SBCL 1.0.6 @code{sb-cover} is still experimental, and the
+interfaces documented here might change in later versions.
+
+@subsection Example Usage
+
+@lisp
+;;; Load SB-COVER
+(require :sb-cover)
+
+;;; Turn on generation of code coverage instrumentation in the compiler
+(declaim (optimize sb-cover:store-coverage-data))
+
+;;; Load some code, ensuring that it's recompiled with the new optimization
+;;; policy.
+(asdf:oos 'asdf:load-op :cl-ppcre-test :force t)
+
+;;; Run the test suite.
+(cl-ppcre-test:test)
+
+;;; Produce a coverage report
+(sb-cover:report "/tmp/report/")
+
+;;; Turn off instrumentation
+(declaim (optimize (sb-cover:store-coverage-data 0)))
+@end lisp
+
+@c @subsection Output
+@c Write some documentation about how to interpret the results
+
+@subsection Functions
+
+@include fun-sb-cover-report.texinfo
+
+@include fun-sb-cover-reset-coverage.texinfo
+
+@include fun-sb-cover-clear-coverage.texinfo
+
--- /dev/null
+(in-package sb-cover-test)
+
+(defun test1 ()
+ (+ 1 2))
+
--- /dev/null
+(in-package sb-cover-test)
+
+(defun test2 (x)
+ (let ((a 0))
+ (when (plusp x)
+ (incf a))
+ a))
+
+;;; This test would show that we do correct detection of non-cons
+;;; source forms in non-PROGN-contexts. Which we don't, so this test
+;;; is commented out.
+#+nil
+(defun test2-b (x)
+ (let ((a 0))
+ (when x
+ (incf a))
+ a))
--- /dev/null
+(defpackage sb-cover-test
+ (:use "CL"))
+
+(in-package sb-cover-test)
+
+(defparameter *path* #.(truename *compile-file-pathname*))
+(defparameter *output-directory*
+ (merge-pathnames (make-pathname :name nil
+ :type nil
+ :version nil
+ :directory '(:relative "test-output"))
+ (make-pathname :directory (pathname-directory *path*))))
+
+(defun report ()
+ (handler-case
+ (sb-cover:report *output-directory*)
+ (warning ()
+ (error "Unexpected warning"))))
+
+(defun report-expect-failure ()
+ (handler-case
+ (progn
+ (sb-cover:report *output-directory*)
+ (error "Should've raised a warning"))
+ (warning ())))
+
+;;; No instrumentation
+(load (compile-file (merge-pathnames #p"test-data-1.lisp" *path*)))
+(report-expect-failure)
+
+;;; Instrument the file, try again
+
+(proclaim '(optimize sb-cover:store-coverage-data))
+(load (compile-file (merge-pathnames #p"test-data-1.lisp" *path*)))
+
+(report)
+
+(assert (probe-file (make-pathname :name "cover-index" :type "html"
+ :defaults *output-directory*)))
+
+;;; None of the code was executed
+(assert (zerop (sb-cover::ok-of (getf sb-cover::*counts* :branch))))
+(assert (zerop (sb-cover::all-of (getf sb-cover::*counts* :branch))))
+(assert (zerop (sb-cover::ok-of (getf sb-cover::*counts* :expression))))
+(assert (plusp (sb-cover::all-of (getf sb-cover::*counts* :expression))))
+
+;;; Call the function again
+(test1)
+(report)
+
+;;; And now we should have complete expression coverage
+(assert (zerop (sb-cover::ok-of (getf sb-cover::*counts* :branch))))
+(assert (zerop (sb-cover::all-of (getf sb-cover::*counts* :branch))))
+(assert (plusp (sb-cover::ok-of (getf sb-cover::*counts* :expression))))
+(assert (= (sb-cover::ok-of (getf sb-cover::*counts* :expression))
+ (sb-cover::all-of (getf sb-cover::*counts* :expression))))
+
+;;; Reset-coverage clears the instrumentation
+(sb-cover:reset-coverage)
+
+(report)
+
+;;; So none of the code should be marked as executed
+(assert (zerop (sb-cover::ok-of (getf sb-cover::*counts* :branch))))
+(assert (zerop (sb-cover::all-of (getf sb-cover::*counts* :branch))))
+(assert (zerop (sb-cover::ok-of (getf sb-cover::*counts* :expression))))
+(assert (plusp (sb-cover::all-of (getf sb-cover::*counts* :expression))))
+
+;;; Forget all about that file
+(sb-cover:clear-coverage)
+(report-expect-failure)
+
+;;; Another file, with some branches
+(load (compile-file (merge-pathnames #p"test-data-2.lisp" *path*)))
+
+(test2 1)
+(report)
+
+;; Complete expression coverage
+(assert (plusp (sb-cover::ok-of (getf sb-cover::*counts* :expression))))
+(assert (= (sb-cover::ok-of (getf sb-cover::*counts* :expression))
+ (sb-cover::all-of (getf sb-cover::*counts* :expression))))
+;; Partial branch coverage
+(assert (plusp (sb-cover::ok-of (getf sb-cover::*counts* :branch))))
+(assert (plusp (sb-cover::all-of (getf sb-cover::*counts* :branch))))
+(assert (/= (sb-cover::ok-of (getf sb-cover::*counts* :branch))
+ (sb-cover::all-of (getf sb-cover::*counts* :branch))))
+
+(test2 0)
+(report)
+
+;; Complete branch coverage
+(assert (= (sb-cover::ok-of (getf sb-cover::*counts* :branch))
+ (sb-cover::all-of (getf sb-cover::*counts* :branch))))
CONTRIBDIR="../../contrib/"
I_FLAGS=-I $(DOCSTRINGDIR) -I $(CONTRIBDIR)
# List of contrib modules that docstring docs will be created for.
-MODULES=':sb-md5 :sb-rotate-byte :sb-grovel :sb-sprof :sb-bsd-sockets'
+MODULES=':sb-md5 :sb-rotate-byte :sb-grovel :sb-sprof :sb-bsd-sockets :sb-cover'
# List of package names that docstring docs will be created for.
-PACKAGES=":COMMON-LISP :SB-ALIEN :SB-DEBUG :SB-EXT :SB-GRAY :SB-MOP :SB-PROFILE :SB-THREAD :SB-MD5 :SB-ROTATE-BYTE :SB-SPROF :SB-BSD-SOCKETS"
+PACKAGES=":COMMON-LISP :SB-ALIEN :SB-DEBUG :SB-EXT :SB-GRAY :SB-MOP :SB-PROFILE :SB-THREAD :SB-MD5 :SB-ROTATE-BYTE :SB-SPROF :SB-BSD-SOCKETS :SB-COVER"
# SBCL_SYSTEM is an optional argument to this make program. If this
# variable is set, its contents are used as the command line for
* sb-grovel::
* sb-md5::
* sb-rotate-byte::
+* sb-cover::
@end menu
@page
@page
@include sb-rotate-byte/sb-rotate-byte.texinfo
+@page
+@include sb-cover/sb-cover.texinfo
"CHECK-UNSIGNED-BYTE-32" "CHECK-UNSIGNED-BYTE-64"
"CLOSURE-INIT" "CLOSURE-REF"
"CODE-CONSTANT-REF" "CODE-CONSTANT-SET"
+ "*CODE-COVERAGE-INFO*"
"COMPILE-IN-LEXENV"
"COMPILE-LAMBDA-FOR-DEFUN"
"%COMPILER-DEFUN" "COMPILER-ERROR" "FATAL-COMPILER-ERROR"
"SOURCE-LOCATION"
"SOURCE-TRANSFORM-LAMBDA"
"SPECIFY-SAVE-TN"
+ "STORE-COVERAGE-DATA"
"TAIL-CALL" "TAIL-CALL-NAMED"
"TAIL-CALL-VARIABLE" "TEMPLATE-OR-LOSE"
"TN" "TN-OFFSET" "TN-P" "TN-REF" "TN-REF-ACROSS" "TN-REF-LOAD-TN"
(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 (gethash form *source-paths*)
+ (and (consp form)
+ (some #'sub form)))))
+ (or (sub form)))))
\f
;;;; BLOCK and TAGBODY
(setf (lvar-reoptimize arg) nil)))
(check-important-result node info)
(let ((fun (fun-info-destroyed-constant-args info)))
- (when fun
+ (when (and fun
+ ;; If somebody is really sure that they want to modify
+ ;; constants, let them.
+ (policy node (> safety 0)))
(let ((destroyed-constant-args (funcall fun args)))
(when destroyed-constant-args
(let ((*compiler-error-context* node))
;;; The hashtables used to hold global namespace info must be
;;; reallocated elsewhere. Note also that *LEXENV* is not bound, so
;;; that local macro definitions can be introduced by enclosing code.
-(defun ir1-toplevel (form path for-value)
+(defun ir1-toplevel (form path for-value &optional (allow-instrumenting t))
(declare (list path))
(let* ((*current-path* path)
(component (make-empty-component))
(*current-component* component)
- (*allow-instrumenting* t))
+ (*allow-instrumenting* allow-instrumenting))
(setf (component-name component) 'initial-component)
(setf (component-kind component) :initial)
(let* ((forms (if for-value `(,form) `(,form nil)))
'(progn
(when (atom subform) (return))
(let ((fm (car subform)))
- (when (consp fm)
- (sub-find-source-paths fm (cons pos path)))
+ (if (consp fm)
+ ;; If it's a cons, recurse
+ (sub-find-source-paths fm (cons pos path))
+ ;; Otherwise store the containing form. It's
+ ;; not perfect, but better than nothing.
+ (setf (gethash subform *source-paths*)
+ (list* 'original-source-start
+ *current-form-number*
+ pos
+ path)))
(incf pos))
(setq subform (cdr subform))
(when (eq subform trail) (return)))))
;; namespace.
(defun ir1-convert (start next result form)
(ir1-error-bailout (start next result form)
- (let ((*current-path* (or (gethash form *source-paths*)
- (cons form *current-path*))))
+ (let* ((*current-path* (or (gethash form *source-paths*)
+ (cons form *current-path*)))
+ (start (instrument-coverage start nil form)))
(cond ((atom form)
(cond ((and (symbolp form) (not (keywordp form)))
(ir1-convert-var start next result form))
(forms body))
(loop
(let ((form (car forms)))
+ (setf this-start
+ (maybe-instrument-progn-like this-start forms form))
(when (endp (cdr forms))
(ir1-convert this-start next result form)
(return))
(setq this-start this-ctran
forms (cdr forms)))))))
(values))
+
+\f
+;;;; code coverage
+
+;;; Check the policy for whether we should generate code coverage
+;;; instrumentation. If not, just return the original START
+;;; ctran. Otherwise ninsert 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 nil))))
+ (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)))
+ ;; 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 (gethash form *source-paths*)))
+ (let ((*current-path* (gethash forms *source-paths*)))
+ (when *current-path*
+ (instrument-coverage start :progn 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) nil)))
+ *code-coverage-info*))
+
\f
;;;; converting combinations
(let ((node (make-combination fun-lvar)))
(setf (lvar-dest fun-lvar) node)
(collect ((arg-lvars))
- (let ((this-start start))
+ (let ((this-start start)
+ (forms args))
(dolist (arg args)
+ (setf this-start
+ (maybe-instrument-progn-like this-start forms arg))
+ (setf forms (cdr forms))
(let ((this-ctran (make-ctran))
(this-lvar (make-lvar node)))
(ir1-convert this-start this-ctran this-lvar arg)
(ir1-convert start next result transformed)))
(ir1-convert-maybe-predicate start next result form var))))))
+;;; KLUDGE: If we insert a synthetic IF for a function with the PREDICATE
+;;; attribute, don't generate any branch coverage instrumentation for it.
+(defvar *instrument-if-for-code-coverage* t)
+
;;; If the function has the PREDICATE attribute, and the RESULT's DEST
;;; isn't an IF, then we convert (IF <form> T NIL), ensuring that a
;;; predicate always appears in a conditional context.
(if (and info
(ir1-attributep (fun-info-attributes info) predicate)
(not (if-p (and result (lvar-dest result)))))
- (ir1-convert start next result `(if ,form t nil))
+ (let ((*instrument-if-for-code-coverage* nil))
+ (ir1-convert start next result `(if ,form t nil)))
(ir1-convert-combination-checking-type start next result form var))))
;;; Actually really convert a global function call that we are allowed
as if it were a constant. If READ-ONLY-P is non-NIL, then the resultant
object is guaranteed to never be modified, so it can be put in read-only
storage."
- (if (producing-fasl-file)
- (multiple-value-bind (handle type)
- (compile-load-time-value (if read-only-p
- form
- `(make-value-cell ,form)))
- (declare (ignore type))
- (ir1-convert start next result
- (if read-only-p
- `(%load-time-value ',handle)
- `(value-cell-ref (%load-time-value ',handle)))))
- (let ((value
- (handler-case (eval form)
- (error (condition)
- (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
- condition)))))
- (ir1-convert start next result
- (if read-only-p
- `',value
- `(value-cell-ref ',(make-value-cell value)))))))
+ (let ((*allow-instrumenting* nil))
+ (if (producing-fasl-file)
+ (multiple-value-bind (handle type)
+ (compile-load-time-value (if read-only-p
+ form
+ `(make-value-cell ,form)))
+ (declare (ignore type))
+ (ir1-convert start next result
+ (if read-only-p
+ `(%load-time-value ',handle)
+ `(value-cell-ref (%load-time-value ',handle)))))
+ (let ((value
+ (handler-case (eval form)
+ (error (condition)
+ (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
+ condition)))))
+ (ir1-convert start next result
+ (if read-only-p
+ `',value
+ `(value-cell-ref ',(make-value-cell value))))))))
(defoptimizer (%load-time-value ir2-convert) ((handle) node block)
(aver (constant-lvar-p handle))
(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))
+
\f
;;;; WITH-COMPILATION-UNIT and WITH-COMPILATION-VALUES
(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)))
(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))
(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
0
3)
("no" "yes" "yes" "yes"))
+
+(define-optimization-quality store-coverage-data
+ 0
+ ("no" "no" "yes" "yes"))
(*toplevel-lambdas* ())
(*block-compile* nil)
(*allow-instrumenting* nil)
+ (*code-coverage-records* nil)
+ (*code-coverage-blocks* nil)
(*compiler-error-bailout*
(lambda (&optional error)
(declare (ignore error))
;; lvar, transforms it into a quoted form, and gives this
;; source transform another chance, so it all works out OK, in a
;; weird roundabout way. -- WHN 2001-03-18
- (if (and (consp spec) (eq (car spec) 'quote))
+ (if (and (consp spec)
+ (eq (car spec) 'quote)
+ (or (not *allow-instrumenting*)
+ (policy *lexenv* (= store-coverage-data 0))))
(source-transform-typep object (cadr spec))
(values nil t)))
\f
(t form))))
(let ((walked-lambda (walk-form method-lambda env #'walk-function)))
- (values walked-lambda
+ ;;; FIXME: the walker's rewriting of the source code causes
+ ;;; trouble when doing code coverage. The rewrites should be
+ ;;; removed, and the same operations done using
+ ;;; compiler-macros or tranforms.
+ (values (if (sb-c:policy env (= sb-c:store-coverage-data 0))
+ walked-lambda
+ method-lambda)
call-next-method-p
closurep
next-method-p-p
(if (eq type t)
nil
`('type-check-function (lambda (value)
- (declare (type ,type value))
+ (declare (type ,type value)
+ (optimize (sb-c:store-coverage-data 0)))
value))))
(canon `(:name ',name :readers ',readers :writers ',writers
:initargs ',initargs
(unless entry
(setq entry (list initform
(gensym)
- `(function (lambda () ,initform))))
+ `(function (lambda ()
+ (declare (optimize
+ (sb-c:store-coverage-data 0)))
+ ,initform))))
(push entry *initfunctions-for-this-defclass*))
(cadr entry)))))
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.5.27"
+"1.0.5.28"
projects / sbcl.git / commitdiff