X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FFloatIn.lhs;h=8938731df07a6c468390f12b4febb875d7e05d77;hb=2e06595241350a6548b6ab6430c65d6458f7c197;hp=b80a8e0b2a7081158bce453ba3b08ec6ad64508f;hpb=d5934bbb856aa0aa620c9b2e0fa51c90a1a5a048;p=ghc-hetmet.git diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs index b80a8e0..8938731 100644 --- a/compiler/simplCore/FloatIn.lhs +++ b/compiler/simplCore/FloatIn.lhs @@ -20,12 +20,13 @@ import DynFlags ( DynFlags, DynFlag(..) ) import CoreSyn import CoreUtils ( exprIsHNF, exprIsDupable ) import CoreLint ( showPass, endPass ) -import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf ) -import Id ( isOneShotBndr ) -import Var ( Id, idType ) +import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf, idRuleVars ) +import Id ( isOneShotBndr, idType ) +import Var import Type ( isUnLiftedType ) import VarSet import Util ( zipEqual, zipWithEqual, count ) +import UniqFM import Outputable \end{code} @@ -124,7 +125,7 @@ the closure for a is not built. type FreeVarsSet = IdSet type FloatingBinds = [(CoreBind, FreeVarsSet)] - -- In reverse dependency order (innermost bindiner first) + -- In reverse dependency order (innermost binder first) -- The FreeVarsSet is the free variables of the binding. In the case -- of recursive bindings, the set doesn't include the bound @@ -142,7 +143,7 @@ fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) 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 _ (_, AnnLit lit) = Lit lit \end{code} Applications: we do float inside applications, mainly because we @@ -206,7 +207,7 @@ 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)) @@ -214,13 +215,6 @@ 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@(TickBox {}) expr) - = -- Wimp out for now - mkCoLets' to_drop (Note note (fiExpr [] expr)) -fiExpr to_drop (_, AnnNote note@(BinaryTickBox {}) expr) - = -- Wimp out for now - mkCoLets' to_drop (Note note (fiExpr [] expr)) - fiExpr to_drop (_, AnnNote note@(CoreNote _) expr) = Note note (fiExpr to_drop expr) \end{code} @@ -247,23 +241,52 @@ So: rather than drop \tr{w}'s binding here, we add it onto the list of things to drop in the outer let's body, and let nature take its course. +Note [extra_fvs (1): avoid floating into RHS] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consdider let x=\y....t... in body. We do not necessarily want to float +a binding for t into the RHS, because it'll immediately be floated out +again. (It won't go inside the lambda else we risk losing work.) +In letrec, we need to be more careful still. We don't want to transform + let x# = y# +# 1# + in + letrec f = \z. ...x#...f... + in ... +into + letrec f = let x# = y# +# 1# in \z. ...x#...f... in ... +because now we can't float the let out again, because a letrec +can't have unboxed bindings. + +So we make "extra_fvs" which is the rhs_fvs of such bindings, and +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 +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. + + \begin{code} fiExpr to_drop (_,AnnLet (AnnNonRec id rhs@(rhs_fvs, ann_rhs)) body) = fiExpr new_to_drop body where body_fvs = freeVarsOf body - final_body_fvs | noFloatIntoRhs ann_rhs - || isUnLiftedType (idType id) = body_fvs `unionVarSet` rhs_fvs - | otherwise = body_fvs - -- See commments with letrec below + rule_fvs = idRuleVars 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 + -- See Note [extra_fvs (2): avoid floating into RHS] -- No point in floating in only to float straight out again -- Ditto ok-for-speculation unlifted RHSs - [shared_binds, rhs_binds, body_binds] = sepBindsByDropPoint False [rhs_fvs, final_body_fvs] to_drop + [shared_binds, extra_binds, rhs_binds, body_binds] + = sepBindsByDropPoint False [extra_fvs, rhs_fvs, body_fvs] to_drop new_to_drop = body_binds ++ -- the bindings used only in the body [(NonRec id rhs', rhs_fvs')] ++ -- the new binding itself + extra_binds ++ -- bindings from extra_fvs shared_binds -- the bindings used both in rhs and body -- Push rhs_binds into the right hand side of the binding @@ -278,32 +301,20 @@ fiExpr to_drop (_,AnnLet (AnnRec bindings) body) rhss_fvs = map freeVarsOf rhss body_fvs = freeVarsOf body - -- Add to body_fvs the free vars of any RHS that has - -- a lambda at the top. This has the effect of making it seem - -- that such things are used in the body as well, and hence prevents - -- them getting floated in. The big idea is to avoid turning: - -- let x# = y# +# 1# - -- in - -- letrec f = \z. ...x#...f... - -- in ... - -- into - -- letrec f = let x# = y# +# 1# in \z. ...x#...f... in ... - -- - -- Because now we can't float the let out again, because a letrec - -- can't have unboxed bindings. - - final_body_fvs = foldr (unionVarSet . get_extras) body_fvs rhss - get_extras (rhs_fvs, rhs) | noFloatIntoRhs rhs = rhs_fvs - | otherwise = emptyVarSet - - (shared_binds:body_binds:rhss_binds) = sepBindsByDropPoint False (final_body_fvs:rhss_fvs) to_drop - - new_to_drop = -- the bindings used only in the body - body_binds ++ - -- the new binding itself + -- 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 + + (shared_binds:extra_binds:body_binds:rhss_binds) + = sepBindsByDropPoint False (extra_fvs:body_fvs:rhss_fvs) to_drop + + new_to_drop = body_binds ++ -- the bindings used only in the body [(Rec (fi_bind rhss_binds bindings), rhs_fvs')] ++ - -- the bindings used both in rhs and body or in more than one rhs - shared_binds + -- The new binding itself + 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)) @@ -338,12 +349,13 @@ 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 :: AnnExpr' Var (UniqFM Var) -> Bool noFloatIntoRhs (AnnNote InlineMe _) = True noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) -- IMPORTANT: don't say 'True' for a RHS with a one-shot lambda at the top. @@ -357,7 +369,8 @@ noFloatIntoRhs (AnnLam b _) = not (is_one_shot b) noFloatIntoRhs rhs = exprIsHNF (deAnnotate' rhs) -- We'd just float right back out again... -is_one_shot b = isId b && isOneShotBndr b +is_one_shot :: Var -> Bool +is_one_shot b = isIdVar b && isOneShotBndr b \end{code} @@ -399,8 +412,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)) @@ -418,7 +431,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 @@ -451,6 +464,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) @@ -459,6 +474,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}