Big collection of patches for the new codegen branch.

[ghc-hetmet.git] / compiler / nativeGen / RegLiveness.hs

diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs
index e18931c..fc8749c 100644 (file)
--- a/compiler/nativeGen/RegLiveness.hs
+++ b/compiler/nativeGen/RegLiveness.hs
@@ -23,7 +23,6 @@ module RegLiveness (
        spillNatBlock,
        slurpConflicts,
        slurpReloadCoalesce,
-       lifetimeCount,
        eraseDeltasLive,
        patchEraseLive,
        patchRegsLiveInstr,
@@ -31,8 +30,7 @@ module RegLiveness (
 
   ) where
 
-#include "HsVersions.h"
-
+import BlockId
 import MachRegs
 import MachInstrs
 import PprMach
@@ -47,6 +45,7 @@ import UniqFM
 import UniqSupply
 import Bag
 import State
+import FastString
 
 import Data.List
 import Data.Maybe
@@ -59,10 +58,10 @@ type RegMap a = UniqFM a
 emptyRegMap :: UniqFM a
 emptyRegMap = emptyUFM
 
-type BlockMap a = UniqFM a
+type BlockMap a = BlockEnv a
 
-emptyBlockMap :: UniqFM a
-emptyBlockMap = emptyUFM
+emptyBlockMap :: BlockEnv a
+emptyBlockMap = emptyBlockEnv
 
 
 -- | A top level thing which carries liveness information.
@@ -113,9 +112,9 @@ instance Outputable LiveInstr where
         =  ppr instr
                $$ (nest 8
                        $ vcat
-                       [ pprRegs (ptext SLIT("# born:    ")) (liveBorn live)
-                       , pprRegs (ptext SLIT("# r_dying: ")) (liveDieRead live)
-                       , pprRegs (ptext SLIT("# w_dying: ")) (liveDieWrite live) ]
+                       [ pprRegs (ptext (sLit "# born:    ")) (liveBorn live)
+                       , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live)
+                       , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ]
                    $+$ space)
 
         where  pprRegs :: SDoc -> RegSet -> SDoc
@@ -201,12 +200,12 @@ slurpConflicts live
 
        slurpBlock info rs (BasicBlock blockId instrs)  
                | LiveInfo _ _ blockLive        <- info
-               , Just rsLiveEntry              <- lookupUFM blockLive blockId
+               , Just rsLiveEntry              <- lookupBlockEnv blockLive blockId
                , (conflicts, moves)            <- slurpLIs rsLiveEntry rs instrs
                = (consBag rsLiveEntry conflicts, moves)
 
                | otherwise
-               = error "RegLiveness.slurpBlock: bad block"
+               = panic "RegLiveness.slurpBlock: bad block"
 
        slurpLIs rsLive (conflicts, moves) []
                = (consBag rsLive conflicts, moves)
@@ -245,14 +244,14 @@ slurpConflicts live
                                        , moves) lis
 
 
--- | For spill/reloads
+-- | For spill\/reloads
 --
 --     SPILL  v1, slot1
 --     ...
 --     RELOAD slot1, v2
 --
 --     If we can arrange that v1 and v2 are allocated to the same hreg it's more likely
---     the spill/reload instrs can be cleaned and replaced by a nop reg-reg move.
+--     the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move.
 --
 --
 slurpReloadCoalesce :: LiveCmmTop -> Bag (Reg, Reg)
@@ -347,7 +346,8 @@ stripLive live
 
  where stripCmm (CmmData sec ds)       = CmmData sec ds
        stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps))
-               = CmmProc info label params (ListGraph $ concatMap stripComp comps)
+               = CmmProc info label params
+                          (ListGraph $ concatMap stripComp comps)
 
        stripComp  (BasicBlock _ blocks)        = map stripBlock blocks
        stripBlock (BasicBlock i instrs)        = BasicBlock i (map stripLI instrs)
@@ -381,48 +381,6 @@ spillNatBlock (BasicBlock i is)
         =      spillNat (instr : acc) instrs
 
 
--- | Slurp out a map of how many times each register was live upon entry to an instruction.
-
-lifetimeCount
-       :: LiveCmmTop
-       -> UniqFM (Reg, Int)    -- ^ reg -> (reg, count)
-
-lifetimeCount cmm
-       = countCmm emptyUFM cmm
- where
-       countCmm fm  CmmData{}          = fm
-       countCmm fm (CmmProc info _ _ (ListGraph blocks))
-               = foldl' (countComp info) fm blocks
-               
-       countComp info fm (BasicBlock _ blocks)
-               = foldl' (countBlock info) fm blocks
-               
-       countBlock info fm (BasicBlock blockId instrs)
-               | LiveInfo _ _ blockLive        <- info
-               , Just rsLiveEntry              <- lookupUFM blockLive blockId
-               = countLIs rsLiveEntry fm instrs
-
-               | otherwise
-               = error "RegLiveness.countBlock: bad block"
-               
-       countLIs _      fm []                           = fm
-       countLIs rsLive fm (Instr _ Nothing : lis)      = countLIs rsLive fm lis
-       
-       countLIs rsLiveEntry fm (Instr _ (Just live) : lis)
-        = let
-               rsLiveAcross    = rsLiveEntry `minusUniqSet` (liveDieRead live)
-
-               rsLiveNext      = (rsLiveAcross `unionUniqSets` (liveBorn     live))
-                                                `minusUniqSet` (liveDieWrite live)
-
-               add r fm        = addToUFM_C
-                                       (\(r1, l1) (_, l2) -> (r1, l1 + l2))
-                                       fm r (r, 1)
-
-               fm'             = foldUniqSet add fm rsLiveEntry
-          in   countLIs rsLiveNext fm' lis
-          
-
 -- | Erase Delta instructions.
 
 eraseDeltasLive :: LiveCmmTop -> LiveCmmTop
@@ -454,7 +412,7 @@ patchEraseLive patchF cmm
        patchCmm (CmmProc info label params (ListGraph comps))
         | LiveInfo static id blockMap  <- info
         = let  patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
-               blockMap'       = mapUFM patchRegSet blockMap
+               blockMap'       = mapBlockEnv patchRegSet blockMap
 
                info'           = LiveInfo static id blockMap'
           in   CmmProc info' label params $ ListGraph $ map patchComp comps
@@ -523,7 +481,7 @@ regLiveness (CmmData i d)
 
 regLiveness (CmmProc info lbl params (ListGraph []))
        = returnUs $ CmmProc
-                       (LiveInfo info Nothing emptyUFM)
+                       (LiveInfo info Nothing emptyBlockEnv)
                        lbl params (ListGraph [])
 
 regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
@@ -539,13 +497,12 @@ regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _)))
                         -> panic "RegLiveness.regLiveness: no blocks in scc list")
                 $ ann_sccs
 
-   in  returnUs $ CmmProc
-                       (LiveInfo info (Just first_id) block_live)
-                       lbl params (ListGraph liveBlocks)
+   in  returnUs $ CmmProc (LiveInfo info (Just first_id) block_live)
+                          lbl params (ListGraph liveBlocks)
 
 
 sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock]
-sccBlocks blocks = stronglyConnComp graph
+sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
   where
        getOutEdges :: [Instr] -> [BlockId]
        getOutEdges instrs = foldl' (\a x -> jumpDests x a) [] instrs
@@ -601,7 +558,7 @@ livenessSCCs blockmap done
                  concatMap tail $
                  groupBy (\(a1, _) (a2, _) -> eq a1 a2) $
                  iterate (\(a, _) -> f a b) $
-                 (a, error "RegisterAlloc.livenessSCCs")
+                 (a, panic "RegLiveness.livenessSCCs")
 
 
             linearLiveness :: BlockMap RegSet -> [NatBasicBlock]
@@ -612,8 +569,8 @@ livenessSCCs blockmap done
                 -- BlockMaps for equality.
            equalBlockMaps a b
                = a' == b'
-             where a' = map f $ ufmToList a
-                   b' = map f $ ufmToList b
+             where a' = map f $ blockEnvToList a
+                   b' = map f $ blockEnvToList b
                    f (key,elt) = (key, uniqSetToList elt)
 
 
@@ -629,7 +586,7 @@ livenessBlock blockmap (BasicBlock block_id instrs)
  = let
        (regsLiveOnEntry, instrs1)
                = livenessBack emptyUniqSet blockmap [] (reverse instrs)
-       blockmap'       = addToUFM blockmap block_id regsLiveOnEntry
+       blockmap'       = extendBlockEnv blockmap block_id regsLiveOnEntry
 
        instrs2         = livenessForward regsLiveOnEntry instrs1
 
@@ -729,9 +686,9 @@ liveness1 liveregs blockmap instr
            not_a_branch = null targets
 
            targetLiveRegs target
-                  = case lookupUFM blockmap target of
+                  = case lookupBlockEnv blockmap target of
                                 Just ra -> ra
-                                Nothing -> emptyBlockMap
+                                Nothing -> emptyRegMap
 
             live_from_branch = unionManyUniqSets (map targetLiveRegs targets)