(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
(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
(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)
;; Otherwise store the containing form. It's
;; not perfect, but better than nothing.
(unless (zerop pos)
- (setf (gethash subform *source-paths*)
- (list* 'original-source-start
- *current-form-number*
- pos
- path))))
+ (note-source-path subform pos path)))
(incf pos))
(setq subform (cdr subform))
(when (eq subform trail) (return)))))
;; 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)
(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)"
\f
;;;; 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
;; 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)
`(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.
;;; 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 nil form))))
start))
(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)))
+
\f
;;;; converting combinations
projects / sbcl.git / blobdiff