X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegLiveness.hs;h=fc8749c286207cf40c449dc6123357976d64cad6;hb=27992bf89c008991fd6450b2b5bb224eda1f068a;hp=e18931caa234b07fc7955b6963168bf289fe8b77;hpb=86f1f4e0748ba1146cf74786af38a68a88164e2f;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs index e18931c..fc8749c 100644 --- 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)