Commit e9e6b283 authored by ram's avatar ram
Browse files

Added stuff to allow multiple move VOPs per SC pair, with selection ebing

done by the primitive type of the operands.  Also, added stuff to delete
moves to :NORMAL TNs that have no reads.  Changed the existing 
special-casing of unread results to only punt on :NORMAL TNs.
Also, fixed the move/coerce generation stuff to just leave alone the MOVEs
that are o.k., instead of deleting the old MOVE and inserting a new one.
parent 2dac9e98
......@@ -145,21 +145,26 @@
(get-operand-info op)
(declare (ignore costs more-p))
(collect ((load-lose)
(dotimes (i sc-number-limit)
(let ((i-sc (svref (backend-sc-numbers *backend*) i)))
(when (eq (svref load-scs i) t)
(cond ((not (sc-allowed-by-primitive-type i-sc ptype))
(load-lose i-sc))
((not (if write-p
(svref (sc-move-vops op-sc) i)
(svref (sc-move-vops i-sc) op-scn)))
(move-lose i-sc))
((not (find-move-vop op-tn write-p i-sc ptype
(let ((vops (if write-p
(svref (sc-move-vops op-sc) i)
(svref (sc-move-vops i-sc) op-scn))))
(if vops
(dolist (vop vops) (move-lose (template-name vop)))
(no-move-scs i-sc))))
(error "Representation selection flamed out for no ~
obvious reason."))))))
(unless (or (load-lose) (move-lose))
(unless (or (load-lose) (no-move-scs) (move-lose))
(error "Representation selection flamed out for no obvious reason.~@
Try again after recompiling the VM definition."))
......@@ -169,6 +174,8 @@
~@[The primitive type disallows these loadable SCs:~% ~S~%~]~
~@[No move VOPs are defined to coerce to these allowed SCs:~
~% ~S~%~]~
~@[These move VOPs couldn't be used due to operand type ~
restrictions:~% ~S~%~]~
Current cost info inconsistent with that in effect at compile ~
time. Recompile.~%Compilation order may be incorrect.~]"
......@@ -177,7 +184,8 @@
(primitive-type-name ptype)
(mapcar #'sc-name (listify-restrictions load-scs))
(mapcar #'sc-name (load-lose))
(mapcar #'sc-name (move-lose))
(mapcar #'sc-name (no-move-scs))
......@@ -359,6 +367,45 @@
;;; FIND-MOVE-VOP -- Internal
;;; Find a move VOP to move from the operand OP-TN to some other
;;; representation corresponding to OTHER-SC and OTHER-PTYPE. Slot is the SC
;;; slot that we grab from (move or move-argument). Write-P indicates that OP
;;; is a VOP result, so OP is the move result and other is the arg, otherwise
;;; OP is the arg and other is the result.
;;; If an operand is of primitive type T, then we use the type of the other
;;; operand instead, effectively intersecting the argument and result type
;;; assertions. This way, a move VOP can restrict whichever operand makes more
;;; sense, without worrying about which operand has the type info.
(defun find-move-vop (op-tn write-p other-sc other-ptype slot)
(declare (type tn op-tn) (type sc other-sc)
(type primitive-type other-ptype)
(type function slot))
(let* ((op-sc (tn-sc op-tn))
(op-scn (sc-number op-sc))
(other-scn (sc-number other-sc))
(any-ptype (backend-any-primitive-type *backend*))
(op-ptype (tn-primitive-type op-tn)))
(dolist (info (if write-p
(svref (funcall slot op-sc) other-scn)
(svref (funcall slot other-sc) op-scn))
(when (and (operand-restriction-ok
(first (template-arg-types info))
(if (or write-p (eq op-ptype any-ptype))
other-ptype op-ptype)
:tn op-tn :t-ok nil)
(first (template-result-types info))
(if (or write-p (eq other-ptype any-ptype))
op-ptype other-ptype)
:t-ok nil))
(return info)))))
;;; EMIT-COERCE-VOP -- Internal
;;; Emit a coercion VOP for Op Before the specifed VOP or die trying. SCS
......@@ -381,8 +428,6 @@
(declare (type tn-ref op) (type sc-vector scs) (type (or vop null) before)
(type (or tn null) dest-tn))
(let* ((op-tn (tn-ref-tn op))
(op-sc (tn-sc op-tn))
(op-scn (sc-number op-sc))
(ptype (tn-primitive-type op-tn))
(write-p (tn-ref-write-p op))
(vop (tn-ref-vop op))
......@@ -392,9 +437,7 @@
(let ((i-sc (svref (backend-sc-numbers *backend*) i)))
(when (and (eq (svref scs i) t)
(sc-allowed-by-primitive-type i-sc ptype))
(let ((res (if write-p
(svref (sc-move-vops op-sc) i)
(svref (sc-move-vops i-sc) op-scn))))
(let ((res (find-move-vop op-tn write-p i-sc ptype #'sc-move-vops)))
(when res
(when (>= (vop-info-cost res) *efficency-note-cost-threshold*)
(do-coerce-efficency-note res op dest-tn))
......@@ -403,7 +446,8 @@
((not write-p)
(emit-move-template node block res op-tn temp before))
((null (tn-reads op-tn)))
((and (null (tn-reads op-tn))
(eq (tn-kind op-tn) :normal)))
(emit-move-template node block res temp op-tn before))))
......@@ -470,8 +514,9 @@
(let* ((val-tn (tn-ref-tn val))
(pass-tn (first pass))
(pass-sc (tn-sc pass-tn))
(res (svref (sc-move-arg-vops pass-sc)
(sc-number (tn-sc val-tn)))))
(res (find-move-vop val-tn nil pass-sc
(tn-primitive-type pass-tn)
(unless res
(bad-move-arg-error val-tn pass-tn))
......@@ -506,6 +551,8 @@
;;; Scan the IR2 looking for move operations that need to be replaced with
;;; special-case VOPs and emitting coercion VOPs for operands of normal VOPs.
;;; We delete moves to TNs that are never read at this point, rather than
;;; possibly converting them to some expensive move operation.
(defun emit-moves-and-coercions (block)
(declare (type ir2-block block))
......@@ -520,9 +567,13 @@
(let* ((args (vop-args vop))
(x (tn-ref-tn args))
(y (tn-ref-tn (vop-results vop)))
(res (svref (sc-move-vops (tn-sc y))
(sc-number (tn-sc x)))))
(cond (res
(res (find-move-vop x nil (tn-sc y) (tn-primitive-type y)
(cond ((and (null (tn-reads y))
(eq (tn-kind y) :normal))
(delete-vop vop))
((eq res info))
(when (>= (vop-info-cost res) *efficency-note-cost-threshold*)
(do-coerce-efficency-note res args y))
(emit-move-template node block res x y vop)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment