X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcoreSyn%2FCorePrep.lhs;h=04057160b8f27d81e545c24e80c25a5d239d47ca;hp=b8dd80f703e66e55ddfc2ae624ba0767efdb38b1;hb=86add45dbfb6f962b65e371143dd467ae783f9e7;hpb=62eeda5aed31173b234b2965ccf4bd6979ffd9a4 diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index b8dd80f..0405716 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -11,15 +11,18 @@ module CorePrep ( #include "HsVersions.h" +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 @@ -34,9 +37,11 @@ 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} @@ -74,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 @@ -85,10 +90,11 @@ 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. @@ -99,19 +105,21 @@ Invariants Here is the syntax of the Core produced by CorePrep: Trivial expressions - triv ::= lit | var | triv ty | /\a. triv | triv |> co + triv ::= lit | var + | triv ty | /\a. triv + | truv co | /\c. triv | triv |> co Applications - app ::= lit | var | app triv | app ty | app |> co + 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 + | /\a. body | /\c. body | body |> co - Right hand sides (only place where lambdas can occur) + 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 @@ -145,7 +153,7 @@ 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 @@ -193,24 +201,38 @@ 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. +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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -230,6 +252,61 @@ always fully applied, and the bindings are just there to support partial applications. But it's easier to let them through. +Note [Dead code in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Imagine that we got an input program like this: + + 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 + +After specialisation and SpecConstr, we would get something like this: + + 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 = ... + +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. + +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. + +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 + +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: + + Rec { + f = ... f ... + } + +Into this one: + + f = ... f ... + +(Since f is not considered to be free in its own RHS.) + + %************************************************************************ %* * The main code @@ -242,7 +319,7 @@ cpeBind :: TopLevelFlag -> UniqSM (CorePrepEnv, Floats) cpeBind top_lvl env (NonRec bndr rhs) = do { (_, bndr1) <- cloneBndr env bndr - ; let is_strict = isStrictDmd (idNewDemandInfo bndr) + ; let is_strict = isStrictDmd (idDemandInfo bndr) is_unlifted = isUnLiftedType (idType bndr) ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive (is_strict || is_unlifted) @@ -260,7 +337,7 @@ cpeBind top_lvl env (Rec 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) + all_pairs = foldrOL add_float (bndrs2 `zip` rhss2) (concatFloats floats_s) ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2), unitFloat (FloatLet (Rec all_pairs))) } @@ -274,38 +351,89 @@ cpeBind top_lvl env (Rec pairs) --------------- cpePair :: TopLevelFlag -> RecFlag -> RhsDemand -> CorePrepEnv -> Id -> CoreExpr - -> UniqSM (Floats, Id, CoreExpr) + -> UniqSM (Floats, Id, CpeRhs) -- 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 + = 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 + | otherwise = bndr `setIdUnfolding` noUnfolding - ; return (floats, bndr', rhs') } + ; return (floats3, bndr', rhs') } where - want_float floats rhs - | isTopLevel top_lvl = wantFloatTop bndr floats - | otherwise = wantFloatNested is_rec is_strict_or_unlifted floats rhs - - + 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. +-} -- --------------------------------------------------------------------------- -- CpeRhs: produces a result satisfying CpeRhs -- --------------------------------------------------------------------------- -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') @@ -315,10 +443,16 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs) -- For example -- f (g x) ===> ([v = g x], f v) -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 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 @@ -377,8 +511,13 @@ cpeBody env expr ; return (floats1 `appendFloats` floats2, body) } -------- +rhsToBodyNF :: CpeRhs -> UniqSM CpeBody +rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs + ; return (wrapBinds floats body) } + +-------- rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody) --- Remove top level lambdas by let-bindinig +-- Remove top level lambdas by let-binding rhsToBody (Note n expr) -- You can get things like @@ -391,7 +530,7 @@ rhsToBody (Cast e co) ; return (floats, Cast e' co) } rhsToBody expr@(Lam {}) - | Just no_lam_result <- tryEtaReduce bndrs body + | Just no_lam_result <- tryEtaReducePrep bndrs body = return (emptyFloats, no_lam_result) | all isTyVar bndrs -- Type lambdas are ok = return (emptyFloats, expr) @@ -444,9 +583,13 @@ cpeApp env expr = 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 + ; let (ss1, ss_rest) = case ss of (ss1:ss_rest) -> (ss1, ss_rest) [] -> (lazyDmd, []) @@ -461,7 +604,7 @@ cpeApp env expr ; 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 @@ -473,7 +616,7 @@ cpeApp env expr -- partial application might be seq'd collect_args (Cast fun co) depth - = do { let (_ty1,ty2) = coercionKind co + = do { let Pair _ty1 ty2 = coercionKind co ; (fun', hd, _, floats, ss) <- collect_args fun depth ; return (Cast fun' co, hd, ty2, floats, ss) } @@ -482,10 +625,10 @@ cpeApp env expr = 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') <- 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 @@ -498,14 +641,21 @@ cpeApp env expr 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) } + = 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) @@ -551,9 +701,7 @@ maybeSaturate fn expr n_args ------------- 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 +-- See Note [dataToTag magic] saturateDataToTag sat_expr = do { let (eta_bndrs, eta_body) = collectBinders sat_expr ; eta_body' <- eval_data2tag_arg eta_body @@ -577,7 +725,14 @@ saturateDataToTag sat_expr = 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 +How might it not be evaluated? Well, we might have floated it out +of the scope of a `seq`, or dropped the `seq` altogether. %************************************************************************ @@ -597,7 +752,6 @@ ignoreNote :: Note -> Bool -- want to get this: -- unzip = /\ab \xs. (__inline_me__ ...) a b xs ignoreNote (CoreNote _) = True -ignoreNote InlineMe = True ignoreNote _other = False @@ -605,10 +759,10 @@ 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 (SCC _) _) = False -cpe_ExprIsTrivial (Note _ e) = 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 @@ -655,7 +809,7 @@ Instead CoreArity.etaExpand gives f = /\a -> \y -> let s = h 3 in g s y \begin{code} -cpeEtaExpand :: Arity -> CoreExpr -> CoreExpr +cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs cpeEtaExpand arity expr | arity == 0 = expr | otherwise = etaExpand arity expr @@ -673,8 +827,8 @@ get to a partial application: ==> case x of { p -> map f } \begin{code} -tryEtaReduce :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr -tryEtaReduce bndrs expr@(App _ _) +tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr +tryEtaReducePrep bndrs expr@(App _ _) | ok_to_eta_reduce f && n_remaining >= 0 && and (zipWith ok bndrs last_args) && @@ -694,15 +848,15 @@ tryEtaReduce bndrs expr@(App _ _) ok_to_eta_reduce (Var f) = not (hasNoBinding f) ok_to_eta_reduce _ = False --safe. ToDo: generalise -tryEtaReduce bndrs (Let bind@(NonRec _ r) body) +tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body) | not (any (`elemVarSet` fvs) bndrs) - = case tryEtaReduce bndrs body of + = case tryEtaReducePrep bndrs body of Just e -> Just (Let bind e) Nothing -> Nothing where fvs = exprFreeVars r -tryEtaReduce _ _ = Nothing +tryEtaReducePrep _ _ = Nothing \end{code} @@ -722,18 +876,37 @@ type RhsDemand = Bool -- True => used strictly; hence not top-level, non-recurs \begin{code} data FloatingBind - = FloatLet CoreBind -- Rhs of bindings are CpeRhss - | FloatCase Id CpeBody Bool -- The bool indicates "ok-for-speculation" + = 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" data Floats = Floats OkToSpec (OrdList FloatingBind) +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 - = NotOkToSpec -- definitely not - | OkToSpec -- yes - | IfUnboxedOk -- only if floating an unboxed binding is ok + = 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 @@ -748,7 +921,10 @@ mkFloat is_strict is_unlifted bndr rhs emptyFloats :: Floats emptyFloats = Floats OkToSpec nilOL -wrapBinds :: Floats -> CoreExpr -> CoreExpr +isEmptyFloats :: Floats -> Bool +isEmptyFloats (Floats _ bs) = isNilOL bs + +wrapBinds :: Floats -> CpeBody -> CpeBody wrapBinds (Floats _ binds) body = foldrOL mk_bind body binds where @@ -785,27 +961,70 @@ 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 (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] ------------------------------------------- -wantFloatTop :: Id -> Floats -> Bool +canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs) -- Note [CafInfo and floating] -wantFloatTop bndr floats = mayHaveCafRefs (idCafInfo bndr) - && allLazyTop floats +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 - = strict_or_unlifted + = isEmptyFloats floats + || strict_or_unlifted || (allLazyNested is_rec floats && exprIsHNF rhs) -- Why the test for allLazyNested? -- v = f (x `divInt#` y) @@ -860,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)