Index: /branches/gz-working/compiler/PPC/ppc2.lisp =================================================================== --- /branches/gz-working/compiler/PPC/ppc2.lisp (revision 8476) +++ /branches/gz-working/compiler/PPC/ppc2.lisp (revision 8477) @@ -2146,5 +2146,6 @@ (defun ppc2-code-coverage-entry (seg) - (let ((note (getf (afunc-lfun-info *ppc2-cur-afunc*) 'function-source-note))) + (let* ((afunc *ppc2-cur-afunc*) + (note (getf (afunc-lfun-info afunc) 'function-source-note))) (when note (setf (afunc-bits afunc) (%ilogior (afunc-bits afunc) (ash 1 $fbitccoverage))) @@ -2159,5 +2160,6 @@ (append-dll-node (setf (source-note-start-pc note) (make-vinsn-label nil)) seg)) (when *compile-code-coverage* - (setf (afunc-bits afunc) (%ilogior (afunc-bits afunc) (ash 1 $fbitccoverage))) + (let ((afunc *ppc2-cur-afunc*)) + (setf (afunc-bits afunc) (%ilogior (afunc-bits afunc) (ash 1 $fbitccoverage)))) (with-ppc-local-vinsn-macros (seg) (ppc2-store-immediate seg note ($ ppc::arg_x)) Index: /branches/gz-working/compiler/lambda-list.lisp =================================================================== --- /branches/gz-working/compiler/lambda-list.lisp (revision 8476) +++ /branches/gz-working/compiler/lambda-list.lisp (revision 8477) @@ -26,5 +26,5 @@ (defun function-source-note (fn) - (get (%lfun-info (require-type fn 'function) 'function-source-note))) + (getf (%lfun-info (require-type fn 'function)) 'function-source-note)) (defun %lfun-info-index (fn) Index: /branches/gz-working/compiler/nx.lisp =================================================================== --- /branches/gz-working/compiler/nx.lisp (revision 8476) +++ /branches/gz-working/compiler/nx.lisp (revision 8477) @@ -153,15 +153,43 @@ (defparameter *nx-source-note-map* nil) -(defmacro nx-source-note (form) - `(gethash ,form *nx-source-note-map*)) - -(defun nx-ensure-source-note (form parent) - ;; Here's a fun code coverage issue: What if the same source form gets used multiple - ;; times. e.g. (macrolet ((dup (x) `(progn (foo ,x) (bar ,x)))) (dup (something))). - ;; We could arrange to have separate records for each instance, but as of right now no - ;; existing or contemplated UI has a means of showing the distinction, so don't bother. - (or (nx-source-note form) - (and (consp form) - (setf (nx-source-note form) (make-source-note :form form :source parent))))) +(defun note-contained-in-p (note parent) + (loop for n = note then (source-note-source n) while (source-note-p n) thereis (eq n parent))) + +(defun nx-ensure-source-note (form parent-note) + ;; Try to find a source note for this form; if the form doesn't come from user source, just make + ;; a new record for it. The act of matching up a source note with forms that might come from + ;; macroexpansion is heuristic at best. In general, err in favor of making a new record, because + ;; that leads to fewer false positives in code coverage reporting. But still, try hard to + ;; match things up best we can. The main problem is with atoms, which the source recording stuff + ;; doesn't track properly. + (let ((note (gethash form *nx-source-note-map*))) + (when note + (let* ((parent-source (loop for n = parent-note then (source-note-source n) + when (or (null n) (source-note-start-pos n)) return n))) + (setq note + (when parent-source + (if (consp note) + ;; This form (typically an atom) has multiple source locations. + ;; At least try to distinguish occurences in different outer forms. This allows + ;; reasonable code coverage reporting for "(if (test) t (other))", although it + ;; doesn't work for cases like "(if foo foo (other))". + (loop with found = nil + for n in note + when (note-contained-in-p n parent-source) + do (if found (return nil) (setq found n)) + finally (return found)) + (when (note-contained-in-p note parent-source) + ;; As an aside, here's a fun code coverage issue: What if the same source + ;; form (i.e. single source location) gets used multiple times. e.g. + ;; (macrolet ((dup (x) `(progn (foo ,x) (bar ,x)))) (dup (something))). + ;; We could arrange to have separate records for each instance, but as of right + ;; now no existing or contemplated UI has a means of showing the distinction, + ;; so don't bother. + note)))))) + (unless note + (setq note (make-source-note :form form :source parent-note))) + (when (and parent-note (neq note parent-note)) + (push note (source-note-subform-notes parent-note))) + note)) (eval-when (:compile-toplevel) Index: /branches/gz-working/compiler/nx0.lisp =================================================================== --- /branches/gz-working/compiler/nx0.lisp (revision 8476) +++ /branches/gz-working/compiler/nx0.lisp (revision 8477) @@ -79,4 +79,5 @@ (defvar *nx-warnings* nil) (defvar *nx-current-source-note* nil) + (defvar *nx1-compiler-special-forms* nil "Real special forms") @@ -1571,11 +1572,12 @@ (defun nx1-transformed-form (form env &optional original) - (if (and (consp form) *nx-current-source-note*) + (if *nx-current-source-note* (let* ((original (or original form)) - (*nx-current-source-note* (nx-ensure-source-note original *nx-current-source-note*))) - (unless *nx-current-source-note* + (new-note (nx-ensure-source-note original *nx-current-source-note*)) + (*nx-current-source-note* new-note)) + (unless new-note (compiler-bug "No source note for ~s -> ~s" original form)) (make-acode (%nx1-operator with-source-note) - *nx-current-source-note* + new-note (nx1-transformed-form-aux form env))) (nx1-transformed-form-aux form env))) Index: /branches/gz-working/compiler/optimizers.lisp =================================================================== --- /branches/gz-working/compiler/optimizers.lisp (revision 8476) +++ /branches/gz-working/compiler/optimizers.lisp (revision 8477) @@ -544,13 +544,11 @@ (define-compiler-macro if (&whole call test true &optional false &environment env) (multiple-value-bind (test test-win) (nx-transform test env) - (multiple-value-bind (true true-win) (nx-transform true env) - (multiple-value-bind (false false-win) (nx-transform false env) - (if (or (quoted-form-p test) (self-evaluating-p test)) - (if (eval test) - true - false) - (if (or test-win true-win false-win) - `(if ,test ,true ,false) - call)))))) + (if (or (quoted-form-p test) (self-evaluating-p test)) + (if (eval test) + true + false) + (if test-win + `(if ,test ,@(cddr call)) + call)))) (define-compiler-macro %ilsr (&whole call &environment env shift value) Index: /branches/gz-working/level-0/l0-init.lisp =================================================================== --- /branches/gz-working/level-0/l0-init.lisp (revision 8476) +++ /branches/gz-working/level-0/l0-init.lisp (revision 8477) @@ -132,6 +132,4 @@ (defparameter *loading-file-source-file* nil) -(defvar *code-covered-functions* nil "All lfuns instrumented for code coverage") - (defvar *nx-speed* 1) (defvar *nx-space* 1) Index: /branches/gz-working/level-0/nfasload.lisp =================================================================== --- /branches/gz-working/level-0/nfasload.lisp (revision 8476) +++ /branches/gz-working/level-0/nfasload.lisp (revision 8477) @@ -687,4 +687,17 @@ (provide (%fasl-expr s))) + +;;; files compiled with code coverage do this +;; list of lfuns and (source-fn-name . vector-of-lfuns), the latter put there by fasloading. +(defvar *code-covered-functions* nil) + +(defun register-code-covered-functions (functions) + (let ((a (assoc (pathname *loading-file-source-file*) + *code-covered-functions* + :test #'equalp))) + (when (null a) + (push (setq a (list nil nil)) *code-covered-functions*)) + (setf (car a) *loading-file-source-file* (cdr a) functions) + nil)) ;;; The loader itself Index: /branches/gz-working/level-1/l1-aprims.lisp =================================================================== --- /branches/gz-working/level-1/l1-aprims.lisp (revision 8476) +++ /branches/gz-working/level-1/l1-aprims.lisp (revision 8477) @@ -974,5 +974,7 @@ (and (not (logbitp $lfbits-gfn-bit bits)) (not (logbitp $lfbits-cm-bit bits)))) - (nth-immediate lfun 1)))) + (if (logbitp $lfbits-code-coverage-bit bits) + (nth-immediate lfun 2) + (nth-immediate lfun 1))))) Index: /branches/gz-working/level-1/l1-reader.lisp =================================================================== --- /branches/gz-working/level-1/l1-reader.lisp (revision 8476) +++ /branches/gz-working/level-1/l1-reader.lisp (revision 8477) @@ -2469,5 +2469,5 @@ (start-pos (file-position stream))) (declare (fixnum attr)) - (if (= attr $cht_ill) + (if (eql attr $cht_ill) (signal-reader-error stream "Illegal character ~S." firstchar)) (let* ((vals (multiple-value-list @@ -2492,8 +2492,11 @@ (destructuring-bind (form &optional nested-source-notes) vals + ;; Can't really trust random reader macros to return source notes... + (unless (and (consp nested-source-notes) + (source-note-p (car nested-source-notes))) + (setq nested-source-notes nil)) (values form t - (and (consp form) - start-pos + (and start-pos (make-source-note :form form :stream stream @@ -3004,9 +3007,20 @@ (defmethod print-object ((note source-note) stream) - (declare (ignore stream)) - (if *print-circle* - (call-next-method) - (let ((*print-circle* t)) - (call-next-method)))) + (print-unreadable-object (note stream :type t :identity t) + (let ((text (ignore-errors (source-note-text note)))) + (when (null text) + (setq text (ignore-errors + (let ((*print-circle* t)) + (format nil "~s" (source-note-form note)))))) + (when (> (length text) 20) + (let ((end (position #\Newline text :start 20))) + (when (or end (> (length text) 120)) + (setq text (concatenate 'string + (subseq text 0 (min (or end (length text)) 120)) + "..."))))) + (format stream "[~s] for ~s (~s subforms)" + (source-note-code-coverage note) + text + (length (source-note-subform-notes note)))))) (defun source-note-length (note) @@ -3015,5 +3029,6 @@ (defun source-note-text (note) (multiple-value-bind (string offset) (source-note-string-and-offset note) - (subseq string offset (+ offset (source-note-length note))))) + (when string + (subseq string offset (+ offset (source-note-length note)))))) (defun source-note-string-and-offset (note) @@ -3023,5 +3038,5 @@ (assert (<= (source-note-length note) (length source))) (values source 0)) - (t + ((source-note-p source) (let ((start (source-note-start-pos note)) (parent-start (source-note-start-pos source))) @@ -3058,6 +3073,5 @@ (t (let* ((start (file-position stream)) (form (read-internal stream nil eofval nil))) - (values form (and (consp form) - (not (eq form eofval)) + (values form (and (neq form eofval) (%make-source-note :form form :file-name file-name @@ -3073,27 +3087,29 @@ (when (and recording (not *read-suppress*)) (destructuring-bind (map file-name stream-offset) (cdr recording) - (let ((note (%make-source-note :form form - :file-name file-name - :start-pos (+ stream-offset start-pos) - :end-pos (+ stream-offset end-pos)))) - (setf (gethash form map) note) - (labels ((rec (subnote) - (cond - ((consp subnote) - (if (null (car subnote)) - (rec (cdr subnote)) - (progn (rec (car subnote)) (rec (cdr subnote))))) - ((source-note-p subnote) - (unless (source-note-source subnote) - (setf (source-note-source subnote) note))) - #| ((null note) '()) - (t (error "Don't know how to deal with a source note like ~S." - nested-source-notes)) |# ))) - (rec subform-notes)) - note)))) + (let* ((prev (gethash form map)) + (note (%make-source-note :form form + :file-name file-name + :start-pos (+ stream-offset start-pos) + :end-pos (+ stream-offset end-pos)))) + (setf (gethash form map) + (cond ((null prev) note) + ((consp prev) (cons note prev)) + (t (list note prev)))) + (loop for sub in subform-notes as subnote = (require-type sub 'source-note) + do (when (source-note-source subnote) (error "Subnote ~s already owned?" subnote)) + do (setf (source-note-source subnote) note)) + note)))) ;; Else note for a form generated by macroexpansion (let* ((source (and source (require-type source 'source-note))) - (note (%make-source-note :form form :source source))) - (when source (push note (source-note-subform-notes source))) + (note (%make-source-note + ;; Unfortunately, recording the macroexpanded form is problematic, since they + ;; can have references to non-dumpable forms, see e.g. loop. + ;; Could print it with *print-string-length* bound to 80 or so, and record + ;; the string instead. + ;; :form form + :source source))) + ;; For debugging + #+gz (setf (source-note-form note) + (with-output-to-string (s) (let ((*print-string-length* 80)) (prin1 form s)))) note))) Index: /branches/gz-working/lib/backquote.lisp =================================================================== --- /branches/gz-working/lib/backquote.lisp (revision 8476) +++ /branches/gz-working/lib/backquote.lisp (revision 8477) @@ -371,5 +371,5 @@ (let ((*backquote-stack* (list* |`,| |`,.| |`,@| *backquote-stack*))) (read stream t nil t))))) - (if *backquote-expand* (macroexpand-1 form) form)))) + (if *backquote-expand* (values (macroexpand-1 form)) form)))) (set-macro-character Index: /branches/gz-working/lib/nfcomp.lisp =================================================================== --- /branches/gz-working/lib/nfcomp.lisp (revision 8476) +++ /branches/gz-working/lib/nfcomp.lisp (revision 8477) @@ -448,5 +448,5 @@ (when *fcomp-covered-functions* (let ((v (nreverse (coerce *fcomp-covered-functions* 'vector)))) - (fcomp-random-toplevel-form `(setq *code-covered-functions* (cons '(,*loading-file-source-file* . ,v) *code-covered-functions*))))) + (fcomp-random-toplevel-form `(register-code-covered-functions ',v) env nil))) (while (setq form *fasl-eof-forms*) (setq *fasl-eof-forms* nil)