X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=026b5098ff20995aa58f8a7a627513f34113edef;hb=2287399f246955badf9d61bf123145e76eaf884d;hp=5adc631a491f6a19bef8ed01f4d0afdf9a00c87b;hpb=3a2e34d8ed1293f2cecb5c2c6ea359b622e3f4f8;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 5adc631..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,34 +1023,13 @@ (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 ;;; -;;; There are some things which are intended always to be optimized -;;; away by DEFTRANSFORMs and such, and so never compiled into full -;;; calls. This has been a source of bugs so many times that it seems -;;; worth listing some of them here so that we can check the list -;;; whenever we compile a full call. -;;; -;;; FIXME: It might be better to represent this property by setting a -;;; flag in DEFKNOWN, instead of representing it by membership in this -;;; list. -(defvar *always-optimized-away* - '(;; This should always be DEFTRANSFORMed away, but wasn't in a bug - ;; reported to cmucl-imp 2000-06-20. - %instance-ref - ;; These should always turn into VOPs, but wasn't in a bug which - ;; appeared when LTN-POLICY stuff was being tweaked in - ;; sbcl-0.6.9.16. in sbcl-0.6.0 - data-vector-set - data-vector-ref)) - -;;; more stuff to check in PONDER-FULL-CALL -;;; ;;; These came in handy when troubleshooting cold boot after making ;;; major changes in the package structure: various transforms and ;;; VOPs and stuff got attached to the wrong symbol, so that @@ -1087,10 +1073,14 @@ ;; functions are actually optimized away. Thus, we skip the check ;; in that case. (unless *failure-p* - (when (memq fname *always-optimized-away*) - (/show (policy node speed) (policy node safety)) - (/show (policy node compilation-speed)) - (bug "full call to ~S" fname))) + ;; check to see if we know anything about the function + (let ((info (info :function :info fname))) + ;; if we know something, check to see if the full call was valid + (when (and info (ir1-attributep (fun-info-attributes info) + always-translatable)) + (/show (policy node speed) (policy node safety)) + (/show (policy node compilation-speed)) + (bug "full call to ~S" fname)))) (when (consp fname) (aver (legal-fun-name-p fname)) @@ -1138,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))))) @@ -1157,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)))) @@ -1278,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) @@ -1314,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 @@ -1537,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))