X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=903a0a673f47d475521bb6b23bde80cd25c49453;hb=6bbc22725d3bf663726ed9adca544e39316364a6;hp=8f80aefc5a35f4d7b9957c2b816b24902dc6e575;hpb=49e92ee57b3b01f5862d0c6fa65f521de1688941;p=sbcl.git diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 8f80aef..903a0a6 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -14,15 +14,40 @@ (declaim (special *compiler-error-bailout*)) +;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the +;;; form number to associate with a source path. This should be bound +;;; to an initial value of 0 before the processing of each truly +;;; top level form. +(declaim (type index *current-form-number*)) +(defvar *current-form-number*) + ;;; *SOURCE-PATHS* is a hashtable from source code forms to the path ;;; taken through the source to reach the form. This provides a way to ;;; keep track of the location of original source forms, even when ;;; macroexpansions and other arbitary permutations of the code ;;; happen. This table is initialized by calling FIND-SOURCE-PATHS on ;;; the original source. +;;; +;;; It is fairly useless to store symbols, characters, or fixnums in +;;; this table, as 42 is EQ to 42 no matter where in the source it +;;; appears. GET-SOURCE-PATH and NOTE-SOURCE-PATH functions should be +;;; always used to access this table. (declaim (hash-table *source-paths*)) (defvar *source-paths*) +(declaim (inline source-form-has-path-p)) +(defun source-form-has-path-p (form) + (not (typep form '(or symbol fixnum character)))) + +(defun get-source-path (form) + (when (source-form-has-path-p form) + (gethash form *source-paths*))) + +(defun note-source-path (form &rest arguments) + (when (source-form-has-path-p form) + (setf (gethash form *source-paths*) + (apply #'list* 'original-source-start *current-form-number* arguments)))) + ;;; *CURRENT-COMPONENT* is the COMPONENT structure which we link ;;; blocks into as we generate them. This just serves to glue the ;;; emitted blocks together until local call analysis and flow graph @@ -410,13 +435,6 @@ (functional-kind res) :toplevel) res))) -;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the -;;; form number to associate with a source path. This should be bound -;;; to an initial value of 0 before the processing of each truly -;;; top level form. -(declaim (type index *current-form-number*)) -(defvar *current-form-number*) - ;;; This function is called on freshly read forms to record the ;;; initial location of each form (and subform.) Form is the form to ;;; find the paths in, and TLF-NUM is the top level form number of the @@ -430,9 +448,8 @@ (sub-find-source-paths form (list tlf-num))) (values)) (defun sub-find-source-paths (form path) - (unless (gethash form *source-paths*) - (setf (gethash form *source-paths*) - (list* 'original-source-start *current-form-number* path)) + (unless (get-source-path form) + (note-source-path form path) (incf *current-form-number*) (let ((pos 0) (subform form) @@ -447,11 +464,8 @@ (sub-find-source-paths fm (cons pos path)) ;; Otherwise store the containing form. It's ;; not perfect, but better than nothing. - (setf (gethash subform *source-paths*) - (list* 'original-source-start - *current-form-number* - pos - path))) + (unless (zerop pos) + (note-source-path subform pos path))) (incf pos)) (setq subform (cdr subform)) (when (eq subform trail) (return))))) @@ -493,7 +507,7 @@ ;; namespace. (defun ir1-convert (start next result form) (ir1-error-bailout (start next result form) - (let* ((*current-path* (or (gethash form *source-paths*) + (let* ((*current-path* (or (get-source-path form) (cons form *current-path*))) (start (instrument-coverage start nil form))) (cond ((atom form) @@ -736,7 +750,7 @@ (let ((*print-pretty* nil) ;; We rely on the printer to abbreviate FORM. (*print-length* 3) - (*print-level* 1)) + (*print-level* 3)) (format nil #-sb-xc-host "(in macroexpansion of ~S)" @@ -818,9 +832,18 @@ ;;;; code coverage +;;; Used as the CDR of the code coverage instrumentation records +;;; (instead of NIL) to ensure that any well-behaving user code will +;;; not have constants EQUAL to that record. This avoids problems with +;;; the records getting coalesced with non-record conses, which then +;;; get mutated when the instrumentation runs. Note that it's +;;; important for multiple records for the same location to be +;;; coalesced. -- JES, 2008-01-02 +(defconstant +code-coverage-unmarked+ '%code-coverage-unmarked%) + ;;; Check the policy for whether we should generate code coverage ;;; instrumentation. If not, just return the original START -;;; ctran. Otherwise ninsert code coverage instrumentation after +;;; ctran. Otherwise insert code coverage instrumentation after ;;; START, and return the new ctran. (defun instrument-coverage (start mode form) ;; We don't actually use FORM for anything, it's just convenient to @@ -843,7 +866,7 @@ ;; each instrument for the same block. (or (gethash path *code-coverage-records*) (setf (gethash path *code-coverage-records*) - (cons path nil)))) + (cons path +code-coverage-unmarked+)))) (next (make-ctran)) (*allow-instrumenting* nil)) (push (ctran-block start) @@ -853,7 +876,8 @@ `(locally (declare (optimize speed (safety 0) - (debug 0))) + (debug 0) + (check-constant-modification 0))) ;; We're being naughty here, and ;; modifying constant data. That's ok, ;; we know what we're doing. @@ -870,10 +894,10 @@ ;;; EQness of the conses. (defun maybe-instrument-progn-like (start forms form) (or (when (and *allow-instrumenting* - (not (gethash form *source-paths*))) - (let ((*current-path* (gethash forms *source-paths*))) + (not (get-source-path form))) + (let ((*current-path* (get-source-path forms))) (when *current-path* - (instrument-coverage start :progn form)))) + (instrument-coverage start nil form)))) start)) (defun record-code-coverage (info cc) @@ -886,9 +910,15 @@ (maphash (lambda (info cc) (declare (ignore info)) (dolist (cc-entry cc) - (setf (cdr cc-entry) nil))) + (setf (cdr cc-entry) +code-coverage-unmarked+))) *code-coverage-info*)) +(defun code-coverage-record-marked (record) + (aver (consp record)) + (ecase (cdr record) + ((#.+code-coverage-unmarked+) nil) + ((t) t))) + ;;;; converting combinations