;;; 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)
(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
(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
(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
for idx upfrom 0
do (vop sb!vm::more-arg node block
(lvar-tn node block context)
- (make-constant-tn (find-constant idx))
+ (emit-constant idx)
loc)))
(:unknown
(let ((locs (ir2-lvar-locs 2lvar)))
(progn
(labels ((,unbind (vars)
(declare (optimize (speed 2) (debug 0)))
- (let ((unbound-marker (%primitive make-other-immediate-type
- 0 sb!vm:unbound-marker-widetag)))
+ (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.
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))