X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=15ac812a880e39aa4724e7af0a12fea198982994;hb=da8cb4801a3ab35070f380e22aea3d260f9df8aa;hp=783ba7be00e339e16579d800b0fc053b738133cc;hpb=de1859fb0815446420c6e0d58adb266012134acc;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 783ba7b..15ac812 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -393,12 +393,12 @@
 ;;; The hashtables used to hold global namespace info must be
 ;;; reallocated elsewhere. Note also that *LEXENV* is not bound, so
 ;;; that local macro definitions can be introduced by enclosing code.
-(defun ir1-toplevel (form path for-value)
+(defun ir1-toplevel (form path for-value &optional (allow-instrumenting t))
   (declare (list path))
   (let* ((*current-path* path)
          (component (make-empty-component))
          (*current-component* component)
-         (*allow-instrumenting* t))
+         (*allow-instrumenting* allow-instrumenting))
     (setf (component-name component) 'initial-component)
     (setf (component-kind component) :initial)
     (let* ((forms (if for-value `(,form) `(,form nil)))
@@ -442,8 +442,17 @@
                    '(progn
                       (when (atom subform) (return))
                       (let ((fm (car subform)))
-                        (when (consp fm)
-                          (sub-find-source-paths fm (cons pos path)))
+                        (if (consp fm)
+                            ;; If it's a cons, recurse
+                            (sub-find-source-paths fm (cons pos path))
+                            ;; 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))))
                         (incf pos))
                       (setq subform (cdr subform))
                       (when (eq subform trail) (return)))))
@@ -485,11 +494,10 @@
   ;; namespace.
   (defun ir1-convert (start next result form)
     (ir1-error-bailout (start next result form)
-      (let ((*current-path* (or (gethash form *source-paths*)
-                                (cons form *current-path*))))
-        (cond ((step-form-p form)
-               (ir1-convert-step start next result form))
-              ((atom form)
+      (let* ((*current-path* (or (gethash form *source-paths*)
+                                 (cons form *current-path*)))
+             (start (instrument-coverage start nil form)))
+        (cond ((atom form)
                (cond ((and (symbolp form) (not (keywordp form)))
                       (ir1-convert-var start next result form))
                      ((leaf-p form)
@@ -591,28 +599,33 @@
 (defun ir1-convert-var (start next result name)
   (declare (type ctran start next) (type (or lvar null) result) (symbol name))
   (let ((var (or (lexenv-find name vars) (find-free-var name))))
-    (etypecase var
-      (leaf
-       (when (lambda-var-p var)
-         (let ((home (ctran-home-lambda-or-null start)))
-           (when home
-             (pushnew var (lambda-calls-or-closes home))))
-         (when (lambda-var-ignorep var)
-           ;; (ANSI's specification for the IGNORE declaration requires
-           ;; that this be a STYLE-WARNING, not a full WARNING.)
-           #-sb-xc-host
-           (compiler-style-warn "reading an ignored variable: ~S" name)
-           ;; there's no need for us to accept ANSI's lameness when
-           ;; processing our own code, though.
-           #+sb-xc-host
-           (warn "reading an ignored variable: ~S" name)))
-       (reference-leaf start next result var))
-      (cons
-       (aver (eq (car var) 'macro))
-       ;; FIXME: [Free] type declarations. -- APD, 2002-01-26
-       (ir1-convert start next result (cdr var)))
-      (heap-alien-info
-       (ir1-convert start next result `(%heap-alien ',var)))))
+    (if (and (global-var-p var) (not result))
+        ;; KLUDGE: If the reference is dead, convert using SYMBOL-VALUE
+        ;; which is not flushable, so that unbound dead variables signal
+        ;; an error (bug 412).
+        (ir1-convert start next result `(symbol-value ',name))
+        (etypecase var
+          (leaf
+           (when (lambda-var-p var)
+             (let ((home (ctran-home-lambda-or-null start)))
+               (when home
+                 (sset-adjoin var (lambda-calls-or-closes home))))
+             (when (lambda-var-ignorep var)
+               ;; (ANSI's specification for the IGNORE declaration requires
+               ;; that this be a STYLE-WARNING, not a full WARNING.)
+               #-sb-xc-host
+               (compiler-style-warn "reading an ignored variable: ~S" name)
+               ;; there's no need for us to accept ANSI's lameness when
+               ;; processing our own code, though.
+               #+sb-xc-host
+               (warn "reading an ignored variable: ~S" name)))
+           (reference-leaf start next result var))
+          (cons
+           (aver (eq (car var) 'macro))
+           ;; FIXME: [Free] type declarations. -- APD, 2002-01-26
+           (ir1-convert start next result (cdr var)))
+          (heap-alien-info
+           (ir1-convert start next result `(%heap-alien ',var))))))
   (values))
 
 ;;; Find a compiler-macro for a form, taking FUNCALL into account.
@@ -701,7 +714,9 @@
     (:macro
      (ir1-convert start next result
                   (careful-expand-macro (info :function :macro-function fun)
-                                        form)))
+                                        form))
+     (unless (policy *lexenv* (zerop store-xref-data))
+       (record-macroexpansion fun (ctran-block start) *current-path*)))
     ((nil :function)
      (ir1-convert-srctran start next result
                           (find-free-fun fun "shouldn't happen! (no-cmacro)")
@@ -790,6 +805,8 @@
             (forms body))
         (loop
           (let ((form (car forms)))
+            (setf this-start
+                  (maybe-instrument-progn-like this-start forms form))
             (when (endp (cdr forms))
               (ir1-convert this-start next result form)
               (return))
@@ -798,9 +815,100 @@
               (setq this-start this-ctran
                     forms (cdr forms)))))))
   (values))
+
+
+;;;; code coverage
+
+;;; 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
+;;; 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
+  ;; have around when debugging the instrumentation.
+  (declare (ignore form))
+  (if (and (policy *lexenv* (> store-coverage-data 0))
+           *code-coverage-records*
+           *allow-instrumenting*)
+      (let ((path (source-path-original-source *current-path*)))
+        (when mode
+          (push mode path))
+        (if (member (ctran-block start)
+                    (gethash path *code-coverage-blocks*))
+            ;; If this source path has already been instrumented in
+            ;; this block, don't instrument it again.
+            start
+            (let ((store
+                   ;; Get an interned record cons for the path. A cons
+                   ;; with the same object identity must be used for
+                   ;; each instrument for the same block.
+                   (or (gethash path *code-coverage-records*)
+                       (setf (gethash path *code-coverage-records*)
+                             (cons path nil))))
+                  (next (make-ctran))
+                  (*allow-instrumenting* nil))
+              (push (ctran-block start)
+                    (gethash path *code-coverage-blocks*))
+              (let ((*allow-instrumenting* nil))
+                (ir1-convert start next nil
+                             `(locally
+                                  (declare (optimize speed
+                                                     (safety 0)
+                                                     (debug 0)))
+                                ;; We're being naughty here, and
+                                ;; modifying constant data. That's ok,
+                                ;; we know what we're doing.
+                                (%rplacd ',store t))))
+              next)))
+      start))
+
+;;; In contexts where we don't have a source location for FORM
+;;; e.g. due to it not being a cons, but where we have a source
+;;; location for the enclosing cons, use the latter source location if
+;;; available. This works pretty well in practice, since many PROGNish
+;;; macroexpansions will just directly splice a block of forms into
+;;; some enclosing form with `(progn ,@body), thus retaining the
+;;; 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*)))
+          (when *current-path*
+            (instrument-coverage start nil form))))
+      start))
+
+(defun record-code-coverage (info cc)
+  (setf (gethash info *code-coverage-info*) cc))
+
+(defun clear-code-coverage ()
+  (clrhash *code-coverage-info*))
+
+(defun reset-code-coverage ()
+  (maphash (lambda (info cc)
+             (declare (ignore info))
+             (dolist (cc-entry cc)
+               (setf (cdr cc-entry) nil)))
+           *code-coverage-info*))
+
 
 ;;;; converting combinations
 
+;;; Does this form look like something that we should add single-stepping
+;;; instrumentation for?
+(defun step-form-p (form)
+  (flet ((step-symbol-p (symbol)
+           (not (member (symbol-package symbol)
+                        (load-time-value
+                         ;; KLUDGE: packages we're not interested in
+                         ;; stepping.
+                         (mapcar #'find-package '(sb!c sb!int sb!impl
+                                                  sb!kernel sb!pcl)))))))
+    (and *allow-instrumenting*
+         (policy *lexenv* (= insert-step-conditions 3))
+         (listp form)
+         (symbolp (car form))
+         (step-symbol-p (car form)))))
+
 ;;; Convert a function call where the function FUN is a LEAF. FORM is
 ;;; the source for the call. We return the COMBINATION node so that
 ;;; the caller can poke at it if it wants to.
@@ -810,7 +918,20 @@
   (let ((ctran (make-ctran))
         (fun-lvar (make-lvar)))
     (ir1-convert start ctran fun-lvar `(the (or function symbol) ,fun))
-    (ir1-convert-combination-args fun-lvar ctran next result (cdr form))))
+    (let ((combination
+           (ir1-convert-combination-args fun-lvar ctran next result
+                                         (cdr form))))
+      (when (step-form-p form)
+        ;; Store a string representation of the form in the
+        ;; combination node. This will let the IR2 translator know
+        ;; that we want stepper instrumentation for this node. The
+        ;; string will be stored in the debug-info by DUMP-1-LOCATION.
+        (setf (combination-step-info combination)
+              (let ((*print-pretty* t)
+                    (*print-circle* t)
+                    (*print-readably* nil))
+                (prin1-to-string form))))
+      combination)))
 
 ;;; Convert the arguments to a call and make the COMBINATION
 ;;; node. FUN-LVAR yields the function to call. ARGS is the list of
@@ -824,8 +945,12 @@
   (let ((node (make-combination fun-lvar)))
     (setf (lvar-dest fun-lvar) node)
     (collect ((arg-lvars))
-      (let ((this-start start))
+      (let ((this-start start)
+            (forms args))
         (dolist (arg args)
+          (setf this-start
+                (maybe-instrument-progn-like this-start forms arg))
+          (setf forms (cdr forms))
           (let ((this-ctran (make-ctran))
                 (this-lvar (make-lvar node)))
             (ir1-convert this-start this-ctran this-lvar arg)
@@ -858,6 +983,10 @@
                     (ir1-convert start next result transformed)))
               (ir1-convert-maybe-predicate start next result form var))))))
 
+;;; KLUDGE: If we insert a synthetic IF for a function with the PREDICATE
+;;; attribute, don't generate any branch coverage instrumentation for it.
+(defvar *instrument-if-for-code-coverage* t)
+
 ;;; If the function has the PREDICATE attribute, and the RESULT's DEST
 ;;; isn't an IF, then we convert (IF <form> T NIL), ensuring that a
 ;;; predicate always appears in a conditional context.
@@ -873,7 +1002,8 @@
     (if (and info
              (ir1-attributep (fun-info-attributes info) predicate)
              (not (if-p (and result (lvar-dest result)))))
-        (ir1-convert start next result `(if ,form t nil))
+        (let ((*instrument-if-for-code-coverage* nil))
+          (ir1-convert start next result `(if ,form t nil)))
         (ir1-convert-combination-checking-type start next result form var))))
 
 ;;; Actually really convert a global function call that we are allowed