From bbc5191640761ca9773abc898c077363b7beb4e7 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Fri, 24 Jul 2020 17:41:08 +0100 Subject: Kill off sc_mult and as_mult fields They are readily derivable from other fields, so this is more efficient, and less error prone. Fixes #18494 --- compiler/GHC/Core/Opt/Simplify.hs | 71 +++++++++++---------------------- compiler/GHC/Core/Opt/Simplify/Utils.hs | 38 +++++++++--------- 2 files changed, 42 insertions(+), 67 deletions(-) diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index e7fc0fbced..aaf4e346b9 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -1004,7 +1004,7 @@ simplExprF1 env (App fun arg) cont , sc_hole_ty = hole' , sc_cont = cont } } _ -> - -- crucially, these are /lazy/ bindings. They will + -- Crucially, sc_hole_ty is a /lazy/ binding. It will -- be forced only if we need to run contHoleType. -- When these are forced, we might get quadratic behavior; -- this quadratic blowup could be avoided by drilling down @@ -1012,17 +1012,10 @@ simplExprF1 env (App fun arg) cont -- (instead of one-at-a-time). But in practice, we have not -- observed the quadratic behavior, so this extra entanglement -- seems not worthwhile. - -- - -- But the (exprType fun) is repeated, to push it into two - -- separate, rarely used, thunks; rather than always alloating - -- a shared thunk. Makes a small efficiency difference - let fun_ty = exprType fun - (m, _, _) = splitFunTy fun_ty - in simplExprF env fun $ ApplyToVal { sc_arg = arg, sc_env = env , sc_hole_ty = substTy env (exprType fun) - , sc_dup = NoDup, sc_cont = cont, sc_mult = m } + , sc_dup = NoDup, sc_cont = cont } simplExprF1 env expr@(Lam {}) cont = {-#SCC "simplExprF1-Lam" #-} @@ -1327,8 +1320,8 @@ rebuild env expr cont Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont } -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont - StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty, sc_mult = m } - -> rebuildCall env (addValArgTo fun (m, expr) fun_ty ) cont + StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty } + -> rebuildCall env (addValArgTo fun expr fun_ty ) cont StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body , sc_env = se, sc_cont = cont } -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr @@ -1420,7 +1413,7 @@ simplCast env body co0 cont0 -- co1 :: t1 ~ s1 -- co2 :: s2 ~ t2 addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se - , sc_dup = dup, sc_cont = tail, sc_mult = m }) + , sc_dup = dup, sc_cont = tail }) | Just (co1, m_co2) <- pushCoValArg co , let new_ty = coercionRKind co1 , not (isTypeLevPoly new_ty) -- Without this check, we get a lev-poly arg @@ -1444,8 +1437,7 @@ simplCast env body co0 cont0 , sc_env = arg_se' , sc_dup = dup' , sc_cont = tail' - , sc_hole_ty = coercionLKind co - , sc_mult = m }) } } + , sc_hole_ty = coercionLKind co }) } } addCoerce co cont | isReflexiveCo co = return cont -- Having this at the end makes a huge @@ -1981,17 +1973,18 @@ rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_c -- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o -- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ]) rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args }) - (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont, sc_mult = m }) + (ApplyToVal { sc_arg = arg, sc_env = arg_se + , sc_cont = cont, sc_hole_ty = fun_ty }) | fun_id `hasKey` runRWKey , not (contIsStop cont) -- Don't fiddle around if the continuation is boring , [ TyArg {}, TyArg {} ] <- rev_args = do { s <- newId (fsLit "s") Many realWorldStatePrimTy - ; let env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s] + ; let (m,_,_) = splitFunTy fun_ty + env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s] ty' = contResultType cont cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s , sc_env = env', sc_cont = cont - , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' - , sc_mult = m } + , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' } -- cont' applies to s, then K ; body' <- simplExprC env' arg cont' ; let arg' = Lam s body' @@ -2002,10 +1995,10 @@ rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args }) rebuildCall env fun_info (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_dup = dup_flag, sc_hole_ty = fun_ty - , sc_cont = cont, sc_mult = m }) + , sc_cont = cont }) -- Argument is already simplified | isSimplified dup_flag -- See Note [Avoid redundant simplification] - = rebuildCall env (addValArgTo fun_info (m, arg) fun_ty) cont + = rebuildCall env (addValArgTo fun_info arg fun_ty) cont -- Strict arguments | isStrictArgInfo fun_info @@ -2014,7 +2007,7 @@ rebuildCall env fun_info simplExprF (arg_se `setInScopeFromE` env) arg (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty , sc_dup = Simplified - , sc_cont = cont, sc_mult = m }) + , sc_cont = cont }) -- Note [Shadowing] -- Lazy arguments @@ -2025,7 +2018,7 @@ rebuildCall env fun_info -- floating a demanded let. = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg (mkLazyArgStop arg_ty (lazyArgContext fun_info)) - ; rebuildCall env (addValArgTo fun_info (m, arg') fun_ty) cont } + ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont } where arg_ty = funArgTy fun_ty @@ -2233,24 +2226,10 @@ trySeqRules in_env scrut rhs cont , as_hole_ty = res2_ty } , ValArg { as_arg = no_cast_scrut , as_dmd = seqDmd - , as_hole_ty = res3_ty - , as_mult = Many } ] - -- The multiplicity of the scrutiny above is Many because the type - -- of seq requires that its first argument is unrestricted. The - -- typing rule of case also guarantees it though. In a more - -- general world, where the first argument of seq would have - -- affine multiplicity, then we could use the multiplicity of - -- the case (held in the case binder) instead. + , as_hole_ty = res3_ty } ] rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs , sc_env = in_env, sc_cont = cont - , sc_hole_ty = res4_ty, sc_mult = Many } - -- The multiplicity in sc_mult above is the - -- multiplicity of the second argument of seq. Since - -- seq's type, as it stands, imposes that its second - -- argument be unrestricted, so is - -- sc_mult. However, a more precise typing rule, - -- for seq, would be to have it be linear. In which - -- case, sc_mult should be 1. + , sc_hole_ty = res4_ty } -- Lazily evaluated, so we don't do most of this @@ -3304,7 +3283,7 @@ mkDupableContWithDmds env _ mkDupableContWithDmds env _ (StrictArg { sc_fun = fun, sc_cont = cont - , sc_fun_ty = fun_ty, sc_mult = m }) + , sc_fun_ty = fun_ty }) -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable | thumbsUpPlanA cont = -- Use Plan A of Note [Duplicating StrictArg] @@ -3318,18 +3297,17 @@ mkDupableContWithDmds env _ , StrictArg { sc_fun = fun { ai_args = args' } , sc_cont = cont' , sc_fun_ty = fun_ty - , sc_mult = m , sc_dup = OkToDup} ) } | otherwise = -- Use Plan B of Note [Duplicating StrictArg] -- K[ f a b <> ] --> join j x = K[ f a b x ] -- j <> - do { let arg_ty = funArgTy fun_ty - rhs_ty = contResultType cont - ; arg_bndr <- newId (fsLit "arg") m arg_ty -- ToDo: check this linearity argument + do { let rhs_ty = contResultType cont + (m,arg_ty,_) = splitFunTy fun_ty + ; arg_bndr <- newId (fsLit "arg") m arg_ty ; let env' = env `addNewInScopeIds` [arg_bndr] - ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (m, Var arg_bndr) fun_ty) cont + ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty } where thumbsUpPlanA (StrictArg {}) = False @@ -3349,7 +3327,7 @@ mkDupableContWithDmds env dmds mkDupableContWithDmds env dmds (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se - , sc_cont = cont, sc_hole_ty = hole_ty, sc_mult = mult }) + , sc_cont = cont, sc_hole_ty = hole_ty }) = -- e.g. [...hole...] (...arg...) -- ==> -- let a = ...arg... @@ -3369,7 +3347,7 @@ mkDupableContWithDmds env dmds -- has turned arg'' into a fresh variable -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils , sc_dup = OkToDup, sc_cont = cont' - , sc_hole_ty = hole_ty, sc_mult = mult }) } + , sc_hole_ty = hole_ty }) } mkDupableContWithDmds env _ (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) @@ -3439,7 +3417,6 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty , sc_fun = arg_info , sc_fun_ty = idType join_bndr , sc_cont = mkBoringStop res_ty - , sc_mult = Many -- ToDo: check this! } ) } mkDupableAlt :: Platform -> OutId diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 0d3a577938..210fd73701 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -125,8 +125,7 @@ data SimplCont -- See Note [The hole type in ApplyToTy/Val] , sc_arg :: InExpr -- The argument, , sc_env :: StaticEnv -- see Note [StaticEnv invariant] - , sc_cont :: SimplCont - , sc_mult :: Mult } + , sc_cont :: SimplCont } | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ] { sc_arg_ty :: OutType -- Argument type @@ -160,8 +159,7 @@ data SimplCont , sc_fun_ty :: OutType -- Type of the function (f e1 .. en), -- presumably (arg_ty -> res_ty) -- where res_ty is expected by sc_cont - , sc_cont :: SimplCont - , sc_mult :: Mult } + , sc_cont :: SimplCont } | TickIt -- (TickIt t K)[e] = K[ tick t e ] (Tickish Id) -- Tick tickish @@ -282,8 +280,7 @@ data ArgInfo } data ArgSpec - = ValArg { as_mult :: Mult - , as_dmd :: Demand -- Demand placed on this argument + = ValArg { as_dmd :: Demand -- Demand placed on this argument , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal , as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2) @@ -300,16 +297,15 @@ instance Outputable ArgInfo where , text "args =" <+> ppr args ]) instance Outputable ArgSpec where - ppr (ValArg { as_mult = mult, as_arg = arg }) = text "ValArg" <+> ppr mult <+> ppr arg + ppr (ValArg { as_arg = arg }) = text "ValArg" <+> ppr arg ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty ppr (CastBy c) = text "CastBy" <+> ppr c -addValArgTo :: ArgInfo -> (Mult, OutExpr) -> OutType -> ArgInfo -addValArgTo ai (w, arg) hole_ty +addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo +addValArgTo ai arg hole_ty | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs, ai_rules = rules } <- ai -- Pop the top demand and and discounts off - , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty - , as_mult = w, as_dmd = dmd } + , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd } = ai { ai_args = arg_spec : ai_args ai , ai_dmds = dmds , ai_discs = discs @@ -345,9 +341,9 @@ pushSimplifiedArgs env (arg : args) k = case arg of TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty } -> ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest } - ValArg { as_arg = arg, as_hole_ty = hole_ty, as_mult = w } + ValArg { as_arg = arg, as_hole_ty = hole_ty } -> ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified - , sc_hole_ty = hole_ty, sc_cont = rest, sc_mult = w } + , sc_hole_ty = hole_ty, sc_cont = rest } CastBy c -> CastIt c rest where rest = pushSimplifiedArgs env args k @@ -446,7 +442,7 @@ contHoleType (TickIt _ k) = contHoleType k contHoleType (CastIt co _) = coercionLKind co contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se }) = perhapsSubstTy dup se (idType b) -contHoleType (StrictArg { sc_fun_ty = ty, sc_mult = _m }) = funArgTy ty +contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy] contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy/Val] contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) @@ -464,12 +460,14 @@ contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se }) contHoleScaling :: SimplCont -> Mult contHoleScaling (Stop _ _) = One contHoleScaling (CastIt _ k) = contHoleScaling k -contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) = - (idMult id) `mkMultMul` contHoleScaling k -contHoleScaling (StrictArg { sc_mult = w, sc_cont = k }) = - w `mkMultMul` contHoleScaling k -contHoleScaling (Select { sc_bndr = id, sc_cont = k }) = - (idMult id) `mkMultMul` contHoleScaling k +contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k }) + = idMult id `mkMultMul` contHoleScaling k +contHoleScaling (Select { sc_bndr = id, sc_cont = k }) + = idMult id `mkMultMul` contHoleScaling k +contHoleScaling (StrictArg { sc_fun_ty = fun_ty, sc_cont = k }) + = w `mkMultMul` contHoleScaling k + where + (w, _, _) = splitFunTy fun_ty contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k contHoleScaling (TickIt _ k) = contHoleScaling k -- cgit v1.2.1