diff options
Diffstat (limited to 'compiler/GHC/Core/Opt')
| -rw-r--r-- | compiler/GHC/Core/Opt/OccurAnal.hs | 12 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/SetLevels.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 32 |
3 files changed, 48 insertions, 6 deletions
diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index c4f714eef1..1312b33387 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -39,6 +39,7 @@ import GHC.Types.Demand ( argOneShots, argsOneShots ) import GHC.Data.Graph.Directed ( SCC(..), Node(..) , stronglyConnCompFromEdgedVerticesUniq , stronglyConnCompFromEdgedVerticesUniqR ) +import GHC.Builtin.Names( runRWKey ) import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set @@ -1882,8 +1883,15 @@ occAnalApp :: OccEnv -> (UsageDetails, Expr CoreBndr) -- Naked variables (not applied) end up here too occAnalApp env (Var fun, args, ticks) - | null ticks = (all_uds, mkApps fun' args') - | otherwise = (all_uds, mkTicks ticks $ mkApps fun' args') + -- Account for join arity of runRW# continuation + -- See Note [Simplification of runRW#] + | fun `hasKey` runRWKey + , [t1, t2, arg] <- args + , let (usage, arg') = occAnalRhs env (Just 1) arg + = (usage, mkTicks ticks $ mkApps (Var fun) [t1, t2, arg']) + + | otherwise + = (all_uds, mkTicks ticks $ mkApps fun' args') where (fun', fun_id') = lookupVarEnv (occ_bs_env env) fun `orElse` (Var fun, fun) diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs index 0a1395a432..cef8230436 100644 --- a/compiler/GHC/Core/Opt/SetLevels.hs +++ b/compiler/GHC/Core/Opt/SetLevels.hs @@ -91,11 +91,13 @@ import GHC.Types.Demand ( StrictSig, Demand, isStrictDmd, splitStrictSig, import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Types.Name ( getOccName, mkSystemVarName ) import GHC.Types.Name.Occurrence ( occNameString ) +import GHC.Types.Unique ( hasKey ) import GHC.Core.Type ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType , mightBeUnliftedType, closeOverKindsDSet ) import GHC.Types.Basic ( Arity, RecFlag(..), isRec ) import GHC.Core.DataCon ( dataConOrigResTy ) import GHC.Builtin.Types +import GHC.Builtin.Names ( runRWKey ) import GHC.Types.Unique.Supply import GHC.Utils.Misc import GHC.Utils.Outputable @@ -399,8 +401,14 @@ lvlNonTailExpr env expr lvlApp :: LevelEnv -> CoreExprWithFVs -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application - -> LvlM LevelledExpr -- Result expression + -> LvlM LevelledExpr -- Result expression lvlApp env orig_expr ((_,AnnVar fn), args) + -- Try to ensure that runRW#'s continuation isn't floated out. + -- See Note [Simplification of runRW#]. + | fn `hasKey` runRWKey + = do { args' <- mapM (lvlExpr env) args + ; return (foldl' App (lookupVar env fn) args') } + | floatOverSat env -- See Note [Floating over-saturated applications] , arity > 0 , arity < n_val_args diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 154b15e9d8..9c2bea4e11 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -37,10 +37,13 @@ import GHC.Core.DataCon , StrictnessMark (..) ) import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) ) import GHC.Core +import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) +import GHC.Builtin.Names( runRWKey ) import GHC.Types.Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd , mkClosedStrictSig, topDmd, botDiv ) import GHC.Types.Cpr ( mkCprSig, botCpr ) import GHC.Core.Ppr ( pprCoreExpr ) +import GHC.Types.Unique ( hasKey ) import GHC.Core.Unfold import GHC.Core.Utils import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg @@ -1877,14 +1880,36 @@ rebuildCall env info (CastIt co cont) rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont }) = rebuildCall env (addTyArgTo info arg_ty) cont -rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty +---------- The runRW# rule. Do this after absorbing all arguments ------ +-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o +-- K[ runRW# rr ty (\s. body) ] --> runRW rr' ty' (\s. K[ body ]) +rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) + (ApplyToVal { sc_arg = arg, sc_env = arg_se, sc_cont = cont }) + | fun `hasKey` runRWKey + , not (contIsStop cont) -- Don't fiddle around if the continuation is boring + , [ TyArg {}, TyArg {} ] <- rev_args + = do { s <- newId (fsLit "s") realWorldStatePrimTy + ; let env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s] + cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s + , sc_env = env', sc_cont = cont } + ; body' <- simplExprC env' arg cont' + ; let arg' = Lam s body' + ty' = contResultType cont + rr' = getRuntimeRep ty' + call' = mkApps (Var fun) [mkTyArg rr', mkTyArg ty', arg'] + ; return (emptyFloats env, call') } + +rebuildCall env info@(ArgInfo { ai_type = fun_ty, ai_encl = encl_rules , ai_strs = str:strs, ai_discs = disc:discs }) (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_dup = dup_flag, sc_cont = cont }) + + -- Argument is already simplified | isSimplified dup_flag -- See Note [Avoid redundant simplification] = rebuildCall env (addValArgTo info' arg) cont - | str -- Strict argument + -- Strict arguments + | str , sm_case_case (getMode env) = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setInScopeFromE` env) arg @@ -1892,7 +1917,8 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty , sc_dup = Simplified, sc_cont = cont }) -- Note [Shadowing] - | otherwise -- Lazy argument + -- Lazy arguments + | otherwise -- DO NOT float anything outside, hence simplExprC -- There is no benefit (unlike in a let-binding), and we'd -- have to be very careful about bogus strictness through |