(event make-value-cell-event node)
(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)))
+ ;; FIXME: See bug 419
+ (and leaf (eq :truly (leaf-dynamic-extent leaf)))
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
(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))
+ (unless (drop-thru-p if alternative)
+ (vop branch node block (block-label alternative))))
(t
- (emit-template node block template args nil
- (list* (block-label consequent) not-p info-args))
+ (emit-template node block template args nil info-args)
+ (vop branch-if node block (block-label consequent) flags not-p)
(unless (drop-thru-p if alternative)
(vop branch node block (block-label alternative)))))))
(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.
(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
(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
(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)))
+ (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 "bind ~S" val)
+ (%primitive bind val var))
+ (,bind (cdr vars) (cdr vals))))))
(,bind ,vars ,vals))
nil
,@body)
projects / sbcl.git / blobdiff