Changeset 14044


Ignore:
Timestamp:
Jul 26, 2010, 1:18:34 PM (9 years ago)
Author:
gz
Message:

support for reporting code coverage of acode, needs more testing

Location:
trunk/source
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/lambda-list.lisp

    r13067 r14044  
    3535(defun function-source-note (fn)
    3636  (getf (%lfun-info fn) '%function-source-note))
     37
     38(defun %function-acode-string (fn)
     39  (getf (%lfun-info fn) '%function-acode-string))
    3740
    3841(defun uncompile-function (fn)
  • trunk/source/compiler/nx-basic.lisp

    r13971 r14044  
    738738
    739739(defun nx-record-code-coverage-acode (afunc)
    740   (assert (and *nx-current-code-note* (null (afunc-parent afunc))))
     740  (assert *nx-current-code-note*)
    741741  (let* ((form->note (make-hash-table :test #'eq))
    742742         (*nx-acode-inner-refs* nil)
     
    776776                                         (setf (code-note-acode-range note)
    777777                                               (encode-file-range start pos))))))))))))))
    778     (setf (afunc-lfun-info afunc) (list* '%function-acode-string string (afunc-lfun-info afunc)))
     778    (iterate store ((afunc afunc))
     779      (setf (getf (afunc-lfun-info afunc) '%function-acode-string) string)
     780      (loop for inner in (afunc-inner-functions afunc)
     781        unless (getf (afunc-lfun-info inner) '%function-acode-string)
     782        do (store inner)))
    779783    afunc))
    780784
  • trunk/source/library/cover.lisp

    r12300 r14044  
    4747          without-compiling-code-coverage))
    4848
    49 (defconstant $not-executed-style 2)
    50 (defconstant $totally-covered-style 5)
    51 (defconstant $partially-covered-style 6)
     49(defconstant $no-style 0)
     50(defconstant $not-executed-style 1)
     51(defconstant $totally-covered-style 2)
     52(defconstant $partially-covered-style 3)
    5253
    5354(defparameter *file-coverage* ())
     
    5556(defparameter *emitted-code-notes* (make-hash-table :test #'eq))
    5657(defparameter *entry-code-notes* (make-hash-table :test #'eq))
    57 
     58(defparameter *code-note-acode-strings* (make-hash-table :test #'eq))
     59
     60(defparameter *coverage-acode-queue* nil)
    5861
    5962(defstruct (coverage-state (:conc-name "%COVERAGE-STATE-"))
     
    8386(defun entry-code-note-p (note)
    8487  (gethash note *entry-code-notes*))
     88
     89(defun code-note-acode-string (note)
     90  (gethash note *code-note-acode-strings*))
    8591
    8692(defun map-function-coverage (lfun fn &optional refs)
     
    94100              do (map-function-coverage imm fn refs))))
    95101
    96 (defun get-function-coverage (fn refs)
     102(defun get-function-coverage (fn refs acode)
    97103  (let ((entry (function-entry-code-note fn))
    98         (refs (cons fn refs)))
     104        (refs (cons fn refs))
     105        (acode (or (%function-acode-string fn) acode)))
    99106    (declare (dynamic-extent refs))
    100107    (when entry
    101108      (assert (eq fn (gethash entry *entry-code-notes* fn)))
    102       (setf (gethash entry *entry-code-notes*) fn))
     109      (setf (gethash entry *entry-code-notes*) fn)
     110      (when acode
     111        (setf (gethash entry *code-note-acode-strings*) acode)))
    103112    (nconc
    104113     (and entry (list fn))
    105114     (lfunloop for imm in fn
    106115       when (code-note-p imm)
    107        do (setf (gethash imm *emitted-code-notes*) t)
     116       do (progn
     117            (setf (gethash imm *emitted-code-notes*) t)
     118            (when acode
     119              (setf (gethash imm *code-note-acode-strings*) acode)))
    108120       when (and (functionp imm)
    109121                 (not (memq imm refs)))
    110        nconc (get-function-coverage imm refs)))))
     122       nconc (get-function-coverage imm refs acode)))))
    111123
    112124(defun get-coverage ()
     
    115127  (clrhash *emitted-code-notes*)
    116128  (clrhash *entry-code-notes*)
     129  (clrhash *code-note-acode-strings*)
    117130  (loop for data in *code-covered-functions*
    118131        when (consp data)
     
    124137                          (delete-duplicates
    125138                           (loop for fn across toplevel-functions
    126                                 nconc (get-function-coverage fn nil)))
     139                                nconc (get-function-coverage fn nil nil)))
    127140                          toplevel-functions)
    128141                   *file-coverage*)))
     
    132145                 while parent
    133146                 do (pushnew n (gethash parent *coverage-subnotes*))
    134                  until (emitted-code-note-p parent))))
     147                 until (emitted-code-note-p parent)))
     148  (let ((hash (make-hash-table :test #'eq)))
     149    ;; distribute entry acode to the toplevel source note it belongs to.
     150    (loop for entry being the hash-key of *entry-code-notes* using (hash-value fn)
     151      as acode = (code-note-acode-string entry)
     152      as sn = (entry-note-unambiguous-source entry)
     153      as toplevel-sn = (function-source-form-note fn)
     154      do (when sn
     155           (assert toplevel-sn)
     156           (let* ((pos (source-note-end-pos sn))
     157                  (cell (assq acode (gethash toplevel-sn hash))))
     158             (if cell
     159               (setf (cdr cell) (max (cdr cell) pos))
     160               (push (cons acode pos) (gethash toplevel-sn hash))))))
     161    (setf *coverage-acode-queue*
     162          (sort (loop for sn being the hash-key of hash using (hash-value alist)
     163                  collect (cons (source-note-end-pos sn)
     164                                (mapcar #'car (sort alist #'< :key #'cdr))))
     165                #'< :key #'car))))
    135166
    136167#+debug
     
    145176             (when (entry-code-note-p note)
    146177               (format t " (Entry to ~s)" (entry-code-note-p note)))
     178             (when (code-note-acode-range note)
     179               (multiple-value-bind (s e) (decode-file-range (code-note-acode-range note))
     180                 (format t " [acode ~a:~a]" s e)))
    147181             (format t "~%")
    148182             (when (code-note-p note)
     
    531565
    532566
     567(defun style-for-coverage (coverage)
     568  (case coverage
     569    ((full) $totally-covered-style)
     570    ((nil) $not-executed-style)
     571    (t $partially-covered-style)))
     572 
    533573(defun fill-with-text-style (coverage location-note styles)
    534   (let ((style (case coverage
    535                  ((full) $totally-covered-style)
    536                  ((nil) $not-executed-style)
    537                  (t $partially-covered-style))))
    538     (fill styles style
    539           :start (source-note-start-pos location-note)
    540           :end (source-note-end-pos location-note))))
     574  (fill styles (style-for-coverage coverage)
     575        :start (source-note-start-pos location-note)
     576        :end (source-note-end-pos location-note)))
    541577
    542578(defun update-text-styles (note styles)
     
    600636             (return sn))))
    601637
    602  
    603 (defun colorize-function (fn styles &optional refs)
     638(defun colorize-acode (fn acode-styles)
     639  (let* ((acode (%function-acode-string fn))
     640         (note (function-entry-code-note fn))
     641         (range (and note (code-note-acode-range note))))
     642    (when (and acode range)
     643      (let ((styles (or (gethash acode acode-styles)
     644                        (setf (gethash acode acode-styles)
     645                              (make-array (length acode)
     646                                          :initial-element $no-style
     647                                          :element-type '(unsigned-byte 2))))))
     648        (iterate update ((note note))
     649          (multiple-value-bind (start end) (decode-file-range (code-note-acode-range note))
     650            (when (and start
     651                       (setq start (position-if-not #'whitespacep acode :start start :end end)))
     652              (fill styles (style-for-coverage (code-note-code-coverage note))
     653                    :start start
     654                    :end end)))
     655          (loop for sub in (coverage-subnotes note)
     656            unless (entry-code-note-p sub)
     657            do (update sub)))))))
     658
     659(defun colorize-function (fn styles acode-styles &optional refs)
    604660  (let* ((note (function-entry-code-note fn))
    605661         (source (function-source-form-note fn))
     
    608664    ;; Colorize the body of the function
    609665    (when note
    610       (colorize-source-note note styles))
     666      (colorize-source-note note styles)
     667      (colorize-acode fn acode-styles))
    611668    ;; And now any subfunction references
    612669    (lfunloop for imm in fn
     
    622679                                      (warn "Ignoring ref to ~s from ~s" imm fn)
    623680                                      nil)))
    624               do (colorize-function imm styles refs))))
     681              do (colorize-function imm styles acode-styles refs))))
    625682
    626683(defun report-file-coverage (index-file coverage html-stream external-format)
     
    634691                     string)))
    635692         (styles (make-array (length source)
    636                              :initial-element 0
    637                              :element-type '(unsigned-byte 2))))
    638     (map nil #'(lambda (fn) (colorize-function fn styles)) (file-coverage-toplevel-functions coverage))
    639     (print-file-coverage-report index-file html-stream coverage styles source)
     693                             :initial-element $no-style
     694                             :element-type '(unsigned-byte 2)))
     695         (acode-styles (make-hash-table :test #'eq)))
     696    (map nil #'(lambda (fn) (colorize-function fn styles acode-styles)) (file-coverage-toplevel-functions coverage))
     697    (print-file-coverage-report index-file html-stream coverage styles acode-styles source)
    640698    (format html-stream "</body></html>")))
    641699
    642 (defun print-file-coverage-report (index-file html-stream coverage styles source)
     700(defun print-file-coverage-report (index-file html-stream coverage styles acode-styles source)
    643701  (let ((*print-case* :downcase))
    644702    (format html-stream "<h3><a href=~s>Coverage report</a>: ~a <br />~%</h3>~%"
     
    652710
    653711    (format html-stream "<div class='key'><b>Key</b><br />~%")
    654     (format html-stream "<div class='state-~a'>Fully covered - every single instruction executed</div>" $totally-covered-style)
    655     (format html-stream "<div class='state-~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style)
    656     (format html-stream "<div class='state-~a'>Never entered - not a single instruction executed</div>" $not-executed-style)
    657     (format html-stream "<p></p><div><code>~%")
    658 
    659     (flet ((line (line)
    660              (unless (eql line 0)
    661                (format html-stream "</span>"))
    662              (incf line)
    663              (format html-stream "</code></div></nobr>~%<nobr><div class='source'><div class='line-number'><code>~A</code></div><code>&#160;" line)
    664              line))
    665       (loop with line = (line 0) with col = 0
    666         for last-style = nil then style
    667         for char across source
    668         for style across styles
    669         do (unless (eq style last-style)
    670              (when last-style
    671                (format html-stream "</span>"))
    672              (format html-stream "<span class='state-~a'>" style))
     712    (format html-stream "<div class='st~a'>Fully covered - every single instruction executed</div>" $totally-covered-style)
     713    (format html-stream "<div class='st~a'>Partly covered - entered but some subforms not executed</div>" $partially-covered-style)
     714    (format html-stream "<div class='st~a'>Never entered - not a single instruction executed</div>" $not-executed-style)
     715    (format html-stream "</div><p></p>~%")
     716
     717    ;; Output source intertwined with acode
     718    (iterate output ((start 0) (line 0))
     719      (format html-stream "<div class='source'><code>")
     720      (let ((next (car *coverage-acode-queue*)))
     721        (multiple-value-bind (end last-line)
     722                             (output-styled html-stream source styles
     723                                            :start start
     724                                            :line line
     725                                            :limit (car next))
     726          (format html-stream "</code></div>~%")
     727          (when (and next end (<= (car next) end))
     728            (destructuring-bind (pos . strings) next
     729              (format html-stream "<a href=javascript:swap('~d')><span class='toggle' id='p~:*~d'>Show expansion</span></a>~%~
     730                                   <div class='acode' id='a~:*~d'><code>" pos)
     731              (loop for acode in strings as styles = (gethash acode acode-styles)
     732                do (assert styles)
     733                do (output-styled html-stream acode styles)
     734                do (fresh-line html-stream))
     735              (format html-stream "</code></div><hr/>~%"))
     736            (pop *coverage-acode-queue*)
     737            (output (1+ end) last-line)))))))
     738
     739(defun output-styled (html-stream source styles &key (start 0) line limit)
     740  (let ((last-style $no-style)
     741        (col 0)
     742        (line line))
     743    (labels ((outch (char)
     744               (if (eql char #\Tab)
     745                 (dotimes (i (- 8 (mod col 8)))
     746                   (incf col)
     747                   (write-string " " html-stream))
     748                 (progn
     749                   (incf col)
     750                   (if (or (alphanumericp char) (find char "()+-:* ")) ;; common and safe
     751                     (write-char char html-stream)
     752                     (format html-stream "&#~D;" (char-code char))))))
     753             (start-line ()
     754               (when line
     755                 (incf line)
     756                 (format html-stream "<span class='line'>~A</span>" line))
     757               (write-char #\space html-stream)
     758               (setq col 0))
     759             (set-style (new)
     760               (unless (eq last-style new)
     761                 (unless (eq last-style $no-style) (format html-stream "</span>"))
     762                 (unless (eq new $no-style) (format html-stream "<span class='st~a'>" new))
     763                 (setq last-style new)))
     764             (end-line ()
     765               (set-style $no-style)
     766               (format html-stream "~%")))
     767      (declare (inline outch start-line end-line))
     768      (unless limit (setq limit (length source)))
     769      (start-line)
     770      (loop
     771        for pos from start below (length source)
     772        as char = (aref source pos) as style = (aref styles pos)
     773        do (set-style style)
    673774        do (case char
    674775             ((#\Newline)
    675               (setq style nil)
    676               (setq col 0)
    677               (setq line (line line)))
    678              ((#\Space)
    679               (incf col)
    680               (write-string "&#160;" html-stream))
    681              ((#\Tab)
    682               (dotimes (i (- 8 (mod col 8)))
    683                 (incf col)
    684                 (write-string "&#160;" html-stream)))
     776              (end-line)
     777              (when (<= limit pos)
     778                (return (values pos line)))
     779              (start-line))
    685780             (t
    686               (incf col)
    687               (if (alphanumericp char)
    688                 (write-char char html-stream)
    689                 (format html-stream "&#~D;" (char-code char))))))
    690       (format html-stream "</code></div>"))))
     781              (outch char)))
     782        finally (end-line)))))
    691783
    692784
     
    833925(defun write-coverage-styles (html-stream)
    834926  (format html-stream "<style type='text/css'>
    835 *.state-~a { background-color: #ffaaaa }
    836 *.state-~a { background-color: #aaffaa }
    837 *.state-~a { background-color: #44dd44 }
    838 div.key { margin: 20px; width: 88ex }
    839 div.source { width: 98ex; background-color: #eeeeee; padding-left: 5px;
     927*.st~a { background-color: #ffaaaa }
     928*.st~a { background-color: #aaffaa }
     929*.st~a { background-color: #44dd44 }
     930*.key { margin: 20px; width: 88ex }
     931*.source { width: 120ex; background-color: #eeeeee; padding-left: 5px;
    840932             /* border-style: solid none none none; border-width: 1px;
    841              border-color: #dddddd */ }
    842 
    843 *.line-number { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; }
     933             border-color: #dddddd */
     934             white-space: pre; }
     935
     936*.acode { border-left: 1px dashed #c0c0c0;
     937         margin-top: 1ex;
     938         margin-left: 6ex;
     939         margin-bottom: 2ex;
     940         white-space: pre;
     941         display: none; }
     942
     943*.line { color: #666666; float: left; width: 6ex; text-align: right; margin-right: 1ex; }
     944
     945*.toggle { font-size: small; }
    844946
    845947table.summary tr.head-row { background-color: #aaaaff }
     
    850952table.summary tr.subheading { background-color: #aaaaff}
    851953table.summary tr.subheading td { text-align: left; font-weight: bold; padding-left: 5ex; }
    852 </style>"
     954
     955</style>
     956
     957<script type='text/javascript'>
     958function swap (id) {
     959  var acode = document.getElementById('a' + id);
     960  var prompt = document.getElementById('p' + id);
     961  if (acode.style.display == 'block') {
     962      acode.style.display = 'none';
     963      prompt.innerHTML = 'Show expansion';
     964  } else {
     965    acode.style.display = 'block';
     966    prompt.innerHTML = 'Hide expansion';
     967  }
     968}
     969</script>
     970"
    853971          $not-executed-style
    854972          $partially-covered-style
    855973          $totally-covered-style
    856974          ))
     975
Note: See TracChangeset for help on using the changeset viewer.