(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))
+ (vop make-value-cell node block value nil res))
\f
;;;; leaf reference
;;; If LEAF already has a constant TN, return that, otherwise make a
;;; TN for it.
-(defun constant-tn (leaf)
+(defun constant-tn (leaf boxedp)
(declare (type constant leaf))
- (or (leaf-info leaf)
- (setf (leaf-info leaf)
- (make-constant-tn leaf))))
+ ;; When convenient we can have both a boxed and unboxed TN for
+ ;; constant.
+ (if boxedp
+ (or (constant-boxed-tn leaf)
+ (setf (constant-boxed-tn leaf) (make-constant-tn leaf t)))
+ (or (leaf-info leaf)
+ (setf (leaf-info leaf) (make-constant-tn leaf nil)))))
;;; Return a TN that represents the value of LEAF, or NIL if LEAF
;;; isn't directly represented by a TN. ENV is the environment that
;;; the reference is done in.
-(defun leaf-tn (leaf env)
+(defun leaf-tn (leaf env boxedp)
(declare (type leaf leaf) (type physenv env))
(typecase leaf
(lambda-var
(unless (lambda-var-indirect leaf)
(find-in-physenv leaf env)))
- (constant (constant-tn leaf))
+ (constant (constant-tn leaf boxedp))
(t nil)))
;;; This is used to conveniently get a handle on a constant TN during
;;; IR2 conversion. It returns a constant TN representing the Lisp
;;; object VALUE.
(defun emit-constant (value)
- (constant-tn (find-constant value)))
+ (constant-tn (find-constant value) t))
+
+(defun boxed-ref-p (ref)
+ (let ((dest (lvar-dest (ref-lvar ref))))
+ (cond ((and (basic-combination-p dest) (eq :full (basic-combination-kind dest)))
+ t)
+ ;; Other cases?
+ (t
+ nil))))
;;; Convert a REF node. The reference must not be delayed.
(defun ir2-convert-ref (node block)
(res (first locs)))
(etypecase leaf
(lambda-var
- (let ((tn (find-in-physenv leaf (node-physenv node))))
- (if (lambda-var-indirect leaf)
- (vop value-cell-ref node block tn res)
- (emit-move node block tn res))))
+ (let ((tn (find-in-physenv leaf (node-physenv node)))
+ (indirect (lambda-var-indirect leaf))
+ (explicit (lambda-var-explicit-value-cell leaf)))
+ (cond
+ ((and indirect explicit)
+ (vop value-cell-ref node block tn res))
+ ((and indirect
+ (not (eq (node-physenv node)
+ (lambda-physenv (lambda-var-home leaf)))))
+ (let ((reffer (third (primitive-type-indirect-cell-type
+ (primitive-type (leaf-type leaf))))))
+ (if reffer
+ (funcall reffer node block tn (leaf-info leaf) res)
+ (vop ancestor-frame-ref node block tn (leaf-info leaf) res))))
+ (t (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 (boxed-ref-p node)) res))
(functional
(ir2-convert-closure node block leaf res))
(global-var
- (let ((unsafe (policy node (zerop safety)))
- (name (leaf-source-name leaf)))
- (ecase (global-var-kind leaf)
- ((:special :global)
- (aver (symbolp name))
- (let ((name-tn (emit-constant name)))
- (if unsafe
- (vop fast-symbol-value node block name-tn res)
- (vop symbol-value node block name-tn res))))
- (:global-function
- (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
- (if unsafe
- (vop fdefn-fun node block fdefn-tn res)
- (vop safe-fdefn-fun node block fdefn-tn res))))))))
+ (ir2-convert-global-var node block leaf res)))
(move-lvar-result node block locs lvar))
(values))
+(defun ir2-convert-global-var (node block leaf res)
+ (let ((unsafe (policy node (zerop safety)))
+ (name (leaf-source-name leaf)))
+ (ecase (global-var-kind leaf)
+ ((:special :unknown)
+ (aver (symbolp name))
+ (let ((name-tn (emit-constant name)))
+ (if (or unsafe (info :variable :always-bound name))
+ (vop fast-symbol-value node block name-tn res)
+ (vop symbol-value node block name-tn res))))
+ (:global
+ (aver (symbolp name))
+ (let ((name-tn (emit-constant name)))
+ (if (or unsafe (info :variable :always-bound name))
+ (vop fast-symbol-global-value node block name-tn res)
+ (vop symbol-global-value node block name-tn res))))
+ (:global-function
+ (cond #-sb-xc-host
+ ((and (info :function :definition name)
+ (info :function :info name))
+ ;; Known functions can be saved without going through fdefns,
+ ;; except during cross-compilation
+ (emit-move node block (make-load-time-constant-tn :known-fun name)
+ res))
+ (t
+ (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
+ (if unsafe
+ (vop fdefn-fun node block fdefn-tn res)
+ (vop safe-fdefn-fun node block fdefn-tn res)))))))))
+
;;; some sanity checks for a CLAMBDA passed to IR2-CONVERT-CLOSURE
(defun assertions-on-ir2-converted-clambda (clambda)
;; This assertion was sort of an experiment. It would be nice and
(type ir2-block ir2-block)
(type functional functional)
(type tn res))
- (aver (not (eql (functional-kind functional) :deleted)))
- (unless (leaf-info functional)
- (setf (leaf-info functional)
- (make-entry-info :name (functional-debug-name functional))))
- (let ((closure (etypecase functional
- (clambda
- (assertions-on-ir2-converted-clambda functional)
- (physenv-closure (get-lambda-physenv functional)))
- (functional
- (aver (eq (functional-kind functional) :toplevel-xep))
- nil))))
-
- (cond (closure
- (let* ((physenv (node-physenv ref))
- (tn (find-in-physenv functional physenv)))
- (emit-move ref ir2-block tn res)))
- (t
- (let ((entry (make-load-time-constant-tn :entry functional)))
- (emit-move ref ir2-block entry res)))))
+ (flet ((prepare ()
+ (aver (not (eql (functional-kind functional) :deleted)))
+ (unless (leaf-info functional)
+ (setf (leaf-info functional)
+ (make-entry-info :name
+ (functional-debug-name functional))))))
+ (let ((closure (etypecase functional
+ (clambda
+ (assertions-on-ir2-converted-clambda functional)
+ (physenv-closure (get-lambda-physenv functional)))
+ (functional
+ (aver (eq (functional-kind functional) :toplevel-xep))
+ nil)))
+ global-var)
+ (cond (closure
+ (prepare)
+ (let* ((physenv (node-physenv ref))
+ (tn (find-in-physenv functional physenv)))
+ (emit-move ref ir2-block tn res)))
+ ;; we're about to emit a reference to a "closure" that's actually
+ ;; an inlinable global function.
+ ((and (global-var-p (setf global-var
+ (functional-inline-expanded functional)))
+ (eq :global-function (global-var-kind global-var)))
+ (ir2-convert-global-var ref ir2-block global-var res))
+ (t
+ ;; if we're here, we should have either a toplevel-xep (some
+ ;; global scope function in a different component) or an external
+ ;; reference to the "closure"'s body.
+ (prepare)
+ (aver (memq (functional-kind functional) '(:external :toplevel-xep)))
+ (let ((entry (make-load-time-constant-tn :entry functional)))
+ (emit-move ref ir2-block entry res))))))
(values))
+(defun closure-initial-value (what this-env current-fp)
+ (declare (type (or nlx-info lambda-var clambda) what)
+ (type physenv this-env)
+ (type (or tn null) current-fp))
+ ;; If we have an indirect LAMBDA-VAR that does not require an
+ ;; EXPLICIT-VALUE-CELL, and is from this environment (not from being
+ ;; closed over), we need to store the current frame pointer.
+ (if (and (lambda-var-p what)
+ (lambda-var-indirect what)
+ (not (lambda-var-explicit-value-cell what))
+ (eq (lambda-physenv (lambda-var-home what))
+ this-env))
+ current-fp
+ (find-in-physenv what this-env)))
+
(defoptimizer (%allocate-closures ltn-annotate) ((leaves) node ltn-policy)
ltn-policy ; a hack to effectively (DECLARE (IGNORE LTN-POLICY))
(when (lvar-dynamic-extent leaves)
(vop current-stack-pointer call 2block
(ir2-lvar-stack-pointer (lvar-info leaves))))
(dolist (leaf (lvar-value leaves))
- (binding* ((xep (functional-entry-fun leaf) :exit-if-null)
+ (binding* ((xep (awhen (functional-entry-fun leaf)
+ ;; if the xep's been deleted then we can skip it
+ (if (eq (functional-kind it) :deleted)
+ nil it))
+ :exit-if-null)
(nil (aver (xep-p xep)))
(entry-info (lambda-info xep) :exit-if-null)
(tn (entry-info-closure-tn entry-info) :exit-if-null)
;; putting of all closures after all creations
;; (though it may require more registers).
(if (lambda-p what)
- (delayed (list tn (find-in-physenv what this-env) n))
- (vop closure-init call 2block
- tn
- (find-in-physenv what this-env)
- n)))))))
+ (delayed (list tn (find-in-physenv what this-env) n))
+ (let ((initial-value (closure-initial-value
+ what this-env nil)))
+ (if initial-value
+ (vop closure-init call 2block
+ tn initial-value n)
+ ;; An initial-value of NIL means to stash
+ ;; the frame pointer... which requires a
+ ;; different VOP.
+ (vop closure-init-from-fp call 2block tn n)))))))))
(loop for (tn what n) in (delayed)
do (vop closure-init call 2block
tn what n))))
(etypecase leaf
(lambda-var
(when (leaf-refs leaf)
- (let ((tn (find-in-physenv leaf (node-physenv node))))
- (if (lambda-var-indirect leaf)
- (vop value-cell-set node block tn val)
- (emit-move node block val tn)))))
+ (let ((tn (find-in-physenv leaf (node-physenv node)))
+ (indirect (lambda-var-indirect leaf))
+ (explicit (lambda-var-explicit-value-cell leaf)))
+ (cond
+ ((and indirect explicit)
+ (vop value-cell-set node block tn val))
+ ((and indirect
+ (not (eq (node-physenv node)
+ (lambda-physenv (lambda-var-home leaf)))))
+ (let ((setter (fourth (primitive-type-indirect-cell-type
+ (primitive-type (leaf-type leaf))))))
+ (if setter
+ (funcall setter node block tn val (leaf-info leaf))
+ (vop ancestor-frame-set node block tn val (leaf-info leaf)))))
+ (t (emit-move node block val tn))))))
(global-var
+ (aver (symbolp (leaf-source-name leaf)))
(ecase (global-var-kind leaf)
- ((:special :global)
- (aver (symbolp (leaf-source-name leaf)))
- (vop set node block (emit-constant (leaf-source-name leaf)) val)))))
+ ((:special)
+ (vop set node block (emit-constant (leaf-source-name leaf)) val))
+ ((:global)
+ (vop %set-symbol-global-value node
+ block (emit-constant (leaf-source-name leaf)) val)))))
(when locs
(emit-move node block val (first locs))
(move-lvar-result node block locs lvar)))
(ecase (ir2-lvar-kind 2lvar)
(:delayed
(let ((ref (lvar-uses lvar)))
- (leaf-tn (ref-leaf ref) (node-physenv ref))))
+ (leaf-tn (ref-leaf ref) (node-physenv ref) (boxed-ref-p ref))))
(:fixed
(aver (= (length (ir2-lvar-locs 2lvar)) 1))
(first (ir2-lvar-locs 2lvar)))))
;;; an lvar.
;;;
;;; If the lvar isn't annotated (meaning the values are discarded) or
-;;; is unknown-values, the then we make temporaries for each supplied
+;;; is unknown-values, then we make temporaries for each supplied
;;; value, providing a place to compute the result in until we decide
;;; what to do with it (if anything.)
;;;
;;; Return a list of TNs wired to the standard value passing
;;; conventions that can be used to receive values according to the
-;;; unknown-values convention. This is used with together
+;;; unknown-values convention. This is used together with
;;; MOVE-LVAR-RESULT for delivering unknown values to a fixed values
;;; lvar.
;;;
;;; If necessary, emit coercion code needed to deliver the RESULTS to
;;; the specified lvar. NODE and BLOCK provide context for emitting
;;; code. Although usually obtained from STANDARD-RESULT-TNs or
-;;; LVAR-RESULT-TNs, RESULTS my be a list of any type or
+;;; LVAR-RESULT-TNs, RESULTS may be a list of any type or
;;; number of TNs.
;;;
;;; If the lvar is fixed values, then move the results into the lvar
(declare (type node node) (type ir2-block block)
(type template template) (type (or tn-ref null) args)
(list info-args) (type cif if) (type boolean not-p))
- (aver (= (template-info-arg-count template) (+ (length info-args) 2)))
(let ((consequent (if-consequent if))
- (alternative (if-alternative if)))
- (cond ((drop-thru-p if consequent)
+ (alternative (if-alternative if))
+ (flags (and (consp (template-result-types template))
+ (rest (template-result-types template)))))
+ (aver (= (template-info-arg-count template)
+ (+ (length info-args)
+ (if flags 0 2))))
+ (when not-p
+ (rotatef consequent alternative)
+ (setf not-p nil))
+ (when (drop-thru-p if consequent)
+ (rotatef consequent alternative)
+ (setf not-p t))
+ (cond ((not flags)
(emit-template node block template args nil
- (list* (block-label alternative) (not not-p)
- info-args)))
+ (list* (block-label consequent) not-p
+ info-args))
+ (if (drop-thru-p if alternative)
+ (register-drop-thru alternative)
+ (vop branch node block (block-label alternative))))
(t
- (emit-template node block template args nil
- (list* (block-label consequent) not-p info-args))
- (unless (drop-thru-p if alternative)
- (vop branch node block (block-label alternative)))))))
+ (emit-template node block template args nil info-args)
+ (vop branch-if node block (block-label consequent) flags not-p)
+ (if (drop-thru-p if alternative)
+ (register-drop-thru alternative)
+ (vop branch node block (block-label alternative)))))))
;;; Convert an IF that isn't the DEST of a conditional template.
(defun ir2-convert-if (node block)
(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 (args-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.
(multiple-value-bind (args info-args)
(reference-args call block (combination-args call) template)
(aver (not (template-more-results-type template)))
- (if (eq rtypes :conditional)
+ (if (template-conditional-p template)
(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)))
(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)
(aver (not (template-more-results-type template)))
- (aver (not (eq rtypes :conditional)))
+ (aver (not (template-conditional-p template)))
(aver (null info-args))
(if info
(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
(when arg
(let ((src (lvar-tn node block arg))
(dest (leaf-info var)))
- (if (lambda-var-indirect var)
+ (if (and (lambda-var-indirect var)
+ (lambda-var-explicit-value-cell var))
(emit-make-value-cell node block src dest)
(emit-move node block src dest)))))
(lambda-vars fun) (basic-combination-args node))
;;; OLD-FP. If null, then the call is to the same environment (an
;;; :ASSIGNMENT), so we only move the arguments, and leave the
;;; environment alone.
-(defun emit-psetq-moves (node block fun old-fp)
+;;;
+;;; CLOSURE-FP is for calling a closure that has "implicit" value
+;;; cells (stored in the allocating stack frame), and is the frame
+;;; pointer TN to use for values allocated in the outbound stack
+;;; frame. This is distinct from OLD-FP for the specific case of a
+;;; tail-local-call.
+(defun emit-psetq-moves (node block fun old-fp &optional (closure-fp old-fp))
(declare (type combination node) (type ir2-block block) (type clambda fun)
- (type (or tn null) old-fp))
+ (type (or tn null) old-fp closure-fp))
(let ((actuals (mapcar (lambda (x)
(when x
(lvar-tn node block x)))
(loc (leaf-info var)))
(when actual
(cond
- ((lambda-var-indirect var)
+ ((and (lambda-var-indirect var)
+ (lambda-var-explicit-value-cell var))
(let ((temp
(make-normal-tn *backend-t-primitive-type*)))
(emit-make-value-cell node block actual temp)
(let ((this-1env (node-physenv node))
(called-env (physenv-info (lambda-physenv fun))))
(dolist (thing (ir2-physenv-closure called-env))
- (temps (find-in-physenv (car thing) this-1env))
+ (temps (closure-initial-value (car thing) this-1env closure-fp))
(locs (cdr thing)))
(temps old-fp)
(locs (ir2-physenv-old-fp called-env))))
;;; function's passing location.
(defun ir2-convert-tail-local-call (node block fun)
(declare (type combination node) (type ir2-block block) (type clambda fun))
- (let ((this-env (physenv-info (node-physenv node))))
+ (let ((this-env (physenv-info (node-physenv node)))
+ (current-fp (make-stack-pointer-tn)))
(multiple-value-bind (temps locs)
- (emit-psetq-moves node block fun (ir2-physenv-old-fp this-env))
+ (emit-psetq-moves node block fun
+ (ir2-physenv-old-fp this-env) current-fp)
+
+ ;; If we're about to emit a move from CURRENT-FP then we need to
+ ;; initialize it.
+ (when (find current-fp temps)
+ (vop current-fp node block current-fp))
(mapc (lambda (temp loc)
(emit-move node block temp loc))
((node-tail-p node)
(ir2-convert-tail-local-call node block fun))
(t
- (let ((start (block-label (lambda-block fun)))
+ (let ((start (block-trampoline (lambda-block fun)))
(returns (tail-set-info (lambda-tail-set fun)))
(lvar (node-lvar node)))
(ecase (if returns
(when (leaf-refs arg)
(let ((pass (standard-arg-location n))
(home (leaf-info arg)))
- (if (lambda-var-indirect arg)
+ (if (and (lambda-var-indirect arg)
+ (lambda-var-explicit-value-cell arg))
(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)))
+ (vop note-environment-start node block lab)
+ #!+sb-safepoint
+ (unless (policy fun (>= inhibit-safepoints 2))
+ (vop sb!vm::insert-safepoint node block))))
(values))
\f
(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)))
(values))
\f
;;;; debugger hooks
+;;;;
+;;;; These are used by the debugger to find the top function on the
+;;;; stack. They return the OLD-FP and RETURN-PC for the current
+;;;; function as multiple values.
-;;; This is used by the debugger to find the top function on the
-;;; stack. It returns the OLD-FP and RETURN-PC for the current
-;;; function as multiple values.
-(defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block)
+(defoptimizer (%caller-frame ir2-convert) (() node block)
(let ((ir2-physenv (physenv-info (node-physenv node))))
(move-lvar-result node block
- (list (ir2-physenv-old-fp ir2-physenv)
- (ir2-physenv-return-pc ir2-physenv))
+ (list (ir2-physenv-old-fp ir2-physenv))
+ (node-lvar node))))
+
+(defoptimizer (%caller-pc ir2-convert) (() node block)
+ (let ((ir2-physenv (physenv-info (node-physenv node))))
+ (move-lvar-result node block
+ (list (ir2-physenv-return-pc ir2-physenv))
(node-lvar node))))
\f
;;;; multiple values
(mapc (lambda (src var)
(when (leaf-refs var)
(let ((dest (leaf-info var)))
- (if (lambda-var-indirect var)
+ (if (and (lambda-var-indirect var)
+ (lambda-var-explicit-value-cell var))
(emit-make-value-cell node block src dest)
(emit-move node block src dest)))))
(lvar-tns node block lvar
(binding* ((lvar (node-lvar node) :exit-if-null)
(2lvar (lvar-info lvar)))
(ecase (ir2-lvar-kind 2lvar)
- (:fixed (ir2-convert-full-call node block))
+ (:fixed
+ ;; KLUDGE: this is very much unsafe, and can leak random stack values.
+ ;; OTOH, I think the :FIXED case can only happen with (safety 0) in the
+ ;; first place.
+ ;; -PK
+ (loop for loc in (ir2-lvar-locs 2lvar)
+ for idx upfrom 0
+ do (vop sb!vm::more-arg node block
+ (lvar-tn node block context)
+ (emit-constant idx)
+ loc)))
(:unknown
(let ((locs (ir2-lvar-locs 2lvar)))
(vop* %more-arg-values node block
(progn
(labels ((,unbind (vars)
(declare (optimize (speed 2) (debug 0)))
- (dolist (var vars)
- (%primitive bind nil var)
- (makunbound var)))
+ (let ((unbound-marker (%primitive make-unbound-marker)))
+ (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 'progv)
+ (%primitive bind unbound-marker var))))
(,bind (vars vals)
- (declare (optimize (speed 2) (debug 0)))
+ (declare (optimize (speed 2) (debug 0)
+ (insert-debug-catch 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 'progv val t)
+ (%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
(def list*))
\f
+(defoptimizer (mask-signed-field ir2-convert) ((width x) node block)
+ (block nil
+ (when (constant-lvar-p width)
+ (case (lvar-value width)
+ (#.(- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits)
+ (when (or (csubtypep (lvar-type x)
+ (specifier-type 'word))
+ (csubtypep (lvar-type x)
+ (specifier-type 'sb!vm:signed-word)))
+ (let* ((lvar (node-lvar node))
+ (temp (make-normal-tn
+ (if (csubtypep (lvar-type x)
+ (specifier-type 'word))
+ (primitive-type-of most-positive-word)
+ (primitive-type-of
+ (- (ash most-positive-word -1))))))
+ (results (lvar-result-tns
+ lvar
+ (list (primitive-type-or-lose 'fixnum)))))
+ (emit-move node block (lvar-tn node block x) temp)
+ (vop sb!vm::move-from-word/fixnum node block
+ temp (first results))
+ (move-lvar-result node block results lvar)
+ (return))))
+ (#.sb!vm:n-word-bits
+ (when (csubtypep (lvar-type x) (specifier-type 'word))
+ (let* ((lvar (node-lvar node))
+ (temp (make-normal-tn
+ (primitive-type-of most-positive-word)))
+ (results (lvar-result-tns
+ lvar
+ (list (primitive-type
+ (specifier-type 'sb!vm:signed-word))))))
+ (emit-move node block (lvar-tn node block x) temp)
+ (vop sb!vm::word-move node block
+ temp (first results))
+ (move-lvar-result node block results lvar)
+ (return))))))
+ (if (template-p (basic-combination-info node))
+ (ir2-convert-template node block)
+ (ir2-convert-full-call node block))))
+
+;; just a fancy identity
+(defoptimizer (%typep-wrapper ir2-convert) ((value variable type) node block)
+ (let* ((lvar (node-lvar node))
+ (results (lvar-result-tns lvar (list (primitive-type-or-lose t)))))
+ (emit-move node block (lvar-tn node block value) (first results))
+ (move-lvar-result node block results lvar)))
+\f
;;; Convert the code in a component into VOPs.
(defun ir2-convert (component)
(declare (type component component))
2block
#!+sb-dyncount *dynamic-counts-tn* #!-sb-dyncount nil
num))))
+ #!+sb-safepoint
+ (let ((first-node (block-start-node block)))
+ (unless (or (and (bind-p first-node)
+ (xep-p (bind-lambda first-node)))
+ (and (valued-node-p first-node)
+ (node-lvar first-node)
+ (eq (lvar-fun-name
+ (node-lvar first-node))
+ '%nlx-entry)))
+ (when (and (rest (block-pred block))
+ (block-loop block)
+ (member (loop-kind (block-loop block))
+ '(:natural :strange))
+ (eq block (loop-head (block-loop block)))
+ (policy first-node (< inhibit-safepoints 2)))
+ (vop sb!vm::insert-safepoint first-node 2block))))
(ir2-convert-block block)
(incf num))))))
(values))
;;; If necessary, emit a terminal unconditional branch to go to the
;;; successor block. If the successor is the component tail, then
-;;; there isn't really any successor, but if the end is an unknown,
-;;; non-tail call, then we emit an error trap just in case the
-;;; function really does return.
+;;; there isn't really any successor, but if the end is a non-tail
+;;; call to a function that's not *known* to never return, then we
+;;; emit an error trap just in case the function really does return.
+;;;
+;;; Trapping after known calls makes it easier to understand type
+;;; derivation bugs at runtime: they show up as nil-fun-returned-error,
+;;; rather than the execution of arbitrary code or error traps.
(defun finish-ir2-block (block)
(declare (type cblock block))
(let* ((2block (block-info block))
(let ((target (first succ)))
(cond ((eq target (component-tail (block-component block)))
(when (and (basic-combination-p last)
- (eq (basic-combination-kind last) :full))
+ (or (eq (basic-combination-kind last) :full)
+ (and (eq (basic-combination-kind last) :known)
+ (eq (basic-combination-info last) :full))))
(let* ((fun (basic-combination-fun last))
(use (lvar-uses fun))
(name (and (ref-p use)
(leaf-has-source-name-p (ref-leaf use))
- (leaf-source-name (ref-leaf use)))))
+ (leaf-source-name (ref-leaf use))))
+ (ftype (and (info :function :info name) ; only use the FTYPE if
+ (info :function :type name)))) ; NAME was DEFKNOWN
(unless (or (node-tail-p last)
- (info :function :info name)
- (policy last (zerop safety)))
+ (policy last (zerop safety))
+ (and (fun-type-p ftype)
+ (eq *empty-type* (fun-type-returns ftype))))
(vop nil-fun-returned-error last 2block
(if name
(emit-constant name)
(aver (not named))
tn)))))))
((not (eq (ir2-block-next 2block) (block-info target)))
- (vop branch last 2block (block-label target)))))))
+ (vop branch last 2block (block-label target)))
+ (t
+ (register-drop-thru target))))))
(values))