Index: /branches/gz-working/compiler/PPC/ppc2.lisp =================================================================== --- /branches/gz-working/compiler/PPC/ppc2.lisp (revision 8507) +++ /branches/gz-working/compiler/PPC/ppc2.lisp (revision 8508) @@ -2160,6 +2160,4 @@ (append-dll-node (setf (code-note-start-pc note) (make-vinsn-label nil)) seg)) (when *compile-code-coverage* - (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)) @@ -2171,5 +2169,5 @@ (defun ppc2-digest-code-notes () - (when (or *compile-code-coverage* *record-pc-mapping*) + (when *record-pc-mapping* (flet ((address (label) (when (typep label 'vinsn-label) @@ -2185,5 +2183,5 @@ (defun ppc2-reset-code-notes () - (when (or *compile-code-coverage* *record-pc-mapping*) + (when *record-pc-mapping* (flet ((clear (label) (if (typep label 'vinsn-label) nil label))) (labels ((rec (note) @@ -5117,5 +5115,5 @@ (let* ((id (vinsn-label-id v))) (if (or (typep id 'fixnum) (null id)) - (when (or t (vinsn-label-refs v)) + (when (or t (vinsn-label-refs v) (null id)) (setf (vinsn-label-info v) (emit-lap-label v))) (ppc2-expand-note id))) @@ -5312,4 +5310,6 @@ (ppc2-allocate-global-registers *ppc2-fcells* *ppc2-vcells* (afunc-all-vars afunc) no-regs)) (@ (backend-get-next-label)) ; generic self-reference label, should be label #1 + (when keys ;; Ensure keyvect is the first immediate + (backend-immediate-index (%cadr (%cdddr keys)))) (when *compile-code-coverage* (ppc2-code-coverage-entry seg)) Index: /branches/gz-working/compiler/X86/x862.lisp =================================================================== --- /branches/gz-working/compiler/X86/x862.lisp (revision 8507) +++ /branches/gz-working/compiler/X86/x862.lisp (revision 8508) @@ -571,4 +571,6 @@ (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc))) (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit)))) + (when (logbitp $fbitccoverage (the fixnum (afunc-bits afunc))) + (setq bits (+ bits (ash 1 $lfbits-code-coverage-bit)))) (let* ((function-debugging-info (afunc-lfun-info afunc))) (when (or function-debugging-info lambda-form *x862-record-symbols*) @@ -609,5 +611,7 @@ #-x86-target (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info))) - (x862-digest-symbols))))) + (x862-digest-symbols) + (x862-digest-code-notes))))) + (x862-reset-code-notes) (backend-remove-labels)))) afunc)) @@ -2280,14 +2284,9 @@ (^)))) -(defx862 x862-code-coverage code-coverage (seg vreg xfer ccrec form) - (with-x86-local-vinsn-macros (seg) - (x862-store-immediate seg ccrec x8664::arg_x) - (! load-t x8664::arg_y) - (! misc-set-c-node x8664::arg_y x8664::arg_x 1)) - (x862-form seg vreg xfer form)) - (defun x862-code-coverage-entry (seg) - (let ((ccrec (getf (afunc-lfun-info *x862-cur-afunc*) 'function-code-coverage))) - (when ccrec + (let* ((afunc *x862-cur-afunc*) + (note (getf (afunc-lfun-info afunc) 'function-source-note))) + (when note + (setf (afunc-bits afunc) (%ilogior (afunc-bits afunc) (ash 1 $fbitccoverage))) (with-x86-local-vinsn-macros (seg) (let* ((ccreg ($ x8664::arg_x)) @@ -2295,9 +2294,48 @@ (! vpush-register ccreg) (! vpush-register valreg) - (! ref-constant x8664::arg_x (x86-immediate-label ccrec)) + (! ref-constant ccreg (x86-immediate-label note)) (! load-t valreg) (! misc-set-c-node valreg ccreg 1) (! vpop-register valreg) (! vpop-register ccreg)))))) + +(defx862 x862-with-code-note with-code-note (seg vreg xfer note form &aux val) + (when *record-pc-mapping* + (append-dll-node (setf (code-note-start-pc note) (make-vinsn-label nil)) seg)) + (when *compile-code-coverage* + (with-x86-local-vinsn-macros (seg) + (x862-store-immediate seg note x8664::arg_x) + (! load-t x8664::arg_y) + (! misc-set-c-node x8664::arg_y x8664::arg_x 1))) + (setq val (x862-form seg vreg xfer form)) + (when *record-pc-mapping* + (append-dll-node (setf (code-note-end-pc note) (make-vinsn-label nil)) seg)) + val) + + +(defun x862-digest-code-notes () + (when *record-pc-mapping* + (flet ((address (label) + (when (typep label 'vinsn-label) + (let ((lap-label (or (vinsn-label-info label) + (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)))))) + +(defun x862-reset-code-notes () + (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)))))) + (defun x862-vset (seg vreg xfer type-keyword vector index value safe) @@ -5266,5 +5304,5 @@ (let* ((id (vinsn-label-id v))) (if (or (typep id 'fixnum) (null id)) - (when (or t (vinsn-label-refs v)) + (when (or t (vinsn-label-refs v) (null id)) (setf (vinsn-label-info v) (emit-x86-lap-label frag-list v))) (x862-expand-note frag-list id))) @@ -5536,5 +5574,8 @@ (! establish-fn) (@ (backend-get-next-label)) ; self-call label - (x862-code-coverage-entry seg) + (when keys ;; Ensure keyvect is the first immediate + (x86-immediate-label (%cadr (%cdddr keys)))) + (when *compile-code-coverage* + (x862-code-coverage-entry seg)) (unless next-method-p @@ -5586,5 +5627,4 @@ (unless (= nprev 0) (x862-lri seg x8664::imm0 (ash nprev *x862-target-fixnum-shift*))) - (x86-immediate-label keyvect) (if (= 0 nprev) (! simple-keywords) Index: /branches/gz-working/level-1/l1-aprims.lisp =================================================================== --- /branches/gz-working/level-1/l1-aprims.lisp (revision 8507) +++ /branches/gz-working/level-1/l1-aprims.lisp (revision 8508) @@ -974,7 +974,5 @@ (and (not (logbitp $lfbits-gfn-bit bits)) (not (logbitp $lfbits-cm-bit bits)))) - (if (logbitp $lfbits-code-coverage-bit bits) - (nth-immediate lfun 2) - (nth-immediate lfun 1))))) + (nth-immediate lfun 1)))) Index: /branches/gz-working/level-1/l1-boot-2.lisp =================================================================== --- /branches/gz-working/level-1/l1-boot-2.lisp (revision 8507) +++ /branches/gz-working/level-1/l1-boot-2.lisp (revision 8508) @@ -267,4 +267,5 @@ (bin-load-provide "DESCRIBE" "describe") (bin-load-provide "SOURCE-FILES" "source-files") + (bin-load-provide "COVER" "cover") (bin-load-provide "MCL-COMPAT" "mcl-compat") (require "LOOP") Index: /branches/gz-working/level-1/l1-reader.lisp =================================================================== --- /branches/gz-working/level-1/l1-reader.lisp (revision 8507) +++ /branches/gz-working/level-1/l1-reader.lisp (revision 8508) @@ -3013,5 +3013,5 @@ (print-unreadable-object (note stream :type t :identity t) (let ((text (and (source-note-p note) (ignore-errors (source-note-text note))))) - (when (null text) + (when (and (null text) (code-note-form note)) (setq text (ignore-errors (let ((*print-circle* t)) @@ -3023,5 +3023,5 @@ (subseq text 0 (min (or end (length text)) 120)) "..."))))) - (format stream "[~s]~:[~;for ~:*~a~] (~s subforms)" + (format stream "[~s]~:[~; for ~:*~a~] (~s subforms)" (code-note-code-coverage note) text Index: /branches/gz-working/lib/nfcomp.lisp =================================================================== --- /branches/gz-working/lib/nfcomp.lisp (revision 8507) +++ /branches/gz-working/lib/nfcomp.lisp (revision 8508) @@ -36,4 +36,6 @@ (read stream nil eofval nil))) #-BOOTSTRAPPED (defvar *save-source-locations* nil) +#-BOOTSTRAPPED (defvar *record-pc-mapping* nil) +#-BOOTSTRAPPED (defvar *compile-code-coverage* nil) (defmacro short-fixnum-p (fixnum)