[commit: ghc] wip/float-join-points: Allow joins to float to top level (9b522eb)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/float-join-points
Link       : http://ghc.haskell.org/trac/ghc/changeset/9b522eba9829ea9ab0fb6d4d0b4cc762d1d0fd91/ghc

>---------------------------------------------------------------

commit 9b522eba9829ea9ab0fb6d4d0b4cc762d1d0fd91
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Jan 5 17:14:56 2018 +0000

    Allow joins to float to top level


>---------------------------------------------------------------

9b522eba9829ea9ab0fb6d4d0b4cc762d1d0fd91
 compiler/simplCore/SetLevels.hs | 44 ++++++++++++++++++++++-------------------
 compiler/simplCore/Simplify.hs  |  1 -
 2 files changed, 24 insertions(+), 21 deletions(-)

diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
index 4074d70..f0c9063 100644
--- a/compiler/simplCore/SetLevels.hs
+++ b/compiler/simplCore/SetLevels.hs
@@ -1026,12 +1026,7 @@ lvlBind :: LevelEnv
         -> LvlM (LevelledBind, LevelEnv)
 
 lvlBind env (AnnNonRec bndr rhs)
-  | isTyVar bndr    -- Don't do anything for TyVar binders
-                    --   (simplifier gets rid of them pronto)
-  || isCoVar bndr   -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)
-                    -- so we will ignore this case for now
-  || isJoinId bndr
-  || not (profitableFloat env dest_lvl)
+  |  not (profitableFloat env dest_lvl [bndr])
   || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty))
           -- We can't float an unlifted binding to top level (except
           -- literal strings), so we don't float it at all.  It's a
@@ -1061,12 +1056,12 @@ lvlBind env (AnnNonRec bndr rhs)
        ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }
 
   where
-    bndr_ty    = idType bndr
-    ty_fvs     = tyCoVarsOfType bndr_ty
-    rhs_fvs    = freeVarsOf rhs
-    bind_fvs   = rhs_fvs `unionDVarSet` dIdFreeVars bndr
-    abs_vars   = abstractVars dest_lvl env bind_fvs
-    dest_lvl   = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join
+    bndr_ty     = idType bndr
+    ty_fvs      = tyCoVarsOfType bndr_ty
+    rhs_fvs     = freeVarsOf rhs
+    bind_fvs    = rhs_fvs `unionDVarSet` dIdFreeVars bndr
+    abs_vars    = abstractVars dest_lvl env bind_fvs
+    dest_lvl    = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join
 
     deann_rhs  = deAnnotate rhs
     mb_bot_str = exprBotStrictness_maybe deann_rhs
@@ -1078,10 +1073,7 @@ lvlBind env (AnnNonRec bndr rhs)
     is_join       = isJust mb_join_arity
 
 lvlBind env (AnnRec pairs)
-  |  any isJoinId bndrs
-  || floatTopLvlOnly env && not (isTopLvl dest_lvl)
-         -- Only floating to the top level is allowed.
-  || not (profitableFloat env dest_lvl)
+  | not (profitableFloat env dest_lvl bndrs)
   = do { let bind_lvl       = incMinorLvl (le_ctxt_lvl env)
              (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs
              lvl_rhs (b,r)  = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r
@@ -1162,11 +1154,23 @@ lvlBind env (AnnRec pairs)
     dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join
     abs_vars = abstractVars dest_lvl env bind_fvs
 
-profitableFloat :: LevelEnv -> Level -> Bool
-profitableFloat env dest_lvl
-  =  (dest_lvl `ltMajLvl` le_ctxt_lvl env)  -- Escapes a value lambda
-  || isTopLvl dest_lvl                      -- Going all the way to top level
+profitableFloat :: LevelEnv -> Level -> [Id] -> Bool
+profitableFloat env dest_lvl (bndr:_)
+  | isTyVar bndr    -- Don't do anything for TyVar binders
+                    --   (simplifier gets rid of them pronto)
+  || isCoVar bndr   -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)
+                    -- so we will ignore this case for now
+  = False
+
+  | isTopLvl dest_lvl
+  = True
+
+  | otherwise
+  =  not (isJoinId bndr)
+  && not (floatTopLvlOnly env)
+  && (dest_lvl `ltMajLvl` le_ctxt_lvl env)
 
+profitableFloat _ _ [] = panic "profitableFloat"
 
 ----------------------------------------------------
 -- Three help functions for the type-abstraction case
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index 0d2b77f..19ada04 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -273,7 +273,6 @@ simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
                                             (getOccFS bndr1) (idInfo bndr1) body1
         ; let body_floats2 = body_floats1 `addLetFloats` let_floats
 
-
         ; (rhs_floats, body3) <- floatLetBinds env top_lvl is_rec tvs'
                                                body_floats2 body2