diff options
author | Vanessa McHale <vamchale@gmail.com> | 2022-03-25 08:04:43 -0500 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-06-22 08:21:32 -0400 |
commit | f89bf85fcedb595f457dee2c7ef50a15cc958c1a (patch) | |
tree | 1378e618a6002e9d7f4fe0cdedad2241eecdc0c2 | |
parent | 1a4ce4b27623b3bcde8a02f0bd43402fbd78ff8a (diff) | |
download | haskell-f89bf85fcedb595f457dee2c7ef50a15cc958c1a.tar.gz |
Flags to disable local let-floating; -flocal-float-out, -flocal-float-out-top-level CLI flags
These flags affect the behaviour of local let floating.
If `-flocal-float-out` is disabled (the default) then we disable all
local floating.
```
…(let x = let y = e in (a,b) in body)...
===>
…(let y = e; x = (a,b) in body)...
```
Further to this, top-level local floating can be disabled on it's own by
passing -fno-local-float-out-top-level.
```
x = let y = e in (a,b)
===>
y = e; x = (a,b)
```
Note that this is only about local floating, ie, floating two adjacent
lets past each other and doesn't say anything about the global floating
pass which is controlled by `-fno-float`.
Fixes #13663
-rw-r--r-- | compiler/GHC/Core/Opt/Monad.hs | 46 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Pipeline.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Env.hs | 22 | ||||
-rw-r--r-- | compiler/GHC/Core/Opt/Simplify/Utils.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Driver/Flags.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Driver/Session.hs | 16 | ||||
-rw-r--r-- | docs/users_guide/using-optimisation.rst | 48 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T20895.hs | 30 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/T20895.stderr | 56 | ||||
-rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 3 |
11 files changed, 226 insertions, 8 deletions
diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index 4753555221..11b1d2c7c2 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -13,6 +13,8 @@ module GHC.Core.Opt.Monad ( CoreToDo(..), runWhen, runMaybe, SimplMode(..), FloatOutSwitches(..), + FloatEnable(..), + floatEnable, pprPassDetails, -- * Plugins @@ -171,6 +173,49 @@ pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n , ppr md ] pprPassDetails _ = Outputable.empty + +data FloatEnable -- Controls local let-floating + = FloatDisabled -- Do no local let-floating + | FloatNestedOnly -- Local let-floating for nested (NotTopLevel) bindings only + | FloatEnabled -- Do local let-floating on all bindings + +floatEnable :: DynFlags -> FloatEnable +floatEnable dflags = + case (gopt Opt_LocalFloatOut dflags, gopt Opt_LocalFloatOutTopLevel dflags) of + (True, True) -> FloatEnabled + (True, False)-> FloatNestedOnly + (False, _) -> FloatDisabled + +{- +Note [Local floating] +~~~~~~~~~~~~~~~~~~~~~ +The Simplifier can perform local let-floating: it floats let-bindings +out of the RHS of let-bindings. See + Let-floating: moving bindings to give faster programs (ICFP'96) + https://www.microsoft.com/en-us/research/publication/let-floating-moving-bindings-to-give-faster-programs/ + +Here's an example + x = let y = v+1 in (y,true) + +The RHS of x is a thunk. Much better to float that y-binding out to give + y = v+1 + x = (y,true) + +Not only have we avoided building a thunk, but any (case x of (p,q) -> ...) in +the scope of the x-binding can now be simplified. + +This local let-floating is done in GHC.Core.Opt.Simplify.prepareBinding, +controlled by the predicate GHC.Core.Opt.Simplify.Env.doFloatFromRhs. + +The `FloatEnable` data type controls where local let-floating takes place; +it allows you to specify that it should be done only for nested bindings; +or for top-level bindings as well; or not at all. + +Note that all of this is quite separate from the global FloatOut pass; +see GHC.Core.Opt.FloatOut. + +-} + data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad = SimplMode { sm_names :: [String] -- ^ Name(s) of the phase @@ -182,6 +227,7 @@ data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas? , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled + , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out , sm_logger :: !Logger , sm_dflags :: DynFlags -- Just for convenient non-monadic access; we don't override these. diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index 589441bffe..40b9536583 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -136,6 +136,7 @@ getCoreToDo logger dflags phases = simplPhases dflags max_iter = maxSimplIterations dflags rule_check = ruleCheck dflags + float_enable = floatEnable dflags const_fold = gopt Opt_CoreConstantFolding dflags call_arity = gopt Opt_CallArity dflags exitification = gopt Opt_Exitification dflags @@ -177,6 +178,7 @@ getCoreToDo logger dflags , sm_inline = True , sm_case_case = True , sm_pre_inline = pre_inline_on + , sm_float_enable = float_enable } simpl_phase phase name iter diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index b5dac4d385..1523394be9 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -722,7 +722,7 @@ prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs -- Finally, decide whether or not to float ; let all_floats = rhs_floats1 `addLetFloats` anf_floats - ; if doFloatFromRhs top_lvl is_rec strict_bind all_floats rhs2 + ; if doFloatFromRhs (sm_float_enable $ seMode env) top_lvl is_rec strict_bind all_floats rhs2 then -- Float! do { tick LetFloatFromLet ; return (all_floats, rhs2) } diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 30afb9aac2..47927d5d7f 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -36,7 +36,7 @@ module GHC.Core.Opt.Simplify.Env ( doFloatFromRhs, getTopFloatBinds, -- * LetFloats - LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat, + LetFloats, FloatEnable(..), letFloatBinds, emptyLetFloats, unitLetFloat, addLetFlts, mapLetFloats, -- * JoinFloats @@ -47,7 +47,7 @@ module GHC.Core.Opt.Simplify.Env ( import GHC.Prelude import GHC.Core.Opt.Simplify.Monad -import GHC.Core.Opt.Monad ( SimplMode(..) ) +import GHC.Core.Opt.Monad ( SimplMode(..), FloatEnable (..) ) import GHC.Core import GHC.Core.Utils import GHC.Core.Multiplicity ( scaleScaled ) @@ -506,10 +506,14 @@ andFF FltOkSpec FltCareful = FltCareful andFF FltOkSpec _ = FltOkSpec andFF FltLifted flt = flt -doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool --- If you change this function look also at FloatIn.noFloatFromRhs -doFloatFromRhs lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs - = not (isNilOL fs) && want_to_float && can_float + +doFloatFromRhs :: FloatEnable -> TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool +-- If you change this function look also at FloatIn.noFloatIntoRhs +doFloatFromRhs fe lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs + = floatEnabled lvl fe + && not (isNilOL fs) + && want_to_float + && can_float where want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs -- See Note [Float when cheap or expandable] @@ -518,6 +522,12 @@ doFloatFromRhs lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff FltOkSpec -> isNotTopLevel lvl && isNonRec rec FltCareful -> isNotTopLevel lvl && isNonRec rec && strict_bind + -- Whether any floating is allowed by flags. + floatEnabled :: TopLevelFlag -> FloatEnable -> Bool + floatEnabled _ FloatDisabled = False + floatEnabled lvl FloatNestedOnly = not (isTopLevel lvl) + floatEnabled _ FloatEnabled = True + {- Note [Float when cheap or expandable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index f209713de7..3197b8024b 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -48,7 +48,7 @@ import GHC.Driver.Session import GHC.Core import GHC.Types.Literal ( isLitRubbish ) import GHC.Core.Opt.Simplify.Env -import GHC.Core.Opt.Monad ( SimplMode(..), Tick(..) ) +import GHC.Core.Opt.Monad ( SimplMode(..), Tick(..), floatEnable ) import qualified GHC.Core.Subst import GHC.Core.Ppr import GHC.Core.TyCo.Ppr ( pprParendType ) @@ -951,12 +951,14 @@ simplEnvForGHCi logger dflags , sm_cast_swizzle = True , sm_case_case = True , sm_pre_inline = pre_inline_on + , sm_float_enable = float_enable } where rules_on = gopt Opt_EnableRewriteRules dflags eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags pre_inline_on = gopt Opt_SimplPreInlining dflags uf_opts = unfoldingOpts dflags + float_enable = floatEnable dflags updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode updModeForStableUnfoldings unf_act current_mode diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 209e6d1776..bac257670c 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -187,6 +187,11 @@ data GeneralFlag | Opt_KillOneShot | Opt_FullLaziness | Opt_FloatIn + | Opt_LocalFloatOut -- ^ Enable floating out of let-bindings in the + -- simplifier + | Opt_LocalFloatOutTopLevel -- ^ Enable floating out of let-bindings at the + -- top level in the simplifier + -- N.B. See Note [RHS Floating] | Opt_LateSpecialise | Opt_Specialise | Opt_SpecialiseAggressively diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 627b2c69b3..99a2c10bf6 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -733,6 +733,15 @@ data DynFlags = DynFlags { cfgWeights :: Weights } +{- Note [RHS Floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We provide both 'Opt_LocalFloatOut' and 'Opt_LocalFloatOutTopLevel' to correspond to + 'doFloatFromRhs'; with this we can control floating out with GHC flags. + + This addresses https://gitlab.haskell.org/ghc/ghc/-/issues/13663 and + allows for experminentation. +-} + class HasDynFlags m where getDynFlags :: m DynFlags @@ -3414,6 +3423,8 @@ fFlagsDeps = [ flagSpec "full-laziness" Opt_FullLaziness, depFlagSpec' "fun-to-thunk" Opt_FunToThunk (useInstead "-f" "full-laziness"), + flagSpec "local-float-out" Opt_LocalFloatOut, + flagSpec "local-float-out-top-level" Opt_LocalFloatOutTopLevel, flagSpec "gen-manifest" Opt_GenManifest, flagSpec "ghci-history" Opt_GhciHistory, flagSpec "ghci-leak-check" Opt_GhciLeakCheck, @@ -3799,10 +3810,15 @@ defaultFlags settings ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] -- The default -O0 options + -- Default floating flags (see Note [RHS Floating]) + ++ [ Opt_LocalFloatOut, Opt_LocalFloatOutTopLevel ] + + ++ default_PIC platform ++ validHoleFitDefaults + where platform = sTargetPlatform settings -- | These are the default settings for the display and sorting of valid hole diff --git a/docs/users_guide/using-optimisation.rst b/docs/users_guide/using-optimisation.rst index ab49f08ade..02f1fd50f6 100644 --- a/docs/users_guide/using-optimisation.rst +++ b/docs/users_guide/using-optimisation.rst @@ -743,6 +743,54 @@ by saying ``-fno-wombat``. Sets the maximal number of iterations for the simplifier. +.. ghc-flag:: -flocal-float-out + :shortdesc: Enable local floating definitions out of let-binds. + :type: dynamic + :reverse: -fno-local-float-out + :category: + + :default: on + + Enable local floating of bindings from the RHS of a let(rec) in the + simplifier. For example :: + + let x = let y = rhs_y in rhs_x in blah + ==> + let y = rhs_y in let x = rhs_x in blah + + See the paper "Let-floating: moving bindings to give faster programs", Partain, Santos, and Peyton Jones; ICFP 1996. + https://www.microsoft.com/en-us/research/publication/let-floating-moving-bindings-to-give-faster-programs/ + + .. note:: + This is distinct from the global floating pass which can be disabled with + :ghc-flag:`-fno-full-laziness`. + +.. ghc-flag:: -flocal-float-out-top-level + :shortdesc: Enable local floating to float top-level bindings + :type: dynamic + :reverse: -fno-local-float-out-top-level + :category: + + :default: on + + Enable local floating of top-level bindings from the RHS of a let(rec) in + the simplifier. For example + + x = let y = e in (a,b) + ===> + y = e; x = (a,b) + + + See the paper "Let-floating: moving bindings to give faster programs", Partain, Santos, and Peyton Jones; ICFP 1996. + https://www.microsoft.com/en-us/research/publication/let-floating-moving-bindings-to-give-faster-programs/ + + Note that if :ghc-flag:`-fno-local-float-out` is set, that will take + precedence. + + .. note:: + This is distinct from the global floating pass which can be disabled with + :ghc-flag:`-fno-full-laziness`. + .. ghc-flag:: -fmax-worker-args=⟨n⟩ :shortdesc: *default: 10.* Maximum number of value arguments for a worker. :type: dynamic diff --git a/testsuite/tests/simplCore/should_compile/T20895.hs b/testsuite/tests/simplCore/should_compile/T20895.hs new file mode 100644 index 0000000000..a35cfc4c70 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T20895.hs @@ -0,0 +1,30 @@ +module Test where + +import Control.Applicative + +topEntity :: [((),())] +topEntity = (,) <$> outport1 <*> outport2 + where + (outport1, outResp1) = gpio (decodeReq 1 req) + (outport2, outResp2) = gpio (decodeReq 2 req) + ramResp = ram (decodeReq 0 req) + + req = core $ (<|>) <$> ramResp <*> ((<|>) <$> outResp1 <*> outResp2) + +core :: [Maybe ()] -> [()] +core = fmap (maybe () id) +{-# NOINLINE core #-} + +ram :: [()] -> [Maybe ()] +ram = fmap pure +{-# NOINLINE ram #-} + +decodeReq :: Integer -> [()] -> [()] +decodeReq 0 = fmap (const ()) +decodeReq 1 = id +decodeReq _ = fmap id +{-# NOINLINE decodeReq #-} + +gpio :: [()] -> ([()],[Maybe ()]) +gpio i = (i,pure <$> i) +{-# NOINLINE gpio #-} diff --git a/testsuite/tests/simplCore/should_compile/T20895.stderr b/testsuite/tests/simplCore/should_compile/T20895.stderr new file mode 100644 index 0000000000..fb44e0f576 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T20895.stderr @@ -0,0 +1,56 @@ + +==================== Tidy Core ==================== +Result size of Tidy Core + = {terms: 110, types: 177, coercions: 0, joins: 0/3} + +$trModule = Module (TrNameS "main"#) (TrNameS "Test"#) + +gpio + = \ i_amK -> + (i_amK, <$> $fFunctor[] (pure $fApplicativeMaybe) i_amK) + +decodeReq + = \ ds_dY6 -> + case == $fEqInteger ds_dY6 (IS 0#) of { + False -> + case == $fEqInteger ds_dY6 (IS 1#) of { + False -> fmap $fFunctor[] id; + True -> id + }; + True -> fmap $fFunctor[] (const ()) + } + +ram = fmap $fFunctor[] (pure $fApplicativeMaybe) + +core = fmap $fFunctor[] (maybe () id) + +topEntity + = letrec { + ds_dYh = gpio (decodeReq (IS 1#) req_aWD); + ds1_dYi = gpio (decodeReq (IS 2#) req_aWD); + req_aWD + = $ core + (<*> + $fApplicative[] + (<$> + $fFunctor[] + (<|> $fAlternativeMaybe) + (ram (decodeReq (IS 0#) req_aWD))) + (<*> + $fApplicative[] + (<$> + $fFunctor[] + (<|> $fAlternativeMaybe) + (case ds_dYh of { (outport1_aWz, outResp1_X2) -> outResp1_X2 })) + (case ds1_dYi of { (outport2_aWJ, outResp2_X2) -> + outResp2_X2 + }))); } in + <*> + $fApplicative[] + (<$> + $fFunctor[] + (\ ds2_dYf ds3_dYg -> (ds2_dYf, ds3_dYg)) + (case ds_dYh of { (outport1_aWz, outResp1_X2) -> outport1_aWz })) + (case ds1_dYi of { (outport2_aWJ, outResp2_X2) -> outport2_aWJ }) + + diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index b9b1956f51..2ddbef16bb 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -385,6 +385,9 @@ test('T19790', normal, compile, ['-O -ddump-rule-firings']) # which (before the fix) lost crucial dependencies test('T20820', normal, compile, ['-O0']) +# Verify that the letrec is still there +test('T20895', [ grep_errmsg(r'\s*=\s*letrec') ], compile, ['-O0 -ddump-simpl -dsuppress-all -fno-local-float-out-top-level']) + test('OpaqueNoAbsentArgWW', normal, compile, ['-O -ddump-simpl -dsuppress-uniques']) test('OpaqueNoCastWW', normal, compile, ['-O -ddump-simpl -dsuppress-uniques']) test('OpaqueNoRebox', normal, compile, ['-O -ddump-simpl -dsuppress-uniques']) |