[Git][ghc/ghc][wip/T17910] More care with floating

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/T17910 at Glasgow Haskell Compiler / GHC


Commits:
64b75bbf by Simon Peyton Jones at 2023-09-29T09:28:22+01:00
More care with floating

T5642 still floats out (from inside a lamdba)
   lvl = /\a. L1 @a (L1 @a X)
which is flattened by the next simplifer run, which takes one
extra iteration, but that's a corner case.

- - - - -


4 changed files:

- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/SpecConstr.hs


Changes:

=====================================
compiler/GHC/Core/Opt/Pipeline.hs
=====================================
@@ -279,7 +279,7 @@ getCoreToDo dflags hpt_rule_base extra_vars
         runWhen full_laziness $
            CoreDoFloatOutwards FloatOutSwitches {
                                  floatOutLambdas     = floatLamArgs dflags,
-                                 floatOutConstants   = False,
+                                 floatOutConstants   = True,
                                  floatOutOverSatApps = True,
                                  floatToTopLevelOnly = False },
                 -- nofib/spectral/hartel/wang doubles in speed if you


=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -702,8 +702,9 @@ lvlMFE env _strict_ctxt ann_expr
     is_bot_lam   = isJust mb_bot_str   -- True of bottoming thunks too!
     is_function  = isFunction ann_expr
     mb_bot_str   = exprBotStrictness_maybe expr
-                           -- See Note [Bottoming floats]
-                           -- esp Bottoming floats (2)
+                   -- See Note [Bottoming floats], esp Bottoming floats (2)
+                   -- NB: exprBotStrictness_maybe does not look deeply into expr
+                   --     which can be
     expr_ok_for_spec = exprOkForSpeculation expr
     abs_vars = abstractVars dest_lvl env fvs
     dest_lvl = destLevel env fvs fvs_ty is_function is_bot_lam False
@@ -735,15 +736,18 @@ lvlMFE env _strict_ctxt ann_expr
     escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env)
                   -- See Note [Escaping a value lambda]
 
-    is_con_app (Cast e _) = is_con_app e
-    is_con_app (App f _)  = is_con_app f
-    is_con_app (Var v)    = isDataConWorkId v
-    is_con_app _          = False
+    send_rhs_to_top (_, AnnCast e _) = send_rhs_to_top e
+    send_rhs_to_top (_, AnnApp f _)  = send_rhs_to_top f
+    send_rhs_to_top (_, AnnLam {})   = True
+    send_rhs_to_top (_, AnnVar v)    = case idDetails v of
+                                         DFunId {} -> True
+                                         _         -> floatConsts env
+    send_rhs_to_top _ = floatConsts env
 
     -- See Note [Floating to the top]
     saves_alloc =  isTopLvl dest_lvl
-                && (  (is_bot_lam && escapes_value_lam)
-                   || (exprIsExpandable expr && not (is_con_app expr)) )
+                && (  send_rhs_to_top ann_expr
+                   || (escapes_value_lam && is_bot_lam) )
 -- escapes_value_lam very important
 --   f x = let fail = error ("foo" ++ x) in ...
 -- We want to float this out
@@ -1620,10 +1624,8 @@ addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs
 floatLams :: LevelEnv -> Maybe Int
 floatLams le = floatOutLambdas (le_switches le)
 
-{-
 floatConsts :: LevelEnv -> Bool
 floatConsts le = floatOutConstants (le_switches le)
--}
 
 floatOverSat :: LevelEnv -> Bool
 floatOverSat le = floatOutOverSatApps (le_switches le)


=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1423,8 +1423,8 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
     one_occ OneOcc{ occ_n_br = 1, occ_in_lam = in_lam, occ_int_cxt = int_cxt }
        | is_value_lam rhs, IsInteresting <- int_cxt
        = True
-       | NotInsideLam <- in_lam
-       , not (isTopLevel top_lvl) || not (exprIsExpandable rhs)
+       | NotInsideLam <- in_lam    -- Once things are flattened to top level, don't
+       , not (isTopLevel top_lvl)  -- re-inline them.  See Note [Floating to the top]
        = True
        | otherwise
        = False


=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -642,7 +642,7 @@ for why we do this.
 
 Note [Specialising on dictionaries]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In #21386, SpecConstr saw this call:
+In #21386 (see nofib/real/eff/VSM), SpecConstr saw this call:
 
    $wgo 100# @.. ($fMonadStateT @.. @.. $fMonadIdentity)
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64b75bbff987aa46d7823cc2399604c44d5e331c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/64b75bbff987aa46d7823cc2399604c44d5e331c
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230929/a79e3939/attachment-0001.html>