Index: /trunk/source/compiler/nx-basic.lisp =================================================================== --- /trunk/source/compiler/nx-basic.lisp (revision 14186) +++ /trunk/source/compiler/nx-basic.lisp (revision 14187) @@ -739,18 +739,33 @@ (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,28 +773,19 @@ (*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,5 +831,5 @@ (< 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,6 +907,9 @@ (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,13 +922,13 @@ `(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,5 +960,19 @@ `(,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,6 +1000,10 @@ `(,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,5 +1013,5 @@ `(,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))) Index: /trunk/source/lib/nfcomp.lisp =================================================================== --- /trunk/source/lib/nfcomp.lisp (revision 14186) +++ /trunk/source/lib/nfcomp.lisp (revision 14187) @@ -311,4 +311,5 @@ (funcall (compile-named-function lambda + :compile-code-coverage nil :source-notes *fcomp-source-note-map* :env *fasl-compile-time-env* @@ -321,4 +322,5 @@ ;;; 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,4 +963,7 @@ (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,11 +1044,14 @@ (*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,5 +1059,5 @@ $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)) Index: /trunk/source/library/cover.lisp =================================================================== --- /trunk/source/library/cover.lisp (revision 14186) +++ /trunk/source/library/cover.lisp (revision 14187) @@ -58,6 +58,4 @@ (defparameter *code-note-acode-strings* (make-hash-table :test #'eq)) -(defparameter *coverage-acode-queue* nil) - (defstruct (coverage-state (:conc-name "%COVERAGE-STATE-")) alist) @@ -88,5 +86,6 @@ (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,8 +99,9 @@ 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,6 +119,12 @@ (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,18 +146,17 @@ (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,23 +164,24 @@ 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,6 +462,7 @@ (*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,4 +509,5 @@ (*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,8 +720,5 @@ 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,5 +741,6 @@ :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 ""))) @@ -758,12 +764,12 @@ ;; 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 "
") - (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 "
~%") (when (and next end (<= (car next) end)) @@ -772,10 +778,9 @@
" 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 "
~%")) - (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 "
~%") + (output (1+ end) last-line (cdr queue))))))))) (defun output-styled (html-stream source styles &key (start 0) line limit)