[Git][ghc/ghc][wip/simplifier-tweaks] Further wibbles

[Simon Peyton Jones (@simonpj)]

Simon Peyton Jones pushed to branch wip/simplifier-tweaks at Glasgow Haskell Compiler / GHC


Commits:
3a3a5ade by Simon Peyton Jones at 2023-08-03T16:47:26+01:00
Further wibbles

- - - - -


3 changed files:

- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Unfold.hs


Changes:

=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -87,12 +87,7 @@ import GHC.Prelude
 
 import GHC.Core
 import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )
-import GHC.Core.Utils   ( exprType, exprIsHNF
-                        , exprOkForSpeculation
-                        , exprIsTopLevelBindable
-                        , collectMakeStaticArgs
-                        , mkLamTypes, extendInScopeSetBndrs
-                        )
+import GHC.Core.Utils
 import GHC.Core.Opt.Arity   ( exprBotStrictness_maybe, isOneShotBndr )
 import GHC.Core.FVs     -- all of it
 import GHC.Core.Subst
@@ -1127,17 +1122,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  -- Don't float join points
-  || not (profitableFloat env dest_lvl)
-  || (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
-          -- bit brutal, but unlifted bindings aren't expensive either
-
+  | dontFloatNonRec env dest_lvl is_bot_lam bndr bndr_ty deann_rhs
   = -- No float
     do { rhs' <- lvlRhs env NonRecursive is_bot_lam mb_join_arity rhs
        ; let  bind_lvl        = incMinorLvl (le_ctxt_lvl env)
@@ -1271,6 +1256,30 @@ 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
 
+dontFloatNonRec :: LevelEnv -> Level -> Bool
+                -> Id -> Type -> CoreExpr -> Bool
+dontFloatNonRec env dest_lvl is_bot bndr bndr_ty deann_rhs
+  | isTyVar bndr           -- Don't do anything for TyVar binders
+  = True                   --   (simplifier gets rid of them pronto)
+  | isCoVar bndr           -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)
+  = True                    -- so we will ignore this case for now
+
+  | not (profitableFloat env dest_lvl)
+  = True
+
+  | JoinPoint join_arity <- idJoinPointHood bndr
+  , let (_, body) = collectNBinders join_arity deann_rhs
+  = not (isTopLvl dest_lvl) || (not is_bot && exprIsCheap body)
+
+  | isTopLvl dest_lvl
+  , not (exprIsTopLevelBindable deann_rhs bndr_ty)
+  = True     -- We can't float an unlifted binding to top level (except
+             -- literal strings), so we don't float it at all.  It's a
+             -- bit brutal, but unlifted bindings aren't expensive either
+
+  | otherwise
+  = False
+
 profitableFloat :: LevelEnv -> Level -> Bool
 profitableFloat env dest_lvl
   =  (dest_lvl `ltMajLvl` le_ctxt_lvl env)  -- Escapes a value lambda


=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -63,7 +63,7 @@ import GHC.Builtin.PrimOps ( PrimOp (SeqOp, DataToTagOp, TagToEnumOp) )
 import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
 import GHC.Builtin.Names( runRWKey )
 
-import GHC.Data.Maybe   ( isNothing, isJust, orElse, mapMaybe )
+import GHC.Data.Maybe   ( isNothing, orElse, mapMaybe )
 import GHC.Data.FastString
 import GHC.Unit.Module ( moduleName )
 import GHC.Utils.Outputable
@@ -3969,12 +3969,16 @@ ok_to_dup_alt _case_bndr _alt_bndrs alt_rhs
 
   | (Var v, args) <- collectArgs alt_rhs
   , all exprIsTrivial args
-  = if isJust (isDataConId_maybe v)
+  , Nothing <- isDataConId_maybe v
+  = True
+{-
+    if isJust (isDataConId_maybe v)
     then -- See Note [Duplicating join points] (DJ3) for the
          -- reason for this apparently strange test
-         False -- exprsFreeIds args `subVarSet` bndr_set
+         exprsFreeIds args `subVarSet` bndr_set
     else True  -- Duplicating a simple call (f a b c) is fine,
                -- (especially if f is itself a join point).
+-}
 
   | otherwise
   = False


=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -54,6 +54,7 @@ import GHC.Utils.Outputable
 import GHC.Types.ForeignCall
 import GHC.Types.Tickish
 
+import Data.Maybe( isJust )
 import qualified Data.ByteString as BS
 
 -- | Unfolding options
@@ -421,8 +422,8 @@ uncondInline :: Bool -> CoreExpr -> Arity -> CoreExpr -> Int -> Bool
 -- See Note [INLINE for small functions]
 uncondInline is_join rhs arity body size
   | is_join   = case collectArgs body of
-                  (Var {}, args) -> all exprIsTrivial args
-                  _              -> False
+                  (Var v, args) -> not (isJust (isDataConId_maybe v)) && all exprIsTrivial args
+                  _             -> False
   | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1)
   | otherwise = exprIsTrivial rhs        -- See Note [INLINE for small functions] (4)
 



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3a3a5ade8e5e5caa026526ba3ff2ad2f61073cef

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3a3a5ade8e5e5caa026526ba3ff2ad2f61073cef
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/20230803/d3d1ee6b/attachment-0001.html>