X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FRegLiveness.hs;h=5f8db1796023a19de2c9fc99228d1a518645f68a;hb=295d2a0018243d94a7bd4e72d88d056db32ff3cf;hp=c47ce96006b7b976e6734aa1b07161b06ffc6174;hpb=272f0ba89eca1d9fc700cf4c27b9f8c3e23d6fe8;p=ghc-hetmet.git diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs index c47ce96..5f8db17 100644 --- a/compiler/nativeGen/RegLiveness.hs +++ b/compiler/nativeGen/RegLiveness.hs @@ -5,7 +5,7 @@ -- (c) The University of Glasgow 2004 -- ----------------------------------------------------------------------------- -{-# OPTIONS -fno-warn-missing-signatures #-} +{-# OPTIONS -Wall -fno-warn-name-shadowing #-} module RegLiveness ( RegSet, @@ -22,6 +22,7 @@ module RegLiveness ( stripLive, spillNatBlock, slurpConflicts, + slurpReloadCoalesce, lifetimeCount, eraseDeltasLive, patchEraseLive, @@ -36,7 +37,7 @@ import MachRegs import MachInstrs import PprMach import RegAllocInfo -import Cmm +import Cmm hiding (RegSet) import Digraph import Outputable @@ -69,7 +70,7 @@ type LiveCmmTop = GenCmmTop CmmStatic LiveInfo - (GenBasicBlock LiveInstr) + (ListGraph (GenBasicBlock LiveInstr)) -- the "instructions" here are actually more blocks, -- single blocks are acyclic -- multiple blocks are taken to be cyclic. @@ -150,10 +151,11 @@ mapBlockTopM mapBlockTopM _ cmm@(CmmData{}) = return cmm -mapBlockTopM f (CmmProc header label params comps) +mapBlockTopM f (CmmProc header label params (ListGraph comps)) = do comps' <- mapM (mapBlockCompM f) comps - return $ CmmProc header label params comps' + return $ CmmProc header label params (ListGraph comps') +mapBlockCompM :: Monad m => (a -> m a') -> (GenBasicBlock a) -> m (GenBasicBlock a') mapBlockCompM f (BasicBlock i blocks) = do blocks' <- mapM f blocks return $ BasicBlock i blocks' @@ -161,8 +163,8 @@ mapBlockCompM f (BasicBlock i blocks) -- map a function across all the basic blocks in this code mapGenBlockTop - :: (GenBasicBlock i -> GenBasicBlock i) - -> (GenCmmTop d h i -> GenCmmTop d h i) + :: (GenBasicBlock i -> GenBasicBlock i) + -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i)) mapGenBlockTop f cmm = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) () @@ -171,15 +173,15 @@ mapGenBlockTop f cmm -- | map a function across all the basic blocks in this code (monadic version) mapGenBlockTopM :: Monad m - => (GenBasicBlock i -> m (GenBasicBlock i)) - -> (GenCmmTop d h i -> m (GenCmmTop d h i)) + => (GenBasicBlock i -> m (GenBasicBlock i)) + -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i))) mapGenBlockTopM _ cmm@(CmmData{}) = return cmm -mapGenBlockTopM f (CmmProc header label params blocks) +mapGenBlockTopM f (CmmProc header label params (ListGraph blocks)) = do blocks' <- mapM f blocks - return $ CmmProc header label params blocks' + return $ CmmProc header label params (ListGraph blocks') -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. @@ -191,7 +193,7 @@ slurpConflicts live = slurpCmm (emptyBag, emptyBag) live where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc info _ _ blocks) + slurpCmm rs (CmmProc info _ _ (ListGraph blocks)) = foldl' (slurpComp info) rs blocks slurpComp info rs (BasicBlock _ blocks) @@ -243,6 +245,51 @@ slurpConflicts live , moves) lis +-- | 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. +-- +-- TODO: This only works intra-block at the momement. It's be nice to join up the mappings +-- across blocks also. +-- +slurpReloadCoalesce :: LiveCmmTop -> Bag (Reg, Reg) +slurpReloadCoalesce live + = slurpCmm emptyBag live + + where slurpCmm cs CmmData{} = cs + slurpCmm cs (CmmProc _ _ _ (ListGraph blocks)) + = foldl' slurpComp cs blocks + + slurpComp cs (BasicBlock _ blocks) + = foldl' slurpBlock cs blocks + + slurpBlock cs (BasicBlock _ instrs) + = let (_, mMoves) = mapAccumL slurpLI emptyUFM instrs + in unionBags cs (listToBag $ catMaybes mMoves) + + slurpLI :: UniqFM Reg -> LiveInstr -> (UniqFM Reg, Maybe (Reg, Reg)) + slurpLI slotMap (Instr instr _) + + -- remember what reg was stored into the slot + | SPILL reg slot <- instr + , slotMap' <- addToUFM slotMap slot reg + = (slotMap', Nothing) + + -- add an edge betwen the this reg and the last one stored into the slot + | RELOAD slot reg <- instr + = case lookupUFM slotMap slot of + Just reg2 -> (slotMap, Just (reg, reg2)) + Nothing -> (slotMap, Nothing) + + | otherwise + = (slotMap, Nothing) + + -- | Strip away liveness information, yielding NatCmmTop stripLive :: LiveCmmTop -> NatCmmTop @@ -250,8 +297,8 @@ stripLive live = stripCmm live where stripCmm (CmmData sec ds) = CmmData sec ds - stripCmm (CmmProc (LiveInfo info _ _) label params comps) - = CmmProc info label params (concatMap stripComp comps) + stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps)) + = CmmProc info label params (ListGraph $ concatMap stripComp comps) stripComp (BasicBlock _ blocks) = map stripBlock blocks stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI instrs) @@ -295,7 +342,7 @@ lifetimeCount cmm = countCmm emptyUFM cmm where countCmm fm CmmData{} = fm - countCmm fm (CmmProc info _ _ blocks) + countCmm fm (CmmProc info _ _ (ListGraph blocks)) = foldl' (countComp info) fm blocks countComp info fm (BasicBlock _ blocks) @@ -355,13 +402,13 @@ patchEraseLive patchF cmm where patchCmm cmm@CmmData{} = cmm - patchCmm (CmmProc info label params comps) + patchCmm (CmmProc info label params (ListGraph comps)) | LiveInfo static id blockMap <- info = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set blockMap' = mapUFM patchRegSet blockMap info' = LiveInfo static id blockMap' - in CmmProc info' label params $ map patchComp comps + in CmmProc info' label params $ ListGraph $ map patchComp comps patchComp (BasicBlock id blocks) = BasicBlock id $ map patchBlock blocks @@ -425,12 +472,12 @@ regLiveness regLiveness (CmmData i d) = returnUs $ CmmData i d -regLiveness (CmmProc info lbl params []) +regLiveness (CmmProc info lbl params (ListGraph [])) = returnUs $ CmmProc (LiveInfo info Nothing emptyUFM) - lbl params [] + lbl params (ListGraph []) -regLiveness (CmmProc info lbl params blocks@(first : _)) +regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _))) = let first_id = blockId first sccs = sccBlocks blocks (ann_sccs, block_live) = computeLiveness sccs @@ -445,7 +492,7 @@ regLiveness (CmmProc info lbl params blocks@(first : _)) in returnUs $ CmmProc (LiveInfo info (Just first_id) block_live) - lbl params liveBlocks + lbl params (ListGraph liveBlocks) sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock] @@ -588,6 +635,7 @@ livenessBack liveregs blockmap acc (instr : instrs) in livenessBack liveregs' blockmap (instr' : acc) instrs -- don't bother tagging comments or deltas with liveness +liveness1 :: RegSet -> BlockMap RegSet -> Instr -> (RegSet, LiveInstr) liveness1 liveregs _ (instr@COMMENT{}) = (liveregs, Instr instr Nothing)