Changeset 14046


Ignore:
Timestamp:
Jul 26, 2010, 3:59:01 PM (9 years ago)
Author:
gz
Message:

merge r13685: when reporting code coverage, check for changed source file. Also, update mergeinfo

Location:
trunk/source
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/source

  • trunk/source/level-0/nfasload.lisp

    r13279 r14046  
    787787
    788788;;; files compiled with code coverage do this
    789 ;; list of lfuns and (source-fn-name . vector-of-lfuns), the latter put there by fasloading.
     789;; list of lfuns and (source-fn-name vector-of-lfuns external-format id), the latter put there by fasloading.
    790790(defvar *code-covered-functions* nil)
    791791
    792 (defun register-code-covered-functions (functions)
     792(defun register-code-covered-functions (functions &optional external-format id)
    793793  ;; unpack the parent-note references - see comment at fcomp-digest-code-notes
    794794  (labels ((reg (lfun refs)
     
    817817                                       (and p q (equalp p q)))))))))
    818818    (when (null a)
    819       (push (setq a (list nil nil)) *code-covered-functions*))
    820     (setf (car a) *loading-file-source-file* (cdr a) functions))
     819      (push (setq a (list nil nil nil nil)) *code-covered-functions*))
     820    (setf (car a) *loading-file-source-file*
     821          (cadr a) functions
     822          (caddr a) external-format
     823          (cadddr a) id))
    821824  nil)
    822825
  • trunk/source/lib/nfcomp.lisp

    r13745 r14046  
    498498        (fcomp-compile-toplevel-forms env)
    499499        (let* ((fns (fcomp-code-covered-functions))
    500                (v (nreverse (coerce fns 'vector))))
     500               (v (nreverse (coerce fns 'vector)))
     501               (id (fcomp-file-checksum stream)))
    501502          (map nil #'fcomp-digest-code-notes v)
    502           (fcomp-random-toplevel-form `(register-code-covered-functions ',v) env)))
     503          (fcomp-random-toplevel-form `(register-code-covered-functions ',v
     504                                                                        ',*fcomp-external-format*
     505                                                                        ,id)
     506                                      env)))
    503507      (while (setq form *fasl-eof-forms*)
    504508        (setq *fasl-eof-forms* nil)
     
    507511        (fcomp-output-form $fasl-src env (namestring *compile-file-pathname*)))
    508512      (fcomp-compile-toplevel-forms env))))
     513
     514(defvar *crc32-table* (let ((crc-table (make-array 256 :element-type '(unsigned-byte 32))))
     515                        (loop for i from 0 below 255 as crc = i
     516                              do (loop for j from 0 below 8
     517                                       do (setq crc (ash crc -1))
     518                                       do (when (oddp crc)
     519                                            (setq crc (logxor crc  #xEDB88320))))
     520                              do (setf (aref crc-table i) crc))
     521                        crc-table))
     522(declaim (type (simple-array (unsigned-byte 32) (256)) *crc32-table*))
     523
     524(defun fcomp-stream-checksum (stream)
     525  ;; Could consider crc16 for 32-bit targets, but this is only used with code
     526  ;; coverage so don't worry about efficiency anyway.
     527  (file-position stream 0)
     528  (let ((crc 0))
     529    (declare (type (unsigned-byte 32) crc))
     530    (loop for char base-char = (read-char stream nil) while char
     531          do (setq crc (logxor
     532                         (%ilogand (ash crc -8) #x00FFFFFF)
     533                         (aref *crc32-table* (logand (logxor crc (char-code char)) #xFF)))))
     534    (logior (ash (file-position stream) 32) crc)))
     535
     536(defun fcomp-file-checksum (filename &key (external-format *fcomp-external-format*))
     537  (when (setq filename (probe-file filename))
     538    (with-open-file (stream filename
     539                            :element-type 'base-char
     540                            :external-format external-format)
     541      (fcomp-stream-checksum stream))))
    509542
    510543(defun fcomp-code-covered-functions ()
  • trunk/source/library/cover.lisp

    r14044 r14046  
    122122       nconc (get-function-coverage imm refs acode)))))
    123123
     124(defun code-covered-info.file (data) (and (consp data) (car data)))
     125(defun code-covered-info.fns (data) (and (consp data) (if (consp (cdr data)) (cadr data) (cdr data))))
     126(defun code-covered-info.ef (data) (and (consp data) (consp (cdr data)) (caddr data)))
     127(defun code-covered-info.id (data) (and (consp data) (consp (cdr data)) (cadddr data)))
     128
     129(defun code-covered-info-with-fns (data new-fns)
     130  (assert (consp data))
     131  (if (consp (cdr data))
     132    (cons (car data) new-fns)
     133    (let ((new (copy-list data)))
     134      (setf (cadr new) new-fns)
     135      new)))
     136
    124137(defun get-coverage ()
    125138  (setq *file-coverage* nil)
     
    129142  (clrhash *code-note-acode-strings*)
    130143  (loop for data in *code-covered-functions*
    131         when (consp data)
    132         do (destructuring-bind (file . toplevel-functions) data
    133              (push (list* file
    134                           ;; Duplicates are possible if you have multiple instances of
    135                           ;; (load-time-value (foo)) where (foo) returns an lfun.
    136                           ;; CL-PPCRE does that.
    137                           (delete-duplicates
    138                            (loop for fn across toplevel-functions
    139                                 nconc (get-function-coverage fn nil nil)))
    140                           toplevel-functions)
    141                    *file-coverage*)))
     144        do (let* ((file (code-covered-info.file data))
     145                  (toplevel-functions (code-covered-info.fns data)))
     146             (when file
     147               (push (list* file
     148                            ;; Duplicates are possible if you have multiple instances of
     149                            ;; (load-time-value (foo)) where (foo) returns an lfun.
     150                            ;; CL-PPCRE does that.
     151                            (delete-duplicates
     152                             (loop for fn across toplevel-functions
     153                                   nconc (get-function-coverage fn nil nil)))
     154                            toplevel-functions)
     155                     *file-coverage*))))
    142156  ;; Now get subnotes, including un-emitted ones.
    143157  (loop for note being the hash-key of *emitted-code-notes*
     
    194208
    195209(defun covered-functions-for-file (path)
    196   (cdr (assoc-by-filename path *code-covered-functions*)))
     210  (code-covered-info.fns (assoc-by-filename path *code-covered-functions*)))
    197211
    198212(defun clear-coverage ()
     
    211225  (loop for data in *code-covered-functions*
    212226        do (typecase data
    213              (cons ;; (source-file . functions)
    214                 (loop for fn across (cdr data)
     227             (cons
     228                (loop for fn across (code-covered-info.fns data)
    215229                      do (reset-function-coverage fn)))
    216230             (function (reset-function-coverage data)))))
     
    229243
    230244(defmacro with-coverage-mismatch-catch ((saved-file) &body body)
    231   `(let ((file ,saved-file)
    232          (err (catch 'coverage-mismatch ,@body nil)))
    233      (when err
    234        (error "Mismatched coverage data for ~s, ~?" file (car err) (cdr err)))))
     245  `(let ((file ,saved-file))
     246     (with-simple-restart (ignore-file "Ignore ~s and continue" file)
     247       (let ((err (catch 'coverage-mismatch
     248                    ,@body
     249                    nil)))
     250         (when err
     251           (error "Mismatched coverage data for ~s, ~?" file (car err) (cdr err)))))))
    235252
    236253
     
    312329   :alist (loop for data in *code-covered-functions*
    313330                when (consp data)
    314                   collect (cons (car data)
    315                                 (map 'vector #'save-function-coverage (cdr data))))))
     331                  collect (code-covered-info-with-fns
     332                               data (map 'vector #'save-function-coverage (code-covered-info.fns data))))))
    316333
    317334(defun combine-coverage (coverage-states)
     
    319336    (map nil
    320337         (lambda (coverage-state)
    321            (loop for (saved-file . saved-fns) in (coverage-state-alist coverage-state)
    322                  for result-fns = (cdr (assoc-by-filename saved-file result))
     338           (loop for saved-data in (coverage-state-alist coverage-state)
     339                 as saved-file = (code-covered-info.file saved-data)
     340                 as saved-fns = (code-covered-info.fns saved-data)
     341                 as result-data = (assoc-by-filename saved-file result)
     342                 as result-fns = (code-covered-info.fns result-data)
    323343                 do (with-coverage-mismatch-catch (saved-file)
    324344                      (cond ((null result-fns)
    325                              (push (cons saved-file
    326                                         (map 'vector #'copy-function-coverage saved-fns))
     345                             (push (code-covered-info-with-fns
     346                                    saved-data (map 'vector #'copy-function-coverage saved-fns))
    327347                                   result))
    328348                            ((not (eql (length result-fns) (length saved-fns)))
    329349                             (coverage-mismatch "different function counts"))
    330                             (t
     350                            (t
     351                             (unless (equal (code-covered-info.id saved-data)
     352                                            (code-covered-info.id result-data))
     353                               (cerror "Ignore the mismatch"
     354                                       "Combining different versions of file ~s (checksum mismatch)"
     355                                       saved-file))
    331356                             (loop for result-fn across result-fns
    332357                                   for saved-fn across saved-fns
     
    338363(defun restore-coverage (coverage-state)
    339364  "Restore the code coverage data back to an earlier state produced by SAVE-COVERAGE."
    340   (loop for (saved-file . saved-fns) in (coverage-state-alist coverage-state)
    341         for fns = (covered-functions-for-file saved-file)
     365  (loop for saved-data in (coverage-state-alist coverage-state)
     366        for saved-file = (code-covered-info.file saved-data)
     367        as saved-fns = (code-covered-info.fns saved-data)
     368        for current-data = (assoc-by-filename saved-file *code-covered-functions*)
     369        as fns = (and current-data (code-covered-info.fns current-data))
    342370        do (with-coverage-mismatch-catch (saved-file)
    343371             (cond ((null fns)
     
    348376                                       (length saved-fns) (length fns)))
    349377                   (t
     378                    (unless (equal (code-covered-info.id saved-data)
     379                                   (code-covered-info.id current-data))
     380                      (cerror "Ignore the mismatch"
     381                              "Restoring different version of file ~s (checksum mismatch)"
     382                              saved-file))
    350383                    (map nil #'restore-function-coverage fns saved-fns))))))
    351384
     
    386419    (loop for data in *code-covered-functions*
    387420       when (consp data)
    388        do (let ((file (probe-file (car data))))
     421       do (let ((file (probe-file (code-covered-info.file data))))
    389422            (when file
    390423              (cond ((eq host :unknown)
     
    478511    (ensure-directories-exist directory)
    479512    (loop for coverage in *file-coverage*
    480       as file = (or (probe-file (file-coverage-file coverage))
     513      as truename = (or (probe-file (file-coverage-file coverage))
    481514                    (progn (warn "Cannot find ~s, won't report coverage" (file-coverage-file coverage))
    482515                           nil))
    483       do (when file
    484            (let* ((src-name (enough-namestring file coverage-dir))
     516      do (when truename
     517           (let* ((src-name (enough-namestring truename coverage-dir))
    485518                  (html-name (substitute
    486519                              #\_ #\: (substitute
    487520                                       #\_ #\. (substitute
    488                                                 #\_ #\/ (namestring-unquote src-name))))))
     521                                                #\_ #\/ (namestring-unquote src-name)))))
     522                  (file (file-coverage-file coverage)))
    489523             (when html
    490                (with-open-file (stream (make-pathname :name html-name :type "html" :defaults directory)
    491                                        :direction :output
    492                                        :if-exists :supersede
    493                                        :if-does-not-exist :create)
    494                  (report-file-coverage index-file coverage stream external-format)))
     524               (with-coverage-mismatch-catch (file)
     525                 (let* ((data (assoc-by-filename file *code-covered-functions*))
     526                        (checksum (fcomp-file-checksum (code-covered-info.file data)
     527                                                       :external-format (code-covered-info.ef data))))
     528                   (unless (eql checksum (code-covered-info.id data))
     529                     (cerror "Try coloring anyway"
     530                             "File ~s has changed since coverage source location info was recorded."
     531                             (code-covered-info.file data))))
     532                 (with-open-file (stream (make-pathname :name html-name :type "html" :defaults directory)
     533                                         :direction :output
     534                                         :if-exists :supersede
     535                                         :if-does-not-exist :create)
     536                   (report-file-coverage index-file coverage stream external-format))))
    495537             (push (list* src-name html-name coverage) paths))))
    496538    (when (null paths)
Note: See TracChangeset for help on using the changeset viewer.