added -flate-float-leave-LNE, which prevents LNEs from being liftedlate-lam-lift

  ALLOC WORSE                                      llf    llf -flate-float-leave-LNE
            boyer2              3901736           -7.0%           +0.0%
            puzzle            165864064          -19.1%           -2.9%

  TIME BETTER
    fannkuch-redux                 6.55          +11.7%           -0.1%
         --  382807736 ENT_LNE_ctr      <-- likely part of the improvement
             fasta                 1.11           +1.2%           +0.0%
              life                 0.43           +3.8%           -0.8%
               scs                 0.99           -0.3%           -4.7%
     spectral-norm                 3.25           +2.8%           +0.0%
              wang                 0.22           +0.0%           -3.0%

Also causes slowdowns, but I don't immediately see why

   TIME WORSE
      binary-trees                 1.67           +1.4%           +5.0%
            hidden                 0.77           -3.9%           +0.4%
           integer                 2.78           -4.7%           -0.7%
         typecheck                 0.36           -5.6%           +2.8%

I looked at typecheck's ticky and CorePrep changes and didn't see
anything indicative. Ugh.

4 files changed, 37 insertions, 87 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 5fabfe2f73..913c10eae9 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 2fd534b7a9..de04292c1c 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 d2db375380..18dff2f514 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 1ce0ceb73f..66fca16a3d 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