X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Ftn.lisp;h=79ce6dc01a90e1e4ee2895a160a2c2566ba6b253;hb=HEAD;hp=38d1209fadde0dd0d8cd12616c90b4930943372f;hpb=26839b3799e0687e8df96282aea0368ce12c1e95;p=sbcl.git diff --git a/src/compiler/tn.lisp b/src/compiler/tn.lisp index 38d1209..79ce6dc 100644 --- a/src/compiler/tn.lisp +++ b/src/compiler/tn.lisp @@ -199,20 +199,36 @@ ;;; 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*)) @@ -327,11 +343,7 @@ (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) @@ -339,11 +351,7 @@ (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) @@ -353,22 +361,14 @@ (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) @@ -376,6 +376,11 @@ (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) @@ -383,28 +388,39 @@ (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))