From e8437f81801f35d7a02d543fb2560ff07e44d88d Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Wed, 10 Jun 1998 08:31:57 +0000
Subject: [PATCH] [project @ 1998-06-10 08:31:57 by simonpj] Fix float-in bug
---
ghc/compiler/simplCore/FloatIn.lhs | 38 +++++++++++++-----------------
1 file changed, 17 insertions(+), 21 deletions(-)
diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs
index 353a3b2c3d56..77d998294f05 100644
--- a/ghc/compiler/simplCore/FloatIn.lhs
+++ b/ghc/compiler/simplCore/FloatIn.lhs
@@ -352,35 +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)
-
- split' drop_pts_fvs (bind:binds) mult_branch drop_boxes
- | no_of_branches == 1 -- Exactly one branch
- = split' drop_pts_fvs' binds mult_branch drop_boxes'
-
- | otherwise -- Zero or many branches; drop it here
- = split' drop_pts_fvs binds (bind:mult_branch) drop_boxes
+ split' [] drop_boxes = map (reverse . snd) drop_boxes
+ split' (bind:binds) drop_boxes
+ = split' binds drop_boxes'
where
+ 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
+
binders = bindersOf (fst bind)
- no_of_branches = length [() | True <- in_branch_flags]
- in_branch_flags = [ any (`elementOfIdSet` branch_fvs) binders
- | branch_fvs <- drop_pts_fvs ]
+ no_of_branches = length [() | True <- used_in_flags]
+ used_in_flags = [ any (`elementOfIdSet` branch_fvs) binders
+ | (branch_fvs,_) <- drop_boxes ]
- (drop_pts_fvs', drop_boxes') = unzip (zipWith3 drop in_branch_flags drop_pts_fvs drop_boxes)
- drop True drop_fvs box = (drop_fvs `unionIdSets` fvsOfBind bind, bind:box)
- drop False drop_fvs box = (drop_fvs, box)
+ 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
--
GitLab