From 7b0c938483bad5a5c96e02c511fb2b2df059154c Mon Sep 17 00:00:00 2001
From: Sylvain Henry <sylvain@haskus.fr>
Date: Mon, 10 Jan 2022 14:59:21 +0100
Subject: [PATCH] Abstract BangOpts
Avoid requiring to pass DynFlags to mkDataConRep/buildDataCon. When we
load an interface file, these functions don't use the flags.
This is preliminary work to decouple the loader from the type-checker
for #14335.
---
compiler/GHC/IfaceToCore.hs | 12 +++----
compiler/GHC/Tc/TyCl.hs | 21 ++++++-----
compiler/GHC/Tc/TyCl/Build.hs | 13 +++----
compiler/GHC/Types/Id/Make.hs | 66 +++++++++++++++++++++++------------
4 files changed, 67 insertions(+), 45 deletions(-)
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 4b3316f632a2..88fb6cb0ff78 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -1102,15 +1102,15 @@ tcIfaceDataCons tycon_name tycon tc_tybinders if_cons
; prom_rep_name <- newTyConRepName dc_name
+ ; let bang_opts = FixedBangOpts stricts
+ -- Pass the HsImplBangs (i.e. final decisions) to buildDataCon;
+ -- it'll use these to guide the construction of a worker.
+ -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make
+
; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))
+ bang_opts
dc_name is_infix prom_rep_name
(map src_strict if_src_stricts)
- (Just stricts)
- -- Pass the HsImplBangs (i.e. final
- -- decisions) to buildDataCon; it'll use
- -- these to guide the construction of a
- -- worker.
- -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make
lbl_names
univ_tvs ex_tvs user_tv_bndrs
eq_spec theta
diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs
index 798da08ec5ee..7890bce91fbe 100644
--- a/compiler/GHC/Tc/TyCl.hs
+++ b/compiler/GHC/Tc/TyCl.hs
@@ -72,6 +72,7 @@ import GHC.Core.Unify
import GHC.Types.Error
import GHC.Types.Id
+import GHC.Types.Id.Make
import GHC.Types.Var
import GHC.Types.Var.Env
import GHC.Types.Var.Set
@@ -3458,8 +3459,10 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map
; is_infix <- tcConIsInfixH98 name hs_args
; rep_nm <- newTyConRepName name
; fam_envs <- tcGetFamInstEnvs
- ; dc <- buildDataCon fam_envs name is_infix rep_nm
- stricts Nothing field_lbls
+ ; dflags <- getDynFlags
+ ; let bang_opts = SrcBangOpts (initBangOpts dflags)
+ ; dc <- buildDataCon fam_envs bang_opts name is_infix rep_nm
+ stricts field_lbls
tc_tvs ex_tvs user_tvbs
[{- no eq_preds -}] ctxt arg_tys
user_res_ty rep_tycon tag_map
@@ -3541,14 +3544,15 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map
-- Can't print univ_tvs, arg_tys etc, because we are inside the knot here
; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)
; fam_envs <- tcGetFamInstEnvs
+ ; dflags <- getDynFlags
; let
buildOneDataCon (L _ name) = do
{ is_infix <- tcConIsInfixGADT name hs_args
; rep_nm <- newTyConRepName name
- ; buildDataCon fam_envs name is_infix
- rep_nm
- stricts Nothing field_lbls
+ ; let bang_opts = SrcBangOpts (initBangOpts dflags)
+ ; buildDataCon fam_envs bang_opts name is_infix
+ rep_nm stricts field_lbls
univ_tvs ex_tvs tvbndrs' eq_preds
ctxt' arg_tys' res_ty' rep_tycon tag_map
-- NB: we put data_tc, the type constructor gotten from the
@@ -4412,7 +4416,7 @@ checkValidDataCon dflags existential_ok tc con
; let check_bang :: Type -> HsSrcBang -> HsImplBang -> Int -> TcM ()
check_bang orig_arg_ty bang rep_bang n
| HsSrcBang _ _ SrcLazy <- bang
- , not (xopt LangExt.StrictData dflags)
+ , not (bang_opt_strict_data bang_opts)
= addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $
(bad_bang n (text "Lazy annotation (~) without StrictData"))
@@ -4434,7 +4438,7 @@ checkValidDataCon dflags existential_ok tc con
-- 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 (gopt Opt_OmitInterfacePragmas dflags)
+ , not (bang_opt_unbox_disable bang_opts)
-- 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
@@ -4479,11 +4483,12 @@ checkValidDataCon dflags existential_ok tc con
Just (f, _) -> ppr (tyConBinders f) ]
}
where
+ bang_opts = initBangOpts dflags
con_name = dataConName con
con_loc = nameSrcSpan con_name
ctxt = ConArgCtxt con_name
is_strict = \case
- NoSrcStrict -> xopt LangExt.StrictData dflags
+ NoSrcStrict -> bang_opt_strict_data bang_opts
bang -> isSrcStrict bang
bad_bang n herald
diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs
index 4b4406995019..59db2bd3ae8e 100644
--- a/compiler/GHC/Tc/TyCl/Build.hs
+++ b/compiler/GHC/Tc/TyCl/Build.hs
@@ -36,7 +36,6 @@ import GHC.Tc.Utils.TcType
import GHC.Core.Multiplicity
import GHC.Types.SrcLoc( SrcSpan, noSrcSpan )
-import GHC.Driver.Session
import GHC.Tc.Utils.Monad
import GHC.Types.Unique.Supply
import GHC.Utils.Misc
@@ -137,12 +136,11 @@ There are other ways we could do the check (discussion on #19739):
------------------------------------------------------
buildDataCon :: FamInstEnvs
+ -> DataConBangOpts
-> Name
-> Bool -- Declared infix
-> TyConRepName
-> [HsSrcBang]
- -> Maybe [HsImplBang]
- -- See Note [Bangs on imported data constructors] in GHC.Types.Id.Make
-> [FieldLabel] -- Field labels
-> [TyVar] -- Universals
-> [TyCoVar] -- Existentials
@@ -160,7 +158,7 @@ buildDataCon :: FamInstEnvs
-- a) makes the worker Id
-- b) makes the wrapper Id if necessary, including
-- allocating its unique (hence monadic)
-buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs
+buildDataCon fam_envs dc_bang_opts src_name declared_infix prom_info src_bangs
field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty
rep_tycon tag_map
= do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
@@ -171,7 +169,6 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs
; traceIf (text "buildDataCon 1" <+> ppr src_name)
; us <- newUniqueSupply
- ; dflags <- getDynFlags
; let stupid_ctxt = mkDataConStupidTheta rep_tycon (map scaledThing arg_tys) univ_tvs
tag = lookupNameEnv_NF tag_map src_name
-- See Note [Constructor tag allocation], fixes #14657
@@ -181,8 +178,7 @@ buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs
arg_tys res_ty NoRRI rep_tycon tag
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
- dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
- impl_bangs data_con)
+ dc_rep = initUs_ us (mkDataConRep dc_bang_opts fam_envs wrap_name data_con)
; traceIf (text "buildDataCon 2" <+> ppr src_name)
; return data_con }
@@ -343,14 +339,15 @@ buildClass tycon_name binders roles fds
rec_tycon = classTyCon rec_clas
univ_bndrs = tyConInvisTVBinders binders
univ_tvs = binderVars univ_bndrs
+ bang_opts = FixedBangOpts (map (const HsLazy) args)
; rep_nm <- newTyConRepName datacon_name
; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
+ bang_opts
datacon_name
False -- Not declared infix
rep_nm
(map (const no_bang) args)
- (Just (map (const HsLazy) args))
[{- No fields -}]
univ_tvs
[{- no existentials -}]
diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs
index 3992c993fd79..657f33dd915e 100644
--- a/compiler/GHC/Types/Id/Make.hs
+++ b/compiler/GHC/Types/Id/Make.hs
@@ -24,6 +24,7 @@ module GHC.Types.Id.Make (
unwrapNewTypeBody, wrapFamInstBody,
DataConBoxer(..), vanillaDataConBoxer,
mkDataConRep, mkDataConWorkId,
+ DataConBangOpts (..), BangOpts (..), initBangOpts,
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
@@ -654,14 +655,35 @@ and now case-of-known-constructor eliminates the redundant allocation.
-}
-mkDataConRep :: DynFlags
+data DataConBangOpts
+ = FixedBangOpts [HsImplBang]
+ -- ^ Used for imported data constructors
+ -- See Note [Bangs on imported data constructors]
+ | SrcBangOpts !BangOpts
+
+data BangOpts = BangOpts
+ { bang_opt_strict_data :: !Bool -- ^ Strict fields by default
+ , bang_opt_unbox_disable :: !Bool -- ^ Disable automatic field unboxing (e.g. if we aren't optimising)
+ , bang_opt_unbox_strict :: !Bool -- ^ Unbox strict fields
+ , bang_opt_unbox_small :: !Bool -- ^ Unbox small strict fields
+ }
+
+initBangOpts :: DynFlags -> BangOpts
+initBangOpts dflags = BangOpts
+ { bang_opt_strict_data = xopt LangExt.StrictData dflags
+ , bang_opt_unbox_disable = gopt Opt_OmitInterfacePragmas dflags
+ -- Don't unbox if we aren't optimising; rather arbitrarily,
+ -- we use -fomit-iface-pragmas as the indication
+ , bang_opt_unbox_strict = gopt Opt_UnboxStrictFields dflags
+ , bang_opt_unbox_small = gopt Opt_UnboxSmallStrictFields dflags
+ }
+
+mkDataConRep :: DataConBangOpts
-> FamInstEnvs
-> Name
- -> Maybe [HsImplBang]
- -- See Note [Bangs on imported data constructors]
-> DataCon
-> UniqSM DataConRep
-mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
+mkDataConRep dc_bang_opts fam_envs wrap_name data_con
| not wrapper_reqd
= return NoDataConRep
@@ -748,10 +770,10 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
-- if a user declared a wrong newtype we
-- detect this later (see test T2334A)
| otherwise
- = case mb_bangs of
- Nothing -> zipWith (dataConSrcToImplBang dflags fam_envs)
- orig_arg_tys orig_bangs
- Just bangs -> bangs
+ = case dc_bang_opts of
+ SrcBangOpts bang_opts -> zipWith (dataConSrcToImplBang bang_opts fam_envs)
+ orig_arg_tys orig_bangs
+ FixedBangOpts bangs -> bangs
(rep_tys_w_strs, wrappers)
= unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs))
@@ -971,16 +993,16 @@ newLocal name_stem (Scaled w ty) =
-- never on the field of a newtype constructor.
-- See @Note [HsImplBangs for newtypes]@.
dataConSrcToImplBang
- :: DynFlags
+ :: BangOpts
-> FamInstEnvs
-> Scaled Type
-> HsSrcBang
-> HsImplBang
-dataConSrcToImplBang dflags fam_envs arg_ty
+dataConSrcToImplBang bang_opts fam_envs arg_ty
(HsSrcBang ann unpk NoSrcStrict)
- | xopt LangExt.StrictData dflags -- StrictData => strict field
- = dataConSrcToImplBang dflags fam_envs arg_ty
+ | bang_opt_strict_data bang_opts -- StrictData => strict field
+ = dataConSrcToImplBang bang_opts fam_envs arg_ty
(HsSrcBang ann unpk SrcStrict)
| otherwise -- no StrictData => lazy field
= HsLazy
@@ -988,26 +1010,24 @@ dataConSrcToImplBang dflags fam_envs arg_ty
dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)
= HsLazy
-dataConSrcToImplBang dflags fam_envs arg_ty
+dataConSrcToImplBang bang_opts fam_envs arg_ty
(HsSrcBang _ unpk_prag SrcStrict)
| isUnliftedType (scaledThing arg_ty)
= HsLazy -- For !Int#, say, use HsLazy
-- See Note [Data con wrappers and unlifted types]
- | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
- -- Don't unpack if we aren't optimising; rather arbitrarily,
- -- we use -fomit-iface-pragmas as the indication
+ | not (bang_opt_unbox_disable bang_opts) -- Don't unpack if disabled
, 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 }
- , isUnpackableType dflags fam_envs (scaledThing arg_ty')
+ , isUnpackableType bang_opts fam_envs (scaledThing arg_ty')
, (rep_tys, _) <- dataConArgUnpack arg_ty'
, case unpk_prag of
NoSrcUnpack ->
- gopt Opt_UnboxStrictFields dflags
- || (gopt Opt_UnboxSmallStrictFields dflags
+ bang_opt_unbox_strict bang_opts
+ || (bang_opt_unbox_small bang_opts
&& rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields]
srcUnpack -> isSrcUnpacked srcUnpack
= case mb_co of
@@ -1103,13 +1123,13 @@ dataConArgUnpack (Scaled arg_mult arg_ty)
= pprPanic "dataConArgUnpack" (ppr arg_ty)
-- An interface file specified Unpacked, but we couldn't unpack it
-isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool
+isUnpackableType :: BangOpts -> FamInstEnvs -> Type -> Bool
-- True if we can unpack the UNPACK the argument type
-- See Note [Recursive unboxing]
-- We look "deeply" inside rather than relying on the DataCons
-- we encounter on the way, because otherwise we might well
-- end up relying on ourselves!
-isUnpackableType dflags fam_envs ty
+isUnpackableType bang_opts fam_envs ty
| Just data_con <- unpackable_type ty
= ok_con_args emptyNameSet data_con
| otherwise
@@ -1139,13 +1159,13 @@ isUnpackableType dflags fam_envs ty
= True -- NB True here, in contrast to False at top level
attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)
- = xopt LangExt.StrictData dflags
+ = bang_opt_strict_data bang_opts
attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)
= True
attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict)
= True -- Be conservative
attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict)
- = xopt LangExt.StrictData dflags -- Be conservative
+ = bang_opt_strict_data bang_opts -- Be conservative
attempt_unpack _ = False
unpackable_type :: Type -> Maybe DataCon
--
GitLab