Skip to content
Snippets Groups Projects
Commit fe5883f3 authored by ram's avatar ram
Browse files

Changed to understand the new load-scs format, and to not attempt coercions

disallowed by the primitive type.
parent a1dbcc75
No related branches found
No related tags found
No related merge requests found
...@@ -89,7 +89,7 @@ ...@@ -89,7 +89,7 @@
(declare (type sc-vector restr)) (declare (type sc-vector restr))
(collect ((res)) (collect ((res))
(dotimes (i sc-number-limit) (dotimes (i sc-number-limit)
(when (eql (svref restr i) i) (when (eq (svref restr i) t)
(res (svref *sc-numbers* i)))) (res (svref *sc-numbers* i))))
(res))) (res)))
...@@ -138,6 +138,32 @@ ...@@ -138,6 +138,32 @@
val (sc-name (tn-sc val)) val (sc-name (tn-sc val))
pass (sc-name (tn-sc pass)))) pass (sc-name (tn-sc pass))))
#|
;;; ILLEGAL-REPRESENTATION-ERROR -- Internal
;;;
;;; Called when we find that doing an implicit coercion for an operand
;;; results in a representation not allowed by the primitive type.
;;;
(defun illegal-representation-error (ref sc)
(declare (type tn-ref ref))
(let* ((tn (tn-ref-tn ref))
(ptype (tn-primitive-type tn)))
(multiple-value-bind (arg-p pos more-p costs load-scs incon)
(get-operand-info ref)
(declare (ignore more-p costs load-scs))
(error "~S is not valid as the ~:R ~:[result~;argument~] to the~@
~S VOP, since the TN's primitive type ~S disallows coercion to~@
SC ~S. Either the SC restriction is too restrictive, or the ~
operand~@
primitive type restriction is not restrictive enough. ~:[~;~@
Current cost info inconsistent with that in effect at compile ~
time. Recompile.~%Compilation order may be incorrect.~]"
tn pos arg-p
(template-name (vop-info (tn-ref-vop ref)))
(primitive-type-name ptype)
(sc-name sc) incon))))
|#
;;;; VM Consistency Checking: ;;;; VM Consistency Checking:
;;; ;;;
...@@ -260,10 +286,10 @@ ...@@ -260,10 +286,10 @@
;;; VOP will accept. We pick any acceptable coerce VOP, since it practice it ;;; VOP will accept. We pick any acceptable coerce VOP, since it practice it
;;; seems uninteresting to have more than one applicable. ;;; seems uninteresting to have more than one applicable.
;;; ;;;
;;; What we do is look at each SC allowed by the operand restriction, and ;;; What we do is look at each SC allowed by both the operand restriction
;;; see if there is a move VOP which moves between the operand's SC and load ;;; and the operand primitive-type, and see if there is a move VOP which moves
;;; SC. If we find such a VOP, then we make a TN having the load SC as the ;;; between the operand's SC and load SC. If we find such a VOP, then we make
;;; representation. ;;; a TN having the load SC as the representation.
;;; ;;;
;;; If the TN is an unused result TN, then we don't actually emit the move; ;;; If the TN is an unused result TN, then we don't actually emit the move;
;;; we just change to the right kind of TN. ;;; we just change to the right kind of TN.
...@@ -273,26 +299,28 @@ ...@@ -273,26 +299,28 @@
(let* ((op-tn (tn-ref-tn op)) (let* ((op-tn (tn-ref-tn op))
(op-sc (tn-sc op-tn)) (op-sc (tn-sc op-tn))
(op-scn (sc-number op-sc)) (op-scn (sc-number op-sc))
(ptype (tn-primitive-type op-tn))
(write-p (tn-ref-write-p op)) (write-p (tn-ref-write-p op))
(vop (tn-ref-vop op)) (vop (tn-ref-vop op))
(node (vop-node vop)) (node (vop-node vop))
(block (vop-block vop))) (block (vop-block vop)))
(dotimes (i sc-number-limit (bad-costs-error op)) (dotimes (i sc-number-limit (bad-costs-error op))
(when (eql (svref scs i) i) (let ((i-sc (svref *sc-numbers* i)))
(let ((res (if write-p (when (and (eq (svref scs i) t)
(svref (sc-move-vops op-sc) i) (sc-allowed-by-primitive-type i-sc ptype))
(svref (sc-move-vops (svref *sc-numbers* i)) (let ((res (if write-p
op-scn)))) (svref (sc-move-vops op-sc) i)
(when res (svref (sc-move-vops i-sc) op-scn))))
(let ((temp (make-representation-tn i))) (when res
(change-tn-ref-tn op temp) (let ((temp (make-representation-tn ptype i)))
(cond (change-tn-ref-tn op temp)
((not write-p) (cond
(emit-move-template node block res op-tn temp before)) ((not write-p)
((null (tn-reads op-tn))) (emit-move-template node block res op-tn temp before))
(t ((null (tn-reads op-tn)))
(emit-move-template node block res temp op-tn before)))) (t
(return))))))) (emit-move-template node block res temp op-tn before))))
(return))))))))
;;; COERCE-SOME-OPERANDS -- Internal ;;; COERCE-SOME-OPERANDS -- Internal
...@@ -366,6 +394,7 @@ ...@@ -366,6 +394,7 @@
(assert (eq how :known-return)) (assert (eq how :known-return))
(setq nfp-tn (setq nfp-tn
(make-representation-tn (make-representation-tn
*any-primitive-type*
(first (primitive-type-scs (first (primitive-type-scs
*any-primitive-type*)))) *any-primitive-type*))))
(emit-context-template (emit-context-template
...@@ -449,6 +478,7 @@ ...@@ -449,6 +478,7 @@
(do ((tn (ir2-component-normal-tns 2comp) (do ((tn (ir2-component-normal-tns 2comp)
(tn-next tn))) (tn-next tn)))
((null tn)) ((null tn))
(assert (tn-primitive-type tn))
(unless (tn-sc tn) (unless (tn-sc tn)
(let* ((scs (primitive-type-scs (tn-primitive-type tn))) (let* ((scs (primitive-type-scs (tn-primitive-type tn)))
(sc (if (rest scs) (sc (if (rest scs)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment