[commit: ghc] master: Detect levity-polymorphic uses of unsafeCoerce# (e40db7b)

[git at git.haskell.org]

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

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

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

commit e40db7b1676627f5291b463405338e7b69fa3f69
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Wed Dec 13 10:46:26 2017 +0000

    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.


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

e40db7b1676627f5291b463405338e7b69fa3f69
 compiler/basicTypes/Id.hs                          | 26 +++++++++++++++++++---
 compiler/deSugar/DsExpr.hs                         |  3 ++-
 testsuite/tests/polykinds/T14561.hs                | 18 +++++++++++++++
 .../T5472.stdout => polykinds/T14561.stderr}       |  0
 testsuite/tests/polykinds/all.T                    |  1 +
 5 files changed, 44 insertions(+), 4 deletions(-)

diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs
index 63ca38c..fbece0e 100644
--- a/compiler/basicTypes/Id.hs
+++ b/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
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 635a9c6..2f3739e 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/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'
diff --git a/testsuite/tests/polykinds/T14561.hs b/testsuite/tests/polykinds/T14561.hs
new file mode 100644
index 0000000..f528e7c
--- /dev/null
+++ b/testsuite/tests/polykinds/T14561.hs
@@ -0,0 +1,18 @@
+{-# 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
diff --git a/testsuite/tests/deSugar/should_run/T5472.stdout b/testsuite/tests/polykinds/T14561.stderr
similarity index 100%
copy from testsuite/tests/deSugar/should_run/T5472.stdout
copy to testsuite/tests/polykinds/T14561.stderr
diff --git a/testsuite/tests/polykinds/all.T b/testsuite/tests/polykinds/all.T
index 8a03e89..8d0abff 100644
--- a/testsuite/tests/polykinds/all.T
+++ b/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, [''])