--
-----------------------------------------------------------------------------
+{-# OPTIONS -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/Commentary/CodingStyle#Warnings
+-- for details
module RegLiveness (
RegSet,
LiveInfo (..),
LiveBasicBlock,
- mapBlockTop,
- mapBlockTopM,
+ mapBlockTop, mapBlockTopM,
+ mapGenBlockTop, mapGenBlockTopM,
stripLive,
+ spillNatBlock,
slurpConflicts,
lifetimeCount,
eraseDeltasLive,
patchEraseLive,
patchRegsLiveInstr,
regLiveness
+
) where
#include "HsVersions.h"
return $ BasicBlock i blocks'
--- | Slurp out the list of register conflicts from this top level thing.
+-- map a function across all the basic blocks in this code
+mapGenBlockTop
+ :: (GenBasicBlock i -> GenBasicBlock i)
+ -> (GenCmmTop d h i -> GenCmmTop d h i)
+
+mapGenBlockTop f cmm
+ = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) ()
-slurpConflicts :: LiveCmmTop -> Bag (UniqSet Reg)
+
+-- | 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))
+
+mapGenBlockTopM f cmm@(CmmData{})
+ = return cmm
+
+mapGenBlockTopM f (CmmProc header label params blocks)
+ = do blocks' <- mapM f blocks
+ return $ CmmProc header label params blocks'
+
+
+-- | 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)
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) (li@(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.
--
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
stripLI (Instr instr _) = instr
+-- | Make real spill instructions out of SPILL, RELOAD pseudos
+
+spillNatBlock :: NatBasicBlock -> NatBasicBlock
+spillNatBlock (BasicBlock i is)
+ = BasicBlock i instrs'
+ where (instrs', _)
+ = runState (spillNat [] is) 0
+
+ spillNat acc []
+ = return (reverse acc)
+
+ spillNat acc (instr@(DELTA i) : instrs)
+ = do put i
+ spillNat acc instrs
+
+ spillNat acc (SPILL reg slot : instrs)
+ = do delta <- get
+ spillNat (mkSpillInstr reg delta slot : acc) instrs
+
+ spillNat acc (RELOAD slot reg : instrs)
+ = do delta <- get
+ spillNat (mkLoadInstr reg delta slot : acc) instrs
+
+ spillNat acc (instr : instrs)
+ = spillNat (instr : acc) instrs
+
+
-- | Slurp out a map of how many times each register was live upon entry to an instruction.
lifetimeCount
| LiveInfo _ _ blockLive <- info
, Just rsLiveEntry <- lookupUFM blockLive blockId
= countLIs rsLiveEntry fm instrs
+
+ | otherwise
+ = error "RegLiveness.countBlock: bad block"
countLIs rsLive fm [] = fm
countLIs rsLive fm (Instr _ Nothing : lis) = countLIs rsLive fm lis