diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 5fabfe2f738cf2852306ae7a0ef1bf7a2abc69cb..913c10eae96916be1e7da56f75c2af8b399f59f2 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -311,7 +311,7 @@ data GeneralFlag
| Opt_LLF_IgnoreLNEClo -- ^ predict LNEs in the late-float
| Opt_LLF_FloatLNE0 -- ^ float zero-arity LNEs
| Opt_LLF_OneShot
- | Opt_LLF_Retry
+ | Opt_LLF_LeaveLNE
-- Interface files
| Opt_IgnoreInterfacePragmas
@@ -2567,7 +2567,7 @@ fFlags = [
( "late-float-ignore-LNE-clo", Opt_LLF_IgnoreLNEClo, nop),
( "late-float-LNE0", Opt_LLF_FloatLNE0, nop),
( "late-float-oneshot", Opt_LLF_OneShot, nop),
- ( "late-float-retry", Opt_LLF_Retry, nop)
+ ( "late-float-leave-LNE", Opt_LLF_LeaveLNE, nop)
]
-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs
index 2fd534b7a9f3ce4c7edcf68ceb003654a40affd6..de04292c1c33664884a97bcc26c1702cb9dda81a 100644
--- a/compiler/simplCore/CoreMonad.lhs
+++ b/compiler/simplCore/CoreMonad.lhs
@@ -363,8 +363,6 @@ data FloatOutSwitches = FloatOutSwitches {
data FinalPassSwitches = FinalPassSwitches
{ fps_rec :: !(Maybe Int)
-- ^ used as floatOutLambdas for recursive lambdas
- , fps_absLNEVar :: !Bool
- -- ^ abstract over let-no-escaped variables?
, fps_absUnsatVar :: !Bool
-- ^ abstract over undersaturated applied variables?
, fps_absSatVar :: !Bool
@@ -388,7 +386,7 @@ data FinalPassSwitches = FinalPassSwitches
, fps_ignoreLNEClo :: !Bool
, fps_floatLNE0 :: !Bool
, fps_oneShot :: !Bool
- , fps_retry :: !Bool
+ , fps_leaveLNE :: !Bool
}
instance Outputable FloatOutSwitches where
diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index d2db375380a235a0f101851b1575ab4b73ad6f40..18dff2f5147e4b92b16c4f59b258ec1688b80dfd 100644
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -684,6 +684,16 @@ OLD comment was:
|| (strict_ctxt && not (exprIsBottom expr))
to the condition above. We should really try this out.
+Node [Lifting LNEs]
+~~~~~~~~~~~~~~~~~~~
+
+Lifting LNEs is dubious. The only benefit of lifting an LNE is the
+reduction in expression size increasing the likelihood of inlining,
+eg. LNEs do not allocate and by definition cannot pin other function
+closures.
+
+However a function call seems to be a bit slower than an LNE entry;
+TODO investigate the CMM difference.
%************************************************************************
%* *
@@ -770,8 +780,6 @@ lvlBind ctxt_lvl env binding@(AnnRec pairsTB) =
in
case decideBindFloat ctxt_lvl env False binding of
Nothing -> do -- decided to not float
--- | Just pinners <- floatDecision emptyVarSet
- -- when (lateRetry env && not (isEmptyVarEnv pinners)) $ tellLvlM $ mkVarEnv [ (b, (b, pinners)) | b <- bndrs ]
let bind_lvl = incMinorLvl ctxt_lvl
(env', bndrs') = substLetBndrsRec env bndrs bind_lvl
tagged_bndrs = [ TB bndr' (StayPut bind_lvl)
@@ -818,9 +826,10 @@ decideBindFloat ctxt_lvl init_env is_bot binding =
|| isTopLvl dest_lvl -- Going all the way to top level
lateLambdaLift fps
- | all_funs || (fps_floatLNE0 fps && isLNE), -- only late lift functions and zero-arity LNEs
+ | all_funs || (fps_floatLNE0 fps && isLNE),
+ -- only lift functions or zero-arity LNEs
+ not (fps_leaveLNE fps && isLNE), -- see Note [Lifting LNEs]
Nothing <- decider emptyVarEnv = Just (tOP_LEVEL, abs_vars)
- -- TODO Just x <- decider emptyVarEnv -> do the retry stuff
| otherwise = Nothing -- do not lift
where
abs_vars = abstractVars tOP_LEVEL env bindings_fvs
@@ -899,10 +908,10 @@ decideLateLambdaFloat env isRec isLNE all_one_shot abs_ids_set badTime spaceInfo
if floating then Nothing else Just $
if isBadSpace
then emptyVarSet -- do not float, ever
- else unionVarSet badTime spoiledLNEs
+ else badTime
-- not floating, in order to not abstract over these
where
- floating = not $ spoilsLNEs || isBadTime || isBadSpace
+ floating = not $ isBadTime || isBadSpace
msg = (if floating then "late-float" else "late-no-float")
++ (if isRec then "(rec " ++ show (length ids) ++ ")" else "")
@@ -912,8 +921,7 @@ decideLateLambdaFloat env isRec isLNE all_one_shot abs_ids_set badTime spaceInfo
spaceInfo = spaceInfo' pinnees
- spoilsLNEs | fps_absLNEVar fps = False -- allow abstraction over let-no-escape variables
- | otherwise = not $ isEmptyVarSet spoiledLNEs
+ -- this should always be empty, by definition of LNE
spoiledLNEs = le_LNEs env `intersectVarSet` abs_ids_set
isBadSpace | fps_oneShot fps && all_one_shot = False
@@ -953,7 +961,7 @@ decideLateLambdaFloat env isRec isLNE all_one_shot abs_ids_set badTime spaceInfo
, text "closureGrowth:" <+> ppr cg
, text "CG in lam:" <+> ppr cgil
, text "fast-calls:" <+> ppr (varSetElems badTime)
- , text "spoiledLNEs:" <+> ppr spoiledLNEs
+ , if null spoiledLNEs then empty else text "spoiledLNEs!!:" <+> ppr spoiledLNEs
, if opt_PprStyle_Debug then extra_sdoc else empty
]
@@ -1019,8 +1027,7 @@ wouldIncreaseAllocation env isLNE abs_ids_set pairs (FISilt _ scope_fiis scope_s
Nothing -> (False, closuresSize, 0, 0) -- it's a dead variable. Huh.
Just fii -> (violatesPAPs, closuresSize, closureGrowth, closureGrowthInLambda)
where
- violatesPAPs | isLNE = False -- might be a zero-arity LNE
- | otherwise = let (unapplied,_,_,_) = fii_useInfo fii in unapplied
+ violatesPAPs = let (unapplied,_,_,_) = fii_useInfo fii in unapplied
-- TODO consider incorporating PAP creation into the closure
-- growth calculation (ie identifying each PAP, whether its
-- in a lambda, etc), instead of having it as a separate all
@@ -1063,45 +1070,6 @@ wouldIncreaseAllocation env isLNE abs_ids_set pairs (FISilt _ scope_fiis scope_s
argRep_sizer :: ArgRep -> WordOff
argRep_sizer = StgCmmArgRep.argRepSizeW dflags
-{- TODO stuff for the retrying the lambda float
-
- | Just{} <- floatDecision emptyVarSet, not (lateRetry env) = doNotFloat
- | Just pinners <- floatDecision emptyVarSet =
- case isEmptyVarEnv pinners of
- False -> do -- merely pinned
- tellLvlM $ unitVarEnv bndr (bndr, pinners)
- doNotFloat
- True -> do -- not floating for space reasons
- (result, pinnees) <- hijackLvlM doNotFloat
- let (roots, pinnees') = partitionPinnees [bndr] pinnees
- tellLvlM pinnees'
- case isEmptyVarSet $ roots `delVarSet` bndr of
- True -> return result -- the space reasons are valid
- False -> case floatDecision roots of
- Nothing -> doFloat -- a successful unpinning: the space
- -- reasons were invalid
- Just pinners -> do
- -- if space is no longer the reason, announce that we're pinned
- when (not $ isEmptyVarSet pinners) $ tellLvlM $ unitVarEnv bndr (bndr, pinners)
- return result
-
--- partition the pinnees by whether or not they are ultimately (ie
--- transitively) pinned by nothing but these binders
-partitionPinnees :: [Id] -> PinnedLBFs -> (VarSet, PinnedLBFs)
-partitionPinnees bndrs pinnees = go $ PartitionState False (mkVarSet bndrs) pinnees where
- go st
- | ps_stop st = (ps_roots st, ps_nonroots st) -- no new roots
- | otherwise = go $ foldVarEnv isARoot (st { ps_stop = True, ps_nonroots = emptyVarEnv}) (ps_nonroots st)
-
-data PartitionState = PartitionState {ps_stop :: !Bool, ps_roots :: VarSet, ps_nonroots :: PinnedLBFs }
-
-isARoot :: (Id, VarSet) -> PartitionState -> PartitionState
-isARoot p@(id, pinners) !st@PartitionState { ps_roots = roots }
- -- if id is pinned only by roots, it's also a root
- | isEmptyVarEnv (pinners `minusVarSet` roots) = st { ps_stop = False, ps_roots = extendVarSet roots id }
- | otherwise = st { ps_nonroots = extendVarEnv (ps_nonroots st) id p }
-
--}
----------------------------------------------------
-- Three help functions for the type-abstraction case
@@ -1179,12 +1147,6 @@ isFunction (Lam b e) | isId (getVar b) = True
-- isFunction (_, AnnTick _ e) = isFunction e -- dubious
isFunction _ = False
-{-countFreeIds :: VarSet -> Int
-countFreeIds = foldVarSet add 0
- where
- add :: Var -> Int -> Int
- add v n | isId v = n+1
- | otherwise = n-}
\end{code}
@@ -1246,11 +1208,6 @@ isFinalPass le = case finalPass le of
Nothing -> False
Just _ -> True
-{-lateRetry :: LevelEnv -> Bool
-lateRetry le = case finalPass le of
- Nothing -> False
- Just fps -> fps_retry fps
--}
floatConsts :: LevelEnv -> Bool
floatConsts le = floatOutConstants (le_switches le)
@@ -1405,12 +1362,6 @@ instance Monad LvlM where
instance MonadUnique LvlM where
getUniqueSupplyM = LvlM $ getUniqueSupplyM >>= \a -> return (a, emptyVarEnv)
-{-tellLvlM :: PinnedLBFs -> LvlM ()
-tellLvlM pinned = LvlM $ return ((), pinned)
-
-hijackLvlM :: LvlM a -> LvlM (a, PinnedLBFs)
-hijackLvlM (LvlM m) = LvlM $ m >>= \p -> return (p, emptyVarEnv)-}
-
initLvl :: UniqSupply -> LvlM a -> a
initLvl us (LvlM m) = fst $ initUs_ us m
\end{code}
@@ -1667,8 +1618,8 @@ delBinderFVs b fvs = fvs `delVarSet` b `unionVarSet` varTypeTyVars b
-- cost of lifting f.
--
-- NB That floating cannot change the abs_ids of a function closure
--- because nothing floats past a lambda. TODO What about for
--- zero-arity LNEs?
+-- because nothing floats past a lambda. TODO What about zero-arity
+-- LNEs?
--
-- We are *approximating* CorePrep because we do not actually float
-- anything: thus some of the emulated decisions might be
@@ -1794,18 +1745,18 @@ type FVM = Identity
-- Note [recognizing LNE]
-- ~~~~~~~~~~~~~~~~~~~~~~
-- We track escaping variables in order to recognize LNEs. This helps
--- in a couple ways:
+-- in a couple of ways:
--
--- (1) we lift zero-arity LNEs (cf decideBindFloat)
+-- (1) it is ok to lift a "thunk" if it is actually LNE
--
--- (2) LNEs are not proper closures: adding free variables to one
--- does not increase allocation (cf closureFVUp)
+-- (2) LNEs are not actually closures, so adding free variables to
+-- one does not increase allocation (cf closureFVUp)
--
-- (See Note [FVUp] for the semantics of E, F, and E'.)
--
-- NB The escaping variables in E are the same as the escaping
--- variables in F and E'. The example suggesting they might be
--- different is this sort of floating:
+-- variables in F and E'. A deceptive example suggesting they might
+-- instead be different is this sort of floating:
--
-- let t = lne j = ...
-- in E[j]
@@ -1815,12 +1766,13 @@ type FVM = Identity
-- let j = ...
-- t = E[j]
--
--- Since j floated out of t, it is no longer LNE. However, this
--- example is impossible: j would not float out of t. A binding only
--- floats out of a closure if doing so would reveal a head normal form
--- (cf wantFloatNested and CoreUtil's Note [exprIsHNF]), and for all
--- such forms, the free ids of the arguments are escaping. Thus: LNE
--- bindings do not float out of closures.
+-- Since j hypothetically floated out of t, it is no longer
+-- LNE. However, this example is impossible: j would not float out of
+-- t. A binding only floats out of a closure if doing so would reveal
+-- a head normal form (cf wantFloatNested and CoreUtil's Note
+-- [exprIsHNF]), and for all such forms, the free ids of the arguments
+-- are defined to be escaping. Thus: LNE bindings do not float out of
+-- closures.
-- Note [FVUp for closures and floats]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 1ce0ceb73f0c18af75f11f297995a285356c2297..66fca16a3da7b2e92b246a1318c375d35d2723bb 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -149,7 +149,7 @@ getCoreToDo dflags
, fps_strictness = gopt Opt_LLF_UseStr dflags
, fps_floatLNE0 = gopt Opt_LLF_FloatLNE0 dflags
, fps_oneShot = gopt Opt_LLF_OneShot dflags
- , fps_retry = gopt Opt_LLF_Retry dflags
+ , fps_leaveLNE = gopt Opt_LLF_LeaveLNE dflags
}
static_args = gopt Opt_StaticArgumentTransformation dflags
rules_on = gopt Opt_EnableRewriteRules dflags