0.9.17.8:

[sbcl.git] / src / compiler / ir2tran.lisp

diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp
index 777121f..026b509 100644 (file)
--- a/src/compiler/ir2tran.lisp
+++ b/src/compiler/ir2tran.lisp
@@ -21,6 +21,14 @@
     (vop move node block x y))
   (values))
 
+;;; Determine whether we should emit a single-stepper breakpoint
+;;; around a call / before a vop.
+(defun emit-step-p (node)
+  (if (and (policy node (> insert-step-conditions 1))
+           (typep node 'combination))
+      (combination-step-info node)
+      nil))
+
 ;;; If there is any CHECK-xxx template for TYPE, then return it,
 ;;; otherwise return NIL.
 (defun type-check-template (type)
@@ -46,13 +54,8 @@
 
 ;;; Allocate an indirect value cell. Maybe do some clever stack
 ;;; allocation someday.
-;;;
-;;; FIXME: DO-MAKE-VALUE-CELL is a bad name, since it doesn't make
-;;; clear what's the distinction between it and the MAKE-VALUE-CELL
-;;; VOP, and since the DO- further connotes iteration, which has
-;;; nothing to do with this. Clearer, more systematic names, anyone?
 (defevent make-value-cell-event "Allocate heap value cell for lexical var.")
-(defun do-make-value-cell (node block value res)
+(defun emit-make-value-cell (node block value res)
   (event make-value-cell-event node)
   (vop make-value-cell node block value res))
 \f
@@ -670,6 +673,8 @@
             (when (and lvar (lvar-dynamic-extent lvar))
               (vop current-stack-pointer call block
                    (ir2-lvar-stack-pointer (lvar-info lvar))))
+            (when (emit-step-p call)
+              (vop sb!vm::step-instrument-before-vop call block))
             (if info-args
                 (emit-template call block template args r-refs info-args)
                 (emit-template call block template args r-refs))
@@ -714,7 +719,7 @@
             (let ((src (lvar-tn node block arg))
                   (dest (leaf-info var)))
               (if (lambda-var-indirect var)
-                  (do-make-value-cell node block src dest)
+                  (emit-make-value-cell node block src dest)
                   (emit-move node block src dest)))))
         (lambda-vars fun) (basic-combination-args node))
   (values))
@@ -748,7 +753,7 @@
              ((lambda-var-indirect var)
               (let ((temp
                      (make-normal-tn *backend-t-primitive-type*)))
-                (do-make-value-cell node block actual temp)
+                (emit-make-value-cell node block actual temp)
                 (temps temp)))
              ((member actual (locs))
               (let ((temp (make-normal-tn (tn-primitive-type loc))))
@@ -954,11 +959,13 @@
           (vop* tail-call-named node block
                 (fun-tn old-fp return-pc pass-refs)
                 (nil)
-                nargs)
+                nargs
+                (emit-step-p node))
           (vop* tail-call node block
                 (fun-tn old-fp return-pc pass-refs)
                 (nil)
-                nargs))))
+                nargs
+                (emit-step-p node)))))
 
   (values))
 
@@ -998,9 +1005,9 @@
           (fun-lvar-tn node block (basic-combination-fun node))
         (if named
             (vop* call-named node block (fp fun-tn args) (loc-refs)
-                  arg-locs nargs nvals)
+                  arg-locs nargs nvals (emit-step-p node))
             (vop* call node block (fp fun-tn args) (loc-refs)
-                  arg-locs nargs nvals))
+                  arg-locs nargs nvals (emit-step-p node)))
         (move-lvar-result node block locs lvar))))
   (values))
 
@@ -1016,9 +1023,9 @@
           (fun-lvar-tn node block (basic-combination-fun node))
         (if named
             (vop* multiple-call-named node block (fp fun-tn args) (loc-refs)
-                  arg-locs nargs)
+                  arg-locs nargs (emit-step-p node))
             (vop* multiple-call node block (fp fun-tn args) (loc-refs)
-                  arg-locs nargs)))))
+                  arg-locs nargs (emit-step-p node))))))
   (values))
 
 ;;; stuff to check in PONDER-FULL-CALL
@@ -1121,9 +1128,6 @@
       (if (ir2-physenv-closure env)
           (let ((closure (make-normal-tn *backend-t-primitive-type*)))
             (vop setup-closure-environment node block start-label closure)
-            ;; KLUDGE: see the comment around the definition of
-            ;; CLOSURE objects in src/compiler/objdef.lisp
-            (vop funcallable-instance-lexenv node block closure closure)
             (let ((n -1))
               (dolist (loc (ir2-physenv-closure env))
                 (vop closure-ref node block closure (incf n) (cdr loc)))))
@@ -1140,7 +1144,7 @@
             (let ((pass (standard-arg-location n))
                   (home (leaf-info arg)))
               (if (lambda-var-indirect arg)
-                  (do-make-value-cell node block pass home)
+                  (emit-make-value-cell node block pass home)
                   (emit-move node block pass home))))
           (incf n))))
 
@@ -1261,7 +1265,7 @@
             (when (leaf-refs var)
               (let ((dest (leaf-info var)))
                 (if (lambda-var-indirect var)
-                    (do-make-value-cell node block src dest)
+                    (emit-make-value-cell node block src dest)
                     (emit-move node block src dest)))))
           (lvar-tns node block lvar
                             (mapcar (lambda (x)
@@ -1297,11 +1301,13 @@
        ((and 2lvar
              (eq (ir2-lvar-kind 2lvar) :unknown))
         (vop* multiple-call-variable node block (start fun nil)
-              ((reference-tn-list (ir2-lvar-locs 2lvar) t))))
+              ((reference-tn-list (ir2-lvar-locs 2lvar) t))
+              (emit-step-p node)))
        (t
         (let ((locs (standard-result-tns lvar)))
           (vop* call-variable node block (start fun nil)
-                ((reference-tn-list locs t)) (length locs))
+                ((reference-tn-list locs t)) (length locs)
+                (emit-step-p node))
           (move-lvar-result node block locs lvar)))))))
 
 ;;; Reset the stack pointer to the start of the specified
@@ -1520,7 +1526,7 @@
     (ecase kind
       ((:block :tagbody)
        (if (nlx-info-safe-p info)
-           (do-make-value-cell node block res (ir2-nlx-info-home 2info))
+           (emit-make-value-cell node block res (ir2-nlx-info-home 2info))
            (emit-move node block res (ir2-nlx-info-home 2info))))
       (:unwind-protect
        (vop set-unwind-protect node block block-tn))