- 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
-
- -- 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')
- where
- (drop_boxes',mult_branch',as') = split' as [bind] mult_branch drop_boxes
-
- -- 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
-
- -------------------------
- fvsOfBind (_,fvs) = fvs
+ go :: FloatingBinds -> [DropBox] -> [FloatingBinds]
+ -- The *first* one in the argument list is the drop_here set
+ -- The FloatingBinds in the lists are in the reverse of
+ -- the normal FloatingBinds order; that is, they are the right way round!
+
+ go [] drop_boxes = map (reverse . snd) drop_boxes
+
+ go (bind_w_fvs@(bind, bind_fvs) : binds) drop_boxes@(here_box : fork_boxes)
+ = go binds new_boxes
+ where
+ -- "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]
+
+ drop_here = used_here || not can_push
+
+ -- For case expressions we duplicate the binding if it is
+ -- reasonably small, and if it is not used in all the RHSs
+ -- This is good for situations like
+ -- let x = I# y in
+ -- case e of
+ -- C -> error x
+ -- D -> error x
+ -- E -> ...not mentioning x...
+
+ n_alts = length used_in_flags
+ n_used_alts = length [() | True <- used_in_flags]
+
+ can_push = n_used_alts == 1 -- Used in just one branch
+ || (is_case && -- We are looking at case alternatives
+ n_used_alts > 1 && -- It's used in more than one
+ n_used_alts < n_alts && -- ...but not all
+ bindIsDupable bind) -- and we can duplicate the binding
+
+ new_boxes | drop_here = (insert here_box : fork_boxes)
+ | otherwise = (here_box : new_fork_boxes)
+
+ new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags
+
+ insert :: DropBox -> DropBox
+ insert (fvs,drops) = (fvs `unionVarSet` bind_fvs, bind_w_fvs:drops)
+
+ insert_maybe box True = insert box
+ insert_maybe box False = box
+