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.

4 files changed, 67 insertions, 45 deletions

diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index 4b3316f632..88fb6cb0ff 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 798da08ec5..7890bce91f 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 4b44069950..59db2bd3ae 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 3992c993fd..657f33dd91 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