diff options
| -rw-r--r-- | compiler/GHC/IfaceToCore.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/Tc/TyCl.hs | 21 | ||||
| -rw-r--r-- | compiler/GHC/Tc/TyCl/Build.hs | 13 | ||||
| -rw-r--r-- | 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 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 |