Changeset 12300


Ignore:
Timestamp:
Jun 25, 2009, 3:34:05 PM (10 years ago)
Author:
gz
Message:

Code coverage support

Location:
trunk/source
Files:
1 added
11 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/X86/x862.lisp

    r12297 r12300  
    12271227      (compiler-bug "x862-form ? ~s" form)))
    12281228
    1229 (defmacro with-note ((form-var seg-var &rest other-vars) &body body)
     1229(defmacro with-note ((form-var seg-var) &body body)
    12301230  (let* ((note (gensym "NOTE"))
    12311231         (code-note (gensym "CODE-NOTE"))
    12321232         (source-note (gensym "SOURCE-NOTE"))
    12331233         (start (gensym "START"))
    1234          (end (gensym "END"))
    1235          (with-note-body (gensym "WITH-NOTE-BODY")))
    1236     `(flet ((,with-note-body (,form-var ,seg-var ,@other-vars)
    1237               ,@body))
    1238        (let ((,note (acode-note ,form-var)))
    1239          (if ,note
    1240            (let* ((,code-note (and (code-note-p ,note) ,note))
    1241                   (,source-note (if ,code-note
    1242                                   (code-note-source-note ,note)
    1243                                   ,note))
    1244                   (,start (and ,source-note
    1245                                (x862-emit-note ,seg-var :source-location-begin ,source-note))))
    1246              (prog2
    1247                  (when ,code-note
    1248                    (with-x86-local-vinsn-macros (,seg-var)
    1249                      (x862-store-immediate ,seg-var ,code-note *x862-temp0*)
    1250                      (! misc-set-immediate-c-node 0 *x862-temp0* 1)))
    1251                  (,with-note-body ,form-var ,seg-var ,@other-vars)
    1252                (when ,source-note
    1253                  (let ((,end (x862-emit-note ,seg-var :source-location-end)))
    1254                    (setf (vinsn-note-peer ,start) ,end
    1255                          (vinsn-note-peer ,end) ,start)
    1256                    (push ,start *x862-emitted-source-notes*)))))
    1257            (,with-note-body ,form-var ,seg-var ,@other-vars))))))
     1234         (end (gensym "END")))
     1235    `(let* ((,note (acode-note ,form-var))
     1236            (,code-note (and (code-note-p ,note) ,note))
     1237            (,source-note (if ,code-note
     1238                            (code-note-source-note ,note)
     1239                            ,note))
     1240            (,start (and ,source-note
     1241                         (x862-emit-note ,seg-var :source-location-begin ,source-note))))
     1242      #+debug-code-notes (require-type ,note '(or null code-note source-note))
     1243      (when ,code-note
     1244        (with-x86-local-vinsn-macros (,seg-var)
     1245          (x862-store-immediate ,seg-var ,code-note *x862-temp0*)
     1246          (! misc-set-immediate-c-node 0 *x862-temp0* 1)))
     1247      (prog1
     1248          (progn
     1249            ,@body)
     1250        (when ,source-note
     1251          (let ((,end (x862-emit-note ,seg-var :source-location-end)))
     1252            (setf (vinsn-note-peer ,start) ,end
     1253                  (vinsn-note-peer ,end) ,start)
     1254            (push ,start *x862-emitted-source-notes*)))))))
    12581255
    12591256(defun x862-toplevel-form (seg vreg xfer form)
     
    12631260
    12641261(defun x862-form (seg vreg xfer form)
    1265   (with-note (form seg vreg xfer)
     1262  (with-note (form seg)
    12661263    (if (nx-null form)
    12671264      (x862-nil seg vreg xfer)
     
    12801277(defun x862-form-float (seg freg xfer form)
    12811278  (declare (ignore xfer))
    1282   (with-note (form seg freg)
     1279  (with-note (form seg)
    12831280    (when (or (nx-null form)(nx-t form))(compiler-bug "x862-form to freg ~s" form))
    12841281    (when (and (= (get-regspec-mode freg) hard-reg-class-fpr-mode-double)
     
    42274224
    42284225(defun x862-dynamic-extent-form (seg curstack val &aux (form val))
    4229   (when (acode-p form)
    4230     (with-note (form seg curstack) ;; note this binds form/seg/curstack so can't be setq'd.
     4226  (when (acode-p val)
     4227    ;; this will do source note processing even if don't emit anything here,
     4228    ;; which is a bit wasteful but not incorrect.
     4229    (with-note (form seg)
    42314230      (with-x86-local-vinsn-macros (seg)
    42324231        (let* ((op (acode-operator form)))
     
    50675066;;; "XFER" is a compound destination.
    50685067(defun x862-conditional-form (seg xfer form)
    5069   (with-note (form seg xfer)
    5070     (let* ((uwf (acode-unwrapped-form-value form)))
    5071       (if (nx-null uwf)
    5072         (x862-branch seg (x862-cd-false xfer))
    5073         (if (x86-constant-form-p uwf)
    5074           (x862-branch seg (x862-cd-true xfer))
    5075           (with-crf-target () crf
    5076             (let* ((ea (x862-lexical-reference-ea form nil)))
    5077               (if (and ea (memory-spec-p ea))
    5078                 (x862-compare-ea-to-nil seg crf xfer ea x86::x86-e-bits nil)
    5079                 (x862-form seg crf xfer form)))))))))
     5068  (let* ((uwf (acode-unwrapped-form-value form)))
     5069    (if (x86-constant-form-p uwf)
     5070      (with-note (form seg)
     5071        (if (nx-null uwf)
     5072          (x862-branch seg (x862-cd-false xfer))
     5073          (x862-branch seg (x862-cd-true xfer))))
     5074      (with-crf-target () crf
     5075        (let* ((ea (x862-lexical-reference-ea form nil)))
     5076          (if (and ea (memory-spec-p ea))
     5077            (with-note (form seg)
     5078              (x862-compare-ea-to-nil seg crf xfer ea x86::x86-e-bits nil))
     5079            (x862-form seg crf xfer form)))))))
    50805080
    50815081     
     
    89458945                (eq typespec '*))
    89468946          (x862-form seg vreg xfer form)
    8947           (with-note (form seg vreg xfer)
     8947          (with-note (form seg)
    89488948          (let* ((ok (backend-get-next-label)))
    89498949            (if (and (symbolp typespec) (non-nil-symbolp (type-predicate typespec)))
  • trunk/source/compiler/nx-basic.lisp

    r12254 r12300  
    6767  ;; Code coverage state.  This MUST be the first slot - see nx2-code-coverage.
    6868  code-coverage
    69   ;; The actual source form - useful for debugging, otherwise unused.
    70   #+debug-code-notes form
    7169  ;; The source note of this form, or NIL if random code form (no file info,
    7270  ;; generated by macros or other source transform)
    7371  source-note
    7472  ;; the note that was being compiled when this note was emitted.
    75   parent-note)
     73  parent-note
     74  #+debug-code-notes ;; The actual source form - useful for debugging, otherwise unused.
     75  form)
    7676
    7777(defun make-code-note (&key form source-note parent-note)
     
    8787            (with-output-to-string (s) (let ((*print-circle* t)) (prin1 form s)))))
    8888    note))
     89
     90(defmethod print-object ((note code-note) stream)
     91  (print-unreadable-object (note stream :type t :identity t)
     92    (format stream "[~s]" (code-note-code-coverage note))
     93    (let ((sn (code-note-source-note note)))
     94      (if sn
     95        (progn
     96          (format stream " for ")
     97          (print-source-note sn stream))
     98        #+debug-code-notes
     99        (when (code-note-form note)
     100          (format stream " form ~a"
     101                  (string-sans-most-whitespace (code-note-form note))))))))
    89102
    90103(defun nx-ensure-code-note (form &optional parent-note)
  • trunk/source/compiler/nx0.lisp

    r12297 r12300  
    16811681          (nx-note-source-transformation original replacement)
    16821682          (nx1-transformed-form (nx-transform replacement env) env)))
    1683     (nx1-transformed-form (nx-transform original env) env)))
     1683    (multiple-value-bind (form changed source) (nx-transform original env)
     1684      (declare (ignore changed))
     1685      ;; Bind this for cases where the transformed form is an atom, so it doesn't remember the source it came from.
     1686      (let ((*nx-current-note* (or source *nx-current-note*)))
     1687        (nx1-transformed-form form env)))))
    16841688
    16851689(defun nx1-transformed-form (form env)
     
    16991703                      (nx1-symbol form env)
    17001704                      (nx1-immediate (nx-unquote constant-value)))))))
    1701     (cond (*nx-current-code-note*
    1702            (setf (acode-note acode) *nx-current-code-note*))
    1703           (*record-pc-mapping*
    1704            (setf (acode-note acode) (nx-source-note form))))
     1705    (unless (acode-note acode) ;; leave it with most specific note
     1706      (cond (*nx-current-code-note*
     1707             (setf (acode-note acode) *nx-current-code-note*))
     1708            (*record-pc-mapping*
     1709             (setf (acode-note acode) (nx-source-note form)))))
    17051710    acode))
    17061711
     
    22852290         (go START))
    22862291     DONE
    2287        (when (and source (neq source t) (not (gethash form source-note-map)))
    2288          (unless (and (consp form)
    2289                       (eq (%car form) 'the)
    2290                       (eq source (gethash (caddr form) source-note-map)))
    2291            (unless (or (eq form (%unbound-marker))
    2292                        (eq form (%slot-unbound-marker)))
    2293              (setf (gethash form source-note-map) source))))
    2294        (return (values form changed)))))
     2292       (if (eq source t)
     2293         (setq source nil)
     2294         (let ((this (nx-source-note form)))
     2295           (if this
     2296             (setq source this)
     2297             (when source
     2298               (unless (and (consp form)
     2299                            (eq (%car form) 'the)
     2300                            (eq source (gethash (caddr form) source-note-map)))
     2301                 (unless (or (consp form) (vectorp form) (pathnamep form))
     2302                   (unless (or (eq form (%unbound-marker))
     2303                               (eq form (%slot-unbound-marker)))
     2304                     (setf (gethash form source-note-map) source))))))))
     2305       ;; Return source for symbols, even though don't record it in hash table.
     2306       (return (values form changed source)))))
     2307
    22952308
    22962309; Transform all of the arguments to the function call form.
  • trunk/source/compiler/optimizers.lisp

    r12297 r12300  
    551551
    552552(define-compiler-macro if (&whole call test true &optional false &environment env)
    553   (multiple-value-bind (test test-win) (nx-transform test env)
    554     (multiple-value-bind (true true-win) (nx-transform true env)
    555       (multiple-value-bind (false false-win) (nx-transform false env)
    556         (if (nx-form-constant-p test env)
    557           (if (nx-form-constant-value test env)
    558             true
    559             false)
    560           (if (or test-win true-win false-win)
    561             `(if ,test ,true ,false)
    562             call))))))
     553  (let ((test-val (nx-transform test env)))
     554    (if (nx-form-constant-p test-val env)
     555      (if (nx-form-constant-value test-val env)
     556        true
     557        false)
     558      call)))
    563559
    564560(define-compiler-macro %ilsr (&whole call &environment env shift value)
  • trunk/source/level-0/nfasload.lisp

    r11373 r12300  
    735735
    736736
     737;;; files compiled with code coverage do this
     738;; list of lfuns and (source-fn-name . vector-of-lfuns), the latter put there by fasloading.
     739(defvar *code-covered-functions* nil)
     740
     741(defun register-code-covered-functions (functions)
     742  ;; unpack the parent-note references - see comment at fcomp-digest-code-notes
     743  (labels ((reg (lfun refs)
     744             (unless (memq lfun refs)
     745               (let* ((lfv (function-to-function-vector lfun))
     746                      (start #+ppc-target 0 #+x86-target (%function-code-words lfun))
     747                      (refs (cons lfun refs)))
     748                 (declare (dynamic-extent refs))
     749                 (loop for i from start below (uvsize lfv) as imm = (uvref lfv i)
     750                       do (typecase imm
     751                            (code-note
     752                             (let ((parent (code-note-parent-note imm)))
     753                               (when (integerp parent)
     754                                 (setf (code-note-parent-note imm) (uvref lfv parent)))))
     755                            (function (reg imm refs))))))))
     756    (loop for fn across functions do (reg fn nil)))
     757  (let ((a (assoc (pathname *loading-file-source-file*)
     758                  *code-covered-functions*
     759                  :test #'(lambda (p q)
     760                            (and (equalp (pathname-name p) (pathname-name q))
     761                                 ;; same name, so worth trying harder to match 'em up.
     762                                 (or (equal p q)
     763                                     (let ((p (full-pathname p)) (q (full-pathname q)))
     764                                       (and p q (equalp p q)))
     765                                     (let ((p (probe-file p)) (q (probe-file q)))
     766                                       (and p q (equalp p q)))))))))
     767    (when (null a)
     768      (push (setq a (list nil nil)) *code-covered-functions*))
     769    (setf (car a) *loading-file-source-file* (cdr a) functions))
     770  nil)
    737771
    738772;;; The loader itself
  • trunk/source/level-1/l1-aprims.lisp

    r12210 r12300  
    994994         (nth-immediate lfun 1))))
    995995
     996
     997(defun function-entry-code-note (fn)
     998  (let ((bits (lfun-bits (setq fn (require-type fn 'function)))))
     999    (declare (fixnum bits))
     1000    (and (logbitp $lfbits-code-coverage-bit bits)
     1001         (loop for i upfrom 1 as imm = (nth-immediate fn i)
     1002               when (code-note-p imm) do (return imm)))))
    9961003
    9971004
  • trunk/source/level-1/l1-boot-2.lisp

    r12166 r12300  
    306306      (bin-load-provide "EDIT-CALLERS" "edit-callers")
    307307      (bin-load-provide "DESCRIBE" "describe")
     308      (bin-load-provide "COVER" "cover")
    308309      (bin-load-provide "LEAKS" "leaks")
    309310      (bin-load-provide "MCL-COMPAT" "mcl-compat")
  • trunk/source/level-1/l1-reader.lisp

    r12037 r12300  
    30133013(defmethod print-object ((sn source-note) stream)
    30143014  (print-unreadable-object (sn stream :type t :identity nil)
    3015     (let ((*print-length* (min (or *print-length* 3) 3)))
    3016       (format stream "~s:~s-~s ~s" (source-note-filename sn)
    3017               (source-note-start-pos sn) (source-note-end-pos sn)
    3018               (source-note.source sn)))))
     3015    (print-source-note sn stream)))
     3016
     3017(defun print-source-note (sn stream)
     3018  (let* ((file (source-note-filename sn))
     3019         (text (ignore-errors (source-note-text sn))))
     3020    ;; Should fix this when record the name.
     3021    (when (eq (pathname-version file) :newest)
     3022      (setq file (namestring (make-pathname :version nil :defaults file))))
     3023    (when text
     3024      (setq text (string-sans-most-whitespace text 121))
     3025      (when (> (length text) 120)
     3026        (setq text (concatenate 'string (subseq text 0 120) "..."))))
     3027    (format stream "~s:~s-~s ~s" file
     3028            (source-note-start-pos sn) (source-note-end-pos sn)
     3029            text)))
    30193030
    30203031(defun source-note-filename (source)
  • trunk/source/lib/compile-ccl.lisp

    r12139 r12300  
    205205    edit-callers
    206206    describe
     207    cover
    207208    leaks
    208209    asdf
  • trunk/source/lib/nfcomp.lisp

    r12163 r12300  
    455455           (*fasl-eof-forms* nil)
    456456           (*loading-file-source-file* orig-file)
    457            (*fcomp-source-note-map* (and *save-source-locations*
     457           (*fcomp-source-note-map* (and (or *save-source-locations* *compile-code-coverage*)
    458458                                         (make-hash-table :test #'eq :shared nil)))
    459459           (*loading-toplevel-location* nil)
     
    492492            (fcomp-signal-or-defer-warnings *nx-warnings* env)
    493493            (setq *fcomp-previous-position* *fcomp-stream-position*))))
     494      (when *compile-code-coverage*
     495        (fcomp-compile-toplevel-forms env)
     496        (let* ((fns (fcomp-code-covered-functions))
     497               (v (nreverse (coerce fns 'vector))))
     498          (map nil #'fcomp-digest-code-notes v)
     499          (fcomp-random-toplevel-form `(register-code-covered-functions ',v) env)))
    494500      (while (setq form *fasl-eof-forms*)
    495501        (setq *fasl-eof-forms* nil)
     
    499505      (fcomp-compile-toplevel-forms env))))
    500506
     507(defun fcomp-code-covered-functions ()
     508  (loop for op in *fcomp-output-list*
     509        when (consp op)
     510          nconc (if (eq (car op) $fasl-lfuncall)
     511                  ;; Don't collect the toplevel lfun itself, it leads to spurious markings.
     512                  ;; Instead, descend one level and collect any referenced fns.
     513                  (destructuring-bind (fn) (cdr op)
     514                    (lfunloop for imm in fn when (functionp imm) collect imm))
     515                  (loop for arg in (cdr op) when (functionp arg) collect arg))))
    501516
    502517
     
    10251040      (fcomp-signal-or-defer-warnings warnings env)
    10261041      lfun)))
     1042
     1043
     1044;; Convert parent-notes to immediate indices.  The reason this is necessary is to avoid hitting
     1045;; the fasdumper's 64K limit on multiply-referenced objects.  This removes the reference
     1046;; from parent slots, making notes less likely to be multiply-referenced.
     1047(defun fcomp-digest-code-notes (lfun &optional refs)
     1048  (unless (memq lfun refs)
     1049    (let* ((lfv (function-to-function-vector lfun))
     1050           (start #+ppc-target 0 #+x86-target (%function-code-words lfun))
     1051           (refs (cons lfun refs)))
     1052      (declare (dynamic-extent refs))
     1053      (loop for i from start below (uvsize lfv) as imm = (uvref lfv i)
     1054            do (typecase imm
     1055                 (code-note
     1056                  (let* ((parent (code-note-parent-note imm))
     1057                         (pos (when (code-note-p parent)
     1058                                (loop for j from start below i
     1059                                      do (when (eq parent (uvref lfv j)) (return j))))))
     1060                    (when pos
     1061                      (setf (code-note-parent-note imm) pos))))
     1062                 (function
     1063                  (fcomp-digest-code-notes imm refs)))))))
    10271064
    10281065; For now, defer only UNDEFINED-REFERENCEs, signal all others via WARN.
  • trunk/source/lib/systems.lisp

    r11369 r12300  
    204204    (linux-files      "ccl:l1f;linux-files"      ("ccl:level-1;linux-files.lisp"))
    205205    (source-files     "ccl:bin;source-files"     ("ccl:lib;source-files.lisp"))
     206    (cover            "ccl:bin;cover"            ("ccl:library;cover.lisp"))
    206207    (leaks            "ccl:bin;leaks"            ("ccl:library;leaks.lisp"))
    207208 
Note: See TracChangeset for help on using the changeset viewer.