Index: /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp =================================================================== --- /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp (revision 8559) +++ /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp (revision 8560) @@ -22,4 +22,6 @@ (require "X86-ASM") (require "X86-LAP")) + +(defvar *use-source-notes* t) (defstruct (x86-disassembled-instruction (:include dll-node) @@ -2726,5 +2728,6 @@ (entry (x86-ds-entry-point ds))) (let* ((pc (- addr entry))) - (let* ((source-note (source-note-from-%lfun-info (%lfun-info function))) + (let* ((source-note (and *use-source-notes* + (source-note-from-%lfun-info (%lfun-info function)))) (source-info (find-source-at-pc function pc)) (text (if (and source-info @@ -2766,7 +2769,13 @@ (when source-note (format t ";; Source: ~S:~D-~D" - (getf source-note :file-name) - (getf source-note :start) - (getf source-note :end))))) + (if (listp source-note) + (getf source-note :file-name) + (source-note-file-name source-note)) + (if (listp source-note) + (getf source-note :start) + (source-note-start-pos source-note)) + (if (listp source-note) + (getf source-note :end) + (source-note-end-pos source-note)))))) (defun x8664-disassemble-xfunction (function xfunction Index: /branches/working-0711/ccl/compiler/X86/x862.lisp =================================================================== --- /branches/working-0711/ccl/compiler/X86/x862.lisp (revision 8559) +++ /branches/working-0711/ccl/compiler/X86/x862.lisp (revision 8560) @@ -2399,4 +2399,5 @@ (defun x862-digest-code-notes () + #+not-used (when *record-pc-mapping* (flet ((address (label) @@ -2405,20 +2406,27 @@ (compiler-bug "Missing source note label: ~s" label)))) (x86-lap-label-address lap-label))))) - (labels ((rec (note) - (when note - (setf (code-note-start-pc note) (address (code-note-start-pc note))) - (setf (code-note-end-pc note) (address (code-note-end-pc note))) - (dolist (subnote (code-note-subform-notes note)) (rec subnote))))) - (rec (getf (afunc-lfun-info *x862-cur-afunc*) 'function-source-note)))))) + (loop for note in *x862-emitted-source-notes* + do (setf (code-note-start-pc note) (address (code-note-start-pc note))) + do (setf (code-note-end-pc note) (address (code-note-end-pc note)))))) + (when *compile-code-coverage* + ;; Convert parent-notes to immediate indices. The reason this is necessary is to avoid hitting + ;; the fasdumper's 64K limit on multiply-referenced objects. This removes the reference + ;; from parent slots, making notes less likely to be multiply-referenced. + (loop for (note . nil) in *x862-constant-alist* + when (code-note-p note) + do (let* ((parent (code-note-parent-note note)) + (list (and (code-note-p parent) + (member parent *x862-constant-alist* :test #'eq :key #'car)))) + (when list + (setf (code-note-parent-note note) (length list))))))) + (defun x862-reset-code-notes () + #+not-used (when *record-pc-mapping* (flet ((clear (label) (if (typep label 'vinsn-label) nil label))) - (labels ((rec (note) - (when note - (setf (code-note-start-pc note) (clear (code-note-start-pc note))) - (setf (code-note-end-pc note) (clear (code-note-end-pc note))) - (dolist (subnote (code-note-subform-notes note)) (rec subnote))))) - (rec (getf (afunc-lfun-info *x862-cur-afunc*) 'function-source-note)))))) + (loop for note in *x862-emitted-source-notes* + do (setf (code-note-start-pc note) (clear (code-note-start-pc note))) + do (setf (code-note-end-pc note) (clear (code-note-end-pc note))))))) Index: /branches/working-0711/ccl/compiler/nx.lisp =================================================================== --- /branches/working-0711/ccl/compiler/nx.lisp (revision 8559) +++ /branches/working-0711/ccl/compiler/nx.lisp (revision 8560) @@ -196,5 +196,10 @@ (make-code-note :form (or original form) :source parent-note)))) (when (and parent-note (neq note parent-note)) - (push note (code-note-subform-notes parent-note))) + (let ((old (code-note-parent-note note))) + (setf (code-note-parent-note note) + (typecase old + (null parent-note) + (cons (cons parent-note old)) + (t (if (eq old parent-note) old (list parent-note old))))))) note)) Index: /branches/working-0711/ccl/compiler/nx0.lisp =================================================================== --- /branches/working-0711/ccl/compiler/nx0.lisp (revision 8559) +++ /branches/working-0711/ccl/compiler/nx0.lisp (revision 8560) @@ -1636,4 +1636,5 @@ corresponding source notes.") +#| (defun make-source-note-form-map (source-note &optional existing-map) "Creates a mapping from lisp forms to source-notes based on SOURCE-NOTES. This should be bound to @@ -1655,4 +1656,5 @@ (walk source-note)) map)) +|# (defun nx1-source-note (nx1-code) Index: /branches/working-0711/ccl/level-0/nfasload.lisp =================================================================== --- /branches/working-0711/ccl/level-0/nfasload.lisp (revision 8559) +++ /branches/working-0711/ccl/level-0/nfasload.lisp (revision 8560) @@ -693,4 +693,12 @@ (defun register-code-covered-functions (functions) + ;; unpack the parent-note references - see comment at x862-digest-code-notes. + (loop for fn across functions as lfv = (function-to-function-vector fn) + do (loop for i from #+ppc-target 0 #+x86-target (%function-code-words fn) below (uvsize lfv) + as note = (uvref lfv i) + when (code-note-p note) + do (let ((parent (code-note-parent-note note))) + (when (integerp parent) + (setf (code-note-parent-note note) (nth-immediate fn parent)))))) (let ((a (assoc (pathname *loading-file-source-file*) *code-covered-functions* @@ -698,6 +706,6 @@ (when (null a) (push (setq a (list nil nil)) *code-covered-functions*)) - (setf (car a) *loading-file-source-file* (cdr a) functions) - nil)) + (setf (car a) *loading-file-source-file* (cdr a) functions)) + nil) ;;; The loader itself Index: /branches/working-0711/ccl/level-1/l1-boot-2.lisp =================================================================== --- /branches/working-0711/ccl/level-1/l1-boot-2.lisp (revision 8559) +++ /branches/working-0711/ccl/level-1/l1-boot-2.lisp (revision 8560) @@ -267,5 +267,5 @@ (bin-load-provide "DESCRIBE" "describe") (bin-load-provide "SOURCE-FILES" "source-files") -; (bin-load-provide "COVER" "cover") + (bin-load-provide "COVER" "cover") (bin-load-provide "MCL-COMPAT" "mcl-compat") (require "LOOP") Index: /branches/working-0711/ccl/level-1/l1-reader.lisp =================================================================== --- /branches/working-0711/ccl/level-1/l1-reader.lisp (revision 8559) +++ /branches/working-0711/ccl/level-1/l1-reader.lisp (revision 8560) @@ -2999,6 +2999,7 @@ start-pc end-pc - ;; Notes for code-generating subforms of this form - subform-notes) + ;; The note that was being compiled when this note was emitted. Could + ;; be a list in case of a source form that is used multiple times. + parent-note) (defstruct (source-note (:include code-note) @@ -3011,5 +3012,5 @@ ;;; we don't actually store source-note structs in the fasl since that runs into problems dumping ;;; the struct. -(defun source-note-for-%lfun-info (note &key (start t) (end t) (text t) (form t) (subform-notes t) (file-name t)) +(defun source-note-for-%lfun-info (note &key (start t) (end t) (text t) (form t) (parent-note t) (file-name t)) (append (when start (list :start (source-note-start-pos note))) (when end (list :end (source-note-end-pos note))) @@ -3023,5 +3024,5 @@ (code-note (code-note-source source))))))) (when form (list :form (source-note-form note))) - (when subform-notes (list :subform-notes (source-note-subform-notes note))) + (when parent-note (list :parent-note (source-note-parent-note note))) (when file-name (list :file-name (source-note-file-name note))))) @@ -3051,8 +3052,7 @@ (subseq text 0 (min (or end (length text)) 120)) "..."))))) - (format stream "[~s]~:[~; for ~:*~a~] (~s subforms)" + (format stream "[~s]~:[~; for ~:*~a~]" (code-note-code-coverage note) - text - (length (code-note-subform-notes note)))))) + text)))) (defun source-note-length (note) @@ -3097,4 +3097,11 @@ (when (and source-note (not (eq form eofval))) (assert (null (source-note-source source-note))) + ;; Flatten the backpointers so each subnote points directly to the toplevel note. + (loop for note being the hash-value of map + unless (eq note source-note) + do (loop for p = note then (source-note-source p) + do (when (eq p source-note) + (return (setf (source-note-source note) source-note))) + while (source-note-p p))) (let ((text (make-string (source-note-length source-note))) (pos (file-position stream))) @@ -3103,5 +3110,5 @@ (file-position stream pos) (setf (source-note-source source-note) text))) - (values form source-note)))) + (values form source-note)))) ((eql t) (let* ((start (file-position stream)) @@ -3134,15 +3141,16 @@ (declare (ignorable form)) ;; A note for a form generated by macroexpansion - (let* ((source (and source (require-type source 'code-note))) - (note (%make-code-note + (let* ((note (%make-code-note ;; Unfortunately, recording the macroexpanded form is problematic, since they ;; can have references to non-dumpable forms, see e.g. loop. - ;; Could print it and record the string instead. ;; :form form - :source source))) + :source (and source + (if (source-note-p source) + source + (code-note-source source)))))) #+debug (when form (setf (code-note-form note) - (with-output-to-string (s) (let ((*print-string-length* 80)) (prin1 form s))))) + (with-output-to-string (s) (let ((*print-circle* t)) (prin1 form s))))) note)) Index: /branches/working-0711/ccl/lib/nfcomp.lisp =================================================================== --- /branches/working-0711/ccl/lib/nfcomp.lisp (revision 8559) +++ /branches/working-0711/ccl/lib/nfcomp.lisp (revision 8560) @@ -1115,4 +1115,6 @@ (defun fasl-scan-user-form (form) + (when (code-note-p form) + (return-from fasl-scan-user-form (fasl-scan-gvector form))) (multiple-value-bind (load-form init-form) (make-load-form form *fcomp-load-forms-environment*) (labels ((simple-load-form (form) Index: /branches/working-0711/ccl/library/cover.lisp =================================================================== --- /branches/working-0711/ccl/library/cover.lisp (revision 8559) +++ /branches/working-0711/ccl/library/cover.lisp (revision 8560) @@ -16,13 +16,48 @@ (defconstant $partially-covered-style 6) + +(defvar *coverage-subnotes* (make-hash-table :test #'eq)) + +(defmacro coverage-subnotes (note) + `(gethash ,note *coverage-subnotes*)) + + +(defun function-immediates-start (fn) + #+ppc-target 0 #+x86-target (%function-code-words fn)) + +(defun get-function-subnotes (fn) + (unless (setf (coverage-subnotes fn) (function-source-note fn)) + (error "Covered function without source note?")) + (let ((lfv (function-to-function-vector fn))) + (loop for i from (function-immediates-start fn) below (uvsize lfv) + as imm = (uvref lfv i) + when (code-note-p imm) + do (let ((parent (code-note-parent-note imm))) + (when parent + (if (consp parent) + (loop for p in parent + do (push imm (coverage-subnotes p))) + (push imm (coverage-subnotes parent))))) + when (and (functionp imm) + (function-source-note imm) + (not (coverage-subnotes imm))) + do (get-function-subnotes imm)))) + +(defun get-subnotes () + (clrhash *coverage-subnotes*) + (loop for (nil . functions) in *code-covered-functions* + do (loop for fn across functions + do (get-function-subnotes fn)))) + (defun show-notes (note) (when (functionp note) (setq note (function-source-note note))) (labels ((show (note indent label) - (dotimes (i indent) (write-char #\space)) - (format t "~a ~a~%" label note) - (loop with subindent = (+ indent 3) - for sub in (code-note-subform-notes note) as i upfrom 1 - do (show sub subindent (format nil "~a~d." label i))))) + (dotimes (i indent) (write-char #\space)) + (format t "~a ~a~%" label note) + (when (code-note-p note) + (loop with subindent = (+ indent 3) + for sub in (coverage-subnotes note) as i upfrom 1 + do (show sub subindent (format nil "~a~d." label i)))))) (show note 0 ""))) @@ -31,5 +66,7 @@ (data (find-if #'(lambda (data) (and (consp data) - (equalp (probe-file (car data)) true-path))) + (or (equalp (car data) path) + (and true-path + (equalp (probe-file (car data)) true-path))))) *code-covered-functions*))) (cdr data))) @@ -47,5 +84,5 @@ (labels ((rec (note) (when note - (map nil #'rec (code-note-subform-notes note)) + (map nil #'rec (coverage-subnotes note)) (funcall fn note)))) (rec (function-source-note function)))))) @@ -63,4 +100,16 @@ (setf (code-note-code-coverage note) nil)))) +(defun save-function-coverage (fn &optional (refs ())) + (push fn refs) + (cons (let ((name (function-name fn))) + (and (symbolp name) name)) + (let ((lfv (function-to-function-vector fn))) + (loop for i from (function-immediates-start fn) below (uvsize lfv) + as imm = (uvref lfv i) + when (code-note-p imm) + collect (code-note-code-coverage imm) + when (and (functionp imm) (not (memq imm refs))) + collect (save-function-coverage imm refs))))) + (defun save-coverage () "Returns an opaque representation of the current code coverage state. @@ -69,25 +118,46 @@ A representation that has been printed and read back will work identically in RESTORE-COVERAGE." - #+sbcl(loop for file being the hash-keys of sb-c::*code-coverage-info* - using (hash-value states) - collect (cons file states)) - (error "Not implemented yet")) + (loop for data in *code-covered-functions* + when (consp data) + collect (cons (car data) + (map 'vector #'save-function-coverage (cdr data))))) (defun restore-coverage (coverage-state) "Restore the code coverage data back to an earlier state produced by SAVE-COVERAGE." - #+sbcl - (loop for (file . states) in coverage-state - do (let ((image-states (gethash file sb-c::*code-coverage-info*)) - (table (make-hash-table :test 'equal))) - (when image-states - (loop for cons in image-states - do (setf (gethash (car cons) table) cons)) - (loop for (key . value) in states - do (let ((state (gethash key table))) - (when state - (setf (cdr state) value))))))) - coverage-state - (error "Not implemented yet")) + (loop for (saved-file . saved-fns) in coverage-state + as fns = (covered-functions-for-file saved-file) + do (flet ((mismatched (why &rest args) + (error "Mismatched coverage data for ~s, ~?" saved-file why args))) + (cond ((null fns) + (warn "Couldn't restore saved coverage for ~s, no matching file present" + saved-file)) + ((not (eql (length fns) (length saved-fns))) + (mismatched "was ~s functions, now ~s" (length saved-fns) (length fns))) + (t + (loop for fn across fns + for saved-data across saved-fns + do (labels + ((rec (fn saved-data refs) + (push fn refs) + (let* ((lfv (function-to-function-vector fn)) + (name (car saved-data)) + (saved-imms (cdr saved-data))) + (unless (equalp name + (let ((name (function-name fn))) + (and (symbolp name) name))) + (mismatched "had ~s now have ~s" name (function-name fn))) + (loop for i from (function-immediates-start fn) below (uvsize lfv) + as imm = (uvref lfv i) + when (code-note-p imm) + do (if (or (null saved-imms) (consp (car saved-imms))) + (mismatched "in ~s" name) + (setf (code-note-code-coverage imm) (pop saved-imms))) + when (and (functionp imm) (not (memq imm refs))) + do (if (or (null saved-imms) (atom (car saved-imms))) + (mismatched "in ~s" name) + (rec imm (pop saved-imms) refs)))))) + (rec fn saved-data nil))))))) + (clrhash *coverage-subnotes*)) (defun save-coverage-in-file (pathname) @@ -99,5 +169,5 @@ :if-does-not-exist :create) (with-standard-io-syntax - (let ((*package* (find-package :sb-cover))) + (let ((*package* *ccl-package*)) (write (save-coverage) :stream stream))) (values))) @@ -108,5 +178,5 @@ (with-open-file (stream pathname :direction :input) (with-standard-io-syntax - (let ((*package* (find-package :sb-cover))) + (let ((*package* *ccl-package*)) (restore-coverage (read stream)))) (values))) @@ -143,4 +213,5 @@ files can be specified with the EXTERNAL-FORMAT parameter. " + (get-subnotes) (let* ((paths) (directory (make-pathname :name nil :type nil :defaults output-file)) @@ -193,5 +264,5 @@ (when note (if (code-note-code-coverage note) - (let ((subnotes (code-note-subform-notes note))) + (let ((subnotes (coverage-subnotes note))) (map nil #'rec subnotes) (unless (find 'full subnotes :test #'neq @@ -199,5 +270,5 @@ (setf (code-note-code-coverage note) 'full))) #+gz - (let ((subnotes (code-note-subform-notes note))) + (let ((subnotes (coverage-subnotes note))) (unless (every #'(lambda (subnote) (null (code-note-code-coverage subnote))) @@ -221,5 +292,5 @@ ;; that can be showna (not (source-note-p note))) - (map nil #'rec (code-note-subform-notes note)))))) + (map nil #'rec (coverage-subnotes note)))))) (rec note)))) @@ -334,5 +405,5 @@ (when (code-note-code-coverage note) (incf covered)) - (map nil #'rec (code-note-subform-notes note))))) + (map nil #'rec (coverage-subnotes note))))) (rec (function-source-note function)))) functions)