X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=026b5098ff20995aa58f8a7a627513f34113edef;hb=2287399f246955badf9d61bf123145e76eaf884d;hp=777121f774afeaa7ff43a458168636f3066050a8;hpb=34360bf475b3632f625fcc263f626557ef96d94f;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 777121f..026b509 100644 --- 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)) @@ -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))