[project @ 1998-08-27 13:09:44 by sof]

[ghc-hetmet.git] / ghc / compiler / simplCore / FloatIn.lhs

diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs
index 8db461a..77d9982 100644 (file)
--- a/ghc/compiler/simplCore/FloatIn.lhs
+++ b/ghc/compiler/simplCore/FloatIn.lhs
@@ -163,11 +163,11 @@ fiExpr to_drop (_,AnnLam b@(TyBinder tyvar) 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
@@ -183,18 +183,24 @@ fiExpr to_drop (_,AnnApp fun arg)
 
 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}
@@ -346,39 +352,31 @@ sepBindsByDropPoint drop_pts []
 
 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 = nOfThem (length drop_pts) []
+       (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 :: FloatingBinds -> FreeVarsSet