[Git][ghc/ghc][wip/warn-unpack] Support "unusable UNPACK pragma" warning with -O0
Krzysztof Gogolewski (@monoidal)
gitlab at gitlab.haskell.org
Wed Jan 25 10:18:56 UTC 2023
Krzysztof Gogolewski pushed to branch wip/warn-unpack at Glasgow Haskell Compiler / GHC
Commits:
c1ea2666 by Krzysztof Gogolewski at 2023-01-25T11:18:46+01:00
Support "unusable UNPACK pragma" warning with -O0
Fixes #11270
- - - - -
10 changed files:
- compiler/GHC/Core/DataCon.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Tc/Deriv/Generics.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Types/Id/Make.hs
- testsuite/tests/typecheck/should_compile/all.T
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/unboxedsums/all.T
Changes:
=====================================
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)
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -422,7 +422,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
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1185,7 +1185,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)) }
=====================================
compiler/GHC/Tc/Deriv/Generics.hs
=====================================
@@ -686,7 +686,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)
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -2765,9 +2765,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
=====================================
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
=====================================
compiler/GHC/Types/Id/Make.hs
=====================================
@@ -1023,20 +1023,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
@@ -1049,7 +1051,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)
=====================================
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, [''])
=====================================
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'])
=====================================
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, [""])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c1ea2666ad4e51ee904be8069b0a566ec5c53b9d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c1ea2666ad4e51ee904be8069b0a566ec5c53b9d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230125/253598f2/attachment-0001.html>
More information about the ghc-commits
mailing list