Support "unusable UNPACK pragma" warning with -O0

Fixes #11270

10 files changed, 71 insertions, 31 deletions

diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs
index 1b9a4a1815..3835bd0e6f 100644
--- a/compiler/GHC/Core/DataCon.hs
+++ b/compiler/GHC/Core/DataCon.hs
@@ -810,7 +810,10 @@ data HsSrcBang =
 -- after consulting HsSrcBang, flags, etc.
 data HsImplBang
   = HsLazy    -- ^ Lazy field, or one with an unlifted type
-  | HsStrict  -- ^ Strict but not unpacked field
+  | HsStrict Bool -- ^ Strict but not unpacked field
+                  -- True <=> we could have unpacked, but opted not to
+                  -- because of -O0.
+                  -- See Note [Detecting useless UNPACK pragmas]
   | HsUnpack (Maybe Coercion)
     -- ^ Strict and unpacked field
     -- co :: arg-ty ~ product-ty HsBang
@@ -912,13 +915,48 @@ Terminology:
 
 * The dcr_bangs field of the dcRep field records the [HsImplBang]
   If T was defined in this module, Without -O the dcr_bangs might be
-    [HsStrict, HsStrict, HsLazy]
+    [HsStrict _, HsStrict _, HsLazy]
   With -O it might be
-    [HsStrict, HsUnpack _, HsLazy]
+    [HsStrict _, HsUnpack _, HsLazy]
   With -funbox-small-strict-fields it might be
     [HsUnpack, HsUnpack _, HsLazy]
   With -XStrictData it might be
-    [HsStrict, HsUnpack _, HsStrict]
+    [HsStrict _, HsUnpack _, HsStrict _]
+
+Note [Detecting useless UNPACK pragmas]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to issue a warning when there's an UNPACK pragma in the source code,
+but we decided not to unpack.
+However, when compiling with -O0, we never unpack, and that'd generate
+spurious warnings.
+Therefore, we remember in HsStrict a boolean flag, whether we _could_
+have unpacked. This flag is set in GHC.Types.Id.Make.dataConSrcToImplBang.
+Then, in GHC.Tc.TyCl.checkValidDataCon (sub-function check_bang),
+if the user wrote an `{-# UNPACK #-}` pragma (i.e. HsSrcBang contains SrcUnpack)
+we consult HsImplBang:
+
+  HsUnpack _     => field unpacked, no warning
+                    Example: data T = MkT {-# UNPACK #-} !Int   [with -O]
+  HsStrict True  => field not unpacked because -O0, no warning
+                    Example: data T = MkT {-# UNPACK #-} !Int   [with -O0]
+  HsStrict False => field not unpacked, warning
+                    Example: data T = MkT {-# UNPACK #-} !(Int -> Int)
+  HsLazy         => field not unpacked, warning
+                    This can happen in two scenarios:
+
+                    1) UNPACK without a bang
+                    Example: data T = MkT {-# UNPACK #-} Int
+                    This will produce a warning about missing ! before UNPACK.
+
+                    2) UNPACK of an unlifted datatype
+                    Because of bug #20204, we currently do not unpack type T,
+                    and therefore issue a warning:
+                    type IntU :: UnliftedType
+                    data IntU = IntU Int#
+                    data T = Test {-# UNPACK #-} IntU
+
+The boolean flag is used only for this warning.
+See #11270 for motivation.
 
 Note [Data con representation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1003,7 +1041,7 @@ instance Outputable HsImplBang where
     ppr HsLazy                  = text "Lazy"
     ppr (HsUnpack Nothing)      = text "Unpacked"
     ppr (HsUnpack (Just co))    = text "Unpacked" <> parens (ppr co)
-    ppr HsStrict                = text "StrictNotUnpacked"
+    ppr (HsStrict b)            = text "StrictNotUnpacked" <> parens (ppr b)
 
 instance Outputable SrcStrictness where
     ppr SrcLazy     = char '~'
@@ -1056,7 +1094,7 @@ instance Binary SrcUnpackedness where
 -- | Compare strictness annotations
 eqHsBang :: HsImplBang -> HsImplBang -> Bool
 eqHsBang HsLazy               HsLazy              = True
-eqHsBang HsStrict             HsStrict            = True
+eqHsBang (HsStrict _)         (HsStrict _)        = True
 eqHsBang (HsUnpack Nothing)   (HsUnpack Nothing)  = True
 eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2))
   = eqType (coercionType c1) (coercionType c2)
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index bf713aae53..87fe4793b8 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/compiler/GHC/CoreToIface.hs
@@ -428,7 +428,7 @@ toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang
 toIfaceBang _    HsLazy              = IfNoBang
 toIfaceBang _   (HsUnpack Nothing)   = IfUnpack
 toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))
-toIfaceBang _   HsStrict             = IfStrict
+toIfaceBang _   (HsStrict _)         = IfStrict
 
 toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang
 toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 206d4ab4dd..93a3bce842 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1191,7 +1191,7 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
 
     tc_strict :: IfaceBang -> IfL HsImplBang
     tc_strict IfNoBang = return (HsLazy)
-    tc_strict IfStrict = return (HsStrict)
+    tc_strict IfStrict = return (HsStrict True)
     tc_strict IfUnpack = return (HsUnpack Nothing)
     tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
                                       ; return (HsUnpack (Just co)) }
diff --git a/compiler/GHC/Tc/Deriv/Generics.hs b/compiler/GHC/Tc/Deriv/Generics.hs
index 509282d3e5..41e7bb3e92 100644
--- a/compiler/GHC/Tc/Deriv/Generics.hs
+++ b/compiler/GHC/Tc/Deriv/Generics.hs
@@ -689,7 +689,7 @@ tc_mkRepTy gk get_fixity dit@(DerivInstTys{ dit_rep_tc = tycon
 
             pDStrness = mkTyConTy $ case ib of
                                          HsLazy      -> pDLzy
-                                         HsStrict    -> pDStr
+                                         HsStrict _  -> pDStr
                                          HsUnpack{}  -> pDUpk
 
     return (mkD tycon)
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index c12ab7a1aa..943c8dcbd2 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -2781,9 +2781,9 @@ reifySourceBang :: DataCon.HsSrcBang
 reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s)
 
 reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness
-reifyDecidedStrictness HsLazy     = TH.DecidedLazy
-reifyDecidedStrictness HsStrict   = TH.DecidedStrict
-reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack
+reifyDecidedStrictness HsLazy       = TH.DecidedLazy
+reifyDecidedStrictness (HsStrict _) = TH.DecidedStrict
+reifyDecidedStrictness HsUnpack{}   = TH.DecidedUnpack
 
 reifyTypeOfThing :: TH.Name -> TcM TH.Type
 reifyTypeOfThing th_name = do
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 25900f2103..f3e02c0fd0 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -4446,9 +4446,6 @@ checkValidDataCon dflags existential_ok tc con
           checkTc (all isEqPred (dataConOtherTheta con))
                   (TcRnConstraintInKind (dataConRepType con))
 
-          -- Check that UNPACK pragmas and bangs work out
-          -- E.g.  reject   data T = MkT {-# UNPACK #-} Int     -- No "!"
-          --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack
         ; hsc_env <- getTopEnv
         ; let check_bang :: Type -> HsSrcBang -> HsImplBang -> Int -> TcM ()
               check_bang orig_arg_ty bang rep_bang n
@@ -4457,6 +4454,8 @@ checkValidDataCon dflags existential_ok tc con
                = addErrTc $ mkTcRnUnknownMessage $ mkPlainError noHints $
                  (bad_bang n (text "Lazy annotation (~) without StrictData"))
 
+               -- Warn about UNPACK without "!"
+               -- e.g.   data T = MkT {-# UNPACK #-} Int
                | HsSrcBang _ want_unpack strict_mark <- bang
                , isSrcUnpacked want_unpack, not (is_strict strict_mark)
                , not (isUnliftedType orig_arg_ty)
@@ -4475,13 +4474,14 @@ checkValidDataCon dflags existential_ok tc con
                , isUnliftedType orig_arg_ty
                = addDiagnosticTc $ TcRnLazyBangOnUnliftedType orig_arg_ty
 
+               -- Warn about unusable UNPACK pragmas
+               -- e.g.   data T a = MkT {-# UNPACK #-} !a      -- Can't unpack
                | HsSrcBang _ want_unpack _ <- bang
-               , isSrcUnpacked want_unpack
-               , case rep_bang of { HsUnpack {} -> False; _ -> True }
-               -- If not optimising, we don't unpack (rep_bang is never
-               -- HsUnpack), so don't complain!  This happens, e.g., in Haddock.
-               -- See dataConSrcToImplBang.
-               , not (bang_opt_unbox_disable bang_opts)
+
+               -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon.
+               , isSrcUnpacked want_unpack  -- this means the user wrote {-# UNPACK #-}
+               , case rep_bang of { HsUnpack {} -> False; HsStrict True -> False; _ -> True }
+
                -- When typechecking an indefinite package in Backpack, we
                -- may attempt to UNPACK an abstract type.  The test here will
                -- conclude that this is unusable, but it might become usable
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index fec1b6c2be..5a4f0f17ee 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -1028,20 +1028,22 @@ dataConSrcToImplBang bang_opts fam_envs arg_ty
   = HsLazy  -- For !Int#, say, use HsLazy
             -- See Note [Data con wrappers and unlifted types]
 
-  | not (bang_opt_unbox_disable bang_opts) -- Don't unpack if disabled
-  , let mb_co   = topNormaliseType_maybe fam_envs (scaledThing arg_ty)
+  | let mb_co   = topNormaliseType_maybe fam_envs (scaledThing arg_ty)
                      -- Unwrap type families and newtypes
         arg_ty' = case mb_co of
                     { Just redn -> scaledSet arg_ty (reductionReducedType redn)
                     ; Nothing   -> arg_ty }
   , all (not . isNewTyCon . fst) (splitTyConApp_maybe $ scaledThing arg_ty')
   , shouldUnpackTy bang_opts unpk_prag fam_envs arg_ty'
-  = case mb_co of
-      Nothing   -> HsUnpack Nothing
-      Just redn -> HsUnpack (Just $ reductionCoercion redn)
+  = if bang_opt_unbox_disable bang_opts
+    then HsStrict True -- Not unpacking because of -O0
+                       -- See Note [Detecting useless UNPACK pragmas] in GHC.Core.DataCon
+    else case mb_co of
+           Nothing   -> HsUnpack Nothing
+           Just redn -> HsUnpack (Just $ reductionCoercion redn)
 
   | otherwise -- Record the strict-but-no-unpack decision
-  = HsStrict
+  = HsStrict False
 
 -- | Wrappers/Workers and representation following Unpack/Strictness
 -- decisions
@@ -1054,7 +1056,7 @@ dataConArgRep
 dataConArgRep arg_ty HsLazy
   = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
 
-dataConArgRep arg_ty HsStrict
+dataConArgRep arg_ty (HsStrict _)
   = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))
 
 dataConArgRep arg_ty (HsUnpack Nothing)
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 416345e526..5dc3f4ef5f 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -377,7 +377,7 @@ test('T7147', normal, compile, [''])
 test('T7171',normal, makefile_test, [])
 test('T7173', normal, compile, [''])
 test('T7196', normal, compile, [''])
-test('T7050', normal, compile, ['-O'])
+test('T7050', normal, compile, [''])
 test('T7312', normal, compile, [''])
 test('T7384', normal, compile, [''])
 test('T7451', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 5224a58aa6..38d870d9b2 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -212,7 +212,7 @@ test('T3102', normal, compile, [''])
 test('T3613', normal, compile_fail, [''])
 test('fd-loop', normal, compile_fail, [''])
 test('T3950', normal, compile_fail, [''])
-test('T3966', normal, compile_fail, ['-O'])
+test('T3966', normal, compile_fail, [''])
 test('IPFail', normal, compile_fail, [''])
 
 test('T3468', [], multimod_compile_fail, ['T3468', '-v0'])
diff --git a/testsuite/tests/unboxedsums/all.T b/testsuite/tests/unboxedsums/all.T
index b7df22c6b3..2c9110d722 100644
--- a/testsuite/tests/unboxedsums/all.T
+++ b/testsuite/tests/unboxedsums/all.T
@@ -44,7 +44,7 @@ test('unpack_sums_1', normal, compile_and_run, ['-O'])
 test('unpack_sums_2', normal, compile, ['-O'])
 test('unpack_sums_3', normal, compile_and_run, ['-O'])
 test('unpack_sums_4', normal, compile_and_run, ['-O'])
-test('unpack_sums_5', normal, compile, ['-O'])
+test('unpack_sums_5', normal, compile, [''])
 test('unpack_sums_6', fragile(22504), compile_and_run, ['-O'])
 test('unpack_sums_7', normal, makefile_test, [])
 test('unpack_sums_8', normal, compile_and_run, [""])