Refactor bad coercion checking in a few places

We do bad coercion checking in a few places in the compiler, but they
all checked it differently:

- CoreToStg.coreToStgArgs:

  Disallowed lifted-to-unlifted, disallowed changing prim reps even when
  the sizes are the same.

- StgCmmExpr.cgCase:

  Checked primRepSlot equality. This disallowed Int to Int64 coercions
  on 64-bit systems (and Int to Int32 on 32-bit) even though those are
  fine.

- CoreLint:

  Only place where we do this right. Full rules are explained in Note
  [Bad unsafe coercion].

This patch implements the check explained in Note [Bad unsafe coercion]
in CoreLint and uses it in CoreToStg.coreToStgArgs and
StgCmmExpr.cgCase.

This fixes #16952 and unblocks !1381 (which fixes #16893).

This is the most conservative and correct change I came up with that
fixes #16952.

One remaining problem with coercion checking is that it's currently done
in seemingly random places. What's special about CoreToStg.coreToStgArgs
and StgCmmExpr.cgCase? My guess is that adding assertions to those
places caught bugs before so we left assertions in those places. I think
we should remove these assertions and do coercion checking in CoreLint
and StgLint only (#17041).

1 files changed, 3 insertions, 11 deletions

diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 59cd246441..a8661d9de0 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -41,7 +41,7 @@ import Id
 import PrimOp
 import TyCon
 import Type             ( isUnliftedType )
-import RepType          ( isVoidTy, countConRepArgs, primRepSlot )
+import RepType          ( isVoidTy, countConRepArgs )
 import CostCentre       ( CostCentreStack, currentCCS )
 import Maybes
 import Util
@@ -50,7 +50,6 @@ import Outputable
 
 import Control.Monad (unless,void)
 import Control.Arrow (first)
-import Data.Function ( on )
 
 ------------------------------------------------------------------------
 --              cgExpr: the main function
@@ -428,10 +427,9 @@ assignment.
 -}
 cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
   | isUnliftedType (idType v)  -- Note [Dodgy unsafeCoerce 1]
-  || reps_compatible
   = -- assignment suffices for unlifted types
     do { dflags <- getDynFlags
-       ; unless reps_compatible $
+       ; unless (reps_compatible dflags) $
            pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
                     (pp_bndr v $$ pp_bndr bndr)
        ; v_info <- getCgIdInfo v
@@ -441,13 +439,7 @@ cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts
        ; _ <- bindArgToReg (NonVoid bndr)
        ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }
   where
-    reps_compatible = ((==) `on` (primRepSlot . idPrimRep)) v bndr
-      -- Must compare SlotTys, not proper PrimReps, because with unboxed sums,
-      -- the types of the binders are generated from slotPrimRep and might not
-      -- match. Test case:
-      --   swap :: (# Int | Int #) -> (# Int | Int #)
-      --   swap (# x | #) = (# | x #)
-      --   swap (# | y #) = (# y | #)
+    reps_compatible dflags = primRepCompatible dflags (idPrimRep v) (idPrimRep bndr)
 
     pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id))