[commit: ghc] wip/T16185: Don't invoke dataConSrcToImplBang on newtypes (076f586)

[git at git.haskell.org]

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

On branch  : wip/T16185
Link       : http://ghc.haskell.org/trac/ghc/changeset/076f5862a9e46eef762ba19fb7b14e75fa03c2c0/ghc

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

commit 076f5862a9e46eef762ba19fb7b14e75fa03c2c0
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Sat Jan 12 19:05:46 2019 -0500

    Don't invoke dataConSrcToImplBang on newtypes


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

076f5862a9e46eef762ba19fb7b14e75fa03c2c0
 compiler/basicTypes/MkId.hs                        | 48 ++++++++++++++++++----
 testsuite/tests/typecheck/should_compile/T16141.hs | 13 ++++++
 testsuite/tests/typecheck/should_compile/all.T     |  1 +
 3 files changed, 55 insertions(+), 7 deletions(-)

diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index 5a6f1fb..17916cf 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -616,6 +616,8 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
                      , dcr_boxer   = mk_boxer boxers
                      , dcr_arg_tys = rep_tys
                      , dcr_stricts = rep_strs
+                       -- For newtypes, dcr_bangs is always [HsLazy].
+                       -- See Note [HsImplBangs for newtypes].
                      , dcr_bangs   = arg_ibangs }) }
 
   where
@@ -637,11 +639,16 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
              -- Because we are going to apply the eq_spec args manually in the
              -- wrapper
 
-    arg_ibangs =
-      case mb_bangs of
-        Nothing    -> zipWith (dataConSrcToImplBang dflags fam_envs)
-                              orig_arg_tys orig_bangs
-        Just bangs -> bangs
+    new_tycon = isNewTyCon tycon
+    arg_ibangs
+      | new_tycon
+      = ASSERT( isSingleton orig_arg_tys )
+        [HsLazy] -- See Note [HsImplBangs for newtypes]
+      | otherwise
+      = case mb_bangs of
+          Nothing    -> zipWith (dataConSrcToImplBang dflags fam_envs)
+                                orig_arg_tys orig_bangs
+          Just bangs -> bangs
 
     (rep_tys_w_strs, wrappers)
       = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs))
@@ -650,7 +657,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
     (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)
 
     wrapper_reqd =
-        (not (isNewTyCon tycon)
+        (not new_tycon
                      -- (Most) newtypes have only a worker, with the exception
                      -- of some newtypes written with GADT syntax. See below.
          && (any isBanged (ev_ibangs ++ arg_ibangs)
@@ -774,6 +781,29 @@ wrappers! After all, a newtype can also be written with GADT syntax:
 Again, this needs a wrapper data con to reorder the type variables. It does
 mean that this newtype constructor requires another level of indirection when
 being called, but the inliner should make swift work of that.
+
+Note [HsImplBangs for newtypes]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Most of the time, we use the dataConSrctoImplBang function to decide what
+strictness/unpackedness to use for the fields of a data type constructor. But
+there is an exception to this rule: newtype constructors. You might not think
+that newtypes would pose a challenge, since newtypes are seemingly forbidden
+from having strictness annotations in the first place. But consider this
+(from Trac #16141):
+
+  {-# LANGUAGE StrictData #-}
+  {-# OPTIONS_GHC -O #-}
+  newtype T a b where
+    MkT :: forall b a. Int -> T a b
+
+Because StrictData (plus optimization) is enabled, invoking
+dataConSrcToImplBang would sneak in and unpack the field of type Int to Int#!
+This would be disastrous, since the wrapper for `MkT` uses a coercion involving
+Int, not Int#.
+
+Bottom line: dataConSrcToImplBang should never be invoked for newtypes. In the
+case of a newtype constructor, we simply hardcode its dcr_bangs field to
+[HsLazy].
 -}
 
 -------------------------
@@ -781,7 +811,11 @@ newLocal :: Type -> UniqSM Var
 newLocal ty = do { uniq <- getUniqueM
                  ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) }
 
--- | Unpack/Strictness decisions from source module
+-- | Unpack/Strictness decisions from source module.
+--
+-- This function should only ever be invoked for data constructor fields, and
+-- never on the field of a newtype constructor.
+-- See @Note [HsImplBangs for newtypes]@.
 dataConSrcToImplBang
    :: DynFlags
    -> FamInstEnvs
diff --git a/testsuite/tests/typecheck/should_compile/T16141.hs b/testsuite/tests/typecheck/should_compile/T16141.hs
new file mode 100644
index 0000000..da9f2cc
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T16141.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StrictData #-}
+{-# LANGUAGE TypeFamilies #-}
+module T16141 where
+
+data family T1
+newtype instance T1 = MkT1 Int
+  deriving Eq
+
+newtype T2 a b where
+  MkT2 :: forall b a. Int -> T2 a b
+  deriving Eq
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 9d1fc18..3ad727d 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -663,3 +663,4 @@ test('T15778', normal, compile, [''])
 test('T14761c', normal, compile, [''])
 test('T16008', normal, compile, [''])
 test('T16033', normal, compile, [''])
+test('T16141', normal, compile, ['-O'])