Remove use of lambda with a refutable pattern

[ghc-hetmet.git] / compiler / nativeGen / RegAlloc / Liveness.hs

diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index 61e800f..0efc6f5 100644 (file)
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -27,6 +27,7 @@ module RegAlloc.Liveness (
        eraseDeltasLive,
        patchEraseLive,
        patchRegsLiveInstr,
+       reverseBlocksInTops,
        regLiveness,
        natCmmTopToLive
   ) where
@@ -355,21 +356,30 @@ slurpConflicts live
 --
 --
 slurpReloadCoalesce 
-       :: Instruction instr
+       :: forall instr. Instruction instr
        => LiveCmmTop instr
        -> Bag (Reg, Reg)
 
 slurpReloadCoalesce live
        = slurpCmm emptyBag live
 
- where slurpCmm cs CmmData{}   = cs
+ where 
+        slurpCmm :: Bag (Reg, Reg)
+                 -> GenCmmTop t t1 [SCC (LiveBasicBlock instr)]
+                 -> Bag (Reg, Reg)
+        slurpCmm cs CmmData{}  = cs
        slurpCmm cs (CmmProc _ _ _ sccs)
                = slurpComp cs (flattenSCCs sccs)
 
+        slurpComp :: Bag (Reg, Reg)
+                     -> [LiveBasicBlock instr]
+                     -> Bag (Reg, Reg)
        slurpComp  cs blocks
         = let  (moveBags, _)   = runState (slurpCompM blocks) emptyUFM
           in   unionManyBags (cs : moveBags)
 
+        slurpCompM :: [LiveBasicBlock instr]
+                   -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
        slurpCompM blocks
         = do   -- run the analysis once to record the mapping across jumps.
                mapM_   (slurpBlock False) blocks
@@ -380,6 +390,8 @@ slurpReloadCoalesce live
                --      not worth the trouble.
                mapM    (slurpBlock True) blocks
 
+        slurpBlock :: Bool -> LiveBasicBlock instr
+                   -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
        slurpBlock propagate (BasicBlock blockId instrs)
         = do   -- grab the slot map for entry to this block
                slotMap         <- if propagate
@@ -389,8 +401,7 @@ slurpReloadCoalesce live
                (_, mMoves)     <- mapAccumLM slurpLI slotMap instrs
                return $ listToBag $ catMaybes mMoves
 
-       slurpLI :: Instruction instr
-               => UniqFM Reg                           -- current slotMap
+       slurpLI :: UniqFM Reg                           -- current slotMap
                -> LiveInstr instr
                -> State (UniqFM [UniqFM Reg])          -- blockId -> [slot -> reg]
                                                        --      for tracking slotMaps across jumps
@@ -670,9 +681,6 @@ regLiveness (CmmProc info lbl params sccs)
                           lbl params ann_sccs
 
 
-
-
-
 -- -----------------------------------------------------------------------------
 -- | Check ordering of Blocks
 --     The computeLiveness function requires SCCs to be in reverse dependent order.
@@ -688,7 +696,7 @@ checkIsReverseDependent
 checkIsReverseDependent sccs'
  = go emptyUniqSet sccs'
 
- where         go blockssSeen []
+ where         go _ []
         = Nothing
        
        go blocksSeen (AcyclicSCC block : sccs)
@@ -707,12 +715,21 @@ checkIsReverseDependent sccs'
                 []             -> go blocksSeen' sccs
                 bad : _        -> Just bad
                
-       slurpJumpDestsOfBlock (BasicBlock blockId instrs)
+       slurpJumpDestsOfBlock (BasicBlock _ instrs)
                = unionManyUniqSets
                $ map (mkUniqSet . jumpDestsOfInstr) 
                        [ i | LiveInstr i _ <- instrs]
-       
 
+
+-- | If we've compute liveness info for this code already we have to reverse
+--   the SCCs in each top to get them back to the right order so we can do it again.
+reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr
+reverseBlocksInTops top
+ = case top of
+       CmmData{}                       -> top
+       CmmProc info lbl params sccs    -> CmmProc info lbl params (reverse sccs)
+
+       
 -- | Computing liveness
 --     
 --  On entry, the SCCs must be in "reverse" order: later blocks may transfer