[commit: ghc] master: Fix #13458 (cea7141)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/cea7141851ce653cb20207da3591d09e73fa396d/ghc

>---------------------------------------------------------------

commit cea7141851ce653cb20207da3591d09e73fa396d
Author: Richard Eisenberg <rae at cs.brynmawr.edu>
Date:   Wed Mar 22 22:32:04 2017 -0400

    Fix #13458
    
    Core Lint shouldn't check representations of types that don't
    have representations.
    
    test case: typecheck/should_compile/T13458


>---------------------------------------------------------------

cea7141851ce653cb20207da3591d09e73fa396d
 compiler/coreSyn/CoreLint.hs                       | 26 +++++++++++++++-------
 compiler/simplStg/RepType.hs                       |  4 ----
 testsuite/tests/typecheck/should_compile/T13458.hs | 11 +++++++++
 testsuite/tests/typecheck/should_compile/all.T     |  1 +
 4 files changed, 30 insertions(+), 12 deletions(-)

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 0363d6b..b97f97e 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -1630,7 +1630,7 @@ lintCoercion co@(UnivCo prov r ty1 ty2)
               (checkTypes ty1 ty2)
        ; return (k1, k2, ty1, ty2, r) }
    where
-     report s = hang (text $ "Unsafe coercion between " ++ s)
+     report s = hang (text $ "Unsafe coercion: " ++ s)
                      2 (vcat [ text "From:" <+> ppr ty1
                              , text "  To:" <+> ppr ty2])
      isUnBoxed :: PrimRep -> Bool
@@ -1638,10 +1638,20 @@ lintCoercion co@(UnivCo prov r ty1 ty2)
 
        -- see #9122 for discussion of these checks
      checkTypes t1 t2
-       = do { checkWarnL (reps1 `equalLength` reps2)
-                         (report "values with different # of reps")
-            ; zipWithM_ validateCoercion reps1 reps2 }
+       = do { checkWarnL lev_poly1
+                         (report "left-hand type is levity-polymorphic")
+            ; checkWarnL lev_poly2
+                         (report "right-hand type is levity-polymorphic")
+            ; when (not (lev_poly1 || lev_poly2)) $
+              do { checkWarnL (reps1 `equalLength` reps2)
+                              (report "between values with different # of reps")
+                 ; zipWithM_ validateCoercion reps1 reps2 }}
        where
+         lev_poly1 = isTypeLevPoly t1
+         lev_poly2 = isTypeLevPoly t2
+
+         -- don't look at these unless lev_poly1/2 are False
+         -- Otherwise, we get #13458
          reps1 = typePrimRep t1
          reps2 = typePrimRep t2
 
@@ -1649,15 +1659,15 @@ lintCoercion co@(UnivCo prov r ty1 ty2)
      validateCoercion rep1 rep2
        = do { dflags <- getDynFlags
             ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)
-                         (report "unboxed and boxed value")
+                         (report "between unboxed and boxed value")
             ; checkWarnL (TyCon.primRepSizeW dflags rep1
                            == TyCon.primRepSizeW dflags rep2)
-                         (report "unboxed values of different size")
+                         (report "between unboxed values of different size")
             ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1)
                                    (TyCon.primRepIsFloat rep2)
             ; case fl of
-                Nothing    -> addWarnL (report "vector types")
-                Just False -> addWarnL (report "float and integral values")
+                Nothing    -> addWarnL (report "between vector types")
+                Just False -> addWarnL (report "between float and integral values")
                 _          -> return ()
             }
 
diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs
index f59a854..be72574 100644
--- a/compiler/simplStg/RepType.hs
+++ b/compiler/simplStg/RepType.hs
@@ -343,10 +343,6 @@ kindPrimRep doc (TyConApp typ [runtime_rep])
 kindPrimRep doc ki
   = pprPanic "kindPrimRep" (ppr ki $$ doc)
 
-  -- TODO (RAE): Remove:
-  -- WARN( True, text "kindPrimRep defaulting to LiftedRep on" <+> ppr ki $$ doc )
-  -- [LiftedRep]  -- this can happen legitimately for, e.g., Any
-
 -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that
 -- it encodes.
 runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep]
diff --git a/testsuite/tests/typecheck/should_compile/T13458.hs b/testsuite/tests/typecheck/should_compile/T13458.hs
new file mode 100644
index 0000000..9b51378
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T13458.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE MagicHash, TypeInType, ScopedTypeVariables #-}
+{-# OPTIONS_GHC -O #-}
+module T13458 where
+import GHC.Exts
+import Data.Kind
+import Unsafe.Coerce
+
+unsafeCoerce' :: forall (r :: RuntimeRep)
+                       (a :: TYPE r) (b :: TYPE r).
+                a -> b
+unsafeCoerce' = unsafeCoerce id
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 9caaf25..97a5350 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -546,3 +546,4 @@ test('T12926', normal, compile, [''])
 test('T13381', normal, compile_fail, [''])
 test('T13337', normal, compile, [''])
 test('T13343', normal, compile, [''])
+test('T13458', normal, compile, [''])