(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)
(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)))
\f
;;;; leaf reference
(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))
(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))
(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))
(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
(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)))))
(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)))
(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)))
((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
(,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))))))
\f
;;;; non-local exit
projects / sbcl.git / blobdiff