X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegLiveness.hs;h=c47ce96006b7b976e6734aa1b07161b06ffc6174;hb=272f0ba89eca1d9fc700cf4c27b9f8c3e23d6fe8;hp=737ce5a21aee6fa80ae9480fa7c2ecc13fa9e516;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs index 737ce5a..c47ce96 100644 --- a/compiler/nativeGen/RegLiveness.hs +++ b/compiler/nativeGen/RegLiveness.hs @@ -5,13 +5,7 @@ -- (c) The University of Glasgow 2004 -- ----------------------------------------------------------------------------- - -{-# OPTIONS_GHC -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings --- for details +{-# OPTIONS -fno-warn-missing-signatures #-} module RegLiveness ( RegSet, @@ -60,9 +54,13 @@ import Data.Maybe type RegSet = UniqSet Reg type RegMap a = UniqFM a + +emptyRegMap :: UniqFM a emptyRegMap = emptyUFM type BlockMap a = UniqFM a + +emptyBlockMap :: UniqFM a emptyBlockMap = emptyUFM @@ -149,7 +147,7 @@ mapBlockTopM => (LiveBasicBlock -> m LiveBasicBlock) -> LiveCmmTop -> m LiveCmmTop -mapBlockTopM f cmm@(CmmData{}) +mapBlockTopM _ cmm@(CmmData{}) = return cmm mapBlockTopM f (CmmProc header label params comps) @@ -176,7 +174,7 @@ mapGenBlockTopM => (GenBasicBlock i -> m (GenBasicBlock i)) -> (GenCmmTop d h i -> m (GenCmmTop d h i)) -mapGenBlockTopM f cmm@(CmmData{}) +mapGenBlockTopM _ cmm@(CmmData{}) = return cmm mapGenBlockTopM f (CmmProc header label params blocks) @@ -184,28 +182,36 @@ mapGenBlockTopM f (CmmProc header label params blocks) return $ CmmProc header label params blocks' --- | Slurp out the list of register conflicts from this top level thing. - -slurpConflicts :: LiveCmmTop -> Bag (UniqSet Reg) +-- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. +-- Slurping of conflicts and moves is wrapped up together so we don't have +-- to make two passes over the same code when we want to build the graph. +-- +slurpConflicts :: LiveCmmTop -> (Bag (UniqSet Reg), Bag (Reg, Reg)) slurpConflicts live - = slurpCmm emptyBag live + = slurpCmm (emptyBag, emptyBag) live where slurpCmm rs CmmData{} = rs slurpCmm rs (CmmProc info _ _ blocks) = foldl' (slurpComp info) rs blocks - slurpComp info rs (BasicBlock i blocks) + slurpComp info rs (BasicBlock _ blocks) = foldl' (slurpBlock info) rs blocks slurpBlock info rs (BasicBlock blockId instrs) | LiveInfo _ _ blockLive <- info , Just rsLiveEntry <- lookupUFM blockLive blockId - = consBag rsLiveEntry $ slurpLIs rsLiveEntry rs instrs + , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs + = (consBag rsLiveEntry conflicts, moves) + + | otherwise + = error "RegLiveness.slurpBlock: bad block" + + slurpLIs rsLive (conflicts, moves) [] + = (consBag rsLive conflicts, moves) - slurpLIs rsLive rs [] = consBag rsLive rs slurpLIs rsLive rs (Instr _ Nothing : lis) = slurpLIs rsLive rs lis - slurpLIs rsLiveEntry rs (li@(Instr _ (Just live)) : lis) + slurpLIs rsLiveEntry (conflicts, moves) (Instr instr (Just live) : lis) = let -- regs that die because they are read for the last time at the start of an instruction -- are not live across it. @@ -227,7 +233,14 @@ slurpConflicts live -- rsConflicts = unionUniqSets rsLiveNext rsOrphans - in slurpLIs rsLiveNext (consBag rsConflicts rs) lis + in case isRegRegMove instr of + Just rr -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , consBag rr moves) lis + + Nothing -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , moves) lis -- | Strip away liveness information, yielding NatCmmTop @@ -240,7 +253,7 @@ stripLive live stripCmm (CmmProc (LiveInfo info _ _) label params comps) = CmmProc info label params (concatMap stripComp comps) - stripComp (BasicBlock i blocks) = map stripBlock blocks + stripComp (BasicBlock _ blocks) = map stripBlock blocks stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI instrs) stripLI (Instr instr _) = instr @@ -248,15 +261,15 @@ stripLive live -- | Make real spill instructions out of SPILL, RELOAD pseudos spillNatBlock :: NatBasicBlock -> NatBasicBlock -spillNatBlock (BasicBlock i instrs) +spillNatBlock (BasicBlock i is) = BasicBlock i instrs' where (instrs', _) - = runState (spillNat [] instrs) 0 + = runState (spillNat [] is) 0 spillNat acc [] = return (reverse acc) - spillNat acc (instr@(DELTA i) : instrs) + spillNat acc (DELTA i : instrs) = do put i spillNat acc instrs @@ -285,15 +298,18 @@ lifetimeCount cmm countCmm fm (CmmProc info _ _ blocks) = foldl' (countComp info) fm blocks - countComp info fm (BasicBlock i 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 rsLive fm [] = fm + countLIs _ fm [] = fm countLIs rsLive fm (Instr _ Nothing : lis) = countLIs rsLive fm lis countLIs rsLiveEntry fm (Instr _ (Just live) : lis) @@ -339,7 +355,7 @@ patchEraseLive patchF cmm where patchCmm cmm@CmmData{} = cmm - patchCmm cmm@(CmmProc info label params comps) + patchCmm (CmmProc info label params comps) | LiveInfo static id blockMap <- info = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set blockMap' = mapUFM patchRegSet blockMap @@ -406,15 +422,15 @@ regLiveness :: NatCmmTop -> UniqSM LiveCmmTop -regLiveness cmm@(CmmData sec d) - = returnUs $ CmmData sec d +regLiveness (CmmData i d) + = returnUs $ CmmData i d -regLiveness cmm@(CmmProc info lbl params []) +regLiveness (CmmProc info lbl params []) = returnUs $ CmmProc (LiveInfo info Nothing emptyUFM) lbl params [] -regLiveness cmm@(CmmProc info lbl params blocks@(first:rest)) +regLiveness (CmmProc info lbl params blocks@(first : _)) = let first_id = blockId first sccs = sccBlocks blocks (ann_sccs, block_live) = computeLiveness sccs @@ -513,7 +529,7 @@ livenessBlock -> NatBasicBlock -> (BlockMap RegSet, LiveBasicBlock) -livenessBlock blockmap block@(BasicBlock block_id instrs) +livenessBlock blockmap (BasicBlock block_id instrs) = let (regsLiveOnEntry, instrs1) = livenessBack emptyUniqSet blockmap [] (reverse instrs) @@ -532,13 +548,13 @@ livenessForward :: RegSet -- regs live on this instr -> [LiveInstr] -> [LiveInstr] -livenessForward rsLiveEntry [] = [] +livenessForward _ [] = [] livenessForward rsLiveEntry (li@(Instr instr mLive) : lis) | Nothing <- mLive = li : livenessForward rsLiveEntry lis - | Just live <- mLive - , RU read written <- regUsage instr + | Just live <- mLive + , RU _ written <- regUsage instr = let -- Regs that are written to but weren't live on entry to this instruction -- are recorded as being born here. @@ -552,6 +568,8 @@ livenessForward rsLiveEntry (li@(Instr instr mLive) : lis) in Instr instr (Just live { liveBorn = rsBorn }) : livenessForward rsLiveNext lis +livenessForward _ _ = panic "RegLiveness.livenessForward: no match" + -- | Calculate liveness going backwards, -- filling in when regs die, and what regs are live across each instruction @@ -563,17 +581,17 @@ livenessBack -> [Instr] -- instructions -> (RegSet, [LiveInstr]) -livenessBack liveregs blockmap done [] = (liveregs, done) +livenessBack liveregs _ done [] = (liveregs, done) livenessBack liveregs blockmap acc (instr : instrs) = let (liveregs', instr') = liveness1 liveregs blockmap instr in livenessBack liveregs' blockmap (instr' : acc) instrs -- don't bother tagging comments or deltas with liveness -liveness1 liveregs blockmap (instr@COMMENT{}) +liveness1 liveregs _ (instr@COMMENT{}) = (liveregs, Instr instr Nothing) -liveness1 liveregs blockmap (instr@DELTA{}) +liveness1 liveregs _ (instr@DELTA{}) = (liveregs, Instr instr Nothing) liveness1 liveregs blockmap instr