(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.
-;;;
-;;; 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)))
\f
;;;; leaf reference
(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
(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
(ir2-convert-conditional node block (template-or-lose 'if-eq)
test-ref () node t)))
-;;; Return a list of primitive-types that we can pass to
-;;; LVAR-RESULT-TNS describing the result types we want for a
-;;; template call. We duplicate here the determination of output type
-;;; that was done in initially selecting the template, so we know that
-;;; the types we find are allowed by the template output type
-;;; restrictions.
-(defun find-template-result-types (call template rtypes)
- (declare (type combination call)
- (type template template) (list rtypes))
- (declare (ignore template))
- (let* ((dtype (node-derived-type call))
- (type dtype)
- (types (mapcar #'primitive-type
- (if (values-type-p type)
- (append (values-type-required type)
- (values-type-optional type))
- (list type)))))
- (let ((nvals (length rtypes))
- (ntypes (length types)))
- (cond ((< ntypes nvals)
- (append types
- (make-list (- nvals ntypes)
- :initial-element *backend-t-primitive-type*)))
- ((> ntypes nvals)
- (subseq types 0 nvals))
- (t
- types)))))
-
-;;; Return a list of TNs usable in a CALL to TEMPLATE delivering
-;;; values to LVAR. As an efficiency hack, we pick off the common case
-;;; where the LVAR is fixed values and has locations that satisfy the
-;;; result restrictions. This can fail when there is a type check or a
-;;; values count mismatch.
-(defun make-template-result-tns (call lvar template rtypes)
+;;; Return a list of primitive-types that we can pass to LVAR-RESULT-TNS
+;;; describing the result types we want for a template call. We are really
+;;; only interested in the number of results required: in normal case
+;;; TEMPLATE-RESULTS-OK has already checked them.
+(defun find-template-result-types (call rtypes)
+ (let* ((type (node-derived-type call))
+ (types
+ (mapcar #'primitive-type
+ (if (values-type-p type)
+ (append (args-type-required type)
+ (args-type-optional type))
+ (list type))))
+ (primitive-t *backend-t-primitive-type*))
+ (loop for rtype in rtypes
+ for type = (or (pop types) primitive-t)
+ collect type)))
+
+;;; Return a list of TNs usable in a CALL to TEMPLATE delivering values to
+;;; LVAR. As an efficiency hack, we pick off the common case where the LVAR is
+;;; fixed values and has locations that satisfy the result restrictions. This
+;;; can fail when there is a type check or a values count mismatch.
+(defun make-template-result-tns (call lvar rtypes)
(declare (type combination call) (type (or lvar null) lvar)
- (type template template) (list rtypes))
+ (list rtypes))
(let ((2lvar (when lvar (lvar-info lvar))))
(if (and 2lvar (eq (ir2-lvar-kind 2lvar) :fixed))
(let ((locs (ir2-lvar-locs 2lvar)))
(if (and (= (length rtypes) (length locs))
(do ((loc locs (cdr loc))
- (rtype rtypes (cdr rtype)))
+ (rtypes rtypes (cdr rtypes)))
((null loc) t)
(unless (operand-restriction-ok
- (car rtype)
+ (car rtypes)
(tn-primitive-type (car loc))
:t-ok nil)
(return nil))))
locs
(lvar-result-tns
lvar
- (find-template-result-types call template rtypes))))
+ (find-template-result-types call rtypes))))
(lvar-result-tns
lvar
- (find-template-result-types call template rtypes)))))
+ (find-template-result-types call rtypes)))))
;;; Get the operands into TNs, make TN-REFs for them, and then call
;;; the template emit function.
(if (eq rtypes :conditional)
(ir2-convert-conditional call block template args info-args
(lvar-dest lvar) nil)
- (let* ((results (make-template-result-tns call lvar template rtypes))
+ (let* ((results (make-template-result-tns call lvar rtypes))
(r-refs (reference-tn-list results t)))
(aver (= (length info-args)
(template-info-arg-count template)))
(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))
(info (lvar-value info))
(lvar (node-lvar call))
(rtypes (template-result-types template))
- (results (make-template-result-tns call lvar template rtypes))
+ (results (make-template-result-tns call lvar rtypes))
(r-refs (reference-tn-list results t)))
(multiple-value-bind (args info-args)
(reference-args call block (cddr (combination-args call)) template)
(move-lvar-result call block results lvar)))
(values))
+
+(defoptimizer (%%primitive derive-type) ((template info &rest args))
+ (let ((type (template-type (lvar-value template))))
+ (if (fun-type-p type)
+ (fun-type-returns type)
+ *wild-type*)))
\f
;;;; local call
(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))
((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))))
(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
;;;
-;;; 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
;; 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))
(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)))))
(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))))
(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)))
(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)
((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
(progn
(labels ((,unbind (vars)
(declare (optimize (speed 2) (debug 0)))
- (dolist (var vars)
- (%primitive bind nil var)
- (makunbound var)))
+ (let ((unbound-marker (%primitive make-other-immediate-type
+ 0 sb!vm:unbound-marker-widetag)))
+ (dolist (var vars)
+ ;; CLHS says "bound and then made to have no value" -- user
+ ;; should not be able to tell the difference between that and this.
+ (about-to-modify-symbol-value var "bind ~S")
+ (%primitive bind unbound-marker var))))
(,bind (vars vals)
(declare (optimize (speed 2) (debug 0)))
(cond ((null vars))
((null vals) (,unbind vars))
- (t (%primitive bind
- (car vals)
- (car vars))
- (,bind (cdr vars) (cdr vals))))))
+ (t
+ (let ((val (car vals))
+ (var (car vars)))
+ (about-to-modify-symbol-value var "bind ~S" val)
+ (%primitive bind val var))
+ (,bind (cdr vars) (cdr vals))))))
(,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
(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))
projects / sbcl.git / blobdiff