;;; Create a constant TN. The implementation dependent
;;; IMMEDIATE-CONSTANT-SC function is used to determine whether the
;;; constant has an immediate representation.
-(defun make-constant-tn (constant)
+(defun make-constant-tn (constant boxedp)
(declare (type constant constant))
- (let* ((component (component-info *component-being-compiled*))
- (immed (immediate-constant-sc (constant-value constant)))
- (sc (svref *backend-sc-numbers*
- (or immed (sc-number-or-lose 'constant))))
- (res (make-tn 0 :constant (primitive-type (leaf-type constant)) sc)))
- (unless immed
- (let ((constants (ir2-component-constants component)))
- (setf (tn-offset res) (fill-pointer constants))
- (vector-push-extend constant constants)))
- (push-in tn-next res (ir2-component-constant-tns component))
- (setf (tn-leaf res) constant)
- res))
+ (let* ((immed (immediate-constant-sc (constant-value constant)))
+ (use-immed-p (and immed
+ (or (not boxedp)
+ (boxed-immediate-sc-p immed)))))
+ (cond
+ ;; CONSTANT-TN uses two caches, one for boxed and one for unboxed uses.
+ ;;
+ ;; However, in the case of USE-IMMED-P we can have the same TN for both
+ ;; uses. The first two legs here take care of that by cross-pollinating the
+ ;; cached values.
+ ;;
+ ;; Similarly, when there is no immediate SC.
+ ((and (or use-immed-p (not immed)) boxedp (leaf-info constant)))
+ ((and (or use-immed-p (not immed)) (not boxedp) (constant-boxed-tn constant)))
+ (t
+ (let* ((component (component-info *component-being-compiled*))
+ (sc (svref *backend-sc-numbers*
+ (if use-immed-p
+ immed
+ (sc-number-or-lose 'constant))))
+ (res (make-tn 0 :constant (primitive-type (leaf-type constant)) sc)))
+ (unless use-immed-p
+ (let ((constants (ir2-component-constants component)))
+ (setf (tn-offset res) (fill-pointer constants))
+ (vector-push-extend constant constants)))
+ (push-in tn-next res (ir2-component-constant-tns component))
+ (setf (tn-leaf res) constant)
+ res)))))
(defun make-load-time-value-tn (handle type)
(let* ((component (component-info *component-being-compiled*))
(type template template) (type tn x y))
(let ((arg (reference-tn x nil))
(result (reference-tn y t)))
- (multiple-value-bind (first last)
- (funcall (template-emit-function template) node block template arg
- result)
- (insert-vop-sequence first last block before)
- last)))
+ (emit-and-insert-vop node block template arg result before)))
;;; like EMIT-MOVE-TEMPLATE, except that we pass in INFO args too
(defun emit-load-template (node block template x y info &optional before)
(type template template) (type tn x y))
(let ((arg (reference-tn x nil))
(result (reference-tn y t)))
- (multiple-value-bind (first last)
- (funcall (template-emit-function template) node block template arg
- result info)
- (insert-vop-sequence first last block before)
- last)))
+ (emit-and-insert-vop node block template arg result before info)))
;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes two args
(defun emit-move-arg-template (node block template x f y &optional before)
(f-ref (reference-tn f nil))
(y-ref (reference-tn y t)))
(setf (tn-ref-across x-ref) f-ref)
- (multiple-value-bind (first last)
- (funcall (template-emit-function template) node block template x-ref
- y-ref)
- (insert-vop-sequence first last block before)
- last)))
+ (emit-and-insert-vop node block template x-ref y-ref before)))
;;; like EMIT-MOVE-TEMPLATE, except that the VOP takes no args
(defun emit-context-template (node block template y &optional before)
(declare (type node node) (type ir2-block block)
(type template template) (type tn y))
(let ((y-ref (reference-tn y t)))
- (multiple-value-bind (first last)
- (funcall (template-emit-function template) node block template nil
- y-ref)
- (insert-vop-sequence first last block before)
- last)))
+ (emit-and-insert-vop node block template nil y-ref before)))
;;; Return the label marking the start of Block, assigning one if necessary.
(defun block-label (block)
(let ((2block (block-info block)))
(or (ir2-block-%label 2block)
(setf (ir2-block-%label 2block) (gen-label)))))
+(defun block-trampoline (block)
+ (declare (type cblock block))
+ (let ((2block (block-info block)))
+ (or (ir2-block-%trampoline-label 2block)
+ (setf (ir2-block-%trampoline-label 2block) (gen-label)))))
;;; Return true if Block is emitted immediately after the block ended by Node.
(defun drop-thru-p (node block)
(let ((next-block (ir2-block-next (block-info (node-block node)))))
(aver (eq node (block-last (node-block node))))
(eq next-block (block-info block))))
+(defun register-drop-thru (block)
+ (declare (type cblock block))
+ (let ((2block (block-info block)))
+ (setf (ir2-block-dropped-thru-to 2block) t))
+ nil)
-;;; Link a list of VOPs from First to Last into Block, Before the specified
-;;; VOP. If Before is NIL, insert at the end.
-(defun insert-vop-sequence (first last block before)
- (declare (type vop first last) (type ir2-block block)
+;;; Insert a VOP into BLOCK, before the specified
+;;; BEFORE VOP. If BEFORE is NIL, insert at the end.
+(defun insert-vop (vop block before)
+ (declare (type vop vop) (type ir2-block block)
(type (or vop null) before))
(if before
(let ((prev (vop-prev before)))
- (setf (vop-prev first) prev)
+ (setf (vop-prev vop) prev)
(if prev
- (setf (vop-next prev) first)
- (setf (ir2-block-start-vop block) first))
- (setf (vop-next last) before)
- (setf (vop-prev before) last))
+ (setf (vop-next prev) vop)
+ (setf (ir2-block-start-vop block) vop))
+ (setf (vop-next vop) before)
+ (setf (vop-prev before) vop))
(let ((current (ir2-block-last-vop block)))
- (setf (vop-prev first) current)
- (setf (ir2-block-last-vop block) last)
+ (setf (vop-prev vop) current)
+ (setf (ir2-block-last-vop block) vop)
(if current
- (setf (vop-next current) first)
- (setf (ir2-block-start-vop block) first))))
+ (setf (vop-next current) vop)
+ (setf (ir2-block-start-vop block) vop))))
(values))
+(defun emit-and-insert-vop (node block template arg result before
+ &optional info)
+ (let ((vop (emit-vop node block template arg result info)))
+ (insert-vop vop block before)
+ vop))
+
;;; Delete all of the TN-REFs associated with VOP and remove VOP from the IR2.
(defun delete-vop (vop)
(declare (type vop vop))
;;; Return the value of an immediate constant TN.
(defun tn-value (tn)
(declare (type tn tn))
- ;; FIXME: What is :CACHED-CONSTANT?
- (aver (member (tn-kind tn) '(:constant :cached-constant)))
+ (aver (eq (tn-kind tn) :constant))
(constant-value (tn-leaf tn)))
+(defun immediate-tn-p (tn)
+ (declare (type tn tn))
+ (let ((leaf (tn-leaf tn)))
+ ;; Leaves with KIND :CONSTANT can have NIL as the leaf if they
+ ;; represent load time values.
+ (and leaf
+ (eq (tn-kind tn) :constant)
+ (eq (immediate-constant-sc (constant-value leaf))
+ (sc-number-or-lose 'sb!vm::immediate)))))
+
;;; Force TN to be allocated in a SC that doesn't need to be saved: an
;;; unbounded non-save-p SC. We don't actually make it a real "restricted" TN,
;;; but since we change the SC to an unbounded one, we should always succeed in
projects / sbcl.git / blobdiff