From 99bd4ae655984fe3a84a10edf023325cf8c1ea97 Mon Sep 17 00:00:00 2001 From: Sebastian Graf Date: Sat, 9 Jan 2021 22:22:51 +0100 Subject: Factor out DynFlags from WorkWrap.Utils Plus a few minor refactorings: * Introduce `normSplitTyConApp_maybe` to Core.Utils * Reduce boolean blindness in the Bool argument to `wantToUnbox` * Let `wantToUnbox` also decide when to drop an argument, cleaning up `mkWWstr_one` --- compiler/GHC/Core/Opt/CprAnal.hs | 7 +- compiler/GHC/Core/Opt/DmdAnal.hs | 7 +- compiler/GHC/Core/Opt/SpecConstr.hs | 5 +- compiler/GHC/Core/Opt/WorkWrap.hs | 5 +- compiler/GHC/Core/Opt/WorkWrap/Utils.hs | 222 ++++++++++++++++++-------------- compiler/GHC/Core/Utils.hs | 14 +- 6 files changed, 148 insertions(+), 112 deletions(-) diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index cd4c310b3a..ddafa72b33 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -483,7 +483,7 @@ argCprType env arg_ty dmd = CprType 0 (go arg_ty dmd) where go ty dmd | Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args }) ds - <- wantToUnbox (ae_fam_envs env) no_inlineable_prag ty dmd + <- wantToUnbox (ae_fam_envs env) MaybeArgOfInlineableFun ty dmd -- No existentials; see Note [Which types are unboxed?]) -- Otherwise we'd need to call dataConRepInstPat here and thread a -- UniqSupply. So argCprType is a bit less aggressive than it could @@ -493,11 +493,6 @@ argCprType env arg_ty dmd = CprType 0 (go arg_ty dmd) = ConCpr (dataConTag dc) (zipWith go arg_tys ds) | otherwise = topCpr - -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE - -- function, we just assume that we aren't. That flag is only relevant - -- to Note [Do not unpack class dictionaries], the few unboxing - -- opportunities on dicts it prohibits are probably irrelevant to CPR. - no_inlineable_prag = False {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index b317fa5ff5..11270ae8a8 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -537,10 +537,9 @@ forcesRealWorld :: FamInstEnvs -> Type -> Bool forcesRealWorld fam_envs ty | ty `eqType` realWorldStatePrimTy = True - | Just DataConPatContext{ dcpc_dc = dc, dcpc_tc_args = tc_args } - <- splitArgType_maybe fam_envs ty - , isUnboxedTupleDataCon dc - , let field_tys = dataConInstArgTys dc tc_args + | Just (tc, tc_args, _co) <- normSplitTyConApp_maybe fam_envs ty + , isUnboxedTupleTyCon tc + , let field_tys = dataConInstArgTys (tyConSingleDataCon tc) tc_args = any (eqType realWorldStatePrimTy . scaledThing) field_tys | otherwise = False diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index f21d0205f5..c5e89b2ba9 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -1720,7 +1720,7 @@ spec_one env fn arg_bndrs body (call_pat, rule_number) -- And build the results ; let spec_body_ty = exprType spec_body spec_lam_args1 = qvars ++ extra_bndrs - (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env) + (spec_lam_args, spec_call_args) = mkWorkerArgs False spec_lam_args1 spec_body_ty -- mkWorkerArgs: usual w/w hack to avoid generating -- a spec_rhs of unlifted type and no args @@ -2031,8 +2031,9 @@ callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls -- Remove ones that have too many worker variables small_pats = filterOut too_big non_dups + max_args = maxWorkerArgs (sc_dflags env) too_big (CP { cp_qvars = vars, cp_args = args }) - = not (isWorkerSmallEnough (sc_dflags env) (valArgCount args) vars) + = not (isWorkerSmallEnough max_args (valArgCount args) vars) -- We are about to construct w/w pair in 'spec_one'. -- Omit specialisation leading to high arity workers. -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index 2ee334b9f8..a85ff4d04e 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -611,7 +611,7 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs | otherwise = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) ) -- The arity should match the signature - do { mb_stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr_info + do { mb_stuff <- mkWwBodies (initWwOpts dflags fam_envs) rhs_fvs fn_id wrap_dmds use_cpr_info ; case mb_stuff of Nothing -> return [(fn_id, rhs)] @@ -870,7 +870,8 @@ splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [( splitThunk dflags fam_envs is_rec x rhs = ASSERT(not (isJoinId x)) do { let x' = localiseId x -- See comment above - ; (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [x'] + ; (useful,_, wrap_fn, work_fn) + <- mkWWstr (initWwOpts dflags fam_envs) NotArgOfInlineableFun [x'] ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn (work_fn (Var x')))) ] ; if useful then ASSERT2( isNonRec is_rec, ppr x ) -- The thunk must be non-recursive return res diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs index f51e716c38..b257e6d27a 100644 --- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs +++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs @@ -7,8 +7,9 @@ A library for the ``worker\/wrapper'' back-end to the strictness analyser {-# LANGUAGE CPP #-} module GHC.Core.Opt.WorkWrap.Utils - ( mkWwBodies, mkWWstr, mkWorkerArgs - , DataConPatContext(..), UnboxingDecision(..), splitArgType_maybe, wantToUnbox + ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWorkerArgs + , DataConPatContext(..), splitArgType_maybe + , UnboxingDecision(..), ArgOfInlineableFun(..), wantToUnbox , findTypeShape , isWorkerSmallEnough ) @@ -20,7 +21,8 @@ import GHC.Prelude import GHC.Core import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase - , bindNonRec, dataConRepFSInstPat ) + , bindNonRec, dataConRepFSInstPat + , normSplitTyConApp_maybe ) import GHC.Types.Id import GHC.Types.Id.Info ( JoinArity ) import GHC.Core.DataCon @@ -45,7 +47,6 @@ import GHC.Core.TyCon.RecWalk import GHC.Types.Unique.Supply import GHC.Types.Unique import GHC.Types.Name ( getOccFS ) -import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -123,14 +124,31 @@ the unusable strictness-info into the interfaces. @mkWwBodies@ is called when doing the worker\/wrapper split inside a module. -} +data WwOpts + = MkWwOpts + { wo_fam_envs :: !FamInstEnvs + , wo_cpr_anal :: !Bool + , wo_fun_to_thunk :: !Bool + , wo_max_worker_args :: !Int + , wo_output_file :: Maybe String + } + +initWwOpts :: DynFlags -> FamInstEnvs -> WwOpts +initWwOpts dflags fam_envs = MkWwOpts + { wo_fam_envs = fam_envs + , wo_cpr_anal = gopt Opt_CprAnal dflags + , wo_fun_to_thunk = gopt Opt_FunToThunk dflags + , wo_max_worker_args = maxWorkerArgs dflags + , wo_output_file = outputFile dflags + } + type WwResult = ([Demand], -- Demands for worker (value) args JoinArity, -- Number of worker (type OR value) args Id -> CoreExpr, -- Wrapper body, lacking only the worker Id CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs -mkWwBodies :: DynFlags - -> FamInstEnvs +mkWwBodies :: WwOpts -> VarSet -- Free vars of RHS -- See Note [Freshen WW arguments] -> Id -- The original function @@ -149,25 +167,25 @@ mkWwBodies :: DynFlags -- let x = (a,b) in -- E -mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info +mkWwBodies opts rhs_fvs fun_id demands cpr_info = do { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs) -- See Note [Freshen WW arguments] ; (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs empty_subst fun_ty demands ; (useful1, work_args, wrap_fn_str, work_fn_str) - <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args + <- mkWWstr opts inlineable_flag wrap_args -- Do CPR w/w. See Note [Always do CPR w/w] ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty) - <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty cpr_info + <- mkWWcpr opts res_ty cpr_info - ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty + ; let (work_lam_args, work_call_args) = mkWorkerArgs (wo_fun_to_thunk opts) work_args cpr_res_ty worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v] wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args - ; if isWorkerSmallEnough dflags (length demands) work_args + ; if isWorkerSmallEnough (wo_max_worker_args opts) (length demands) work_args && not (too_many_args_for_join_point wrap_args) && ((useful1 && not only_one_void_argument) || useful2) then return (Just (worker_args_dmds, length work_call_args, @@ -184,8 +202,9 @@ mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info where fun_ty = idType fun_id mb_join_arity = isJoinId_maybe fun_id - has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id) - -- See Note [Do not unpack class dictionaries] + inlineable_flag -- See Note [Do not unpack class dictionaries] + | isStableUnfolding (realIdUnfolding fun_id) = MaybeArgOfInlineableFun + | otherwise = NotArgOfInlineableFun -- Note [Do not split void functions] only_one_void_argument @@ -208,9 +227,9 @@ mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info = False -- See Note [Limit w/w arity] -isWorkerSmallEnough :: DynFlags -> Int -> [Var] -> Bool -isWorkerSmallEnough dflags old_n_args vars - = count isId vars <= max old_n_args (maxWorkerArgs dflags) +isWorkerSmallEnough :: Int -> Int -> [Var] -> Bool +isWorkerSmallEnough max_worker_args old_n_args vars + = count isId vars <= max old_n_args max_worker_args -- We count only Free variables (isId) to skip Type, Kind -- variables which have no runtime representation. -- Also if the function took 82 arguments before (old_n_args), it's fine if @@ -274,11 +293,12 @@ add a void argument. E.g. We use the state-token type which generates no code. -} -mkWorkerArgs :: DynFlags -> [Var] +mkWorkerArgs :: Bool + -> [Var] -> Type -- Type of body -> ([Var], -- Lambda bound args [Var]) -- Args at call site -mkWorkerArgs dflags args res_ty +mkWorkerArgs fun_to_thunk args res_ty | any isId args || not needsAValueLambda = (args, args) | otherwise @@ -290,7 +310,7 @@ mkWorkerArgs dflags args res_ty -- We may encounter a levity-polymorphic result, in which case we -- conservatively assume that we have laziness that needs preservation. -- See #15186. - || not (gopt Opt_FunToThunk dflags) + || not fun_to_thunk -- see Note [Protecting the last value argument] -- Might the result be lifted? @@ -546,9 +566,7 @@ data DataConPatContext -- See Note [Which types are unboxed?]. splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext splitArgType_maybe fam_envs ty - | let (co, ty1) = topNormaliseType_maybe fam_envs ty - `orElse` (mkRepReflCo ty, ty) - , Just (tc, tc_args) <- splitTyConApp_maybe ty1 + | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty , Just con <- tyConSingleAlgDataCon_maybe tc = Just DataConPatContext { dcpc_dc = con , dcpc_tc_args = tc_args @@ -564,9 +582,7 @@ splitArgType_maybe _ _ = Nothing -- See Note [Which types are unboxed?]. splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext splitResultType_maybe fam_envs con_tag ty - | let (co, ty1) = topNormaliseType_maybe fam_envs ty - `orElse` (mkRepReflCo ty, ty) - , Just (tc, tc_args) <- splitTyConApp_maybe ty1 + | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty , isDataTyCon tc -- NB: rules out unboxed sums and pairs! , let cons = tyConDataCons tc , cons `lengthAtLeast` con_tag -- This might not be true if we import the @@ -596,6 +612,8 @@ isLinear (Scaled w _ ) = data UnboxingDecision s = StopUnboxing -- ^ We ran out of strictness info. Leave untouched. + | DropAbsent + -- ^ The argument/field was absent. Drop it. | Unbox !DataConPatContext [s] -- ^ The argument is used strictly or the returned product was constructed, so -- unbox it. @@ -604,23 +622,36 @@ data UnboxingDecision s -- The @[s]@ carries the bits of information with which we can continue -- unboxing, e.g. @s@ will be 'Demand'. -wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand +-- | A specialised Bool for an argument to 'wantToUnbox'. +-- See Note [Do not unpack class dictionaries]. +data ArgOfInlineableFun + = NotArgOfInlineableFun -- ^ Definitely not in an inlineable fun. + | MaybeArgOfInlineableFun -- ^ We might be in an inlineable fun, so we won't + -- unbox dictionary args. + deriving Eq + +wantToUnbox :: FamInstEnvs -> ArgOfInlineableFun -> Type -> Demand -> UnboxingDecision Demand -- See Note [Which types are unboxed?] -wantToUnbox fam_envs has_inlineable_prag ty dmd = - case splitArgType_maybe fam_envs ty of - Just dcpc@DataConPatContext{ dcpc_dc = dc } - | isStrUsedDmd dmd - , let arity = dataConRepArity dc - -- See Note [Unpacking arguments with product and polymorphic demands] - , Just cs <- split_prod_dmd_arity dmd arity - -- See Note [Do not unpack class dictionaries] - , not (has_inlineable_prag && isClassPred ty) - -- See Note [mkWWstr and unsafeCoerce] - , cs `lengthIs` arity - -- See Note [Add demands for strict constructors] - , let cs' = addDataConStrictness dc cs - -> Unbox dcpc cs' - _ -> StopUnboxing +wantToUnbox fam_envs inlineable_flag ty dmd + | isAbsDmd dmd + = DropAbsent + + | isStrUsedDmd dmd + , Just dcpc@DataConPatContext{ dcpc_dc = dc } <- splitArgType_maybe fam_envs ty + , let arity = dataConRepArity dc + -- See Note [Unpacking arguments with product and polymorphic demands] + , Just cs <- split_prod_dmd_arity dmd arity + -- See Note [Do not unpack class dictionaries] + , inlineable_flag == NotArgOfInlineableFun || not (isClassPred ty) + -- See Note [mkWWstr and unsafeCoerce] + , cs `lengthIs` arity + -- See Note [Add demands for strict constructors] + , let cs' = addDataConStrictness dc cs + = Unbox dcpc cs' + + | otherwise + = StopUnboxing + where split_prod_dmd_arity dmd arity -- For seqDmd, it should behave like , for some @@ -850,25 +881,23 @@ the case on `x` up through the case on `burble`. ************************************************************************ -} -mkWWstr :: DynFlags - -> FamInstEnvs - -> Bool -- True <=> INLINEABLE pragma on this function defn - -- See Note [Do not unpack class dictionaries] - -> [Var] -- Wrapper args; have their demand info on them - -- *Includes type variables* - -> UniqSM (Bool, -- Is this useful - [Var], -- Worker args - CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call - -- and without its lambdas - -- This fn adds the unboxing - - CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function, - -- and lacking its lambdas. - -- This fn does the reboxing -mkWWstr dflags fam_envs has_inlineable_prag args +mkWWstr :: WwOpts + -> ArgOfInlineableFun -- See Note [Do not unpack class dictionaries] + -> [Var] -- Wrapper args; have their demand info on them + -- *Includes type variables* + -> UniqSM (Bool, -- Is this useful + [Var], -- Worker args + CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call + -- and without its lambdas + -- This fn adds the unboxing + + CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function, + -- and lacking its lambdas. + -- This fn does the reboxing +mkWWstr opts inlineable_flag args = go args where - go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg + go_one arg = mkWWstr_one opts inlineable_flag arg go [] = return (False, [], nop_fn, nop_fn) go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg @@ -885,37 +914,37 @@ mkWWstr dflags fam_envs has_inlineable_prag args -- * work_fn assumes work_args are in scope, a -- brings into scope wrap_arg (via lets) -- See Note [How to do the worker/wrapper split] -mkWWstr_one :: DynFlags -> FamInstEnvs - -> Bool -- True <=> INLINEABLE pragma on this function defn - -- See Note [Do not unpack class dictionaries] +mkWWstr_one :: WwOpts + -> ArgOfInlineableFun -- See Note [Do not unpack class dictionaries] -> Var -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) -mkWWstr_one dflags fam_envs has_inlineable_prag arg - | isTyVar arg - = return (False, [arg], nop_fn, nop_fn) +mkWWstr_one opts inlineable_flag arg = + case wantToUnbox fam_envs inlineable_flag arg_ty arg_dmd of + _ | isTyVar arg -> do_nothing - | isAbsDmd dmd - , Just work_fn <- mk_absent_let dflags arg dmd - -- Absent case. We can't always handle absence for rep-polymorphic - -- types, so we need to choose just the cases we can - -- (that's what mk_absent_let does) - = return (True, [], nop_fn, work_fn) + DropAbsent + | Just work_fn <- mk_absent_let opts arg + -- Absent case. We can't always handle absence for arbitrary + -- unlifted types, so we need to choose just the cases we can + -- (that's what mk_absent_let does) + -> return (True, [], nop_fn, work_fn) - | Unbox dcpc cs <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd - = unbox_one dflags fam_envs arg cs dcpc + Unbox dcpc cs -> unbox_one opts arg cs dcpc - | otherwise -- Other cases - = return (False, [arg], nop_fn, nop_fn) + _ -> do_nothing -- Other cases, like StopUnboxing where - arg_ty = idType arg - dmd = idDemandInfo arg + fam_envs = wo_fam_envs opts + arg_ty = idType arg + arg_dmd = idDemandInfo arg + do_nothing = return (False, [arg], nop_fn, nop_fn) -unbox_one :: DynFlags -> FamInstEnvs -> Var +unbox_one :: WwOpts + -> Var -> [Demand] -> DataConPatContext -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) -unbox_one dflags fam_envs arg cs +unbox_one opts arg cs DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args , dcpc_co = co } = do { (case_bndr_uniq:pat_bndrs_uniqs) <- getUniquesM @@ -930,7 +959,7 @@ unbox_one dflags fam_envs arg cs -- in GHC.Core.Opt.Simplify; and see #13890 rebox_fn = Let (NonRec arg_no_unf con_app) con_app = mkConApp2 dc tc_args (ex_tvs' ++ arg_ids') `mkCast` mkSymCo co - ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False (ex_tvs' ++ arg_ids') + ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr opts NotArgOfInlineableFun (ex_tvs' ++ arg_ids') ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) } -- Don't pass the arg, rebox instead @@ -1142,8 +1171,7 @@ The non-CPR results appear ordered in the unboxed tuple as if by a left-to-right traversal of the result structure. -} -mkWWcpr :: Bool - -> FamInstEnvs +mkWWcpr :: WwOpts -> Type -- function body type -> Cpr -- CPR analysis results -> UniqSM (Bool, -- Is w/w'ing useful? @@ -1151,15 +1179,15 @@ mkWWcpr :: Bool CoreExpr -> CoreExpr, -- New worker Type) -- Type of worker's body -mkWWcpr opt_CprAnal fam_envs body_ty cpr +mkWWcpr opts body_ty cpr -- CPR explicitly turned off (or in -O0) - | not opt_CprAnal = return (False, id, id, body_ty) + | not (wo_cpr_anal opts) = return (False, id, id, body_ty) -- CPR is turned on by default for -O and O2 | otherwise = case asConCpr cpr of Nothing -> return (False, id, id, body_ty) -- No CPR info Just (con_tag, _cprs) - | Just dcpc <- splitResultType_maybe fam_envs con_tag body_ty + | Just dcpc <- splitResultType_maybe (wo_fam_envs opts) con_tag body_ty -> mkWWcpr_help dcpc | otherwise -- See Note [non-algebraic or open body type warning] @@ -1373,12 +1401,12 @@ fragile -- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding -- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be -- found. -mk_absent_let :: DynFlags -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr) -mk_absent_let dflags arg dmd +mk_absent_let :: WwOpts -> Id -> Maybe (CoreExpr -> CoreExpr) +mk_absent_let opts arg -- The lifted case: Bind 'absentError' for a nice panic message if we are -- wrong (like we were in #11126). See (1) in Note [Absent fillers] | Just [LiftedRep] <- mb_mono_prim_reps - , not (isStrictDmd dmd) -- See (2) in Note [Absent fillers] + , not (isStrictDmd (idDemandInfo arg)) -- See (2) in Note [Absent fillers] = Just (Let (NonRec arg panic_rhs)) -- The default case for mono rep: Bind @RUBBISH[prim_reps] \@arg_ty@ @@ -1392,26 +1420,26 @@ mk_absent_let dflags arg dmd = WARN( True, text "No absent value for" <+> ppr arg_ty ) Nothing where - arg_ty = idType arg + arg_ty = idType arg mb_mono_prim_reps = typeMonoPrimRep_maybe arg_ty panic_rhs = mkAbsentErrorApp arg_ty msg - msg = showSDoc (gopt_set dflags Opt_SuppressUniques) - (vcat - [ text "Arg:" <+> ppr arg - , text "Type:" <+> ppr arg_ty - , file_msg - ]) + msg = renderWithContext + (defaultSDocContext { sdocSuppressUniques = True }) + (vcat + [ text "Arg:" <+> ppr arg + , text "Type:" <+> ppr arg_ty + , file_msg ]) -- We need to suppress uniques here because otherwise they'd -- end up in the generated code as strings. This is bad for -- determinism, because with different uniques the strings -- will have different lengths and hence different costs for -- the inliner leading to different inlining. -- See also Note [Unique Determinism] in GHC.Types.Unique - file_msg = case outputFile dflags of - Nothing -> empty - Just f -> text "In output file " <+> quotes (text f) + file_msg = case wo_output_file opts of + Nothing -> empty + Just f -> text "In output file " <+> quotes (text f) ww_prefix :: FastString ww_prefix = fsLit "ww" diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 6b779ef1aa..7d7e5342b9 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -47,7 +47,7 @@ module GHC.Core.Utils ( exprToType, exprToCoercion_maybe, applyTypeToArgs, applyTypeToArg, dataConRepInstPat, dataConRepFSInstPat, - isEmptyTy, + isEmptyTy, normSplitTyConApp_maybe, -- * Working with ticks stripTicksTop, stripTicksTopE, stripTicksTopT, @@ -89,6 +89,7 @@ import GHC.Builtin.PrimOps import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.Type as Type +import GHC.Core.FamInstEnv import GHC.Core.Predicate import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder ) import GHC.Core.Coercion @@ -2596,6 +2597,17 @@ isEmptyTy ty | otherwise = False +-- | If @normSplitTyConApp_maybe _ ty = Just (tc, tys, co)@ +-- then @ty |> co = tc tys@. It's 'splitArgType_maybe', but looks through +-- coercions via 'topNormaliseType_maybe'. Hence the \"norm\" prefix. +normSplitTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion) +normSplitTyConApp_maybe fam_envs ty + | let (co, ty1) = topNormaliseType_maybe fam_envs ty + `orElse` (mkRepReflCo ty, ty) + , Just (tc, tc_args) <- splitTyConApp_maybe ty1 + = Just (tc, tc_args, co) +normSplitTyConApp_maybe _ _ = Nothing + {- ***************************************************** * -- cgit v1.2.1