Changeset 14733 for release/1.6


Ignore:
Timestamp:
Apr 25, 2011, 7:15:59 PM (8 years ago)
Author:
gz
Message:

Merge source location and code coverage fixes from trunk (r14717, r14718)

Location:
release/1.6/source
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/1.6/source

  • release/1.6/source/level-0/l0-misc.lisp

    • Property svn:mergeinfo changed (with no actual effect on merging)
  • release/1.6/source/lib/nfcomp.lisp

    r14691 r14733  
    10881088  ;; don't need to check explicitly.
    10891089  (unless (eq *fcomp-loading-toplevel-location* *loading-toplevel-location*)
     1090    (fcomp-compile-toplevel-forms env)
    10901091    (setq *fcomp-loading-toplevel-location* *loading-toplevel-location*)
    10911092    (fcomp-output-form $fasl-toplevel-location env *loading-toplevel-location*)))
  • release/1.6/source/library/cover.lisp

    r14493 r14733  
    5656(defparameter *emitted-code-notes* (make-hash-table :test #'eq))
    5757(defparameter *entry-code-notes* (make-hash-table :test #'eq))
     58(defparameter *source-coverage* (make-hash-table :test #'eq))
    5859
    5960(defstruct (coverage-state (:conc-name "%COVERAGE-STATE-"))
     
    6667
    6768
     69(defstruct (ccl:coverage-statistics (:conc-name "COVERAGE-"))
     70  source-file
     71  expressions-total
     72  expressions-entered
     73  expressions-covered
     74  unreached-branches
     75  code-forms-total
     76  code-forms-covered
     77  functions-total
     78  functions-fully-covered
     79  functions-partly-covered
     80  functions-not-entered)
     81
     82
    6883(defun file-coverage-file (entry)
    6984  (car entry))
     
    7388
    7489(defun file-coverage-toplevel-functions (entry)
    75   (cddr entry))
     90  (caddr entry))
     91
     92(defun file-coverage-statistics (entry)
     93  (cdddr entry))
    7694
    7795(defun coverage-subnotes (note) ;; reversed parent chain
     
    83101(defun entry-code-note-p (note)
    84102  (gethash note *entry-code-notes*))
     103
     104(defun source-coverage (source-note)
     105  (gethash source-note *source-coverage*))
    85106
    86107(defun map-function-coverage (lfun fn &optional refs)
     
    135156  (clrhash *emitted-code-notes*)
    136157  (clrhash *entry-code-notes*)
     158  (clrhash *source-coverage*)
    137159  (loop for data in *code-covered-functions*
    138160        do (let* ((file (code-covered-info.file data))
     
    145167                                      (loop for fn across toplevel-functions
    146168                                            nconc (get-function-coverage fn nil))))
    147                       (coverage (list* file all-functions toplevel-functions)))
     169                      (coverage (list* file
     170                                       all-functions
     171                                       toplevel-functions
     172                                       (make-coverage-statistics :source-file file))))
    148173                 (push coverage *file-coverage*)))))
    149174  ;; Now get subnotes, including un-emitted ones.
     
    152177                 while parent
    153178                 do (pushnew n (gethash parent *coverage-subnotes*))
    154                  until (emitted-code-note-p parent))))
     179                 until (emitted-code-note-p parent)))
     180  ;; Now get source mapping
     181  (loop for coverage in *file-coverage*
     182        do (precompute-source-coverage coverage)
     183        ;; bit of overkill, but we end up always wanting them.
     184        do (compute-file-coverage-statistics coverage)))
    155185
    156186(defun file-coverage-acode-queue (coverage)
     
    204234  (code-covered-info.fns (assoc-by-filename path *code-covered-functions*)))
    205235
    206 (defun clear-coverage ()
     236(defun ccl:clear-coverage ()
    207237  "Clear all files from the coverage database. The files will be re-entered
    208238into the database when the FASL files (produced by compiling with
     
    215245                                  (setf (code-note-code-coverage note) nil))))
    216246
    217 (defun reset-coverage ()
     247(defun ccl:reset-coverage ()
    218248  "Reset all coverage data back to the `Not executed` state."
    219249  (loop for data in *code-covered-functions*
     
    318348
    319349
    320 (defun save-coverage ()
     350(defun ccl:save-coverage ()
    321351  "Returns a snapshot of the current coverage state"
    322352  (make-coverage-state
     
    326356                               data (map 'vector #'save-function-coverage (code-covered-info.fns data))))))
    327357
    328 (defun combine-coverage (coverage-states)
     358(defun ccl:combine-coverage (coverage-states)
    329359  (let ((result nil))
    330360    (map nil
     
    355385
    356386
    357 (defun restore-coverage (coverage-state)
     387(defun ccl:restore-coverage (coverage-state)
    358388  "Restore the code coverage data back to an earlier state produced by SAVE-COVERAGE."
    359389  (loop for saved-data in (coverage-state-alist coverage-state)
     
    379409(defvar *loading-coverage*)
    380410
    381 (defun write-coverage-to-file (coverage pathname)
     411(defun ccl:write-coverage-to-file (coverage pathname)
    382412  "Write the coverage state COVERAGE in the file designated by PATHNAME"
    383413  (with-open-file (stream pathname
     
    391421    (values)))
    392422 
    393 (defun read-coverage-from-file (pathname)
     423(defun ccl:read-coverage-from-file (pathname)
    394424  " Return the coverage state saved in the file.  Doesn't affect the current coverage state."
    395425  (let ((*package* (pkg-arg "CCL"))
     
    400430    (make-coverage-state :alist *loading-coverage*)))
    401431
    402 (defun save-coverage-in-file (pathname)
     432(defun ccl:save-coverage-in-file (pathname)
    403433  "Save the current coverage state in the file designed by PATHNAME"
    404434  (write-coverage-to-file (save-coverage) pathname))
    405435
    406 (defun restore-coverage-from-file (pathname)
     436(defun ccl:restore-coverage-from-file (pathname)
    407437  "Set the current coverage state from the file designed by PATHNAME"
    408438  (restore-coverage (read-coverage-from-file pathname)))
     
    433463
    434464
    435 (defstruct (coverage-statistics (:conc-name "COVERAGE-"))
    436   source-file
    437   expressions-total
    438   expressions-entered
    439   expressions-covered
    440   unreached-branches
    441   code-forms-total
    442   code-forms-covered
    443   functions-total
    444   functions-fully-covered
    445   functions-partly-covered
    446   functions-not-entered)
    447 
    448 (defun coverage-statistics ()
     465(defun ccl:coverage-statistics ()
    449466  (let* ((*file-coverage* nil)
    450467         (*coverage-subnotes* (make-hash-table :test #'eq :shared nil))
    451468         (*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
    452          (*entry-code-notes* (make-hash-table :test #'eq :shared nil)))
    453     (get-coverage)
    454     (loop for coverage in *file-coverage*
    455           as stats = (make-coverage-statistics :source-file (file-coverage-file coverage))
    456           do (map nil (lambda (fn)
    457                         (let ((note (function-entry-code-note fn)))
    458                           (when note (precompute-note-coverage note))))
    459                   (file-coverage-toplevel-functions coverage))
    460           do (destructuring-bind (total entered %entered covered %covered)
    461                  (count-covered-sexps coverage)
    462                (declare (ignore %entered %covered))
    463                (setf (coverage-expressions-total stats) total)
    464                (setf (coverage-expressions-entered stats) entered)
    465                (setf (coverage-expressions-covered stats) covered))
    466           do (let ((count (count-unreached-branches coverage)))
    467                (setf (coverage-unreached-branches stats) count))
    468           do (destructuring-bind (total covered %covered) (count-covered-aexps coverage)
    469                (declare (ignore %covered))
    470                (setf (coverage-code-forms-total stats) total)
    471                (setf (coverage-code-forms-covered stats) covered))
    472           do (destructuring-bind (total fully %fully partly %partly never %never)
    473                  (count-covered-entry-notes coverage)
    474                (declare (ignore %fully %partly %never))
    475                (setf (coverage-functions-total stats) total)
    476                (setf (coverage-functions-fully-covered stats) fully)
    477                (setf (coverage-functions-partly-covered stats) partly)
    478                (setf (coverage-functions-not-entered stats) never))
    479           collect stats)))
    480 
    481 
    482 (defun report-coverage (output-file &key (external-format :default) (statistics t) (html t))
     469         (*entry-code-notes* (make-hash-table :test #'eq :shared nil))
     470         (*source-coverage* (make-hash-table :test #'eq :shared nil)))
     471    (get-coverage)
     472    (mapcar #'file-coverage-statistics *file-coverage*)))
     473
     474(defun compute-file-coverage-statistics (coverage)
     475  (count-covered-sexps coverage)
     476  (count-unreached-branches coverage)
     477  (count-covered-aexps coverage)
     478  (count-covered-entry-notes coverage))
     479
     480
     481(defun ccl:report-coverage (output-file &key (external-format :default) (statistics t) (html t))
    483482  "If :HTML is non-nil, generate an HTML report, consisting of an index file in OUTPUT-FILE
    484483and, in the same directory, one html file for each instrumented source file that has been
     
    496495         (*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
    497496         (*entry-code-notes* (make-hash-table :test #'eq :shared nil))
     497         (*source-coverage* (make-hash-table :test #'eq :shared nil))
    498498         (index-file (and html (merge-pathnames output-file "index.html")))
    499499         (stats-file (and statistics (merge-pathnames (if (or (stringp statistics)
     
    583583  (when html-stream (format html-stream "</table>")))
    584584
    585 (defun precompute-note-coverage (note &optional refs)
    586   (when note
    587     (let ((subnotes (coverage-subnotes note))
    588           (refs (cons note refs)))
    589       (declare (dynamic-extent refs))
    590       (loop for sub in subnotes
    591             when (member sub refs)
    592             do (break "Circularity!!")
    593             unless (member sub refs)
    594             do (precompute-note-coverage sub refs))
    595       (when (and (or (not (emitted-code-note-p note))
    596                      (code-note-code-coverage note))
    597                  (loop for sub in subnotes
    598                        always (or (eq 'full (code-note-code-coverage sub))
    599                                   (entry-code-note-p sub))))
    600         (setf (code-note-code-coverage note) 'full)))))
    601 
    602 
    603585(defun style-for-coverage (coverage)
    604586  (case coverage
     
    607589    (t $partially-covered-style)))
    608590 
    609 (defun fill-with-text-style (coverage location-note styles)
    610   (fill styles (style-for-coverage coverage)
    611         :start (source-note-start-pos location-note)
    612         :end (source-note-end-pos location-note)))
     591(defun fill-with-text-style (source-note styles)
     592  (fill styles (style-for-coverage (source-coverage source-note))
     593        :start (source-note-start-pos source-note)
     594        :end (source-note-end-pos source-note)))
    613595
    614596(defun update-text-styles (note styles)
    615597  (let ((source (code-note-source-note note)))
    616598    (when source
    617       (fill-with-text-style (code-note-code-coverage note) source styles))
     599      (fill-with-text-style source styles))
    618600    (unless (and (emitted-code-note-p note)
    619601                 (memq (code-note-code-coverage note) '(nil full))
     
    643625        finally (return (code-note-source-note n))))
    644626
     627;; In some cases, a single source form may be claimed by multiple code notes.  Precompute
     628;; per-source coverage info so coloring can reflect aggregated info for all coverage points.
     629;; This also changes coverage flag to 'full if all subforms are called.
     630(defun precompute-source-coverage (coverage)
     631  (labels
     632      ((record-1 (source note)
     633         (when source
     634           (let ((old (gethash source *source-coverage* :default))
     635                 (new (code-note-code-coverage note)))
     636             (unless (eq old new)
     637               (setf (gethash source *source-coverage*) (if (eq old :default) new t))))))
     638       (record* (note)
     639         (loop with full = (or (code-note-code-coverage note)
     640                               (not (emitted-code-note-p note)))
     641               for sub in (coverage-subnotes note)
     642               unless (entry-code-note-p sub)
     643                 do (progn
     644                      (record* sub)
     645                      (unless (eq (code-note-code-coverage sub) 'full)
     646                        (setq full nil)))
     647               finally (when full
     648                         (setf (code-note-code-coverage note) 'full)))
     649         (record-1 (code-note-source-note note) note))
     650       (record-entry (note)
     651         (record* note)
     652         ;; A special kludge for entry notes:
     653         ;; In cases like (setq foo (function (lambda (x) x))), we can colorize "(setq foo (function "
     654         ;; based on whether the setq got executed, and "(lambda (x) x)" on whether the inner
     655         ;; function got executed.  However, suppose have a macro "(setq-fun foo (x) x)" that
     656         ;; expanded into the above, there isn't a clear way to show the distinction between
     657         ;; just referencing the inner fn and executing it.  In practice, the colorization
     658         ;; based on the inner function is more interesting -- consider for example DEFUN,
     659         ;; nobody cares whether the defun form itself got executed.
     660         ;; So when showing the colorization of an inner function, we usurp the whole nearest source
     661         ;; form, provided it can be done unambiguously.
     662         (record-1 (entry-note-unambiguous-source note) note)))
     663    (map-coverage-entry-notes coverage #'record-entry)))
     664
    645665(defun colorize-source-note (note styles)
    646   ;; Change coverage flag to 'full if all subforms are covered.
    647   (precompute-note-coverage note)
    648   ;; Now actually change text styles, from outside in.
    649   ;; But first, a special kludge:
    650   ;; In cases like (setq foo (function (lambda (x) x))), we can colorize "(setq foo (function "
    651   ;; based on whether the setq got executed, and "(lambda (x) x)" on whether the inner
    652   ;; function got executed.  However, suppose have a macro "(setq-fun foo (x) x)" that
    653   ;; expanded into the above, there isn't a clear way to show the distinction between
    654   ;; just referencing the inner fn and executing it.  In practice, the colorization
    655   ;; based on the inner function is more interesting -- consider for example DEFUN,
    656   ;; nobody cares whether the defun form itself got executed.
    657   ;; So when showing the colorization of an inner function, we usurp the whole nearest source
    658   ;; form, provided it can be done unambiguously.
    659   (let ((n (entry-note-unambiguous-source note)))
    660     (when n
    661       (fill-with-text-style (code-note-code-coverage note) n styles)))
     666  ;; See comment in precompute-source-coverage
     667  (let ((source (entry-note-unambiguous-source note)))
     668    (when source
     669      (fill-with-text-style source styles)))
    662670  (update-text-styles note styles))
    663671
     
    854862    (format stats-stream "~a," (file-coverage-file coverage)))
    855863
    856   (let ((exp-counts (count-covered-sexps coverage)))
     864  (let* ((stats (file-coverage-statistics coverage))
     865         (total (coverage-expressions-total stats))
     866         (entered (coverage-expressions-entered stats))
     867         (covered (coverage-expressions-covered stats))
     868         (exp-counts (list total
     869                           entered (if (> total 0) (* 100.0d0 (/ entered total)) '--)
     870                           covered (if (> total 0) (* 100.0d0 (/ covered total)) '--))))
    857871    (when html-stream
    858872      (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}" exp-counts))
     
    860874      (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts)))
    861875
    862   (let ((count (count-unreached-branches coverage)))
     876  (let ((count (coverage-unreached-branches (file-coverage-statistics coverage))))
    863877    (when html-stream
    864878      (format html-stream "<td>~:[-~;~:*~a~]</td>" count))
     
    866880      (format stats-stream "~:[~;~:*~a~]," count)))
    867881
    868   (let ((exp-counts (count-covered-aexps coverage)))
     882  (let* ((stats (file-coverage-statistics coverage))
     883         (total (coverage-code-forms-total stats))
     884         (covered (coverage-code-forms-covered stats))
     885         (exp-counts (list total covered (if (> total 0) (* 100.0d0 (/ covered total)) '--))))
    869886    (when html-stream
    870887      (format html-stream "~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}" exp-counts))
     
    872889      (format stats-stream "~{~:[~;~:*~a~],~:[~;~:*~a~],~:[~;~:*~5,1f%~],~}" exp-counts)))
    873890
    874   (destructuring-bind (total . counts) (count-covered-entry-notes coverage)
     891  (let* ((stats (file-coverage-statistics coverage))
     892         (total (coverage-functions-total stats))
     893         (fully (coverage-functions-fully-covered stats))
     894         (partly (coverage-functions-partly-covered stats))
     895         (never (coverage-functions-not-entered stats))
     896         (counts (list fully
     897                       (if (> total 0) (* 100.0 (/ fully total)) '--)
     898                       partly
     899                       (if (> total 0) (* 100.0 (/ partly total)) '--)
     900                       never
     901                       (if (> total 0) (* 100.0 (/ never total)) '--))))
    875902    (when html-stream
    876903      (format html-stream "<td>~:[-~;~:*~a~]</td>~{<td>~:[-~;~:*~a~]</td><td>~:[-~;~:*~5,1f%~]</td>~}</tr>" total counts))
     
    899926           ((nil) (incf never))
    900927           (t (incf partly)))))
    901     (if (> total 0)
    902         (list total
    903               fully (* 100.0 (/ fully total))
    904               partly (* 100.0 (/ partly total))
    905               never (* 100.0 (/ never total)))
    906         '(0 0 -- 0 -- 0 --))))
     928    (let ((stats (file-coverage-statistics coverage)))
     929      (setf (coverage-functions-total stats) total)
     930      (setf (coverage-functions-fully-covered stats) fully)
     931      (setf (coverage-functions-partly-covered stats) partly)
     932      (setf (coverage-functions-not-entered stats) never))))
    907933
    908934(defun count-covered-aexps (coverage)
     
    919945                        unless (entry-code-note-p sub) do (rec sub))))
    920946         (rec note))))
    921     (list total covered (if (> total 0) (* 100.0d0 (/ covered total)) '--))))
     947    (let ((stats (file-coverage-statistics coverage)))
     948      (setf (coverage-code-forms-total stats) total)
     949      (setf (coverage-code-forms-covered stats) covered))))
    922950
    923951(defun count-covered-sexps (coverage)
    924952  ;; Count the number of source expressions that have been entered (regardless
    925953  ;; of whether or not they are completely covered).
    926   (let ((entered 0) (covered 0) (total 0))
     954  (let ((entered 0) (covered 0) (total 0)
     955        (done (make-hash-table :test #'eq :shared nil)))
    927956    (map-coverage-entry-notes
    928957     coverage
    929958     (lambda (note)
    930959       (labels ((rec (note)
    931                   (when (code-note-source-note note)
    932                     #+debug (format t "~&~s" note)
    933                     (incf total)
    934                     (when (code-note-code-coverage note)
    935                       (incf entered)
    936                       (when (eq (code-note-code-coverage note) 'full)
    937                         (incf covered))))
    938                   (loop for sub in (coverage-subnotes note)
    939                         unless (entry-code-note-p sub) do (rec sub))))
     960                  (let ((source-note (code-note-source-note note)))
     961                    (when (and source-note (not (gethash source-note done)))
     962                      (setf (gethash source-note done) t)
     963                      (incf total)
     964                      (let ((data (source-coverage source-note)))
     965                        (when data
     966                          (incf entered)
     967                          (when (eq data 'full)
     968                            (incf covered)))))
     969                    (loop for sub in (coverage-subnotes note)
     970                          unless (entry-code-note-p sub) do (rec sub)))))
    940971         (rec note))))
    941     (list total
    942           entered (if (> total 0) (* 100.0d0 (/ entered total)) '--)
    943           covered (if (> total 0) (* 100.0d0 (/ covered total)) '--))))
     972    (let ((stats (file-coverage-statistics coverage)))
     973      (setf (coverage-expressions-total stats) total)
     974      (setf (coverage-expressions-entered stats) entered)
     975      (setf (coverage-expressions-covered stats) covered))))
    944976
    945977(defun count-unreached-branches (coverage)
     
    956988                             unless (entry-code-note-p sub) do (rec sub note))))))
    957989         (rec note nil))))
    958     count))
     990    (let ((stats (file-coverage-statistics coverage)))
     991      (setf (coverage-unreached-branches stats) count))))
    959992
    960993(defun write-coverage-styles (html-stream)
Note: See TracChangeset for help on using the changeset viewer.