--
-----------------------------------------------------------------------------
+{-# 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
module RegLiveness (
RegSet,
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)
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
-- | 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 (mapM spillNat instrs) 0
+ = runState (spillNat [] is) 0
- spillNat instr@(DELTA i)
+ spillNat acc []
+ = return (reverse acc)
+
+ spillNat acc (instr@(DELTA i) : instrs)
= do put i
- return instr
+ spillNat acc instrs
- spillNat (SPILL reg slot)
+ spillNat acc (SPILL reg slot : instrs)
= do delta <- get
- return $ mkSpillInstr reg delta slot
+ spillNat (mkSpillInstr reg delta slot : acc) instrs
- spillNat (RELOAD slot reg)
+ spillNat acc (RELOAD slot reg : instrs)
= do delta <- get
- return $ mkLoadInstr reg delta slot
+ spillNat (mkLoadInstr reg delta slot : acc) instrs
- spillNat instr
- = return instr
+ 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.
| 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