X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FFloatIn.lhs;h=48daf7853b422c41c8075c2b4e39830e73346912;hp=4c39336777fb308135e35189bdad757fa247b3f3;hb=c5b178be60a5a44abd2f4ddf8c399857678326e2;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index 4c39336..48daf78 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -12,27 +12,19 @@ case, so that we don't allocate things, save them on the stack, and then discover that they aren't needed in the chosen branch. \begin{code} -{-# OPTIONS_GHC -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings --- for details - module FloatIn ( floatInwards ) where #include "HsVersions.h" -import DynFlags ( DynFlags, DynFlag(..) ) import CoreSyn import CoreUtils ( exprIsHNF, exprIsDupable ) -import CoreLint ( showPass, endPass ) -import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleVars ) -import Id ( isOneShotBndr ) -import Var ( Id, idType ) +import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleAndUnfoldingVars ) +import Id ( isOneShotBndr, idType ) +import Var import Type ( isUnLiftedType ) import VarSet import Util ( zipEqual, zipWithEqual, count ) +import UniqFM import Outputable \end{code} @@ -40,16 +32,8 @@ Top-level interface function, @floatInwards@. Note that we do not actually float any bindings downwards from the top-level. \begin{code} -floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind] - -floatInwards dflags binds - = do { - showPass dflags "Float inwards"; - let { binds' = map fi_top_bind binds }; - endPass dflags "Float inwards" Opt_D_verbose_core2core binds' - {- no specific flag for dumping float-in -} - } - +floatInwards :: [CoreBind] -> [CoreBind] +floatInwards = map fi_top_bind where fi_top_bind (NonRec binder rhs) = NonRec binder (fiExpr [] (freeVars rhs)) @@ -142,14 +126,15 @@ fiExpr :: FloatingBinds -- Binds we're trying to drop -> CoreExprWithFVs -- Input expr -> CoreExpr -- Result -fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v) - -fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) - Type ty -fiExpr to_drop (_, AnnCast expr co) - = Cast (fiExpr to_drop expr) co -- Just float in past coercion - -fiExpr to_drop (_, AnnLit lit) = Lit lit +fiExpr to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit +fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty +fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v) +fiExpr to_drop (_, AnnCoercion co) = mkCoLets' to_drop (Coercion co) +fiExpr to_drop (_, AnnCast expr (fvs_co, co)) + = mkCoLets' (drop_here ++ co_drop) $ + Cast (fiExpr e_drop expr) co + where + [drop_here, e_drop, co_drop] = sepBindsByDropPoint False [freeVarsOf expr, fvs_co] to_drop \end{code} Applications: we do float inside applications, mainly because we @@ -163,8 +148,8 @@ fiExpr to_drop (_,AnnApp fun arg) [drop_here, fun_drop, arg_drop] = sepBindsByDropPoint False [freeVarsOf fun, freeVarsOf arg] to_drop \end{code} -We are careful about lambdas: - +Note [Floating in past a lambda group] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * We must be careful about floating inside inside a value lambda. That risks losing laziness. The float-out pass might rescue us, but then again it might not. @@ -180,24 +165,30 @@ We are careful about lambdas: This is bad as now f is an updatable closure (update PAP) and has arity 0. +* Hack alert! We only float in through one-shot lambdas, + not (as you might guess) through lone big lambdas. + Reason: we float *out* past big lambdas (see the test in the Lam + case of FloatOut.floatExpr) and we don't want to float straight + back in again. + + It *is* important to float into one-shot lambdas, however; + see the remarks with noFloatIntoRhs. + So we treat lambda in groups, using the following rule: - Float inside a group of lambdas only if - they are all either type lambdas or one-shot lambdas. + Float in if (a) there is at least one Id, + and (b) there are no non-one-shot Ids - Otherwise drop all the bindings outside the group. + Otherwise drop all the bindings outside the group. + +This is what the 'go' function in the AnnLam case is doing. + +Urk! if all are tyvars, and we don't float in, we may miss an + opportunity to float inside a nested case branch \begin{code} - -- Hack alert! We only float in through one-shot lambdas, - -- not (as you might guess) through big lambdas. - -- Reason: we float *out* past big lambdas (see the test in the Lam - -- case of FloatOut.floatExpr) and we don't want to float straight - -- back in again. - -- - -- It *is* important to float into one-shot lambdas, however; - -- see the remarks with noFloatIntoRhs. fiExpr to_drop lam@(_, AnnLam _ _) - | all is_one_shot bndrs -- Float in + | go False bndrs -- Float in = mkLams bndrs (fiExpr to_drop body) | otherwise -- Dump it all here @@ -205,6 +196,12 @@ fiExpr to_drop lam@(_, AnnLam _ _) where (bndrs, body) = collectAnnBndrs lam + + go seen_one_shot_id [] = seen_one_shot_id + go seen_one_shot_id (b:bs) + | isTyVar b = go seen_one_shot_id bs + | isOneShotBndr b = go True bs + | otherwise = False -- Give up at a non-one-shot Id \end{code} We don't float lets inwards past an SCC. @@ -213,14 +210,10 @@ We don't float lets inwards past an SCC. cc, change current cc to the new one and float binds into expr. \begin{code} -fiExpr to_drop (_, AnnNote note@(SCC cc) expr) +fiExpr to_drop (_, AnnNote note@(SCC _) expr) = -- Wimp out for now mkCoLets' to_drop (Note note (fiExpr [] expr)) -fiExpr to_drop (_, AnnNote InlineMe expr) - = -- Ditto... don't float anything into an INLINE expression - mkCoLets' to_drop (Note InlineMe (fiExpr [] expr)) - fiExpr to_drop (_, AnnNote note@(CoreNote _) expr) = Note note (fiExpr to_drop expr) \end{code} @@ -267,10 +260,12 @@ arrange to dump bindings that bind extra_fvs before the entire let. Note [extra_fvs (s): free variables of rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider let x{rule mentioning y} = rhs in body +Consider + let x{rule mentioning y} = rhs in body Here y is not free in rhs or body; but we still want to dump bindings that bind y outside the let. So we augment extra_fvs with the -idRuleVars of x. +idRuleAndUnfoldingVars of x. No need for type variables, hence not using +idFreeVars. \begin{code} @@ -279,7 +274,7 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) where body_fvs = freeVarsOf body - rule_fvs = idRuleVars id -- See Note [extra_fvs (2): free variables of rules] + rule_fvs = idRuleAndUnfoldingVars id -- See Note [extra_fvs (2): free variables of rules] extra_fvs | noFloatIntoRhs ann_rhs || isUnLiftedType (idType id) = rule_fvs `unionVarSet` rhs_fvs | otherwise = rule_fvs @@ -297,21 +292,21 @@ fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) -- Push rhs_binds into the right hand side of the binding rhs' = fiExpr rhs_binds rhs - rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds + rhs_fvs' = rhs_fvs `unionVarSet` floatedBindsFVs rhs_binds `unionVarSet` rule_fvs + -- Don't forget the rule_fvs; the binding mentions them! fiExpr to_drop (_,AnnLet (AnnRec bindings) body) = fiExpr new_to_drop body where - rhss = map snd bindings - + (ids, rhss) = unzip bindings rhss_fvs = map freeVarsOf rhss body_fvs = freeVarsOf body -- See Note [extra_fvs (1,2)] - extra_fvs = foldr (unionVarSet . get_extras) emptyVarSet bindings - get_extras (id, (rhs_fvs, rhs)) - | noFloatIntoRhs rhs = idRuleVars id `unionVarSet` rhs_fvs - | otherwise = idRuleVars id + rule_fvs = foldr (unionVarSet . idRuleAndUnfoldingVars) emptyVarSet ids + extra_fvs = rule_fvs `unionVarSet` + unionVarSets [ fvs | (fvs, rhs) <- rhss + , noFloatIntoRhs rhs ] (shared_binds:extra_binds:body_binds:rhss_binds) = sepBindsByDropPoint False (extra_fvs:body_fvs:rhss_fvs) to_drop @@ -322,8 +317,9 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) extra_binds ++ -- Note [extra_fvs (1,2)] shared_binds -- Used in more than one place - rhs_fvs' = unionVarSet (unionVarSets rhss_fvs) - (unionVarSets (map floatedBindsFVs rhss_binds)) + rhs_fvs' = unionVarSets rhss_fvs `unionVarSet` + unionVarSets (map floatedBindsFVs rhss_binds) `unionVarSet` + rule_fvs -- Don't forget the rule variables! -- Push rhs_binds into the right hand side of the binding fi_bind :: [FloatingBinds] -- one per "drop pt" conjured w/ fvs_of_rhss @@ -355,14 +351,14 @@ fiExpr to_drop (_, AnnCase scrut case_bndr ty alts) scrut_fvs = freeVarsOf scrut alts_fvs = map alt_fvs alts all_alts_fvs = unionVarSets alts_fvs - alt_fvs (con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args) + alt_fvs (_con, args, rhs) = foldl delVarSet (freeVarsOf rhs) (case_bndr:args) -- Delete case_bndr and args from free vars of rhs -- to get free vars of alt fi_alt to_drop (con, args, rhs) = (con, args, fiExpr to_drop rhs) -noFloatIntoRhs (AnnNote InlineMe _) = True -noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) +noFloatIntoRhs :: AnnExpr' Var (UniqFM Var) -> Bool +noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top. -- This makes a big difference for things like -- f x# = let x = I# x# @@ -374,6 +370,7 @@ noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs) -- We'd just float right back out again... +is_one_shot :: Var -> Bool is_one_shot b = isId b && isOneShotBndr b \end{code} @@ -416,8 +413,8 @@ sepBindsByDropPoint type DropBox = (FreeVarsSet, FloatingBinds) -sepBindsByDropPoint is_case drop_pts [] - = [] : [[] | p <- drop_pts] -- cut to the chase scene; it happens +sepBindsByDropPoint _is_case drop_pts [] + = [] : [[] | _ <- drop_pts] -- cut to the chase scene; it happens sepBindsByDropPoint is_case drop_pts floaters = go floaters (map (\fvs -> (fvs, [])) (emptyVarSet : drop_pts)) @@ -435,7 +432,7 @@ sepBindsByDropPoint is_case drop_pts floaters -- "here" means the group of bindings dropped at the top of the fork (used_here : used_in_flags) = [ any (`elemVarSet` fvs) (bindersOf bind) - | (fvs, drops) <- drop_boxes] + | (fvs, _) <- drop_boxes] drop_here = used_here || not can_push @@ -468,6 +465,8 @@ sepBindsByDropPoint is_case drop_pts floaters insert_maybe box True = insert box insert_maybe box False = box + go _ _ = panic "sepBindsByDropPoint/go" + floatedBindsFVs :: FloatingBinds -> FreeVarsSet floatedBindsFVs binds = unionVarSets (map snd binds) @@ -476,6 +475,7 @@ mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr mkCoLets' to_drop e = foldl (flip (Let . fst)) e to_drop -- Remember to_drop is in *reverse* dependency order +bindIsDupable :: Bind CoreBndr -> Bool bindIsDupable (Rec prs) = all (exprIsDupable . snd) prs -bindIsDupable (NonRec b r) = exprIsDupable r +bindIsDupable (NonRec _ r) = exprIsDupable r \end{code}