Detect levity-polymorphic uses of unsafeCoerce#

This bug was shown up by Trac #14561. The deguarer carefully
detects unsaturated and levity-polymorphic uses of primops,
but not of things like unsafeCoerce#.

The fix is simple: see Note [Levity-polymorphic Ids] in Id.

compiler/basicTypes/Id.hs

@@ -119,7 +119,8 @@ module Id (
 import GhcPrelude
 
 import DynFlags
-import CoreSyn ( CoreRule, isStableUnfolding, evaldUnfolding, Unfolding( NoUnfolding ) )
+import CoreSyn ( CoreRule, isStableUnfolding, evaldUnfolding,
+                 isCompulsoryUnfolding, Unfolding( NoUnfolding ) )
 
 import IdInfo
 import BasicTypes
@@ -519,7 +520,8 @@ hasNoBinding id = case Var.idDetails id of
                         PrimOpId _       -> True        -- See Note [Primop wrappers]
                         FCallId _        -> True
                         DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc
-                        _                -> False
+                        _                -> isCompulsoryUnfolding (idUnfolding id)
+                                            -- See Note [Levity-polymorphic Ids]
 
 isImplicitId :: Id -> Bool
 -- ^ 'isImplicitId' tells whether an 'Id's info is implied by other
@@ -541,7 +543,25 @@ isImplicitId id
 idIsFrom :: Module -> Id -> Bool
 idIsFrom mod id = nameIsLocalOrFrom mod (idName id)
 
-{-
+{- Note [Levity-polymorphic Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Some levity-polymorphic Ids must be applied and and inlined, not left
+un-saturated.  Example:
+  unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b
+
+This has a compulsory unfolding because we can't lambda-bind those
+arguments.  But the compulsory unfolding may leave levity-polymorphic
+lambdas if it is not applied to enough arguments; e.g. (Trac #14561)
+  bad :: forall (a :: TYPE r). a -> a
+  bad = unsafeCoerce#
+
+The desugar has special magic to detect such cases: DsExpr.badUseOfLevPolyPrimop.
+And we want that magic to apply to levity-polymorphic compulsory-inline things.
+The easiest way to do this is for hasNoBinding to return True of all things
+that have compulsory unfolding.  A very Ids with a compulsory unfolding also
+have a binding, but it does not harm to say they don't here, and its a very
+simple way to fix Trac #14561.
+
 Note [Primop wrappers]
 ~~~~~~~~~~~~~~~~~~~~~~
 Currently hasNoBinding claims that PrimOpIds don't have a curried

compiler/deSugar/DsExpr.hs

@@ -260,7 +260,8 @@ ds_expr _ (HsLit lit)            = dsLit (convertLit lit)
 ds_expr _ (HsOverLit lit)        = dsOverLit lit
 
 ds_expr _ (HsWrap co_fn e)
-  = do { e' <- ds_expr True e
+  = do { e' <- ds_expr True e    -- This is the one place where we recurse to
+                                 -- ds_expr (passing True), rather than dsExpr
        ; wrap' <- dsHsWrapper co_fn
        ; dflags <- getDynFlags
        ; let wrapped_e = wrap' e'

testsuite/tests/polykinds/T14561.hs

+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE MagicHash #-}
+
+module T14561 where
+
+import GHC.Types
+import GHC.Prim
+
+badId :: forall (a :: TYPE r). a -> a
+badId = unsafeCoerce#
+-- Un-saturated application of a levity-polymorphic
+-- function that must be eta-expanded
+
+goodId :: forall (a :: Type). a -> a
+goodId = unsafeCoerce#
+-- But this one is OK

testsuite/tests/polykinds/T14561.stderr

+ 
\ No newline at end of file

testsuite/tests/polykinds/all.T

@@ -180,4 +180,5 @@ test('T14520', normal, compile_fail, [''])
 test('T11203', normal, compile_fail, [''])
 test('T14555', normal, compile_fail, [''])
 test('T14563', normal, compile_fail, [''])
+test('T14561', normal, compile_fail, [''])