X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir2tran.lisp;h=3e1385d0eee06dee0c8e60ce58755a95dd29c931;hb=6bbc22725d3bf663726ed9adca544e39316364a6;hp=29638657358a619547eb3e8dbd6c4b92272471e6;hpb=1751080c69017dfa4d814b20dbed88d9f93701a4;p=sbcl.git diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index 2963865..3e1385d 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,12 +52,13 @@ (emit-move-template node block (type-check-template type) value result) (values)) -;;; Allocate an indirect value cell. Maybe do some clever stack -;;; allocation someday. +;;; Allocate an indirect value cell. (defevent make-value-cell-event "Allocate heap value cell for lexical var.") (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)) + res))) ;;;; leaf reference @@ -665,6 +674,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)) @@ -949,11 +960,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)) @@ -993,9 +1006,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)) @@ -1011,9 +1024,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 @@ -1116,9 +1129,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))))) @@ -1170,6 +1180,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))) @@ -1195,6 +1212,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))) @@ -1292,11 +1314,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 @@ -1429,6 +1453,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