then discover that they aren't needed in the chosen branch.
\begin{code}
-#include "HsVersions.h"
-
-module FloatIn (
- floatInwards
-
- -- and to make the interface self-sufficient...
- ) where
+module FloatIn ( floatInwards ) where
-import Ubiq{-uitous-}
+#include "HsVersions.h"
import AnnCoreSyn
import CoreSyn
import FreeVars
import Id ( emptyIdSet, unionIdSets, unionManyIdSets,
- elementOfIdSet, IdSet(..)
+ elementOfIdSet, IdSet, GenId, Id
)
-import Util ( panic )
+import Util ( nOfThem, panic, zipEqual )
\end{code}
Top-level interface function, @floatInwards@. Note that we do not
Here we are not floating inside lambda (type lambdas are OK):
\begin{code}
-fiExpr to_drop (_,AnnLam (UsageBinder binder) body)
- = panic "FloatIn.fiExpr:AnnLam UsageBinder"
-
fiExpr to_drop (_,AnnLam b@(ValBinder binder) body)
= mkCoLets' to_drop (Lam b (fiExpr [] body))
where
whnf :: CoreExprWithFVs -> Bool
- whnf (_,AnnLit _) = True
- whnf (_,AnnCon _ _) = True
- whnf (_,AnnLam x e) = if isValBinder x then True else whnf e
- whnf (_,AnnSCC _ e) = whnf e
- whnf _ = False
+ whnf (_,AnnLit _) = True
+ whnf (_,AnnCon _ _) = True
+ whnf (_,AnnLam x e) = if isValBinder x then True else whnf e
+ whnf (_,AnnNote _ e) = whnf e
+ whnf _ = False
\end{code}
Applications: we could float inside applications, but it's probably
We don't float lets inwards past an SCC.
-ToDo: SCC: {\em should} keep info on current cc, and when passing
-one, if it is not the same, annotate all lets in binds with current
-cc, change current cc to the new one and float binds into expr.
-\begin{code}
-fiExpr to_drop (_, AnnSCC cc expr)
- = mkCoLets' to_drop (SCC cc (fiExpr [] expr))
-\end{code}
+ToDo: SCC: {\em should}
\begin{code}
-fiExpr to_drop (_, AnnCoerce c ty expr)
- = _trace "fiExpr:Coerce:wimping out" $
- mkCoLets' to_drop (Coerce c ty (fiExpr [] expr))
+fiExpr to_drop (_, AnnNote note@(SCC cc) expr)
+ = -- Wimp out for now
+ -- ToDo: keep info on current cc, and when passing
+ -- one, if it is not the same, annotate all lets in binds with current
+ -- cc, change current cc to the new one and float binds into expr.
+ mkCoLets' to_drop (Note note (fiExpr [] expr))
+
+fiExpr to_drop (_, AnnNote InlineCall expr)
+ = -- Wimp out for InlineCall; keep it close
+ -- the the call it annotates
+ mkCoLets' to_drop (Note InlineCall (fiExpr [] expr))
+
+fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr)
+ = -- Just float in past coercion
+ Note note (fiExpr to_drop expr)
\end{code}
For @Lets@, the possible ``drop points'' for the \tr{to_drop}
-> [(Id, CoreExpr)]
fi_bind to_drops pairs
- = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zip pairs to_drops ]
+ = [ (binder, fiExpr to_drop rhs) | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]
\end{code}
For @Case@, the possible ``drop points'' for the \tr{to_drop}
fi_alts to_drop_deflt to_drop_alts (AnnAlgAlts alts deflt)
= AlgAlts
[ (con, params, fiExpr to_drop rhs)
- | ((con, params, rhs), to_drop) <- alts `zip` to_drop_alts ]
+ | ((con, params, rhs), to_drop) <- zipEqual "fi_alts" alts to_drop_alts ]
(fi_default to_drop_deflt deflt)
fi_alts to_drop_deflt to_drop_alts (AnnPrimAlts alts deflt)
= PrimAlts
[ (lit, fiExpr to_drop rhs)
- | ((lit, rhs), to_drop) <- alts `zip` to_drop_alts ]
+ | ((lit, rhs), to_drop) <- zipEqual "fi_alts2" alts to_drop_alts ]
(fi_default to_drop_deflt deflt)
fi_default to_drop AnnNoDefault = NoDefault
sepBindsByDropPoint drop_pts floaters
= let
- (per_drop_pt, must_stay_here, _)
- --= sep drop_pts emptyIdSet{-fvs of prev drop_pts-} floaters
- = split' drop_pts floaters [] empty_boxes
- empty_boxes = take (length drop_pts) (repeat [])
-
+ (must_stay_here : per_drop_pt)
+ = split' floaters ((emptyIdSet : drop_pts) `zip` repeat [])
in
- (map reverse per_drop_pt, reverse must_stay_here)
+ (per_drop_pt, must_stay_here)
where
- split' drop_pts_fvs [] mult_branch drop_boxes
- = (drop_boxes, mult_branch, drop_pts_fvs)
-
- -- only in a or unused
- split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
- | all (\b -> {-b `elementOfIdSet` a &&-}
- not (b `elementOfIdSet` (unionManyIdSets as)))
- (bindersOf (fst bind))
- = split' (a':as) binds mult_branch ((bind:drop_box_a):drop_boxes)
- where
- a' = a `unionIdSets` fvsOfBind bind
+ split' [] drop_boxes = map (reverse . snd) drop_boxes
- -- not in a
- split' (a:as) (bind:binds) mult_branch (drop_box_a:drop_boxes)
- | all (\b -> not (b `elementOfIdSet` a)) (bindersOf (fst bind))
- = split' (a:as') binds mult_branch' (drop_box_a:drop_boxes')
+ split' (bind:binds) drop_boxes
+ = split' binds drop_boxes'
where
- (drop_boxes',mult_branch',as') = split' as [bind] mult_branch drop_boxes
+ drop_boxes' = zipWith drop drop_flags drop_boxes
+ drop_flags | no_of_branches == 1 -- Exactly one branch
+ = used_in_flags
+ | otherwise -- Zero or many branches; drop it here
+ = True : repeat False
- -- in a and in as
- split' aas@(a:as) (bind:binds) mult_branch drop_boxes
- = split' aas' binds (bind : mult_branch) drop_boxes
- where
- aas' = map (unionIdSets (fvsOfBind bind)) aas
+ binders = bindersOf (fst bind)
+ no_of_branches = length [() | True <- used_in_flags]
+ used_in_flags = [ any (`elementOfIdSet` branch_fvs) binders
+ | (branch_fvs,_) <- drop_boxes ]
+
+ drop True (drop_fvs, box) = (drop_fvs `unionIdSets` fvsOfBind bind, bind:box)
+ drop False (drop_fvs, box) = (drop_fvs, box)
+
- -------------------------
fvsOfBind (_,fvs) = fvs
---floatedBindsFVs ::
+floatedBindsFVs :: FloatingBinds -> FreeVarsSet
floatedBindsFVs binds = unionManyIdSets (map snd binds)
---mkCoLets' :: [FloatingBinds] -> CoreExpr -> CoreExpr
+mkCoLets' :: FloatingBinds -> CoreExpr -> CoreExpr
mkCoLets' to_drop e = mkCoLetsNoUnboxed (reverse (map fst to_drop)) e
\end{code}
projects / ghc-hetmet.git / blobdiff