Changeset 13685 for branches/qres/ccl


Ignore:
Timestamp:
May 6, 2010, 7:56:41 PM (9 years ago)
Author:
gz
Message:

Store checksum with code coverage info, signal error if try to color a different file than stored; Also while in there, add a restart to coverage coloring to let you skip a file if there are any errors.

Location:
branches/qres/ccl
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • branches/qres/ccl/level-0/nfasload.lisp

    r13070 r13685  
    737737
    738738;;; files compiled with code coverage do this
    739 ;; list of lfuns and (source-fn-name . vector-of-lfuns), the latter put there by fasloading.
     739;; list of lfuns and (source-fn-name vector-of-lfuns external-format id), the latter put there by fasloading.
    740740(defvar *code-covered-functions* nil)
    741741
    742 (defun register-code-covered-functions (functions)
     742(defun register-code-covered-functions (functions &optional external-format id)
    743743  ;; unpack the parent-note references - see comment at fcomp-digest-code-notes
    744744  (labels ((reg (lfun refs)
     
    767767                                       (and p q (equalp p q)))))))))
    768768    (when (null a)
    769       (push (setq a (list nil nil)) *code-covered-functions*))
    770     (setf (car a) *loading-file-source-file* (cdr a) functions))
     769      (push (setq a (list nil nil nil nil)) *code-covered-functions*))
     770    (setf (car a) *loading-file-source-file*
     771          (cadr a) functions
     772          (caddr a) external-format
     773          (cadddr a) id))
    771774  nil)
    772775
  • branches/qres/ccl/lib/nfcomp.lisp

    r13565 r13685  
    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 ()
  • branches/qres/ccl/library/cover.lisp

    r12339 r13685  
    110110       nconc (get-function-coverage imm refs)))))
    111111
     112(defun code-covered-info.file (data) (and (consp data) (car data)))
     113(defun code-covered-info.fns (data) (and (consp data) (if (consp (cdr data)) (cadr data) (cdr data))))
     114(defun code-covered-info.ef (data) (and (consp data) (consp (cdr data)) (caddr data)))
     115(defun code-covered-info.id (data) (and (consp data) (consp (cdr data)) (cadddr data)))
     116
     117(defun code-covered-info-with-fns (data new-fns)
     118  (assert (consp data))
     119  (if (consp (cdr data))
     120    (cons (car data) new-fns)
     121    (let ((new (copy-list data)))
     122      (setf (cadr new) new-fns)
     123      new)))
     124
    112125(defun get-coverage ()
    113126  (setq *file-coverage* nil)
     
    116129  (clrhash *entry-code-notes*)
    117130  (loop for data in *code-covered-functions*
    118         when (consp data)
    119         do (destructuring-bind (file . toplevel-functions) data
    120              (push (list* file
    121                           ;; Duplicates are possible if you have multiple instances of
    122                           ;; (load-time-value (foo)) where (foo) returns an lfun.
    123                           ;; CL-PPCRE does that.
    124                           (delete-duplicates
    125                            (loop for fn across toplevel-functions
    126                                 nconc (get-function-coverage fn nil)))
    127                           toplevel-functions)
    128                    *file-coverage*)))
     131        do (let* ((file (code-covered-info.file data))
     132                  (toplevel-functions (code-covered-info.fns data)))
     133             (when file
     134               (push (list* file
     135                            ;; Duplicates are possible if you have multiple instances of
     136                            ;; (load-time-value (foo)) where (foo) returns an lfun.
     137                            ;; CL-PPCRE does that.
     138                            (delete-duplicates
     139                             (loop for fn across toplevel-functions
     140                                   nconc (get-function-coverage fn nil)))
     141                            toplevel-functions)
     142                     *file-coverage*))))
    129143  ;; Now get subnotes, including un-emitted ones.
    130144  (loop for note being the hash-key of *emitted-code-notes*
     
    160174
    161175(defun covered-functions-for-file (path)
    162   (cdr (assoc-by-filename path *code-covered-functions*)))
     176  (code-covered-info.fns (assoc-by-filename path *code-covered-functions*)))
    163177
    164178(defun clear-coverage ()
     
    177191  (loop for data in *code-covered-functions*
    178192        do (typecase data
    179              (cons ;; (source-file . functions)
    180                 (loop for fn across (cdr data)
     193             (cons
     194                (loop for fn across (code-covered-info.fns data)
    181195                      do (reset-function-coverage fn)))
    182196             (function (reset-function-coverage data)))))
     
    195209
    196210(defmacro with-coverage-mismatch-catch ((saved-file) &body body)
    197   `(let ((file ,saved-file)
    198          (err (catch 'coverage-mismatch ,@body nil)))
    199      (when err
    200        (error "Mismatched coverage data for ~s, ~?" file (car err) (cdr err)))))
     211  `(let ((file ,saved-file))
     212     (with-simple-restart (ignore-file "Ignore ~s and continue" file)
     213       (let ((err (catch 'coverage-mismatch
     214                    ,@body
     215                    nil)))
     216         (when err
     217           (error "Mismatched coverage data for ~s, ~?" file (car err) (cdr err)))))))
    201218
    202219
     
    278295   :alist (loop for data in *code-covered-functions*
    279296                when (consp data)
    280                   collect (cons (car data)
    281                                 (map 'vector #'save-function-coverage (cdr data))))))
     297                  collect (code-covered-info-with-fns
     298                               data (map 'vector #'save-function-coverage (code-covered-info.fns data))))))
    282299
    283300(defun combine-coverage (coverage-states)
     
    285302    (map nil
    286303         (lambda (coverage-state)
    287            (loop for (saved-file . saved-fns) in (coverage-state-alist coverage-state)
    288                  for result-fns = (cdr (assoc-by-filename saved-file result))
     304           (loop for saved-data in (coverage-state-alist coverage-state)
     305                 as saved-file = (code-covered-info.file saved-data)
     306                 as saved-fns = (code-covered-info.fns saved-data)
     307                 as result-data = (assoc-by-filename saved-file result)
     308                 as result-fns = (code-covered-info.fns result-data)
    289309                 do (with-coverage-mismatch-catch (saved-file)
    290310                      (cond ((null result-fns)
    291                              (push (cons saved-file
    292                                         (map 'vector #'copy-function-coverage saved-fns))
     311                             (push (code-covered-info-with-fns
     312                                    saved-data (map 'vector #'copy-function-coverage saved-fns))
    293313                                   result))
    294314                            ((not (eql (length result-fns) (length saved-fns)))
    295315                             (coverage-mismatch "different function counts"))
    296                             (t
     316                            (t
     317                             (unless (equal (code-covered-info.id saved-data)
     318                                            (code-covered-info.id result-data))
     319                               (cerror "Ignore the mismatch"
     320                                       "Combining different versions of file ~s (checksum mismatch)"
     321                                       saved-file))
    297322                             (loop for result-fn across result-fns
    298323                                   for saved-fn across saved-fns
     
    304329(defun restore-coverage (coverage-state)
    305330  "Restore the code coverage data back to an earlier state produced by SAVE-COVERAGE."
    306   (loop for (saved-file . saved-fns) in (coverage-state-alist coverage-state)
    307         for fns = (covered-functions-for-file saved-file)
     331  (loop for saved-data in (coverage-state-alist coverage-state)
     332        for saved-file = (code-covered-info.file saved-data)
     333        as saved-fns = (code-covered-info.fns saved-data)
     334        for current-data = (assoc-by-filename saved-file *code-covered-functions*)
     335        as fns = (and current-data (code-covered-info.fns current-data))
    308336        do (with-coverage-mismatch-catch (saved-file)
    309337             (cond ((null fns)
     
    314342                                       (length saved-fns) (length fns)))
    315343                   (t
     344                    (unless (equal (code-covered-info.id saved-data)
     345                                   (code-covered-info.id current-data))
     346                      (cerror "Ignore the mismatch"
     347                              "Restoring different version of file ~s (checksum mismatch)"
     348                              saved-file))
    316349                    (map nil #'restore-function-coverage fns saved-fns))))))
    317350
     
    352385    (loop for data in *code-covered-functions*
    353386       when (consp data)
    354        do (let ((file (probe-file (car data))))
     387       do (let ((file (probe-file (code-covered-info.file data))))
    355388            (when file
    356389              (cond ((eq host :unknown)
     
    444477    (ensure-directories-exist directory)
    445478    (loop for coverage in *file-coverage*
    446       as file = (or (probe-file (file-coverage-file coverage))
     479      as truename = (or (probe-file (file-coverage-file coverage))
    447480                    (progn (warn "Cannot find ~s, won't report coverage" (file-coverage-file coverage))
    448481                           nil))
    449       do (when file
    450            (let* ((src-name (enough-namestring file coverage-dir))
     482      do (when truename
     483           (let* ((src-name (enough-namestring truename coverage-dir))
    451484                  (html-name (substitute
    452485                              #\_ #\: (substitute
    453486                                       #\_ #\. (substitute
    454                                                 #\_ #\/ (namestring-unquote src-name))))))
     487                                                #\_ #\/ (namestring-unquote src-name)))))
     488                  (file (file-coverage-file coverage)))
    455489             (when html
    456                (with-open-file (stream (make-pathname :name html-name :type "html" :defaults directory)
    457                                        :direction :output
    458                                        :if-exists :supersede
    459                                        :if-does-not-exist :create)
    460                  (report-file-coverage index-file coverage stream external-format)))
     490               (with-coverage-mismatch-catch (file)
     491                 (let* ((data (assoc-by-filename file *code-covered-functions*))
     492                        (checksum (fcomp-file-checksum (code-covered-info.file data)
     493                                                       :external-format (code-covered-info.ef data))))
     494                   (unless (eql checksum (code-covered-info.id data))
     495                     (cerror "Try coloring anyway"
     496                             "File ~s has changed since coverage source location info was recorded."
     497                             (code-covered-info.file data))))
     498                 (with-open-file (stream (make-pathname :name html-name :type "html" :defaults directory)
     499                                         :direction :output
     500                                         :if-exists :supersede
     501                                         :if-does-not-exist :create)
     502                   (report-file-coverage index-file coverage stream external-format))))
    461503             (push (list* src-name html-name coverage) paths))))
    462504    (when (null paths)
Note: See TracChangeset for help on using the changeset viewer.