import CoreSyn
import DynFlags ( FloatOutSwitches(..) )
-import CoreUtils ( exprType, exprIsTrivial, exprBotStrictness_maybe, mkPiTypes )
+import CoreUtils ( exprType, exprIsTrivial, mkPiTypes )
+import CoreArity ( exprBotStrictness_maybe )
import CoreFVs -- all of it
import CoreSubst ( Subst, emptySubst, extendInScope, extendInScopeList,
extendIdSubst, cloneIdBndr, cloneRecIdBndrs )
-import Id ( Id, idType, mkSysLocal, isOneShotLambda,
+import Id ( idType, mkSysLocal, isOneShotLambda,
zapDemandIdInfo, transferPolyIdInfo,
idSpecialisation, idUnfolding, setIdInfo,
setIdNewStrictness, setIdArity
But this float-out might occur after strictness analysis. So we use the
cheap-and-cheerful exprBotStrictness_maybe function.
+Note [Case MFEs]
+~~~~~~~~~~~~~~~~
+We don't float a case expression as an MFE from a strict context. Why not?
+Because in doing so we share a tiny bit of computation (the switch) but
+in exchange we build a thunk, which is bad. This case reduces allocation
+by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.
+Doesn't change any other allocation at all.
+
\begin{code}
lvlMFE :: Bool -- True <=> strict context [body of case or let]
-> Level -- Level of innermost enclosing lambda/tylam
= do { e' <- lvlMFE strict_ctxt ctxt_lvl env e
; return (Cast e' co) }
+-- Note [Case MFEs]
+lvlMFE True ctxt_lvl env e@(_, AnnCase {})
+ = lvlExpr ctxt_lvl env e -- Don't share cases
+
lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
| isUnLiftedType ty -- Can't let-bind it; see Note [Unlifted MFEs]
|| exprIsTrivial expr -- Never float if it's trivial
new_rhss <- mapM (lvlExpr ctxt_lvl new_env) rhss
return (Rec ([TB b dest_lvl | b <- new_bndrs] `zip` new_rhss), new_env)
- | isSingleton pairs && count isIdVar abs_vars > 1
+ | isSingleton pairs && count isId abs_vars > 1
= do -- Special case for self recursion where there are
-- several variables carried around: build a local loop:
-- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars
[] bndrs
where
go old_lvl bumped_major rev_lvld_bndrs (bndr:bndrs)
- | isIdVar bndr && -- Go to the next major level if this is a value binder,
+ | isId bndr && -- Go to the next major level if this is a value binder,
not bumped_major && -- and we havn't already gone to the next level (one jump per group)
not (isOneShotLambda bndr) -- and it isn't a one-shot lambda
= go new_lvl True (TB bndr new_lvl : rev_lvld_bndrs) bndrs
-- We may only want to do this if there are sufficiently few free
-- variables. We certainly only want to do it for values, and not for
-- constructors. So the simple thing is just to look for lambdas
-isFunction (_, AnnLam b e) | isIdVar b = True
+isFunction (_, AnnLam b e) | isId b = True
| otherwise = isFunction e
isFunction (_, AnnNote _ e) = isFunction e
isFunction _ = False
Nothing -> [in_var])
max_out out_var lvl
- | isIdVar out_var = case lookupVarEnv lvl_env out_var of
+ | isId out_var = case lookupVarEnv lvl_env out_var of
Just lvl' -> maxLvl lvl' lvl
Nothing -> lvl
- | otherwise = lvl -- Ignore tyvars in *maxIdLevel*
+ | otherwise = lvl -- Ignore tyvars in *maxIdLevel*
lookupVar :: LevelEnv -> Id -> LevelledExpr
lookupVar (_, _, _, id_env) v = case lookupVarEnv id_env v of
-- We are going to lambda-abstract, so nuke any IdInfo,
-- and add the tyvars of the Id (if necessary)
- zap v | isIdVar v = WARN( isInlineRule (idUnfolding v) ||
+ zap v | isId v = WARN( isInlineRule (idUnfolding v) ||
not (isEmptySpecInfo (idSpecialisation v)),
text "absVarsOf: discarding info on" <+> ppr v )
setIdInfo v vanillaIdInfo
-- we must look in x's type
-- And similarly if x is a coercion variable.
absVarsOf id_env v
- | isIdVar v = [av2 | av1 <- lookup_avs v
+ | isId v = [av2 | av1 <- lookup_avs v
, av2 <- add_tyvars av1]
| isCoVar v = add_tyvars v
| otherwise = [v]
let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
return (extendPolyLvlEnv dest_lvl env abs_vars (bndrs `zip` new_bndrs), new_bndrs)
where
- mk_poly_bndr bndr uniq = transferPolyIdInfo bndr $ -- Note [transferPolyIdInfo] in Id.lhs
+ mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in Id.lhs
mkSysLocal (mkFastString str) uniq poly_ty
where
str = "poly_" ++ occNameString (getOccName bndr)
-- But do extend the in-scope env, to satisfy the in-scope invariant
cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl
- = ASSERT( isIdVar v ) do
+ = ASSERT( isId v ) do
us <- getUniqueSupplyM
let
(subst', v1) = cloneIdBndr subst us v
cloneRecVars TopLevel env vs _ _
= return (extendInScopeEnvList env vs, vs) -- Don't clone top level things
cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl
- = ASSERT( all isIdVar vs ) do
+ = ASSERT( all isId vs ) do
us <- getUniqueSupplyM
let
(subst', vs1) = cloneRecIdBndrs subst us vs
projects / ghc-hetmet.git / blobdiff