@lvlMFE@ is just like @lvlExpr@, except that it might let-bind
the expression, so that it can itself be floated.
-[NOTE: unlifted MFEs]
+Note [Unlifted MFEs]
+~~~~~~~~~~~~~~~~~~~~~
We don't float unlifted MFEs, which potentially loses big opportunites.
For example:
\x -> f (h y)
where h :: Int -> Int# is expensive. We'd like to float the (h y) outside
the \x, but we don't because it's unboxed. Possible solution: box it.
+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
lvlMFE _ _ _ (_, AnnType ty)
= return (Type ty)
+-- No point in floating out an expression wrapped in a coercion;
+-- If we do we'll transform lvl = e |> co
+-- to lvl' = e; lvl = lvl' |> co
+-- and then inline lvl. Better just to float out the payload.
+lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e co)
+ = do { expr' <- lvlMFE strict_ctxt ctxt_lvl env e
+ ; return (Cast expr' 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]
+ | isUnLiftedType ty -- Can't let-bind it; see Note [Unlifted MFEs]
|| isInlineCtxt ctxt_lvl -- Don't float out of an __inline__ context
|| exprIsTrivial expr -- Never float if it's trivial
|| not good_destination
-> LvlM (LevelledBind, LevelEnv)
lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
- | isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe
+ | isTyVar bndr -- Don't do anything for TyVar binders
+ -- (simplifier gets rid of them pronto)
+ || isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe
= do rhs' <- lvlExpr ctxt_lvl env rhs
return (NonRec (TB bndr ctxt_lvl) rhs', env)
[] bndrs
where
go old_lvl bumped_major rev_lvld_bndrs (bndr:bndrs)
- | isId 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
initialEnv float_lams = (float_lams, emptyVarEnv, emptySubst, emptyVarEnv)
floatLams :: LevelEnv -> Bool
-floatLams (FloatOutSw float_lams _, _, _, _) = float_lams
+floatLams (fos, _, _, _) = floatOutLambdas fos
floatConsts :: LevelEnv -> Bool
-floatConsts (FloatOutSw _ float_consts, _, _, _) = float_consts
+floatConsts (fos, _, _, _) = floatOutConstants fos
extendLvlEnv :: LevelEnv -> [TaggedBndr Level] -> LevelEnv
-- Used when *not* cloning
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)