contrib/sb-cover/cover.lisp

   1 ;;; A frontend for the SBCL code coverage facility. Written by Juho
   2 ;;; Snellman, and placed under public domain.
   3
   4 ;;; This module includes a modified version of the source path parsing
   5 ;;; routines from Swank. That code was written by Helmut Eller, and
   6 ;;; was placed under Public Domain
   7
   8 (defpackage #:sb-cover
   9   (:use #:cl #:sb-c)
  10   (:export #:report
  11            #:reset-coverage #:clear-coverage
  12            #:store-coverage-data))
  13
  14 (in-package #:sb-cover)
  15
  16 (defclass sample-count ()
  17   ((mode :accessor mode-of :initarg :mode)
  18    (all :accessor all-of :initform 0)
  19    (ok :accessor ok-of :initform 0)))
  20
  21 (defun clear-coverage ()
  22   "Clear all files from the coverage database. The files will be re-entered
  23 into the database when the FASL files (produced by compiling
  24 STORE-COVERAGE-DATA optimization policy set to 3) are loaded again into the
  25 image."
  26   (sb-c::clear-code-coverage))
  27
  28 (defun reset-coverage ()
  29   "Reset all coverage data back to the `Not executed` state."
  30   (sb-c::reset-code-coverage))
  31
  32 (defun report (directory &key (external-format :default))
  33   "Print a code coverage report of all instrumented files into DIRECTORY.
  34 If DIRECTORY does not exist, it will be created. The main report will be
  35 printed to the file cover-index.html. The external format of the source
  36 files can be specified with the EXTERNAL-FORMAT parameter."
  37   (let ((paths)
  38         (*default-pathname-defaults* (merge-pathnames (pathname directory))))
  39     (ensure-directories-exist *default-pathname-defaults*)
  40     (maphash (lambda (k v)
  41                (declare (ignore v))
  42                (let* ((n (substitute #\_ #\. (substitute #\_ #\/ k)))
  43                       (path (make-pathname :name n :type "html")))
  44                  (when (probe-file k)
  45                    (with-open-file (stream path
  46                                            :direction :output
  47                                            :if-exists :supersede
  48                                            :if-does-not-exist :create)
  49                      (push (list* k n (report-file k stream external-format))
  50                            paths)))))
  51              *code-coverage-info*)
  52     (let ((report-file (make-pathname :name "cover-index" :type "html")))
  53       (with-open-file (stream report-file
  54                               :direction :output :if-exists :supersede
  55                               :if-does-not-exist :create)
  56         (write-styles stream)
  57         (unless paths
  58           (warn "No coverage data found for any file, producing an empty report. Maybe you~%forgot to (DECLAIM (OPTIMIZE SB-COVER:STORE-COVERAGE-DATA))?")
  59           (format stream "<h3>No code coverage data found.</h3>")
  60           (close stream)
  61           (return-from report))
  62         (format stream "<table class='summary'>")
  63         (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>")
  64         (format stream "<tr class='head-row'>~{<td width='80px'>~A</td>~}</tr>"
  65                 (list "Source file"
  66                       "Covered" "Total" "%"
  67                       "Covered" "Total" "%"))
  68         (setf paths (sort paths #'string< :key #'car))
  69         (loop for prev = nil then source-file
  70               for (source-file report-file expression branch) in paths
  71               for even = nil then (not even)
  72               do (when (or (null prev)
  73                            (not (equal (pathname-directory (pathname source-file))
  74                                        (pathname-directory (pathname prev)))))
  75                    (format stream "<tr class='subheading'><td colspan='7'>~A</td></tr>~%"
  76                            (namestring (make-pathname :directory (pathname-directory (pathname source-file))))))
  77               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>"
  78                          even
  79                          report-file
  80                          (enough-namestring (pathname source-file)
  81                                             (pathname source-file))
  82                          (list (ok-of expression)
  83                                (all-of expression)
  84                                (percent expression)
  85                                (ok-of branch)
  86                                (all-of branch)
  87                                (percent branch))))
  88         (format stream "</table>"))
  89       report-file)))
  90
  91 (defun percent (count)
  92   (unless (zerop (all-of count))
  93     (* 100
  94        (/ (ok-of count) (all-of count)))))
  95
  96 (defun report-file (file html-stream external-format)
  97   "Print a code coverage report of FILE into the stream HTML-STREAM."
  98   (format html-stream "<html><head>")
  99   (write-styles html-stream)
 100   (format html-stream "</head><body>")
 101   (let* ((source (detabify (read-file file external-format)))
 102          (states (make-array (length source)
 103                              :initial-element 0
 104                              :element-type '(unsigned-byte 4)))
 105          ;; Convert the code coverage records to a more suitable format
 106          ;; for this function.
 107          (expr-records (convert-records (gethash file *code-coverage-info*)
 108                                         :expression))
 109          (branch-records (convert-records (gethash file *code-coverage-info*)
 110                                           :branch))
 111          ;; Cache the source-maps
 112          (maps (with-input-from-string (stream source)
 113                  (loop with map = nil
 114                        with form = nil
 115                        with eof = nil
 116                        do (setf (values form map)
 117                                 (handler-case
 118                                     (read-and-record-source-map stream)
 119                                   (end-of-file ()
 120                                     (setf eof t))
 121                                   (error ()
 122                                     (values nil nil))))
 123                        until eof
 124                        when map
 125                        collect (cons form map)))))
 126     (mapcar (lambda (map)
 127               (maphash (lambda (k locations)
 128                          (declare (ignore k))
 129                          (dolist (location locations)
 130                            (destructuring-bind (start end suppress) location
 131                              (when suppress
 132                                (fill-with-state source states 15 (1- start)
 133                                                 end)))))
 134                        (cdr map)))
 135             maps)
 136     ;; Go through all records, find the matching source in the file,
 137     ;; and update STATES to contain the state of the record in the
 138     ;; indexes matching the source location. Process the longest paths
 139     ;; first, so that the state of each index will reflect the state
 140     ;; of the innermost containing form. Processes branch-records
 141     ;; before expr-records of the same length, for the same reason.
 142     (let ((counts (list :branch (make-instance 'sample-count :mode :branch)
 143                         :expression (make-instance 'sample-count
 144                                                    :mode :expression))))
 145       (let ((records (append branch-records expr-records)))
 146         (dolist (record (stable-sort records #'>
 147                                      :key (lambda (e) (length (second e)))))
 148           (destructuring-bind (mode path state) record
 149             (let* ((path (reverse path))
 150                    (tlf (car path))
 151                    (source-form (car (nth tlf maps)))
 152                    (source-map (cdr (nth tlf maps)))
 153                    (source-path (cdr path)))
 154               (cond ((eql mode :branch)
 155                      (let ((count (getf counts :branch)))
 156                        ;; For branches mode each record accounts for two paths
 157                        (incf (ok-of count)
 158                              (ecase state
 159                                (5 2)
 160                                ((6 9) 1)
 161                                (10 0)))
 162                        (incf (all-of count) 2)))
 163                     (t
 164                      (let ((count (getf counts :expression)))
 165                        (when (eql state 1)
 166                          (incf (ok-of count)))
 167                        (incf (all-of count)))))
 168               (if source-map
 169                   (handler-case
 170                       (multiple-value-bind (start end)
 171                           (source-path-source-position (cons 0 source-path)
 172                                                        source-form
 173                                                        source-map)
 174                         (fill-with-state source states state start end))
 175                     (error ()
 176                       (warn "Error finding source location for source path ~A in file ~A~%" source-path file)))
 177                   (warn "Unable to find a source map for toplevel form ~A in file ~A~%" tlf file))))))
 178       (print-report html-stream file counts states source)
 179       (format html-stream "</body></html>")
 180       (list (getf counts :expression)
 181             (getf counts :branch)))))
 182
 183 (defun fill-with-state (source states state start end)
 184   (let* ((pos (position #\Newline source
 185                         :end start
 186                         :from-end t))
 187          (start-column (if pos
 188                            (- start 1 pos)
 189                            0))
 190          (end-column 0))
 191     (loop for i from start below end
 192           for col from start-column
 193           for char = (aref source i)
 194           do (cond ((eql char #\Newline)
 195                     (setf col -1))
 196                    ((not (eql char #\Space))
 197                     (setf end-column (max end-column col)))))
 198     (loop for i from start below end
 199           for col from start-column
 200           for char = (aref source i)
 201           do (if (eql char #\Newline)
 202                  (setf col -1)
 203                  (when (and (zerop (aref states i))
 204                             #+nil (<= col end-column)
 205                             (>= col start-column))
 206                    (setf (aref states i) state))))))
 207
 208 ;;; Convert tabs to spaces
 209 (defun detabify (source)
 210   (with-output-to-string (stream)
 211     (loop for char across source
 212           for col from 0
 213           for i from 0
 214           do (if (eql char #\Tab)
 215                  (loop repeat (- 8 (mod col 8))
 216                        do (write-char #\Space stream)
 217                        do (incf col)
 218                        finally (decf col))
 219                  (progn
 220                    (when (eql char #\Newline)
 221                      ;; Filter out empty last line
 222                      (when (eql i (1- (length source)))
 223                        (return))
 224                      (setf col -1))
 225                    (write-char char stream))))))
 226
 227 (defvar *counts* nil)
 228
 229 (defun print-report (html-stream file counts states source)
 230   ;; Just used for testing
 231   (setf *counts* counts)
 232   (let ((*print-case* :downcase))
 233     (format html-stream
 234             "<h3>Coverage report: ~a <br />~%</h3>~%" file)
 235     (when (zerop (all-of (getf counts :expression)))
 236       (format html-stream "<b>File has no instrumented forms</b>")
 237       (return-from print-report))
 238     (format html-stream "<table class='summary'><tr class='head-row'>~{<td width='80px'>~a</td>~}"
 239             (list "Kind" "Covered" "All" "%"))
 240     (dolist (mode '(:expression :branch))
 241       (let ((count (getf counts mode)))
 242         (format html-stream "<tr class='~:[odd~;even~]'><td>~A</td><td>~a</td><td>~a</td><td>~5,1F</td></tr>~%"
 243                 (eql mode :branch)
 244                 mode
 245                 (ok-of count)
 246                 (all-of count)
 247                 (percent count))))
 248     (format html-stream "</table>"))
 249   (format html-stream "<div class='key'><b>Key</b><br />~%")
 250   (format html-stream "<div class='state-0'>Not instrumented</div>")
 251   (format html-stream "<div class='state-15'>Conditionalized out</div>")
 252   (format html-stream "<div class='state-1'>Executed</div>")
 253   (format html-stream "<div class='state-2'>Not executed</div>")
 254   (format html-stream "<div>&#160;</div>")
 255   (format html-stream "<div class='state-5'>Both branches taken</div>")
 256   (format html-stream "<div class='state-6'>One branch taken</div>")
 257   (format html-stream "<div class='state-10''>Neither branch taken</div>")
 258   (format html-stream "</div>")
 259   (format html-stream "<nobr><div><code>~%")
 260   (flet ((line (line)
 261            (format html-stream "</code></div></nobr>~%<nobr><div class='source'><div class='line-number'><code>~A</code></div><code>&#160;" line)
 262            line))
 263     (loop for last-state = nil then state
 264           with line = (line 1)
 265           for col from 1
 266           for char across source
 267           for state across states
 268           do (unless (eq state last-state)
 269                (when last-state
 270                  (format html-stream "</span>"))
 271                (format html-stream "<span class='state-~a'>" state))
 272           do (case char
 273                ((#\Newline)
 274                 (setf state nil)
 275                 (setf col 0)
 276                 (format html-stream "</span>")
 277                 (line (incf line)))
 278                ((#\Space)
 279                 (format html-stream "&#160;"))
 280                ((#\Tab)
 281                 (error "tab"))
 282                (t
 283                 (if (alphanumericp char)
 284                     (write-char char html-stream)
 285                     (format html-stream "&#~A;" (char-code char))))))
 286     (format html-stream "</code></div>")))
 287
 288 (defun write-styles (html-stream)
 289   (format html-stream "<style type='text/css'>
 290 *.state-0 { background-color: #eeeeee }
 291 *.state-1 { background-color: #aaffaa }
 292 *.state-5 { background-color: #44dd44 }
 293 *.state-2 { background-color: #ffaaaa }
 294 *.state-10 { background-color: #ee6666 }
 295 *.state-15 { color: #aaaaaa; background-color: #eeeeee }
 296 *.state-9,*.state-6 { background-color: #ffffaa }
 297 div.key { margin: 20px; width: 200px }
 298 div.source { width: 88ex; background-color: #eeeeee; padding-left: 5px;
 299              /* border-style: solid none none none; border-width: 1px;
 300              border-color: #dddddd */ }
 301
 302 *.line-number { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; }
 303
 304 table.summary tr.head-row { background-color: #aaaaff }
 305 table.summary tr td.text-cell { text-align: left }
 306 table.summary tr td.main-head { text-align: center }
 307 table.summary tr td { text-align: right }
 308 table.summary tr.even { background-color: #eeeeff }
 309 table.summary tr.subheading { background-color: #aaaaff}
 310 table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; }
 311 </style>"))
 312
 313 (defun convert-records (records mode)
 314   (ecase mode
 315     (:expression
 316      (loop for record in records
 317            unless (member (caar record) '(:then :else))
 318            collect (list mode
 319                          (car record)
 320                          (ecase (cdr record)
 321                            ((t) 1)
 322                            ((nil) 2)))))
 323     (:branch
 324      (let ((hash (make-hash-table :test 'equal)))
 325        (dolist (record records)
 326          (let ((path (car record)))
 327            (when (member (car path) '(:then :else))
 328              (setf (gethash (cdr path) hash)
 329                    (logior (gethash (cdr path) hash 0)
 330                            (ash (if (cdr record)
 331                                     1
 332                                     2)
 333                                 (if (eql (car path) :then)
 334                                     0
 335                                     2)))))))
 336        (let ((list nil))
 337          (maphash (lambda (k v)
 338                     (push (list mode k v) list))
 339                   hash)
 340          list)))))
 341
 342 ;;;; A mutant version of swank-source-path-parser from Swank/Slime.
 343
 344 (defun read-file (filename external-format)
 345   "Return the entire contents of FILENAME as a string."
 346   (with-open-file (s filename :direction :input
 347                      :external-format external-format)
 348     (let ((string (make-string (file-length s))))
 349       (read-sequence string s)
 350       string)))
 351
 352 (defun make-source-recorder (fn source-map)
 353   "Return a macro character function that does the same as FN, but
 354 additionally stores the result together with the stream positions
 355 before and after of calling FN in the hashtable SOURCE-MAP."
 356   (declare (type function fn))
 357   (lambda (stream char)
 358     (declare (optimize debug safety))
 359     (let ((start (file-position stream))
 360           (values (multiple-value-list (funcall fn stream char)))
 361           (end (file-position stream)))
 362       (unless (null values)
 363         (push (list start end *read-suppress*)
 364               (gethash (car values) source-map)))
 365       (values-list values))))
 366
 367 (defun make-source-recording-readtable (readtable source-map)
 368   "Return a source position recording copy of READTABLE.
 369 The source locations are stored in SOURCE-MAP."
 370   (let* ((tab (copy-readtable readtable))
 371          (*readtable* tab))
 372     (dotimes (code 128)
 373       (let ((char (code-char code)))
 374         (multiple-value-bind (fn term) (get-macro-character char tab)
 375           (when fn
 376             (set-macro-character char (make-source-recorder fn source-map)
 377                                  term tab)))))
 378     (suppress-sharp-dot tab)
 379     (set-macro-character #\(
 380                          (make-source-recorder
 381                           (make-recording-read-list source-map)
 382                           source-map))
 383     tab))
 384
 385 ;;; Ripped from SB-IMPL, since location recording on a cons-cell level
 386 ;;; can't be done just by simple read-table tricks.
 387 (defun make-recording-read-list (source-map)
 388   (lambda (stream ignore)
 389     (block return
 390       (when (eql *package* (find-package :keyword))
 391         (return-from return
 392           (sb-impl::read-list stream ignore)))
 393       (let* ((thelist (list nil))
 394              (listtail thelist))
 395         (do ((firstchar (sb-impl::flush-whitespace stream)
 396                         (sb-impl::flush-whitespace stream)))
 397             ((char= firstchar #\) ) (cdr thelist))
 398           (when (char= firstchar #\.)
 399             (let ((nextchar (read-char stream t)))
 400               (cond ((sb-impl::token-delimiterp nextchar)
 401                      (cond ((eq listtail thelist)
 402                             (unless *read-suppress*
 403                               (sb-impl::%reader-error
 404                                stream
 405                                "Nothing appears before . in list.")))
 406                            ((sb-impl::whitespace[2]p nextchar)
 407                             (setq nextchar (sb-impl::flush-whitespace stream))))
 408                      (rplacd listtail
 409                              ;; Return list containing last thing.
 410                              (car (sb-impl::read-after-dot stream nextchar)))
 411                      (return (cdr thelist)))
 412                     ;; Put back NEXTCHAR so that we can read it normally.
 413                     (t (unread-char nextchar stream)))))
 414           ;; Next thing is not an isolated dot.
 415           (let ((start (file-position stream))
 416                 (listobj (sb-impl::read-maybe-nothing stream firstchar))
 417                 (end (file-position stream)))
 418             ;; allows the possibility that a comment was read
 419             (when listobj
 420              (unless (consp (car listobj))
 421                 (setf (car listobj) (gensym))
 422                 (push (list start end *read-suppress*)
 423                       (gethash (car listobj) source-map)))
 424               (rplacd listtail listobj)
 425               (setq listtail listobj))))))))
 426
 427 (defun suppress-sharp-dot (readtable)
 428   (when (get-macro-character #\# readtable)
 429     (let ((sharp-dot (get-dispatch-macro-character #\# #\. readtable)))
 430       (set-dispatch-macro-character #\# #\. (lambda (&rest args)
 431                                               (let ((*read-suppress* t))
 432                                                 (apply sharp-dot args))
 433                                               (if *read-suppress*
 434                                                   (values)
 435                                                   (list (gensym "#."))))
 436                                     readtable))))
 437
 438 (defun read-and-record-source-map (stream)
 439   "Read the next object from STREAM.
 440 Return the object together with a hashtable that maps
 441 subexpressions of the object to stream positions."
 442   (let* ((source-map (make-hash-table :test #'eq))
 443          (*readtable* (make-source-recording-readtable *readtable* source-map))
 444          (start (file-position stream))
 445          (form (read stream))
 446          (end (file-position stream)))
 447     ;; ensure that at least FORM is in the source-map
 448     (unless (gethash form source-map)
 449       (push (list start end nil)
 450             (gethash form source-map)))
 451     (values form source-map)))
 452
 453 (defun read-source-form (n stream)
 454   "Read the Nth toplevel form number with source location recording.
 455 Return the form and the source-map."
 456   (let ((*read-suppress* t))
 457     (dotimes (i n)
 458       (read stream)))
 459   (let ((*read-suppress* nil)
 460         (*read-eval* nil))
 461     (read-and-record-source-map stream)))
 462
 463 (defun source-path-stream-position (path stream)
 464   "Search the source-path PATH in STREAM and return its position."
 465   (check-source-path path)
 466   (destructuring-bind (tlf-number . path) path
 467     (multiple-value-bind (form source-map) (read-source-form tlf-number stream)
 468       (source-path-source-position (cons 0 path) form source-map))))
 469
 470 (defun check-source-path (path)
 471   (unless (and (consp path)
 472                (every #'integerp path))
 473     (error "The source-path ~S is not valid." path)))
 474
 475 (defun source-path-string-position (path string)
 476   (with-input-from-string (s string)
 477     (source-path-stream-position path s)))
 478
 479 (defun source-path-file-position (path filename)
 480   (with-open-file (file filename)
 481     (source-path-stream-position path file)))
 482
 483 (defun source-path-source-position (path form source-map)
 484   "Return the start position of PATH from FORM and SOURCE-MAP.  All
 485 subforms along the path are considered and the start and end position
 486 of the deepest (i.e. smallest) possible form is returned."
 487   ;; compute all subforms along path
 488   (let ((forms (loop for n in path
 489                      for m on path
 490                      for dummy = (when (eql n :progn)
 491                                    (return forms))
 492                      for f = form then (nth n f)
 493                      unless (null (cdr m))
 494                      collect f into forms
 495                      finally (return forms))))
 496     ;; select the first subform present in source-map
 497     (loop for form in (reverse forms)
 498           for positions = (gethash form source-map)
 499           until (and positions (null (cdr positions)))
 500           finally (destructuring-bind ((start end suppress)) positions
 501                     (declare (ignore suppress))
 502                     (return (values (1- start) end))))))