X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=e98d8390a8afd12f2eb22154eb958ae0eda926b2;hb=f22ad70037030c07074327cf239bd84dc17b44b6;hp=5adc631a491f6a19bef8ed01f4d0afdf9a00c87b;hpb=3a2e34d8ed1293f2cecb5c2c6ea359b622e3f4f8;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 5adc631..e98d839 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) @@ -44,17 +52,16 @@ (emit-move-template node block (type-check-template type) value result) (values)) -;;; 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? +;;; Allocate an indirect value cell. (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)) + (let ((leaf (tn-leaf res))) + (vop make-value-cell node block value + (and leaf (leaf-dynamic-extent leaf) + ;; FIXME: See bug 419 + (policy node (> stack-allocate-value-cells 1))) + res))) ;;;; leaf reference @@ -128,13 +135,7 @@ (vop value-cell-ref node block tn res) (emit-move node block tn res)))) (constant - (if (legal-immediate-constant-p leaf) - (emit-move node block (constant-tn leaf) res) - (let* ((name (leaf-source-name leaf)) - (name-tn (emit-constant name))) - (if (policy node (zerop safety)) - (vop fast-symbol-value node block name-tn res) - (vop symbol-value node block name-tn res))))) + (emit-move node block (constant-tn leaf) res)) (functional (ir2-convert-closure node block leaf res)) (global-var @@ -299,7 +300,7 @@ (emit-move node block val tn))))) (global-var (ecase (global-var-kind leaf) - ((:special :global) + ((:special) (aver (symbolp (leaf-source-name leaf))) (vop set node block (emit-constant (leaf-source-name leaf)) val))))) (when locs @@ -670,6 +671,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 +717,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 +751,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 +957,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 +1003,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 +1021,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 +1071,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 +1126,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 +1142,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)))) @@ -1192,6 +1177,13 @@ (ir2-physenv-return-pc-pass env) (ir2-physenv-return-pc env)) + #!+unwind-to-frame-and-call-vop + (when (and (lambda-allow-instrumenting fun) + (not (lambda-inline-expanded fun)) + (lambda-return fun) + (policy fun (>= insert-debug-catch 2))) + (vop sb!vm::bind-sentinel node block)) + (let ((lab (gen-label))) (setf (ir2-physenv-environment-start env) lab) (vop note-environment-start node block lab))) @@ -1217,6 +1209,11 @@ (old-fp (ir2-physenv-old-fp env)) (return-pc (ir2-physenv-return-pc env)) (returns (tail-set-info (lambda-tail-set fun)))) + #!+unwind-to-frame-and-call-vop + (when (and (lambda-allow-instrumenting fun) + (not (lambda-inline-expanded fun)) + (policy fun (>= insert-debug-catch 2))) + (vop sb!vm::unbind-sentinel node block)) (cond ((and (eq (return-info-kind returns) :fixed) (not (xep-p fun))) @@ -1278,7 +1275,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 +1311,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 @@ -1451,6 +1450,15 @@ (,bind ,vars ,vals)) nil ,@body) + ;; Technically ANSI CL doesn't allow declarations at the + ;; start of the cleanup form. SBCL happens to allow for + ;; them, due to the way the UNWIND-PROTECT ir1 translation + ;; is implemented; the cleanup forms are directly spliced + ;; into an FLET definition body. And a declaration here + ;; actually has exactly the right scope for what we need + ;; (ensure that debug instrumentation is not emitted for the + ;; cleanup function). -- JES, 2007-06-16 + (declare (optimize (insert-debug-catch 0))) (%primitive unbind-to-here ,n-save-bs)))))) ;;;; non-local exit @@ -1537,7 +1545,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))