X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCorePrep.lhs;h=b8dd80f703e66e55ddfc2ae624ba0767efdb38b1;hp=db8bebc7980b41c6929f4ad6a75f86fd9808658a;hb=62eeda5aed31173b234b2965ccf4bd6979ffd9a4;hpb=a17d329568660592dad5c7668fb09f31ab77cd69 diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index db8bebc..b8dd80f 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -11,7 +11,8 @@ module CorePrep ( #include "HsVersions.h" -import CoreUtils hiding (exprIsTrivial) +import CoreUtils +import CoreArity import CoreFVs import CoreLint import CoreSyn @@ -36,6 +37,7 @@ import Util import Outputable import MonadUtils import FastString +import Control.Monad \end{code} -- --------------------------------------------------------------------------- @@ -92,10 +94,41 @@ when type erasure is done for conversion to STG, we don't end up with any trivial or useless bindings. +Invariants +~~~~~~~~~~ +Here is the syntax of the Core produced by CorePrep: --- ----------------------------------------------------------------------------- --- Top level stuff --- ----------------------------------------------------------------------------- + Trivial expressions + triv ::= lit | var | triv ty | /\a. triv | triv |> co + + Applications + app ::= lit | var | app triv | app ty | app |> co + + Expressions + body ::= app + | let(rec) x = rhs in body -- Boxed only + | case body of pat -> body + | /\a. body + | body |> co + + Right hand sides (only place where lambdas can occur) + rhs ::= /\a.rhs | \x.rhs | body + +We define a synonym for each of these non-terminals. Functions +with the corresponding name produce a result in that syntax. + +\begin{code} +type CpeTriv = CoreExpr -- Non-terminal 'triv' +type CpeApp = CoreExpr -- Non-terminal 'app' +type CpeBody = CoreExpr -- Non-terminal 'body' +type CpeRhs = CoreExpr -- Non-terminal 'rhs' +\end{code} + +%************************************************************************ +%* * + Top level stuff +%* * +%************************************************************************ \begin{code} corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind] @@ -119,15 +152,68 @@ corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr corePrepExpr dflags expr = do showPass dflags "CorePrep" us <- mkSplitUniqSupply 's' - let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr) + let new_expr = initUs_ us (cpeBodyNF emptyCorePrepEnv expr) dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr) return new_expr -\end{code} --- ----------------------------------------------------------------------------- --- Implicit bindings --- ----------------------------------------------------------------------------- +corePrepTopBinds :: [CoreBind] -> UniqSM Floats +-- Note [Floating out of top level bindings] +corePrepTopBinds binds + = go emptyCorePrepEnv binds + where + go _ [] = return emptyFloats + go env (bind : binds) = do (env', bind') <- cpeBind TopLevel env bind + binds' <- go env' binds + return (bind' `appendFloats` binds') +mkDataConWorkers :: [TyCon] -> [CoreBind] +-- See Note [Data constructor workers] +mkDataConWorkers data_tycons + = [ NonRec id (Var id) -- The ice is thin here, but it works + | tycon <- data_tycons, -- CorePrep will eta-expand it + data_con <- tyConDataCons tycon, + let id = dataConWorkId data_con ] +\end{code} + +Note [Floating out of top level bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB: we do need to float out of top-level bindings +Consider x = length [True,False] +We want to get + s1 = False : [] + s2 = True : s1 + x = length s2 + +We return a *list* of bindings, because we may start with + x* = f (g y) +where x is demanded, in which case we want to finish with + a = g y + x* = f a +And then x will actually end up case-bound + +Note [CafInfo and floating] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What happens to the CafInfo on the floated bindings? By default, all +the CafInfos will be set to MayHaveCafRefs, which is safe. + +This might be pessimistic, because the floated binding might not refer +to any CAFs and the GC will end up doing more traversal than is +necessary, but it's still better than not floating the bindings at +all, because then the GC would have to traverse the structure in the +heap instead. Given this, we decided not to try to get the CafInfo on +the floated bindings correct, because it looks difficult. + +But that means we can't float anything out of a NoCafRefs binding. +Consider f = g (h x) +If f is NoCafRefs, we don't want to convert to + sat = h x + f = g sat +where sat conservatively says HasCafRefs, because now f's info +is wrong. I don't think this is common, so we simply switch off +floating in this case. + +Note [Data constructor workers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Create any necessary "implicit" bindings for data con workers. We create the rather strange (non-recursive!) binding @@ -143,235 +229,84 @@ Hmm. Should we create bindings for dictionary constructors? They are always fully applied, and the bindings are just there to support partial applications. But it's easier to let them through. -\begin{code} -mkDataConWorkers :: [TyCon] -> [CoreBind] -mkDataConWorkers data_tycons - = [ NonRec id (Var id) -- The ice is thin here, but it works - | tycon <- data_tycons, -- CorePrep will eta-expand it - data_con <- tyConDataCons tycon, - let id = dataConWorkId data_con ] -\end{code} - - -\begin{code} --- --------------------------------------------------------------------------- --- Dealing with bindings --- --------------------------------------------------------------------------- - -data FloatingBind = FloatLet CoreBind - | FloatCase Id CoreExpr Bool - -- Invariant: the expression is not a lambda - -- The bool indicates "ok-for-speculation" - -data Floats = Floats OkToSpec (OrdList FloatingBind) - --- Can we float these binds out of the rhs of a let? We cache this decision --- to avoid having to recompute it in a non-linear way when there are --- deeply nested lets. -data OkToSpec - = NotOkToSpec -- definitely not - | OkToSpec -- yes - | IfUnboxedOk -- only if floating an unboxed binding is ok - -emptyFloats :: Floats -emptyFloats = Floats OkToSpec nilOL - -addFloat :: Floats -> FloatingBind -> Floats -addFloat (Floats ok_to_spec floats) new_float - = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float) - where - check (FloatLet _) = OkToSpec - check (FloatCase _ _ ok_for_spec) - | ok_for_spec = IfUnboxedOk - | otherwise = NotOkToSpec - -- The ok-for-speculation flag says that it's safe to - -- float this Case out of a let, and thereby do it more eagerly - -- We need the top-level flag because it's never ok to float - -- an unboxed binding to the top level - -unitFloat :: FloatingBind -> Floats -unitFloat = addFloat emptyFloats - -appendFloats :: Floats -> Floats -> Floats -appendFloats (Floats spec1 floats1) (Floats spec2 floats2) - = Floats (combine spec1 spec2) (floats1 `appOL` floats2) - -concatFloats :: [Floats] -> Floats -concatFloats = foldr appendFloats emptyFloats - -combine :: OkToSpec -> OkToSpec -> OkToSpec -combine NotOkToSpec _ = NotOkToSpec -combine _ NotOkToSpec = NotOkToSpec -combine IfUnboxedOk _ = IfUnboxedOk -combine _ IfUnboxedOk = IfUnboxedOk -combine _ _ = OkToSpec - -instance Outputable FloatingBind where - ppr (FloatLet bind) = text "FloatLet" <+> ppr bind - ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs - -deFloatTop :: Floats -> [CoreBind] --- For top level only; we don't expect any FloatCases -deFloatTop (Floats _ floats) - = foldrOL get [] floats - where - get (FloatLet b) bs = b:bs - get b _ = pprPanic "corePrepPgm" (ppr b) - -allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool -allLazy top_lvl is_rec (Floats ok_to_spec _) - = case ok_to_spec of - OkToSpec -> True - NotOkToSpec -> False - IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec --- --------------------------------------------------------------------------- --- Bindings --- --------------------------------------------------------------------------- +%************************************************************************ +%* * + The main code +%* * +%************************************************************************ -corePrepTopBinds :: [CoreBind] -> UniqSM Floats -corePrepTopBinds binds - = go emptyCorePrepEnv binds - where - go _ [] = return emptyFloats - go env (bind : binds) = do (env', bind') <- corePrepTopBind env bind - binds' <- go env' binds - return (bind' `appendFloats` binds') +\begin{code} +cpeBind :: TopLevelFlag + -> CorePrepEnv -> CoreBind + -> UniqSM (CorePrepEnv, Floats) +cpeBind top_lvl env (NonRec bndr rhs) + = do { (_, bndr1) <- cloneBndr env bndr + ; let is_strict = isStrictDmd (idNewDemandInfo bndr) + is_unlifted = isUnLiftedType (idType bndr) + ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive + (is_strict || is_unlifted) + env bndr1 rhs + ; let new_float = mkFloat is_strict is_unlifted bndr2 rhs2 --- NB: we do need to float out of top-level bindings --- Consider x = length [True,False] --- We want to get --- s1 = False : [] --- s2 = True : s1 --- x = length s2 - --- We return a *list* of bindings, because we may start with --- x* = f (g y) --- where x is demanded, in which case we want to finish with --- a = g y --- x* = f a --- And then x will actually end up case-bound --- --- What happens to the CafInfo on the floated bindings? By --- default, all the CafInfos will be set to MayHaveCafRefs, --- which is safe. --- --- This might be pessimistic, because eg. s1 & s2 --- might not refer to any CAFs and the GC will end up doing --- more traversal than is necessary, but it's still better --- than not floating the bindings at all, because then --- the GC would have to traverse the structure in the heap --- instead. Given this, we decided not to try to get --- the CafInfo on the floated bindings correct, because --- it looks difficult. - --------------------------------- -corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats) -corePrepTopBind env (NonRec bndr rhs) = do - (env', bndr') <- cloneBndr env bndr - (floats, rhs') <- corePrepRhs TopLevel NonRecursive env (bndr, rhs) - return (env', addFloat floats (FloatLet (NonRec bndr' rhs'))) - -corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs - --------------------------------- -corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats) - -- This one is used for *local* bindings -corePrepBind env (NonRec bndr rhs) = do - rhs1 <- etaExpandRhs bndr rhs - (floats, rhs2) <- corePrepExprFloat env rhs1 - (_, bndr') <- cloneBndr env bndr - (floats', bndr'') <- mkLocalNonRec bndr' (bdrDem bndr) floats rhs2 -- We want bndr'' in the envt, because it records -- the evaluated-ness of the binder - return (extendCorePrepEnv env bndr bndr'', floats') - -corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs - --------------------------------- -corePrepRecPairs :: TopLevelFlag -> CorePrepEnv - -> [(Id,CoreExpr)] -- Recursive bindings - -> UniqSM (CorePrepEnv, Floats) --- Used for all recursive bindings, top level and otherwise -corePrepRecPairs lvl env pairs = do - (env', bndrs') <- cloneBndrs env (map fst pairs) - (floats_s, rhss') <- mapAndUnzipM (corePrepRhs lvl Recursive env') pairs - return (env', unitFloat (FloatLet (Rec (flatten (concatFloats floats_s) bndrs' rhss')))) + ; return (extendCorePrepEnv env bndr bndr2, + addFloat floats new_float) } + +cpeBind top_lvl env (Rec pairs) + = do { let (bndrs,rhss) = unzip pairs + ; (env', bndrs1) <- cloneBndrs env (map fst pairs) + ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss + + ; let (floats_s, bndrs2, rhss2) = unzip3 stuff + all_pairs = foldrOL add_float (bndrs1 `zip` rhss2) + (concatFloats floats_s) + ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2), + unitFloat (FloatLet (Rec all_pairs))) } where -- Flatten all the floats, and the currrent -- group into a single giant Rec - flatten (Floats _ floats) bndrs rhss = foldrOL get (bndrs `zip` rhss) floats - - get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 - get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 - get b _ = pprPanic "corePrepRecPairs" (ppr b) - --------------------------------- -corePrepRhs :: TopLevelFlag -> RecFlag - -> CorePrepEnv -> (Id, CoreExpr) - -> UniqSM (Floats, CoreExpr) --- Used for top-level bindings, and local recursive bindings -corePrepRhs top_lvl is_rec env (bndr, rhs) = do - rhs' <- etaExpandRhs bndr rhs - floats_w_rhs <- corePrepExprFloat env rhs' - floatRhs top_lvl is_rec bndr floats_w_rhs - - --- --------------------------------------------------------------------------- --- Making arguments atomic (function args & constructor args) --- --------------------------------------------------------------------------- - --- This is where we arrange that a non-trivial argument is let-bound -corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand - -> UniqSM (Floats, CoreArg) -corePrepArg env arg dem = do - (floats, arg') <- corePrepExprFloat env arg - if exprIsTrivial arg' && allLazy NotTopLevel NonRecursive floats - -- Note [Floating unlifted arguments] - then return (floats, arg') - else do v <- newVar (exprType arg') - (floats', v') <- mkLocalNonRec v dem floats arg' - return (floats', Var v') - --- version that doesn't consider an scc annotation to be trivial. -exprIsTrivial :: CoreExpr -> Bool -exprIsTrivial (Var _) = True -exprIsTrivial (Type _) = True -exprIsTrivial (Lit _) = True -exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e -exprIsTrivial (Note (SCC _) _) = False -exprIsTrivial (Note _ e) = exprIsTrivial e -exprIsTrivial (Cast e _) = exprIsTrivial e -exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body -exprIsTrivial _ = False -\end{code} - -Note [Floating unlifted arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider C (let v* = expensive in v) - -where the "*" indicates "will be demanded". Usually v will have been -inlined by now, but let's suppose it hasn't (see Trac #2756). Then we -do *not* want to get - - let v* = expensive in C v + add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 + add_float (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 + add_float b _ = pprPanic "cpeBind" (ppr b) + +--------------- +cpePair :: TopLevelFlag -> RecFlag -> RhsDemand + -> CorePrepEnv -> Id -> CoreExpr + -> UniqSM (Floats, Id, CoreExpr) +-- Used for all bindings +cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs + = do { (floats, rhs') <- cpeRhs want_float (idArity bndr) env rhs + + -- Record if the binder is evaluated + ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding + | otherwise = bndr + + ; return (floats, bndr', rhs') } + where + want_float floats rhs + | isTopLevel top_lvl = wantFloatTop bndr floats + | otherwise = wantFloatNested is_rec is_strict_or_unlifted floats rhs -because that has different strictness. Hence the use of 'allLazy'. -(NB: the let v* turns into a FloatCase, in mkLocalNonRec.) -\begin{code} -- --------------------------------------------------------------------------- --- Dealing with expressions +-- CpeRhs: produces a result satisfying CpeRhs -- --------------------------------------------------------------------------- -corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr -corePrepAnExpr env expr = do - (floats, expr) <- corePrepExprFloat env expr - mkBinds floats expr - - -corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr) +cpeRhs :: (Floats -> CpeRhs -> Bool) -- Float the floats out + -> Arity -- Guarantees an Rhs with this manifest arity + -> CorePrepEnv + -> CoreExpr -- Expression and its type + -> UniqSM (Floats, CpeRhs) +cpeRhs want_float arity env expr + = do { (floats, rhs) <- cpeRhsE env expr + ; if want_float floats rhs + then return (floats, cpeEtaExpand arity rhs) + else return (emptyFloats, cpeEtaExpand arity (wrapBinds floats rhs)) } + +cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- If -- e ===> (bs, e') -- then @@ -380,76 +315,115 @@ corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr) -- For example -- f (g x) ===> ([v = g x], f v) -corePrepExprFloat env (Var v) = do - v1 <- fiddleCCall v - let - v2 = lookupCorePrepEnv env v1 - maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2) +cpeRhsE _env expr@(Type _) = return (emptyFloats, expr) +cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr) +cpeRhsE env expr@(App {}) = cpeApp env expr +cpeRhsE env expr@(Var {}) = cpeApp env expr + +cpeRhsE env (Let bind expr) + = do { (env', new_binds) <- cpeBind NotTopLevel env bind + ; (floats, body) <- cpeRhsE env' expr + ; return (new_binds `appendFloats` floats, body) } + +cpeRhsE env (Note note expr) + | ignoreNote note + = cpeRhsE env expr + | otherwise -- Just SCCs actually + = do { body <- cpeBodyNF env expr + ; return (emptyFloats, Note note body) } + +cpeRhsE env (Cast expr co) + = do { (floats, expr') <- cpeRhsE env expr + ; return (floats, Cast expr' co) } + +cpeRhsE env expr@(Lam {}) + = do { let (bndrs,body) = collectBinders expr + ; (env', bndrs') <- cloneBndrs env bndrs + ; body' <- cpeBodyNF env' body + ; return (emptyFloats, mkLams bndrs' body') } + +cpeRhsE env (Case (Var id) bndr ty [(DEFAULT,[],expr)]) + | Just (TickBox {}) <- isTickBoxOp_maybe id + = do { body <- cpeBodyNF env expr + ; return (emptyFloats, Case (Var id) bndr ty [(DEFAULT,[],body)]) } + +cpeRhsE env (Case scrut bndr ty alts) + = do { (floats, scrut') <- cpeBody env scrut + ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding + -- Record that the case binder is evaluated in the alternatives + ; (env', bndr2) <- cloneBndr env bndr1 + ; alts' <- mapM (sat_alt env') alts + ; return (floats, Case scrut' bndr2 ty alts') } + where + sat_alt env (con, bs, rhs) + = do { (env2, bs') <- cloneBndrs env bs + ; rhs' <- cpeBodyNF env2 rhs + ; return (con, bs', rhs') } -corePrepExprFloat _env expr@(Type _) - = return (emptyFloats, expr) +-- --------------------------------------------------------------------------- +-- CpeBody: produces a result satisfying CpeBody +-- --------------------------------------------------------------------------- -corePrepExprFloat _env expr@(Lit _) - = return (emptyFloats, expr) +cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody +cpeBodyNF env expr + = do { (floats, body) <- cpeBody env expr + ; return (wrapBinds floats body) } -corePrepExprFloat env (Let bind body) = do - (env', new_binds) <- corePrepBind env bind - (floats, new_body) <- corePrepExprFloat env' body - return (new_binds `appendFloats` floats, new_body) +-------- +cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody) +cpeBody env expr + = do { (floats1, rhs) <- cpeRhsE env expr + ; (floats2, body) <- rhsToBody rhs + ; return (floats1 `appendFloats` floats2, body) } -corePrepExprFloat env (Note n@(SCC _) expr) = do - expr1 <- corePrepAnExpr env expr - (floats, expr2) <- deLamFloat expr1 - return (floats, Note n expr2) +-------- +rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody) +-- Remove top level lambdas by let-bindinig -corePrepExprFloat env (Note other_note expr) = do - (floats, expr') <- corePrepExprFloat env expr - return (floats, Note other_note expr') +rhsToBody (Note n expr) + -- You can get things like + -- case e of { p -> coerce t (\s -> ...) } + = do { (floats, expr') <- rhsToBody expr + ; return (floats, Note n expr') } -corePrepExprFloat env (Cast expr co) = do - (floats, expr') <- corePrepExprFloat env expr - return (floats, Cast expr' co) +rhsToBody (Cast e co) + = do { (floats, e') <- rhsToBody e + ; return (floats, Cast e' co) } -corePrepExprFloat env expr@(Lam _ _) = do - (env', bndrs') <- cloneBndrs env bndrs - body' <- corePrepAnExpr env' body - return (emptyFloats, mkLams bndrs' body') +rhsToBody expr@(Lam {}) + | Just no_lam_result <- tryEtaReduce bndrs body + = return (emptyFloats, no_lam_result) + | all isTyVar bndrs -- Type lambdas are ok + = return (emptyFloats, expr) + | otherwise -- Some value lambdas + = do { fn <- newVar (exprType expr) + ; let rhs = cpeEtaExpand (exprArity expr) expr + float = FloatLet (NonRec fn rhs) + ; return (unitFloat float, Var fn) } where (bndrs,body) = collectBinders expr -corePrepExprFloat env (Case (Var id) bndr ty [(DEFAULT,[],expr)]) - | Just (TickBox {}) <- isTickBoxOp_maybe id = do - expr1 <- corePrepAnExpr env expr - (floats, expr2) <- deLamFloat expr1 - return (floats, Case (Var id) bndr ty [(DEFAULT,[],expr2)]) - -corePrepExprFloat env (Case scrut bndr ty alts) = do - (floats1, scrut1) <- corePrepExprFloat env scrut - (floats2, scrut2) <- deLamFloat scrut1 - let - bndr1 = bndr `setIdUnfolding` evaldUnfolding - -- Record that the case binder is evaluated in the alternatives - (env', bndr2) <- cloneBndr env bndr1 - alts' <- mapM (sat_alt env') alts - return (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts') - where - sat_alt env (con, bs, rhs) = do - (env2, bs') <- cloneBndrs env bs - rhs1 <- corePrepAnExpr env2 rhs - rhs2 <- deLam rhs1 - return (con, bs', rhs2) +rhsToBody expr = return (emptyFloats, expr) + -corePrepExprFloat env expr@(App _ _) = do - (app, (head,depth), ty, floats, ss) <- collect_args expr 0 - MASSERT(null ss) -- make sure we used all the strictness info + +-- --------------------------------------------------------------------------- +-- CpeApp: produces a result satisfying CpeApp +-- --------------------------------------------------------------------------- + +cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) +-- May return a CpeRhs because of saturating primops +cpeApp env expr + = do { (app, (head,depth), _, floats, ss) <- collect_args expr 0 + ; MASSERT(null ss) -- make sure we used all the strictness info -- Now deal with the function - case head of - Var fn_id -> maybeSaturate fn_id app depth floats ty - _other -> return (floats, app) + ; case head of + Var fn_id -> do { sat_app <- maybeSaturate fn_id app depth + ; return (floats, sat_app) } + _other -> return (floats, app) } where - -- Deconstruct and rebuild the application, floating any non-atomic -- arguments to the outside. We collect the type of the expression, -- the head of the application, and the number of actual value arguments, @@ -458,34 +432,34 @@ corePrepExprFloat env expr@(App _ _) = do collect_args :: CoreExpr - -> Int -- current app depth - -> UniqSM (CoreExpr, -- the rebuilt expression - (CoreExpr,Int), -- the head of the application, - -- and no. of args it was applied to - Type, -- type of the whole expr - Floats, -- any floats we pulled out - [Demand]) -- remaining argument demands - - collect_args (App fun arg@(Type arg_ty)) depth = do - (fun',hd,fun_ty,floats,ss) <- collect_args fun depth - return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) - - collect_args (App fun arg) depth = do - (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1) - let + -> Int -- Current app depth + -> UniqSM (CpeApp, -- The rebuilt expression + (CoreExpr,Int), -- The head of the application, + -- and no. of args it was applied to + Type, -- Type of the whole expr + Floats, -- Any floats we pulled out + [Demand]) -- Remaining argument demands + + collect_args (App fun arg@(Type arg_ty)) depth + = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth + ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) } + + collect_args (App fun arg) depth + = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1) + ; let (ss1, ss_rest) = case ss of (ss1:ss_rest) -> (ss1, ss_rest) [] -> (lazyDmd, []) - (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $ + (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $ splitFunTy_maybe fun_ty - (fs, arg') <- corePrepArg env arg (mkDemTy ss1 arg_ty) - return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) + ; (fs, arg') <- cpeArg env (isStrictDmd ss1) arg arg_ty + ; return (App fun' arg', hd, res_ty, fs `appendFloats` floats, ss_rest) } - collect_args (Var v) depth = do - v1 <- fiddleCCall v - let v2 = lookupCorePrepEnv env v1 - return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) + collect_args (Var v) depth + = do { v1 <- fiddleCCall v + ; let v2 = lookupCorePrepEnv env v1 + ; return (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) } where stricts = case idNewStrictness v of StrictSig (DmdType _ demands _) @@ -498,254 +472,209 @@ corePrepExprFloat env expr@(App _ _) = do -- Here, we can't evaluate the arg strictly, because this -- partial application might be seq'd - collect_args (Cast fun co) depth = do - let (_ty1,ty2) = coercionKind co - (fun', hd, _, floats, ss) <- collect_args fun depth - return (Cast fun' co, hd, ty2, floats, ss) + collect_args (Cast fun co) depth + = do { let (_ty1,ty2) = coercionKind co + ; (fun', hd, _, floats, ss) <- collect_args fun depth + ; return (Cast fun' co, hd, ty2, floats, ss) } collect_args (Note note fun) depth - | ignore_note note = do -- Drop these notes altogether - -- They aren't used by the code generator - (fun', hd, fun_ty, floats, ss) <- collect_args fun depth - return (fun', hd, fun_ty, floats, ss) + | ignoreNote note -- Drop these notes altogether + = collect_args fun depth -- They aren't used by the code generator -- N-variable fun, better let-bind it -- ToDo: perhaps we can case-bind rather than let-bind this closure, -- since it is sure to be evaluated. - collect_args fun depth = do - (fun_floats, fun') <- corePrepExprFloat env fun - fn_id <- newVar ty - (floats, fn_id') <- mkLocalNonRec fn_id onceDem fun_floats fun' - return (Var fn_id', (Var fn_id', depth), ty, floats, []) + collect_args fun depth + = do { (fun_floats, fun') <- cpeArg env True fun ty + ; return (fun', (fun', depth), ty, fun_floats, []) } where ty = exprType fun - ignore_note (CoreNote _) = True - ignore_note InlineMe = True - ignore_note _other = False - -- We don't ignore SCCs, since they require some code generation +-- --------------------------------------------------------------------------- +-- CpeArg: produces a result satisfying CpeArg +-- --------------------------------------------------------------------------- + +-- This is where we arrange that a non-trivial argument is let-bound +cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type + -> UniqSM (Floats, CpeTriv) +cpeArg env is_strict arg arg_ty + | cpe_ExprIsTrivial arg -- Do not eta expand etc a trivial argument + = cpeBody env arg -- Must still do substitution though + | otherwise + = do { (floats, arg') <- cpeRhs want_float + (exprArity arg) env arg + ; v <- newVar arg_ty + ; let arg_float = mkFloat is_strict is_unlifted v arg' + ; return (addFloat floats arg_float, Var v) } + where + is_unlifted = isUnLiftedType arg_ty + want_float = wantFloatNested NonRecursive (is_strict || is_unlifted) +\end{code} + +Note [Floating unlifted arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider C (let v* = expensive in v) + +where the "*" indicates "will be demanded". Usually v will have been +inlined by now, but let's suppose it hasn't (see Trac #2756). Then we +do *not* want to get + + let v* = expensive in C v + +because that has different strictness. Hence the use of 'allLazy'. +(NB: the let v* turns into a FloatCase, in mkLocalNonRec.) + ------------------------------------------------------------------------------ -- Building the saturated syntax -- --------------------------------------------------------------------------- --- maybeSaturate deals with saturating primops and constructors --- The type is the type of the entire application -maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr) -maybeSaturate fn expr n_args floats ty +maybeSaturate deals with saturating primops and constructors +The type is the type of the entire application + +\begin{code} +maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs +maybeSaturate fn expr n_args | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg -- A gruesome special case - = do sat_expr <- saturate_it + = saturateDataToTag sat_expr - -- OK, now ensure that the arg is evaluated. - -- But (sigh) take into account the lambdas we've now introduced - let (eta_bndrs, eta_body) = collectBinders sat_expr - (eta_floats, eta_body') <- eval_data2tag_arg eta_body - if null eta_bndrs then - return (floats `appendFloats` eta_floats, eta_body') - else do - eta_body'' <- mkBinds eta_floats eta_body' - return (floats, mkLams eta_bndrs eta_body'') - - | hasNoBinding fn = do sat_expr <- saturate_it - return (floats, sat_expr) - - | otherwise = return (floats, expr) + | hasNoBinding fn -- There's no binding + = return sat_expr + | otherwise + = return expr where fn_arity = idArity fn excess_arity = fn_arity - n_args - - saturate_it :: UniqSM CoreExpr - saturate_it | excess_arity == 0 = return expr - | otherwise = do us <- getUniquesM - return (etaExpand excess_arity us expr ty) - - -- Ensure that the argument of DataToTagOp is evaluated - eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr) + sat_expr = cpeEtaExpand excess_arity expr + +------------- +saturateDataToTag :: CpeApp -> UniqSM CpeApp +-- Horrid: ensure that the arg of data2TagOp is evaluated +-- (data2tag x) --> (case x of y -> data2tag y) +-- (yuk yuk) take into account the lambdas we've now introduced +saturateDataToTag sat_expr + = do { let (eta_bndrs, eta_body) = collectBinders sat_expr + ; eta_body' <- eval_data2tag_arg eta_body + ; return (mkLams eta_bndrs eta_body') } + where + eval_data2tag_arg :: CpeApp -> UniqSM CpeBody eval_data2tag_arg app@(fun `App` arg) | exprIsHNF arg -- Includes nullary constructors - = return (emptyFloats, app) -- The arg is evaluated + = return app -- The arg is evaluated | otherwise -- Arg not evaluated, so evaluate it - = do arg_id <- newVar (exprType arg) - let - arg_id1 = setIdUnfolding arg_id evaldUnfolding - return (unitFloat (FloatCase arg_id1 arg False ), - fun `App` Var arg_id1) + = do { arg_id <- newVar (exprType arg) + ; let arg_id1 = setIdUnfolding arg_id evaldUnfolding + ; return (Case arg arg_id1 (exprType app) + [(DEFAULT, [], fun `App` Var arg_id1)]) } eval_data2tag_arg (Note note app) -- Scc notes can appear - = do (floats, app') <- eval_data2tag_arg app - return (floats, Note note app') + = do { app' <- eval_data2tag_arg app + ; return (Note note app') } eval_data2tag_arg other -- Should not happen = pprPanic "eval_data2tag" (ppr other) +\end{code} --- --------------------------------------------------------------------------- --- Precipitating the floating bindings --- --------------------------------------------------------------------------- - -floatRhs :: TopLevelFlag -> RecFlag - -> Id - -> (Floats, CoreExpr) -- Rhs: let binds in body - -> UniqSM (Floats, -- Floats out of this bind - CoreExpr) -- Final Rhs - -floatRhs top_lvl is_rec _bndr (floats, rhs) - | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or - allLazy top_lvl is_rec floats -- at top level - = -- Why the test for allLazy? - -- v = f (x `divInt#` y) - -- we don't want to float the case, even if f has arity 2, - -- because floating the case would make it evaluated too early - return (floats, rhs) - - | otherwise = do - -- Don't float; the RHS isn't a value - rhs' <- mkBinds floats rhs - return (emptyFloats, rhs') - --- mkLocalNonRec is used only for *nested*, *non-recursive* bindings -mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand - -> Floats -> CoreExpr -- Rhs: let binds in body - -> UniqSM (Floats, Id) -- The new Id may have an evaldUnfolding, - -- to record that it's been evaluated - -mkLocalNonRec bndr dem floats rhs - | isUnLiftedType (idType bndr) - -- If this is an unlifted binding, we always make a case for it. - = ASSERT( not (isUnboxedTupleType (idType bndr)) ) - let - float = FloatCase bndr rhs (exprOkForSpeculation rhs) - in - return (addFloat floats float, evald_bndr) - - | isStrict dem - -- It's a strict let so we definitely float all the bindings - = let -- Don't make a case for a value binding, - -- even if it's strict. Otherwise we get - -- case (\x -> e) of ...! - float | exprIsHNF rhs = FloatLet (NonRec bndr rhs) - | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs) - in - return (addFloat floats float, evald_bndr) - - | otherwise - = do (floats', rhs') <- floatRhs NotTopLevel NonRecursive bndr (floats, rhs) - return (addFloat floats' (FloatLet (NonRec bndr rhs')), - if exprIsHNF rhs' then evald_bndr else bndr) - - where - evald_bndr = bndr `setIdUnfolding` evaldUnfolding - -- Record if the binder is evaluated - - -mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr --- Lambdas are not allowed as the body of a 'let' -mkBinds (Floats _ binds) body - | isNilOL binds = return body - | otherwise = do { body' <- deLam body - ; return (wrapBinds binds body') } - -wrapBinds :: OrdList FloatingBind -> CoreExpr -> CoreExpr -wrapBinds binds body - = foldrOL mk_bind body binds - where - mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)] - mk_bind (FloatLet bind) body = Let bind body - ---------------------- -etaExpandRhs :: CoreBndr -> CoreExpr -> UniqSM CoreExpr -etaExpandRhs bndr rhs = do - -- Eta expand to match the arity claimed by the binder - -- Remember, CorePrep must not change arity - -- - -- Eta expansion might not have happened already, - -- because it is done by the simplifier only when - -- there at least one lambda already. - -- - -- NB1:we could refrain when the RHS is trivial (which can happen - -- for exported things). This would reduce the amount of code - -- generated (a little) and make things a little words for - -- code compiled without -O. The case in point is data constructor - -- wrappers. - -- - -- NB2: we have to be careful that the result of etaExpand doesn't - -- invalidate any of the assumptions that CorePrep is attempting - -- to establish. One possible cause is eta expanding inside of - -- an SCC note - we're now careful in etaExpand to make sure the - -- SCC is pushed inside any new lambdas that are generated. - -- - -- NB3: It's important to do eta expansion, and *then* ANF-ising - -- f = /\a -> g (h 3) -- h has arity 2 - -- If we ANF first we get - -- f = /\a -> let s = h 3 in g s - -- and now eta expansion gives - -- f = /\a -> \ y -> (let s = h 3 in g s) y - -- which is horrible. - -- Eta expanding first gives - -- f = /\a -> \y -> let s = h 3 in g s y - -- - us <- getUniquesM - let eta_rhs = etaExpand arity us rhs (idType bndr) - - ASSERT2( manifestArity eta_rhs == arity, (ppr bndr <+> ppr arity <+> ppr (exprArity rhs)) - $$ ppr rhs $$ ppr eta_rhs ) - -- Assertion checks that eta expansion was successful - return eta_rhs - where - -- For a GlobalId, take the Arity from the Id. - -- It was set in CoreTidy and must not change - -- For all others, just expand at will - arity | isGlobalId bndr = idArity bndr - | otherwise = exprArity rhs --- --------------------------------------------------------------------------- --- Eliminate Lam as a non-rhs (STG doesn't have such a thing) --- We arrange that they only show up as the RHS of a let(rec) --- --------------------------------------------------------------------------- -deLam :: CoreExpr -> UniqSM CoreExpr --- Takes an expression that may be a lambda, --- and returns one that definitely isn't: --- (\x.e) ==> let f = \x.e in f -deLam expr = do - (Floats _ binds, expr) <- deLamFloat expr - return (wrapBinds binds expr) +%************************************************************************ +%* * + Simple CoreSyn operations +%* * +%************************************************************************ +\begin{code} + -- We don't ignore SCCs, since they require some code generation +ignoreNote :: Note -> Bool +-- Tells which notes to drop altogether; they are ignored by code generation +-- Do not ignore SCCs! +-- It's important that we do drop InlineMe notes; for example +-- unzip = __inline_me__ (/\ab. foldr (..) (..)) +-- Here unzip gets arity 1 so we'll eta-expand it. But we don't +-- want to get this: +-- unzip = /\ab \xs. (__inline_me__ ...) a b xs +ignoreNote (CoreNote _) = True +ignoreNote InlineMe = True +ignoreNote _other = False + + +cpe_ExprIsTrivial :: CoreExpr -> Bool +-- Version that doesn't consider an scc annotation to be trivial. +cpe_ExprIsTrivial (Var _) = True +cpe_ExprIsTrivial (Type _) = True +cpe_ExprIsTrivial (Lit _) = True +cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e +cpe_ExprIsTrivial (Note (SCC _) _) = False +cpe_ExprIsTrivial (Note _ e) = cpe_ExprIsTrivial e +cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e +cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body +cpe_ExprIsTrivial _ = False +\end{code} -deLamFloat :: CoreExpr -> UniqSM (Floats, CoreExpr) --- Remove top level lambdas by let-bindinig +-- ----------------------------------------------------------------------------- +-- Eta reduction +-- ----------------------------------------------------------------------------- -deLamFloat (Note n expr) = do - -- You can get things like - -- case e of { p -> coerce t (\s -> ...) } - (floats, expr') <- deLamFloat expr - return (floats, Note n expr') +Note [Eta expansion] +~~~~~~~~~~~~~~~~~~~~~ +Eta expand to match the arity claimed by the binder Remember, +CorePrep must not change arity + +Eta expansion might not have happened already, because it is done by +the simplifier only when there at least one lambda already. + +NB1:we could refrain when the RHS is trivial (which can happen + for exported things). This would reduce the amount of code + generated (a little) and make things a little words for + code compiled without -O. The case in point is data constructor + wrappers. + +NB2: we have to be careful that the result of etaExpand doesn't + invalidate any of the assumptions that CorePrep is attempting + to establish. One possible cause is eta expanding inside of + an SCC note - we're now careful in etaExpand to make sure the + SCC is pushed inside any new lambdas that are generated. + +Note [Eta expansion and the CorePrep invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It turns out to be much much easier to do eta expansion +*after* the main CorePrep stuff. But that places constraints +on the eta expander: given a CpeRhs, it must return a CpeRhs. + +For example here is what we do not want: + f = /\a -> g (h 3) -- h has arity 2 +After ANFing we get + f = /\a -> let s = h 3 in g s +and now we do NOT want eta expansion to give + f = /\a -> \ y -> (let s = h 3 in g s) y + +Instead CoreArity.etaExpand gives + f = /\a -> \y -> let s = h 3 in g s y -deLamFloat (Cast e co) = do - (floats, e') <- deLamFloat e - return (floats, Cast e' co) +\begin{code} +cpeEtaExpand :: Arity -> CoreExpr -> CoreExpr +cpeEtaExpand arity expr + | arity == 0 = expr + | otherwise = etaExpand arity expr +\end{code} -deLamFloat expr - | null bndrs = return (emptyFloats, expr) - | otherwise - = case tryEta bndrs body of - Just no_lam_result -> return (emptyFloats, no_lam_result) - Nothing -> do fn <- newVar (exprType expr) - return (unitFloat (FloatLet (NonRec fn expr)), - Var fn) - where - (bndrs,body) = collectBinders expr +-- ----------------------------------------------------------------------------- +-- Eta reduction +-- ----------------------------------------------------------------------------- --- Why try eta reduction? Hasn't the simplifier already done eta? --- But the simplifier only eta reduces if that leaves something --- trivial (like f, or f Int). But for deLam it would be enough to --- get to a partial application: --- \xs. map f xs ==> map f +Why try eta reduction? Hasn't the simplifier already done eta? +But the simplifier only eta reduces if that leaves something +trivial (like f, or f Int). But for deLam it would be enough to +get to a partial application: + case x of { p -> \xs. map f xs } + ==> case x of { p -> map f } -tryEta :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr -tryEta bndrs expr@(App _ _) +\begin{code} +tryEtaReduce :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr +tryEtaReduce bndrs expr@(App _ _) | ok_to_eta_reduce f && n_remaining >= 0 && and (zipWith ok bndrs last_args) && @@ -765,15 +694,15 @@ tryEta bndrs expr@(App _ _) ok_to_eta_reduce (Var f) = not (hasNoBinding f) ok_to_eta_reduce _ = False --safe. ToDo: generalise -tryEta bndrs (Let bind@(NonRec _ r) body) +tryEtaReduce bndrs (Let bind@(NonRec _ r) body) | not (any (`elemVarSet` fvs) bndrs) - = case tryEta bndrs body of + = case tryEtaReduce bndrs body of Just e -> Just (Let bind e) Nothing -> Nothing where fvs = exprFreeVars r -tryEta _ _ = Nothing +tryEtaReduce _ _ = Nothing \end{code} @@ -782,35 +711,121 @@ tryEta _ _ = Nothing -- ----------------------------------------------------------------------------- \begin{code} -data RhsDemand - = RhsDemand { isStrict :: Bool, -- True => used at least once - _isOnceDem :: Bool -- True => used at most once - } +type RhsDemand = Bool -- True => used strictly; hence not top-level, non-recursive +\end{code} -mkDem :: Demand -> Bool -> RhsDemand -mkDem strict once = RhsDemand (isStrictDmd strict) once +%************************************************************************ +%* * + Floats +%* * +%************************************************************************ -mkDemTy :: Demand -> Type -> RhsDemand -mkDemTy strict _ty = RhsDemand (isStrictDmd strict) - False {- For now -} +\begin{code} +data FloatingBind + = FloatLet CoreBind -- Rhs of bindings are CpeRhss + | FloatCase Id CpeBody Bool -- The bool indicates "ok-for-speculation" + +data Floats = Floats OkToSpec (OrdList FloatingBind) + +-- Can we float these binds out of the rhs of a let? We cache this decision +-- to avoid having to recompute it in a non-linear way when there are +-- deeply nested lets. +data OkToSpec + = NotOkToSpec -- definitely not + | OkToSpec -- yes + | IfUnboxedOk -- only if floating an unboxed binding is ok -bdrDem :: Id -> RhsDemand -bdrDem id = mkDem (idNewDemandInfo id) - False {- For now -} +mkFloat :: Bool -> Bool -> Id -> CpeRhs -> FloatingBind +mkFloat is_strict is_unlifted bndr rhs + | use_case = FloatCase bndr rhs (exprOkForSpeculation rhs) + | otherwise = FloatLet (NonRec bndr rhs) + where + use_case = is_unlifted || is_strict && not (exprIsHNF rhs) + -- Don't make a case for a value binding, + -- even if it's strict. Otherwise we get + -- case (\x -> e) of ...! + +emptyFloats :: Floats +emptyFloats = Floats OkToSpec nilOL --- safeDem :: RhsDemand --- safeDem = RhsDemand False False -- always safe to use this +wrapBinds :: Floats -> CoreExpr -> CoreExpr +wrapBinds (Floats _ binds) body + = foldrOL mk_bind body binds + where + mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)] + mk_bind (FloatLet bind) body = Let bind body -onceDem :: RhsDemand -onceDem = RhsDemand False True -- used at most once -\end{code} +addFloat :: Floats -> FloatingBind -> Floats +addFloat (Floats ok_to_spec floats) new_float + = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float) + where + check (FloatLet _) = OkToSpec + check (FloatCase _ _ ok_for_spec) + | ok_for_spec = IfUnboxedOk + | otherwise = NotOkToSpec + -- The ok-for-speculation flag says that it's safe to + -- float this Case out of a let, and thereby do it more eagerly + -- We need the top-level flag because it's never ok to float + -- an unboxed binding to the top level + +unitFloat :: FloatingBind -> Floats +unitFloat = addFloat emptyFloats + +appendFloats :: Floats -> Floats -> Floats +appendFloats (Floats spec1 floats1) (Floats spec2 floats2) + = Floats (combine spec1 spec2) (floats1 `appOL` floats2) + +concatFloats :: [Floats] -> OrdList FloatingBind +concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL + +combine :: OkToSpec -> OkToSpec -> OkToSpec +combine NotOkToSpec _ = NotOkToSpec +combine _ NotOkToSpec = NotOkToSpec +combine IfUnboxedOk _ = IfUnboxedOk +combine _ IfUnboxedOk = IfUnboxedOk +combine _ _ = OkToSpec + +instance Outputable FloatingBind where + ppr (FloatLet bind) = text "FloatLet" <+> ppr bind + ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs +deFloatTop :: Floats -> [CoreBind] +-- For top level only; we don't expect any FloatCases +deFloatTop (Floats _ floats) + = foldrOL get [] floats + where + get (FloatLet b) bs = b:bs + get b _ = pprPanic "corePrepPgm" (ppr b) +------------------------------------------- +wantFloatTop :: Id -> Floats -> Bool + -- Note [CafInfo and floating] +wantFloatTop bndr floats = mayHaveCafRefs (idCafInfo bndr) + && allLazyTop floats + +wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool +wantFloatNested is_rec strict_or_unlifted floats rhs + = strict_or_unlifted + || (allLazyNested is_rec floats && exprIsHNF rhs) + -- Why the test for allLazyNested? + -- v = f (x `divInt#` y) + -- we don't want to float the case, even if f has arity 2, + -- because floating the case would make it evaluated too early + +allLazyTop :: Floats -> Bool +allLazyTop (Floats OkToSpec _) = True +allLazyTop _ = False + +allLazyNested :: RecFlag -> Floats -> Bool +allLazyNested _ (Floats OkToSpec _) = True +allLazyNested _ (Floats NotOkToSpec _) = False +allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec +\end{code} %************************************************************************ %* * -\subsection{Cloning} + Cloning %* * %************************************************************************ @@ -827,6 +842,9 @@ emptyCorePrepEnv = CPE emptyVarEnv extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv extendCorePrepEnv (CPE env) id id' = CPE (extendVarEnv env id id') +extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv +extendCorePrepEnvList (CPE env) prs = CPE (extendVarEnvList env prs) + lookupCorePrepEnv :: CorePrepEnv -> Id -> Id lookupCorePrepEnv (CPE env) id = case lookupVarEnv env id of