Changeset 14187

Timestamp:

Aug 13, 2010, 10:01:22 AM (14 years ago)

Author:

gz

Message:

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

Location:

trunk/source

Files:

• . (modified) (1 prop)
• compiler/nx-basic.lisp (modified) (8 diffs)
• lib/nfcomp.lisp (modified) (5 diffs)
• library/cover.lisp (modified) (12 diffs)

trunk/source/compiler/nx-basic.lisp

@@ -739 +739 @@
 (defun nx-record-code-coverage-acode (afunc)
   (assert *nx-current-code-note*)
-  (let* ((form->note (make-hash-table :test #'eq))
-         (*nx-acode-inner-refs* nil)
-         (*nx-acode-refs-counter* 0)
-         (form (decomp-acode (afunc-acode afunc)
-                             :prettify t
-                             :hook (lambda (acode form &aux (note (acode-note acode)))
-                                     ;; For expressions within without-compiling-code-coverage, there is a source
-                                     ;; note and not a code note, so need to check for code note explicitly.
-                                     (when (code-note-p note)
-                                       (dbg-assert (null (gethash form form->note)))
-                                       (dbg-assert (null (code-note-acode-range note)))
-                                       (setf (gethash form form->note) note)))))
-         (package *package*)
-         (string (with-standard-io-syntax
+  (let ((form->note (make-hash-table :test #'eq)))
+    (labels ((decomp-hook (acode form &aux (note (acode-note acode)))
+               ;; For expressions within without-compiling-code-coverage, there is a source
+               ;; note and not a code note, so need to check for code note explicitly.
+               (when (code-note-p note)
+                 (dbg-assert (null (gethash form form->note)))
+                 (dbg-assert (null (code-note-acode-range note)))
+                 (setf (gethash form form->note) note)))
+             (print-hook (form open-p pos)
+               (let* ((note (gethash form form->note))
+                      (range (and note (code-note-acode-range note))))
+                 (when note
+                   (cond (open-p
+                          (dbg-assert (null range))
+                          (setf (code-note-acode-range note)
+                                (encode-file-range pos pos)))
+                         (t
+                          (dbg-assert (not (null range)))
+                          (multiple-value-bind (start end)
+                              (decode-file-range range)
+                            (declare (ignorable end))
+                            (dbg-assert (eq start end))
+                            (setf (code-note-acode-range note)
+                                  (encode-file-range start pos))))))))
+             (stringify (acode)
+               (let* ((*nx-acode-refs-counter* 0)
+                      (form (decomp-acode acode :prettify t :hook #'decomp-hook))
+                      (package *package*))
+                 (with-standard-io-syntax
                      (with-output-to-string (*nx-pprint-stream*)
                        (let* ((*package* package)
@@ -758 +773 @@
                               (*print-case* :downcase)
                               (*print-readably* nil))
-                         (pprint-recording-positions
-                          form *nx-pprint-stream*
-                          (lambda (form open-p pos)
-                            (let* ((note (gethash form form->note))
-                                   (range (and note (code-note-acode-range note))))
-                              (when note
-                                (cond (open-p
-                                       (dbg-assert (null range))
-                                       (setf (code-note-acode-range note)
-                                             (encode-file-range pos pos)))
-                                      (t
-                                       (dbg-assert (not (null range)))
-                                       (multiple-value-bind (start end)
-                                                            (decode-file-range range)
-                                         (declare (ignorable end))
-                                         (dbg-assert (eq start end))
-                                         (setf (code-note-acode-range note)
-                                               (encode-file-range start pos))))))))))))))
-    (iterate store ((afunc afunc))
-      (setf (getf (afunc-lfun-info afunc) '%function-acode-string) string)
-      (loop for inner in (afunc-inner-functions afunc)
-        unless (getf (afunc-lfun-info inner) '%function-acode-string)
-        do (store inner)))
-    afunc))
+                         (pprint-recording-positions form *nx-pprint-stream* #'print-hook))))))
+             (record (afunc)
+               (let* ((*nx-acode-inner-refs* nil);; filled in by stringify.
+                      (string (stringify (afunc-acode afunc))))
+                 (setf (getf (afunc-lfun-info afunc) '%function-acode-string) string)
+                 (loop for ref in *nx-acode-inner-refs* as fn = (acode-afunc-ref-afunc ref)
+                       do (dbg-assert (null (getf (afunc-lfun-info fn) '%function-acode-string)))
+                       do (setf (getf (afunc-lfun-info fn) '%function-acode-string) string)))))
+      (if (getf (afunc-lfun-info afunc) '%function-source-note)
+        (record afunc)
+        ;; If don't have a function source note while recording code coverage, it's
+        ;; probably a toplevel function consed up by the file compiler.  Don't store it,
+        ;; as it just confuses things
+        (loop for inner in (afunc-inner-functions afunc) do (record inner)))))
+  afunc)
 
 (defmethod print-object ((ref acode-afunc-ref) stream)
@@ -825 +831 @@
                                    (< op num))
                           (car (nth (- num op 1) *next-nx-operators*))))
-                  (new (decomp-using-name (or name op) (cdr acode))))
+                  (new (decomp-using-name (or name op) acode)))
              (when *decomp-hook*
                (funcall *decomp-hook* acode new))
@@ -901 +907 @@
   (let ((op-var (car arglist))
         (args-vars (cdr arglist))
-        (op-decls nil)
-        (args-var (gensym)))
+        (acode-var (gensym))
+        (op-decls nil))
+    (when (eq op-var '&whole)
+      (setq acode-var (pop args-vars))
+      (setq op-var (pop args-vars)))
     (multiple-value-bind (body decls) (parse-body body nil)
     ;; Kludge but good enuff for here
@@ -913 +922 @@
     `(progn
        ,@(loop for name in (if (atom names) (list names) names)
-           collect `(defmethod decomp-using-name ((,op-var (eql ',name)) ,args-var)
+           collect `(defmethod decomp-using-name ((,op-var (eql ',name)) ,acode-var)
                       (declare ,@op-decls)
-                      (destructuring-bind ,args-vars ,args-var
+                      (destructuring-bind ,args-vars (cdr ,acode-var)
                         ,@decls
                         ,@body)))))))
 
 ;; Default method
-(defmethod decomp-using-name (op forms)
-  `(,op ,@(decomp-formlist forms)))
+(defmethod decomp-using-name (op acode)
+  `(,op ,@(decomp-formlist (cdr acode))))
 
 ;; not real op, kludge generated below for lambda-bind
@@ -951 +960 @@
   `(,op ,(decomp-afunc afunc)))
 
-(defdecomp (progn prog1 multiple-value-prog1 or list %temp-list values) (op form-list)
+(defun decomp-replace (from-form to-form)
+  (let ((note (acode-note from-form)))
+    (unless (and note (acode-note to-form))
+      (when note
+        (setf (acode-note to-form) note))
+      t)))
+           
+(defdecomp progn (&whole form op form-list)
+  (if (and *decomp-prettify*
+           (null (cdr form-list))
+           (decomp-replace form (car form-list)))
+    (decomp-form (car form-list))
+    `(,op ,@(decomp-formlist form-list))))
+
+(defdecomp (prog1 multiple-value-prog1 or list %temp-list values) (op form-list)
   `(,op ,@(decomp-formlist form-list)))
 
@@ -977 +1000 @@
     `(,op ,(decomp-form cc) ,@(decomp-formlist forms))))
 
-(defdecomp (typed-form type-asserted-form) (op typespec form &optional check-p)
-  `(,op ',typespec ,(decomp-form form) ,@(and check-p (list check-p))))
+(defdecomp (typed-form type-asserted-form) (&whole whole op typespec form &optional check-p)
+  (if (and *decomp-prettify*
+           (not check-p)
+           (decomp-replace whole form))
+    (decomp-form form)
+    `(,op ',typespec ,(decomp-form form) ,@(and check-p (list check-p)))))
 
 (defdecomp (%i+ %i-) (op form1 form2 &optional overflow-p)
@@ -986 +1013 @@
   `(,op ,bits ,@(decomp-formlist forms)))
 
-(defdecomp call (op fn arglist &optional spread-p)
+(defdecomp (builtin-call call) (op fn arglist &optional spread-p)
   (setq op (if spread-p 'apply 'funcall))
   `(,op ,(decomp-form fn) ,@(decomp-arglist arglist)))

trunk/source/lib/nfcomp.lisp

@@ -311 +311 @@
       (funcall (compile-named-function
                 lambda
+                :compile-code-coverage nil
                 :source-notes *fcomp-source-note-map*
                 :env *fasl-compile-time-env*
@@ -321 +322 @@
 ;;; Well, no usable methods by default.  How this is better than
 ;;; getting a NO-APPLICABLE-METHOD error frankly escapes me,
+;;; [Hint: this is called even when there is an applicable method]
 (defun no-make-load-form-for (object)
   (error "No ~S method is defined for ~s" 'make-load-form object))
@@ -961 +963 @@
   (and notes (gethash form notes)))
 
+(defun (setf fcomp-source-note) (note form &aux (notes *fcomp-source-note-map*))
+  (and notes (setf (gethash form notes) note)))
+
 (defun fcomp-note-source-transformation (original new)
   (let* ((*nx-source-note-map* *fcomp-source-note-map*))
@@ -1039 +1044 @@
            (*fcomp-stream-position* *fcomp-previous-position*)
            (*loading-toplevel-location* *fcomp-loading-toplevel-location*)
-           (lambda (if T ;; (null (cdr forms))
-                     `(lambda () ,@forms)
-                     `(lambda ()
-                        (macrolet ((load-time-value (value)
-                                     (declare (ignore value))
-                                     (compiler-function-overflow)))
-                          ,@forms)))))
+           (body (if T ;; (null (cdr forms))
+                   `(progn ,@forms)
+                   `(macrolet ((load-time-value (value)
+                                 (declare (ignore value))
+                                 (compiler-function-overflow)))
+                      ,@forms)))
+           (lambda `(lambda () ,body)))
+      ;; Don't assign a location to the lambda so it doesn't confuse acode printing, but
+      ;; arrange to assign it to any inner lambdas.
+      (setf (fcomp-source-note body) *loading-toplevel-location*)
       (setq *fcomp-toplevel-forms* nil)
       ;(format t "~& Random toplevel form: ~s" lambda)
@@ -1051 +1059 @@
                      $fasl-lfuncall
                      env
-                     (fcomp-named-function lambda nil env *loading-toplevel-location*))
+                     (fcomp-named-function lambda nil env #|*loading-toplevel-location*|#))
         (compiler-function-overflow ()
           (if (null (cdr forms))

trunk/source/library/cover.lisp

@@ -58 +58 @@
 (defparameter *code-note-acode-strings* (make-hash-table :test #'eq))
 
-(defparameter *coverage-acode-queue* nil)
-
 (defstruct (coverage-state (:conc-name "%COVERAGE-STATE-"))
   alist)
@@ -88 +86 @@
 
 (defun code-note-acode-string (note)
-  (gethash note *code-note-acode-strings*))
+  (and *code-note-acode-strings*
+       (gethash note *code-note-acode-strings*)))
 
 (defun map-function-coverage (lfun fn &optional refs)
@@ -100 +99 @@
               do (map-function-coverage imm fn refs))))
 
-(defun get-function-coverage (fn refs acode)
+(defun get-function-coverage (fn refs)
   (let ((entry (function-entry-code-note fn))
         (refs (cons fn refs))
-        (acode (or (%function-acode-string fn) acode)))
+        (acode (%function-acode-string fn))
+        (source (function-source-form-note fn)))
     (declare (dynamic-extent refs))
     (when entry
@@ -119 +119 @@
               (setf (gethash imm *code-note-acode-strings*) acode)))
        when (and (functionp imm)
-                 (not (memq imm refs)))
-       nconc (get-function-coverage imm refs acode)))))
+                 (not (memq imm refs))
+                 ;; Make sure this fn is in the source we're currently looking at.
+                 ;; It might not be, if it is referenced via (load-time-value (foo))
+                 ;; where (foo) returns an lfun from some different source entirely.
+                 ;; CL-PPCRE does that.
+                 (or (null source)
+                     (eq source (function-source-form-note imm))))
+       nconc (get-function-coverage imm refs)))))
 
 (defun code-covered-info.file (data) (and (consp data) (car data)))
@@ -140 +146 @@
   (clrhash *emitted-code-notes*)
   (clrhash *entry-code-notes*)
-  (clrhash *code-note-acode-strings*)
+  (when *code-note-acode-strings* (clrhash *code-note-acode-strings*))
   (loop for data in *code-covered-functions*
         do (let* ((file (code-covered-info.file data))
                   (toplevel-functions (code-covered-info.fns data)))
              (when file
-               (push (list* file
-                            ;; Duplicates are possible if you have multiple instances of
-                            ;; (load-time-value (foo)) where (foo) returns an lfun.
-                            ;; CL-PPCRE does that.
-                            (delete-duplicates
-                             (loop for fn across toplevel-functions
-                                   nconc (get-function-coverage fn nil nil)))
-                            toplevel-functions)
-                     *file-coverage*))))
+               (let* ((all-functions (delete-duplicates
+                                      ;; Duplicates are possible if you have multiple instances of
+                                      ;; (load-time-value (foo)) where (foo) returns an lfun.
+                                      ;; CL-PPCRE does that.
+                                      (loop for fn across toplevel-functions
+                                            nconc (get-function-coverage fn nil))))
+                      (coverage (list* file all-functions toplevel-functions)))
+                 (push coverage *file-coverage*)))))
   ;; Now get subnotes, including un-emitted ones.
   (loop for note being the hash-key of *emitted-code-notes*
@@ -159 +164 @@
                  while parent
                  do (pushnew n (gethash parent *coverage-subnotes*))
-                 until (emitted-code-note-p parent)))
-  (let ((hash (make-hash-table :test #'eq)))
-    ;; distribute entry acode to the toplevel source note it belongs to.
-    (loop for entry being the hash-key of *entry-code-notes* using (hash-value fn)
-      as acode = (code-note-acode-string entry)
-      as sn = (entry-note-unambiguous-source entry)
-      as toplevel-sn = (function-source-form-note fn)
-      do (when sn
-           (assert toplevel-sn)
-           (let* ((pos (source-note-end-pos sn))
-                  (cell (assq acode (gethash toplevel-sn hash))))
-             (if cell
-               (setf (cdr cell) (max (cdr cell) pos))
-               (push (cons acode pos) (gethash toplevel-sn hash))))))
-    (setf *coverage-acode-queue*
-          (sort (loop for sn being the hash-key of hash using (hash-value alist)
-                  collect (cons (source-note-end-pos sn)
-                                (mapcar #'car (sort alist #'< :key #'cdr))))
-                #'< :key #'car))))
+                 until (emitted-code-note-p parent))))
+
+(defun file-coverage-acode-queue (coverage)
+  (loop with hash = (make-hash-table :test #'eq :shared nil)
+        for fn in (file-coverage-functions coverage)
+        as acode = (%function-acode-string fn)
+        as entry = (function-entry-code-note fn)
+        as sn = (entry-note-unambiguous-source entry)
+        as toplevel-sn = (function-source-form-note fn)
+        do (when sn
+             (assert toplevel-sn)
+             (let* ((pos (source-note-end-pos sn))
+                    (cell (assq acode (gethash toplevel-sn hash))))
+               (if cell
+                 (setf (cdr cell) (max (cdr cell) pos))
+                 (push (cons acode pos) (gethash toplevel-sn hash)))))
+        finally (return (sort (loop for sn being the hash-key of hash using (hash-value alist)
+                                    collect (cons (source-note-end-pos sn)
+                                                  (mapcar #'car (sort alist #'< :key #'cdr))))
+                              #'< :key #'car))))
 
 #+debug
@@ -456 +462 @@
          (*coverage-subnotes* (make-hash-table :test #'eq :shared nil))
          (*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
-         (*entry-code-notes* (make-hash-table :test #'eq :shared nil)))
-    (get-coverage)
+         (*entry-code-notes* (make-hash-table :test #'eq :shared nil))
+         (*code-note-acode-strings* nil))
+    (get-coverage) 
     (loop for coverage in *file-coverage*
           as stats = (make-coverage-statistics :source-file (file-coverage-file coverage))
@@ -502 +509 @@
          (*emitted-code-notes* (make-hash-table :test #'eq :shared nil))
          (*entry-code-notes* (make-hash-table :test #'eq :shared nil))
+         (*code-note-acode-strings* (make-hash-table :test #'eq :shared nil))
          (index-file (and html (merge-pathnames output-file "index.html")))
          (stats-file (and statistics (merge-pathnames (if (or (stringp statistics)
@@ -712 +720 @@
               when (and (functionp imm)
                         (not (memq imm refs))
-                        ;; Make sure this fn is in the source we're currently looking at.
-                        ;; It might not be, if it is referenced via (load-time-value (foo))
-                        ;; where (foo) returns an lfun from some different source entirely.
-                        ;; CL-PPCRE does that.
+                        ;; See note in get-function-coverage
                         (or (null source)
                             (eq source (function-source-form-note imm))
@@ -736 +741 @@
                              :element-type '(unsigned-byte 2)))
          (acode-styles (make-hash-table :test #'eq)))
-    (map nil #'(lambda (fn) (colorize-function fn styles acode-styles)) (file-coverage-toplevel-functions coverage))
+    (map nil #'(lambda (fn) (colorize-function fn styles acode-styles))
+         (file-coverage-toplevel-functions coverage))
     (print-file-coverage-report index-file html-stream coverage styles acode-styles source)
     (format html-stream "</body></html>")))
@@ -758 +764 @@
 
     ;; Output source intertwined with acode
-    (iterate output ((start 0) (line 0))
+    (iterate output ((start 0) (line 0) (queue (file-coverage-acode-queue coverage)))
       (format html-stream "<div class='source'><code>")
-      (let ((next (car *coverage-acode-queue*)))
+      (let ((next (car queue)))
         (multiple-value-bind (end last-line)
-                             (output-styled html-stream source styles
-                                            :start start
-                                            :line line
-                                            :limit (car next))
+            (output-styled html-stream source styles
+                           :start start
+                           :line line
+                           :limit (car next))
           (format html-stream "</code></div>~%")
           (when (and next end (<= (car next) end))
@@ -772 +778 @@
                                    <div class='acode' id='a~:*~d'><code>" pos)
               (loop for acode in strings as styles = (gethash acode acode-styles)
-                do (assert styles)
-                do (output-styled html-stream acode styles)
-                do (fresh-line html-stream))
-              (format html-stream "</code></div><hr/>~%"))
-            (pop *coverage-acode-queue*)
-            (output (1+ end) last-line)))))))
+                    do (assert styles)
+                    do (when styles (output-styled html-stream acode styles))
+                    do (fresh-line html-stream))
+              (format html-stream "</code></div><hr/>~%")
+              (output (1+ end) last-line (cdr queue)))))))))
 
 (defun output-styled (html-stream source styles &key (start 0) line limit)