;;; 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)
((and indirect
(not (eq (node-physenv node)
(lambda-physenv (lambda-var-home leaf)))))
- (vop ancestor-frame-ref node block tn (leaf-info leaf) res))
+ (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
- (emit-move node block (constant-tn leaf) res))
+ (emit-move node block (constant-tn leaf (boxed-ref-p node)) res))
(functional
(ir2-convert-closure node block leaf res))
(global-var
((and indirect
(not (eq (node-physenv node)
(lambda-physenv (lambda-var-home leaf)))))
- (vop ancestor-frame-set node block tn val (leaf-info 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 (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)))))
(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))))
+ (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 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)))))))
+ (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)
(let* ((type (node-derived-type call))
(types
(mapcar #'primitive-type
- (if (values-type-p type)
+ (if (args-type-p type)
(append (args-type-required type)
(args-type-optional type))
(list type))))
((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
(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
(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))