Changeset 14187


Ignore:
Timestamp:
Aug 13, 2010, 5:01:22 PM (9 years ago)
Author:
gz
Message:

Fixes in acode code coverage (r14085, r14110, r14164, r14165, r14172 from qres branch)

Location:
trunk/source
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/source

  • trunk/source/compiler/nx-basic.lisp

    r14086 r14187  
    739739(defun nx-record-code-coverage-acode (afunc)
    740740  (assert *nx-current-code-note*)
    741   (let* ((form->note (make-hash-table :test #'eq))
    742          (*nx-acode-inner-refs* nil)
    743          (*nx-acode-refs-counter* 0)
    744          (form (decomp-acode (afunc-acode afunc)
    745                              :prettify t
    746                              :hook (lambda (acode form &aux (note (acode-note acode)))
    747                                      ;; For expressions within without-compiling-code-coverage, there is a source
    748                                      ;; note and not a code note, so need to check for code note explicitly.
    749                                      (when (code-note-p note)
    750                                        (dbg-assert (null (gethash form form->note)))
    751                                        (dbg-assert (null (code-note-acode-range note)))
    752                                        (setf (gethash form form->note) note)))))
    753          (package *package*)
    754          (string (with-standard-io-syntax
     741  (let ((form->note (make-hash-table :test #'eq)))
     742    (labels ((decomp-hook (acode form &aux (note (acode-note acode)))
     743               ;; For expressions within without-compiling-code-coverage, there is a source
     744               ;; note and not a code note, so need to check for code note explicitly.
     745               (when (code-note-p note)
     746                 (dbg-assert (null (gethash form form->note)))
     747                 (dbg-assert (null (code-note-acode-range note)))
     748                 (setf (gethash form form->note) note)))
     749             (print-hook (form open-p pos)
     750               (let* ((note (gethash form form->note))
     751                      (range (and note (code-note-acode-range note))))
     752                 (when note
     753                   (cond (open-p
     754                          (dbg-assert (null range))
     755                          (setf (code-note-acode-range note)
     756                                (encode-file-range pos pos)))
     757                         (t
     758                          (dbg-assert (not (null range)))
     759                          (multiple-value-bind (start end)
     760                              (decode-file-range range)
     761                            (declare (ignorable end))
     762                            (dbg-assert (eq start end))
     763                            (setf (code-note-acode-range note)
     764                                  (encode-file-range start pos))))))))
     765             (stringify (acode)
     766               (let* ((*nx-acode-refs-counter* 0)
     767                      (form (decomp-acode acode :prettify t :hook #'decomp-hook))
     768                      (package *package*))
     769                 (with-standard-io-syntax
    755770                     (with-output-to-string (*nx-pprint-stream*)
    756771                       (let* ((*package* package)
     
    758773                              (*print-case* :downcase)
    759774                              (*print-readably* nil))
    760                          (pprint-recording-positions
    761                           form *nx-pprint-stream*
    762                           (lambda (form open-p pos)
    763                             (let* ((note (gethash form form->note))
    764                                    (range (and note (code-note-acode-range note))))
    765                               (when note
    766                                 (cond (open-p
    767                                        (dbg-assert (null range))
    768                                        (setf (code-note-acode-range note)
    769                                              (encode-file-range pos pos)))
    770                                       (t
    771                                        (dbg-assert (not (null range)))
    772                                        (multiple-value-bind (start end)
    773                                                             (decode-file-range range)
    774                                          (declare (ignorable end))
    775                                          (dbg-assert (eq start end))
    776                                          (setf (code-note-acode-range note)
    777                                                (encode-file-range start pos))))))))))))))
    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)))
    783     afunc))
     775                         (pprint-recording-positions form *nx-pprint-stream* #'print-hook))))))
     776             (record (afunc)
     777               (let* ((*nx-acode-inner-refs* nil);; filled in by stringify.
     778                      (string (stringify (afunc-acode afunc))))
     779                 (setf (getf (afunc-lfun-info afunc) '%function-acode-string) string)
     780                 (loop for ref in *nx-acode-inner-refs* as fn = (acode-afunc-ref-afunc ref)
     781                       do (dbg-assert (null (getf (afunc-lfun-info fn) '%function-acode-string)))
     782                       do (setf (getf (afunc-lfun-info fn) '%function-acode-string) string)))))
     783      (if (getf (afunc-lfun-info afunc) '%function-source-note)
     784        (record afunc)
     785        ;; If don't have a function source note while recording code coverage, it's
     786        ;; probably a toplevel function consed up by the file compiler.  Don't store it,
     787        ;; as it just confuses things
     788        (loop for inner in (afunc-inner-functions afunc) do (record inner)))))
     789  afunc)
    784790
    785791(defmethod print-object ((ref acode-afunc-ref) stream)
     
    825831                                   (< op num))
    826832                          (car (nth (- num op 1) *next-nx-operators*))))
    827                   (new (decomp-using-name (or name op) (cdr acode))))
     833                  (new (decomp-using-name (or name op) acode)))
    828834             (when *decomp-hook*
    829835               (funcall *decomp-hook* acode new))
     
    901907  (let ((op-var (car arglist))
    902908        (args-vars (cdr arglist))
    903         (op-decls nil)
    904         (args-var (gensym)))
     909        (acode-var (gensym))
     910        (op-decls nil))
     911    (when (eq op-var '&whole)
     912      (setq acode-var (pop args-vars))
     913      (setq op-var (pop args-vars)))
    905914    (multiple-value-bind (body decls) (parse-body body nil)
    906915    ;; Kludge but good enuff for here
     
    913922    `(progn
    914923       ,@(loop for name in (if (atom names) (list names) names)
    915            collect `(defmethod decomp-using-name ((,op-var (eql ',name)) ,args-var)
     924           collect `(defmethod decomp-using-name ((,op-var (eql ',name)) ,acode-var)
    916925                      (declare ,@op-decls)
    917                       (destructuring-bind ,args-vars ,args-var
     926                      (destructuring-bind ,args-vars (cdr ,acode-var)
    918927                        ,@decls
    919928                        ,@body)))))))
    920929
    921930;; Default method
    922 (defmethod decomp-using-name (op forms)
    923   `(,op ,@(decomp-formlist forms)))
     931(defmethod decomp-using-name (op acode)
     932  `(,op ,@(decomp-formlist (cdr acode))))
    924933
    925934;; not real op, kludge generated below for lambda-bind
     
    951960  `(,op ,(decomp-afunc afunc)))
    952961
    953 (defdecomp (progn prog1 multiple-value-prog1 or list %temp-list values) (op form-list)
     962(defun decomp-replace (from-form to-form)
     963  (let ((note (acode-note from-form)))
     964    (unless (and note (acode-note to-form))
     965      (when note
     966        (setf (acode-note to-form) note))
     967      t)))
     968           
     969(defdecomp progn (&whole form op form-list)
     970  (if (and *decomp-prettify*
     971           (null (cdr form-list))
     972           (decomp-replace form (car form-list)))
     973    (decomp-form (car form-list))
     974    `(,op ,@(decomp-formlist form-list))))
     975
     976(defdecomp (prog1 multiple-value-prog1 or list %temp-list values) (op form-list)
    954977  `(,op ,@(decomp-formlist form-list)))
    955978
     
    9771000    `(,op ,(decomp-form cc) ,@(decomp-formlist forms))))
    9781001
    979 (defdecomp (typed-form type-asserted-form) (op typespec form &optional check-p)
    980   `(,op ',typespec ,(decomp-form form) ,@(and check-p (list check-p))))
     1002(defdecomp (typed-form type-asserted-form) (&whole whole op typespec form &optional check-p)
     1003  (if (and *decomp-prettify*
     1004           (not check-p)
     1005           (decomp-replace whole form))
     1006    (decomp-form form)
     1007    `(,op ',typespec ,(decomp-form form) ,@(and check-p (list check-p)))))
    9811008
    9821009(defdecomp (%i+ %i-) (op form1 form2 &optional overflow-p)
     
    9861013  `(,op ,bits ,@(decomp-formlist forms)))
    9871014
    988 (defdecomp call (op fn arglist &optional spread-p)
     1015(defdecomp (builtin-call call) (op fn arglist &optional spread-p)
    9891016  (setq op (if spread-p 'apply 'funcall))
    9901017  `(,op ,(decomp-form fn) ,@(decomp-arglist arglist)))
  • trunk/source/lib/nfcomp.lisp

    r14125 r14187  
    311311      (funcall (compile-named-function
    312312                lambda
     313                :compile-code-coverage nil
    313314                :source-notes *fcomp-source-note-map*
    314315                :env *fasl-compile-time-env*
     
    321322;;; Well, no usable methods by default.  How this is better than
    322323;;; getting a NO-APPLICABLE-METHOD error frankly escapes me,
     324;;; [Hint: this is called even when there is an applicable method]
    323325(defun no-make-load-form-for (object)
    324326  (error "No ~S method is defined for ~s" 'make-load-form object))
     
    961963  (and notes (gethash form notes)))
    962964
     965(defun (setf fcomp-source-note) (note form &aux (notes *fcomp-source-note-map*))
     966  (and notes (setf (gethash form notes) note)))
     967
    963968(defun fcomp-note-source-transformation (original new)
    964969  (let* ((*nx-source-note-map* *fcomp-source-note-map*))
     
    10391044           (*fcomp-stream-position* *fcomp-previous-position*)
    10401045           (*loading-toplevel-location* *fcomp-loading-toplevel-location*)
    1041            (lambda (if T ;; (null (cdr forms))
    1042                      `(lambda () ,@forms)
    1043                      `(lambda ()
    1044                         (macrolet ((load-time-value (value)
    1045                                      (declare (ignore value))
    1046                                      (compiler-function-overflow)))
    1047                           ,@forms)))))
     1046           (body (if T ;; (null (cdr forms))
     1047                   `(progn ,@forms)
     1048                   `(macrolet ((load-time-value (value)
     1049                                 (declare (ignore value))
     1050                                 (compiler-function-overflow)))
     1051                      ,@forms)))
     1052           (lambda `(lambda () ,body)))
     1053      ;; Don't assign a location to the lambda so it doesn't confuse acode printing, but
     1054      ;; arrange to assign it to any inner lambdas.
     1055      (setf (fcomp-source-note body) *loading-toplevel-location*)
    10481056      (setq *fcomp-toplevel-forms* nil)
    10491057      ;(format t "~& Random toplevel form: ~s" lambda)
     
    10511059                     $fasl-lfuncall
    10521060                     env
    1053                      (fcomp-named-function lambda nil env *loading-toplevel-location*))
     1061                     (fcomp-named-function lambda nil env #|*loading-toplevel-location*|#))
    10541062        (compiler-function-overflow ()
    10551063          (if (null (cdr forms))
  • trunk/source/library/cover.lisp

    r14046 r14187  
    5858(defparameter *code-note-acode-strings* (make-hash-table :test #'eq))
    5959
    60 (defparameter *coverage-acode-queue* nil)
    61 
    6260(defstruct (coverage-state (:conc-name "%COVERAGE-STATE-"))
    6361  alist)
     
    8886
    8987(defun code-note-acode-string (note)
    90   (gethash note *code-note-acode-strings*))
     88  (and *code-note-acode-strings*
     89       (gethash note *code-note-acode-strings*)))
    9190
    9291(defun map-function-coverage (lfun fn &optional refs)
     
    10099              do (map-function-coverage imm fn refs))))
    101100
    102 (defun get-function-coverage (fn refs acode)
     101(defun get-function-coverage (fn refs)
    103102  (let ((entry (function-entry-code-note fn))
    104103        (refs (cons fn refs))
    105         (acode (or (%function-acode-string fn) acode)))
     104        (acode (%function-acode-string fn))
     105        (source (function-source-form-note fn)))
    106106    (declare (dynamic-extent refs))
    107107    (when entry
     
    119119              (setf (gethash imm *code-note-acode-strings*) acode)))
    120120       when (and (functionp imm)
    121                  (not (memq imm refs)))
    122        nconc (get-function-coverage imm refs acode)))))
     121                 (not (memq imm refs))
     122                 ;; Make sure this fn is in the source we're currently looking at.
     123                 ;; It might not be, if it is referenced via (load-time-value (foo))
     124                 ;; where (foo) returns an lfun from some different source entirely.
     125                 ;; CL-PPCRE does that.
     126                 (or (null source)
     127                     (eq source (function-source-form-note imm))))
     128       nconc (get-function-coverage imm refs)))))
    123129
    124130(defun code-covered-info.file (data) (and (consp data) (car data)))
     
    140146  (clrhash *emitted-code-notes*)
    141147  (clrhash *entry-code-notes*)
    142   (clrhash *code-note-acode-strings*)
     148  (when *code-note-acode-strings* (clrhash *code-note-acode-strings*))
    143149  (loop for data in *code-covered-functions*
    144150        do (let* ((file (code-covered-info.file data))
    145151                  (toplevel-functions (code-covered-info.fns data)))
    146152             (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*))))
     153               (let* ((all-functions (delete-duplicates
     154                                      ;; Duplicates are possible if you have multiple instances of
     155                                      ;; (load-time-value (foo)) where (foo) returns an lfun.
     156                                      ;; CL-PPCRE does that.
     157                                      (loop for fn across toplevel-functions
     158                                            nconc (get-function-coverage fn nil))))
     159                      (coverage (list* file all-functions toplevel-functions)))
     160                 (push coverage *file-coverage*)))))
    156161  ;; Now get subnotes, including un-emitted ones.
    157162  (loop for note being the hash-key of *emitted-code-notes*
     
    159164                 while parent
    160165                 do (pushnew n (gethash parent *coverage-subnotes*))
    161                  until (emitted-code-note-p parent)))
    162   (let ((hash (make-hash-table :test #'eq)))
    163     ;; distribute entry acode to the toplevel source note it belongs to.
    164     (loop for entry being the hash-key of *entry-code-notes* using (hash-value fn)
    165       as acode = (code-note-acode-string entry)
    166       as sn = (entry-note-unambiguous-source entry)
    167       as toplevel-sn = (function-source-form-note fn)
    168       do (when sn
    169            (assert toplevel-sn)
    170            (let* ((pos (source-note-end-pos sn))
    171                   (cell (assq acode (gethash toplevel-sn hash))))
    172              (if cell
    173                (setf (cdr cell) (max (cdr cell) pos))
    174                (push (cons acode pos) (gethash toplevel-sn hash))))))
    175     (setf *coverage-acode-queue*
    176           (sort (loop for sn being the hash-key of hash using (hash-value alist)
    177                   collect (cons (source-note-end-pos sn)
    178                                 (mapcar #'car (sort alist #'< :key #'cdr))))
    179                 #'< :key #'car))))
     166                 until (emitted-code-note-p parent))))
     167
     168(defun file-coverage-acode-queue (coverage)
     169  (loop with hash = (make-hash-table :test #'eq :shared nil)
     170        for fn in (file-coverage-functions coverage)
     171        as acode = (%function-acode-string fn)
     172        as entry = (function-entry-code-note fn)
     173        as sn = (entry-note-unambiguous-source entry)
     174        as toplevel-sn = (function-source-form-note fn)
     175        do (when sn
     176             (assert toplevel-sn)
     177             (let* ((pos (source-note-end-pos sn))
     178                    (cell (assq acode (gethash toplevel-sn hash))))
     179               (if cell
     180                 (setf (cdr cell) (max (cdr cell) pos))
     181                 (push (cons acode pos) (gethash toplevel-sn hash)))))
     182        finally (return (sort (loop for sn being the hash-key of hash using (hash-value alist)
     183                                    collect (cons (source-note-end-pos sn)
     184                                                  (mapcar #'car (sort alist #'< :key #'cdr))))
     185                              #'< :key #'car))))
    180186
    181187#+debug
     
    456462         (*coverage-subnotes* (make-hash-table :test #'eq :shared nil))
    457463         (*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
    458          (*entry-code-notes* (make-hash-table :test #'eq :shared nil)))
    459     (get-coverage)
     464         (*entry-code-notes* (make-hash-table :test #'eq :shared nil))
     465         (*code-note-acode-strings* nil))
     466    (get-coverage)
    460467    (loop for coverage in *file-coverage*
    461468          as stats = (make-coverage-statistics :source-file (file-coverage-file coverage))
     
    502509         (*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
    503510         (*entry-code-notes* (make-hash-table :test #'eq :shared nil))
     511         (*code-note-acode-strings* (make-hash-table :test #'eq :shared nil))
    504512         (index-file (and html (merge-pathnames output-file "index.html")))
    505513         (stats-file (and statistics (merge-pathnames (if (or (stringp statistics)
     
    712720              when (and (functionp imm)
    713721                        (not (memq imm refs))
    714                         ;; Make sure this fn is in the source we're currently looking at.
    715                         ;; It might not be, if it is referenced via (load-time-value (foo))
    716                         ;; where (foo) returns an lfun from some different source entirely.
    717                         ;; CL-PPCRE does that.
     722                        ;; See note in get-function-coverage
    718723                        (or (null source)
    719724                            (eq source (function-source-form-note imm))
     
    736741                             :element-type '(unsigned-byte 2)))
    737742         (acode-styles (make-hash-table :test #'eq)))
    738     (map nil #'(lambda (fn) (colorize-function fn styles acode-styles)) (file-coverage-toplevel-functions coverage))
     743    (map nil #'(lambda (fn) (colorize-function fn styles acode-styles))
     744         (file-coverage-toplevel-functions coverage))
    739745    (print-file-coverage-report index-file html-stream coverage styles acode-styles source)
    740746    (format html-stream "</body></html>")))
     
    758764
    759765    ;; Output source intertwined with acode
    760     (iterate output ((start 0) (line 0))
     766    (iterate output ((start 0) (line 0) (queue (file-coverage-acode-queue coverage)))
    761767      (format html-stream "<div class='source'><code>")
    762       (let ((next (car *coverage-acode-queue*)))
     768      (let ((next (car queue)))
    763769        (multiple-value-bind (end last-line)
    764                              (output-styled html-stream source styles
    765                                             :start start
    766                                             :line line
    767                                             :limit (car next))
     770            (output-styled html-stream source styles
     771                           :start start
     772                           :line line
     773                           :limit (car next))
    768774          (format html-stream "</code></div>~%")
    769775          (when (and next end (<= (car next) end))
     
    772778                                   <div class='acode' id='a~:*~d'><code>" pos)
    773779              (loop for acode in strings as styles = (gethash acode acode-styles)
    774                 do (assert styles)
    775                 do (output-styled html-stream acode styles)
    776                 do (fresh-line html-stream))
    777               (format html-stream "</code></div><hr/>~%"))
    778             (pop *coverage-acode-queue*)
    779             (output (1+ end) last-line)))))))
     780                    do (assert styles)
     781                    do (when styles (output-styled html-stream acode styles))
     782                    do (fresh-line html-stream))
     783              (format html-stream "</code></div><hr/>~%")
     784              (output (1+ end) last-line (cdr queue)))))))))
    780785
    781786(defun output-styled (html-stream source styles &key (start 0) line limit)
Note: See TracChangeset for help on using the changeset viewer.