X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCorePrep.lhs;h=04057160b8f27d81e545c24e80c25a5d239d47ca;hp=db8bebc7980b41c6929f4ad6a75f86fd9808658a;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hpb=85f8276b368d39c93e137fa7b0a8a96ab3c6b389 diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index db8bebc..0405716 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -11,14 +11,18 @@ module CorePrep ( #include "HsVersions.h" -import CoreUtils hiding (exprIsTrivial) +import PrelNames ( lazyIdKey, hasKey ) +import CoreUtils +import CoreArity import CoreFVs -import CoreLint +import CoreMonad ( endPass, CoreToDo(..) ) import CoreSyn +import CoreSubst +import OccurAnal ( occurAnalyseExpr ) import Type import Coercion import TyCon -import NewDemand +import Demand import Var import VarSet import VarEnv @@ -33,9 +37,12 @@ import OrdList import ErrUtils import DynFlags import Util +import Pair import Outputable import MonadUtils import FastString +import Data.List ( mapAccumL ) +import Control.Monad \end{code} -- --------------------------------------------------------------------------- @@ -72,9 +79,9 @@ The goal of this pass is to prepare for code generation. weaker guarantee of no clashes which the simplifier provides. And that is what the code generator needs. - We don't clone TyVars. The code gen doesn't need that, + We don't clone TyVars or CoVars. The code gen doesn't need that, and doing so would be tiresome because then we'd need - to substitute in types. + to substitute in types and coercions. 7. Give each dynamic CCall occurrence a fresh unique; this is @@ -83,19 +90,53 @@ The goal of this pass is to prepare for code generation. 8. Inject bindings for the "implicit" Ids: * Constructor wrappers * Constructor workers - * Record selectors We want curried definitions for all of these in case they aren't inlined by some caller. +9. Replace (lazy e) by e. See Note [lazyId magic] in MkId.lhs + This is all done modulo type applications and abstractions, so that 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 + | truv co | /\c. triv | triv |> co + + Applications + app ::= lit | var | app triv | app ty | app co | app |> co + + Expressions + body ::= app + | let(rec) x = rhs in body -- Boxed only + | case body of pat -> body + | /\a. body | /\c. body + | body |> co + + Right hand sides (only place where value 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] @@ -112,22 +153,89 @@ corePrepPgm dflags binds data_tycons = do floats2 <- corePrepTopBinds implicit_binds return (deFloatTop (floats1 `appendFloats` floats2)) - endPass dflags "CorePrep" Opt_D_dump_prep binds_out + endPass dflags CorePrep binds_out [] return binds_out 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 when we try to float bindings to the top level? At this +point all the CafInfo is supposed to be correct, and we must make certain +that is true of the new top-level bindings. There are two cases +to consider + +a) The top-level binding is marked asCafRefs. In that case we are + basically fine. The floated bindings had better all be lazy lets, + so they can float to top level, but they'll all have HasCafRefs + (the default) which is safe. + +b) The top-level binding is marked NoCafRefs. This really happens + Example. CoreTidy produces + $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah... + Now CorePrep has to eta-expand to + $fApplicativeSTM = let sat = \xy. retry x y + in D:Alternative sat ...blah... + So what we *want* is + sat [NoCafRefs] = \xy. retry x y + $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah... + + So, gruesomely, we must set the NoCafRefs flag on the sat bindings, + *and* substutite the modified 'sat' into the old RHS. + + It should be the case that 'sat' is itself [NoCafRefs] (a value, no + cafs) else the original top-level binding would not itself have been + marked [NoCafRefs]. The DEBUG check in CoreToStg for + consistentCafInfo will find this. + +This is all very gruesome and horrible. It would be better to figure +out CafInfo later, after CorePrep. We'll do that in due course. +Meanwhile this horrible hack works. + + +Note [Data constructor workers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Create any necessary "implicit" bindings for data con workers. We create the rather strange (non-recursive!) binding @@ -143,235 +251,190 @@ 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 --- --------------------------------------------------------------------------- +Note [Dead code in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Imagine that we got an input program like this: -data FloatingBind = FloatLet CoreBind - | FloatCase Id CoreExpr Bool - -- Invariant: the expression is not a lambda - -- The bool indicates "ok-for-speculation" + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g True (Just x) + g () (Just x), g) + where + g :: Show a => a -> Maybe Int -> Int + g _ Nothing = x + g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown -data Floats = Floats OkToSpec (OrdList FloatingBind) +After specialisation and SpecConstr, we would get something like this: --- 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 + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g) + where + {-# RULES g $dBool = g$Bool + g $dUnit = g$Unit #-} + g = ... + {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-} + g$Bool = ... + {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-} + g$Unit = ... + g$Bool_True_Just = ... + g$Unit_Unit_Just = ... -emptyFloats :: Floats -emptyFloats = Floats OkToSpec nilOL +Note that the g$Bool and g$Unit functions are actually dead code: they are only kept +alive by the occurrence analyser because they are referred to by the rules of g, +which is being kept alive by the fact that it is used (unspecialised) in the returned pair. -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 +However, at the CorePrep stage there is no way that the rules for g will ever fire, +and it really seems like a shame to produce an output program that goes to the trouble +of allocating a closure for the unreachable g$Bool and g$Unit functions. -unitFloat :: FloatingBind -> Floats -unitFloat = addFloat emptyFloats +The way we fix this is to: + * In cloneBndr, drop all unfoldings/rules + * In deFloatTop, run the occurrence analyser on each top-level RHS to drop + the dead local bindings -appendFloats :: Floats -> Floats -> Floats -appendFloats (Floats spec1 floats1) (Floats spec2 floats2) - = Floats (combine spec1 spec2) (floats1 `appOL` floats2) +The reason we don't just OccAnal the whole output of CorePrep is that the tidier +ensures that all top-level binders are GlobalIds, so they don't show up in the free +variables any longer. So if you run the occurrence analyser on the output of CoreTidy +(or later) you e.g. turn this program: -concatFloats :: [Floats] -> Floats -concatFloats = foldr appendFloats emptyFloats + Rec { + f = ... f ... + } -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 +Into this one: -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) + f = ... f ... -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 +(Since f is not considered to be free in its own RHS.) --- --------------------------------------------------------------------------- --- Bindings --- --------------------------------------------------------------------------- -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') +%************************************************************************ +%* * + The main code +%* * +%************************************************************************ + +\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 (idDemandInfo 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 (bndrs2 `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 - -because that has different strictness. Hence the use of 'allLazy'. -(NB: the let v* turns into a FloatCase, in mkLocalNonRec.) - + 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, CpeRhs) +-- Used for all bindings +cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs + = do { (floats1, rhs1) <- cpeRhsE env rhs + + -- See if we are allowed to float this stuff out of the RHS + ; (floats2, rhs2) <- float_from_rhs floats1 rhs1 + + -- Make the arity match up + ; (floats3, rhs') + <- if manifestArity rhs1 <= arity + then return (floats2, cpeEtaExpand arity rhs2) + else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr) + -- Note [Silly extra arguments] + (do { v <- newVar (idType bndr) + ; let float = mkFloat False False v rhs2 + ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) }) + + -- Record if the binder is evaluated + -- and otherwise trim off the unfolding altogether + -- It's not used by the code generator; getting rid of it reduces + -- heap usage and, since we may be changing uniques, we'd have + -- to substitute to keep it right + ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding + | otherwise = bndr `setIdUnfolding` noUnfolding + + ; return (floats3, bndr', rhs') } + where + arity = idArity bndr -- We must match this arity + + --------------------- + float_from_rhs floats rhs + | isEmptyFloats floats = return (emptyFloats, rhs) + | isTopLevel top_lvl = float_top floats rhs + | otherwise = float_nested floats rhs + + --------------------- + float_nested floats rhs + | wantFloatNested is_rec is_strict_or_unlifted floats rhs + = return (floats, rhs) + | otherwise = dont_float floats rhs + + --------------------- + float_top floats rhs -- Urhgh! See Note [CafInfo and floating] + | mayHaveCafRefs (idCafInfo bndr) + , allLazyTop floats + = return (floats, rhs) + + -- So the top-level binding is marked NoCafRefs + | Just (floats', rhs') <- canFloatFromNoCaf floats rhs + = return (floats', rhs') + + | otherwise + = dont_float floats rhs + + --------------------- + dont_float floats rhs + -- Non-empty floats, but do not want to float from rhs + -- So wrap the rhs in the floats + -- But: rhs1 might have lambdas, and we can't + -- put them inside a wrapBinds + = do { body <- rhsToBodyNF rhs + ; return (emptyFloats, wrapBinds floats body) } + +{- Note [Silly extra arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we had this + f{arity=1} = \x\y. e +We *must* match the arity on the Id, so we have to generate + f' = \x\y. e + f = \x. f' x + +It's a bizarre case: why is the arity on the Id wrong? Reason +(in the days of __inline_me__): + f{arity=0} = __inline_me__ (let v = expensive in \xy. e) +When InlineMe notes go away this won't happen any more. But +it seems good for CorePrep to be robust. +-} -\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) +cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- If -- e ===> (bs, e') -- then @@ -380,76 +443,126 @@ 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@(Coercion {}) = return (emptyFloats, expr) +cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) +cpeRhsE env expr@(Var {}) = cpeApp env expr + +cpeRhsE env (Var f `App` _ `App` arg) + | f `hasKey` lazyIdKey -- Replace (lazy a) by a + = cpeRhsE env arg -- See Note [lazyId magic] in MkId + +cpeRhsE env expr@(App {}) = 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) +-------- +rhsToBodyNF :: CpeRhs -> UniqSM CpeBody +rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs + ; return (wrapBinds floats body) } -corePrepExprFloat env (Note other_note expr) = do - (floats, expr') <- corePrepExprFloat env expr - return (floats, Note other_note expr') +-------- +rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody) +-- Remove top level lambdas by let-binding -corePrepExprFloat env (Cast expr co) = do - (floats, expr') <- corePrepExprFloat env expr - return (floats, Cast expr' co) +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 expr@(Lam _ _) = do - (env', bndrs') <- cloneBndrs env bndrs - body' <- corePrepAnExpr env' body - return (emptyFloats, mkLams bndrs' body') +rhsToBody (Cast e co) + = do { (floats, e') <- rhsToBody e + ; return (floats, Cast e' co) } + +rhsToBody expr@(Lam {}) + | Just no_lam_result <- tryEtaReducePrep 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) + + + +-- --------------------------------------------------------------------------- +-- CpeApp: produces a result satisfying CpeApp +-- --------------------------------------------------------------------------- -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 :: 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,36 +571,40 @@ 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@(Coercion arg_co)) depth + = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth + ; return (App fun' arg, hd, applyCo fun_ty arg_co, 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 + stricts = case idStrictness v of StrictSig (DmdType _ demands _) | listLengthCmp demands depth /= GT -> demands -- length demands <= depth @@ -498,254 +615,220 @@ 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 Pair _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 + -- The True says that it's sure to be evaluated, + -- so we'll end up case-binding it + ; 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 + = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda + ; (floats2, arg2) <- if want_float floats1 arg1 + then return (floats1, arg1) + else do { body1 <- rhsToBodyNF arg1 + ; return (emptyFloats, wrapBinds floats1 body1) } + -- Else case: arg1 might have lambdas, and we can't + -- put them inside a wrapBinds + + ; if cpe_ExprIsTrivial arg2 -- Do not eta expand a trivial argument + then return (floats2, arg2) + else do + { v <- newVar arg_ty + ; let arg3 = cpeEtaExpand (exprArity arg2) arg2 + arg_float = mkFloat is_strict is_unlifted v arg3 + ; return (addFloat floats2 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 - - -- 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'') + = saturateDataToTag sat_expr - | 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 +-- See Note [dataToTag magic] +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} +Note [dataToTag magic] +~~~~~~~~~~~~~~~~~~~~~~ +Horrid: we must 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 --- --------------------------------------------------------------------------- --- 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') } +How might it not be evaluated? Well, we might have floated it out +of the scope of a `seq`, or dropped the `seq` altogether. -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 _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 (Coercion _) = True +cpe_ExprIsTrivial (Lit _) = True +cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e +cpe_ExprIsTrivial (Note n e) = notSccNote n && 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 -> CpeRhs -> CpeRhs +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} +tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr +tryEtaReducePrep bndrs expr@(App _ _) | ok_to_eta_reduce f && n_remaining >= 0 && and (zipWith ok bndrs last_args) && @@ -765,15 +848,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) +tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body) | not (any (`elemVarSet` fvs) bndrs) - = case tryEta bndrs body of + = case tryEtaReducePrep bndrs body of Just e -> Just (Let bind e) Nothing -> Nothing where fvs = exprFreeVars r -tryEta _ _ = Nothing +tryEtaReducePrep _ _ = Nothing \end{code} @@ -782,35 +865,186 @@ 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 + -- They are always of lifted type; + -- unlifted ones are done with FloatCase + + | FloatCase + Id CpeBody + Bool -- The bool indicates "ok-for-speculation" -bdrDem :: Id -> RhsDemand -bdrDem id = mkDem (idNewDemandInfo id) - False {- For now -} +data Floats = Floats OkToSpec (OrdList FloatingBind) --- safeDem :: RhsDemand --- safeDem = RhsDemand False False -- always safe to use this +instance Outputable FloatingBind where + ppr (FloatLet b) = ppr b + ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r + +instance Outputable Floats where + ppr (Floats flag fs) = ptext (sLit "Floats") <> brackets (ppr flag) <+> + braces (vcat (map ppr (fromOL fs))) + +instance Outputable OkToSpec where + ppr OkToSpec = ptext (sLit "OkToSpec") + ppr IfUnboxedOk = ptext (sLit "IfUnboxedOk") + ppr NotOkToSpec = ptext (sLit "NotOkToSpec") + +-- 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 + = OkToSpec -- Lazy bindings of lifted type + | IfUnboxedOk -- A mixture of lazy lifted bindings and n + -- ok-to-speculate unlifted bindings + | NotOkToSpec -- Some not-ok-to-speculate unlifted bindings + +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 -onceDem :: RhsDemand -onceDem = RhsDemand False True -- used at most once -\end{code} +isEmptyFloats :: Floats -> Bool +isEmptyFloats (Floats _ bs) = isNilOL bs +wrapBinds :: Floats -> CpeBody -> CpeBody +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 +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 + +deFloatTop :: Floats -> [CoreBind] +-- For top level only; we don't expect any FloatCases +deFloatTop (Floats _ floats) + = foldrOL get [] floats + where + get (FloatLet b) bs = occurAnalyseRHSs b : bs + get b _ = pprPanic "corePrepPgm" (ppr b) + + -- See Note [Dead code in CorePrep] + occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr e) + occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes] + +------------------------------------------- +canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs) + -- Note [CafInfo and floating] +canFloatFromNoCaf (Floats ok_to_spec fs) rhs + | OkToSpec <- ok_to_spec -- Worth trying + , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs) + = Just (Floats OkToSpec fs', subst_expr subst rhs) + | otherwise + = Nothing + where + subst_expr = substExpr (text "CorePrep") + + go :: (Subst, OrdList FloatingBind) -> [FloatingBind] + -> Maybe (Subst, OrdList FloatingBind) + + go (subst, fbs_out) [] = Just (subst, fbs_out) + + go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in) + | rhs_ok r + = go (subst', fbs_out `snocOL` new_fb) fbs_in + where + (subst', b') = set_nocaf_bndr subst b + new_fb = FloatLet (NonRec b' (subst_expr subst r)) + + go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in) + | all rhs_ok rs + = go (subst', fbs_out `snocOL` new_fb) fbs_in + where + (bs,rs) = unzip prs + (subst', bs') = mapAccumL set_nocaf_bndr subst bs + rs' = map (subst_expr subst') rs + new_fb = FloatLet (Rec (bs' `zip` rs')) + + go _ _ = Nothing -- Encountered a caffy binding + + ------------ + set_nocaf_bndr subst bndr + = (extendIdSubst subst bndr (Var bndr'), bndr') + where + bndr' = bndr `setIdCafInfo` NoCafRefs + + ------------ + rhs_ok :: CoreExpr -> Bool + -- We can only float to top level from a NoCaf thing if + -- the new binding is static. However it can't mention + -- any non-static things or it would *already* be Caffy + rhs_ok = rhsIsStatic (\_ -> False) + +wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool +wantFloatNested is_rec strict_or_unlifted floats rhs + = isEmptyFloats floats + || 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 +1061,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 @@ -842,13 +1079,19 @@ cloneBndrs env bs = mapAccumLM cloneBndr env bs cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) cloneBndr env bndr - | isLocalId bndr + | isLocalId bndr, not (isCoVar bndr) = do bndr' <- setVarUnique bndr <$> getUniqueM - return (extendCorePrepEnv env bndr bndr', bndr') + + -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings + -- so that we can drop more stuff as dead code. + -- See also Note [Dead code in CorePrep] + let bndr'' = bndr' `setIdUnfolding` noUnfolding + `setIdSpecialisation` emptySpecInfo + return (extendCorePrepEnv env bndr bndr'', bndr'') | otherwise -- Top level things, which we don't want -- to clone, have become GlobalIds by now - -- And we don't clone tyvars + -- And we don't clone tyvars, or coercion variables = return (env, bndr)