Fix CodingStyle#Warnings URLs

[ghc-hetmet.git] / compiler / nativeGen / RegLiveness.hs

diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs
index 4acb3be..f2db089 100644 (file)
--- a/compiler/nativeGen/RegLiveness.hs
+++ b/compiler/nativeGen/RegLiveness.hs
@@ -6,6 +6,12 @@
 --
 -----------------------------------------------------------------------------
 
+{-# 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,
@@ -17,15 +23,17 @@ module RegLiveness (
        LiveInfo (..),
        LiveBasicBlock,
 
-       mapBlockTop,
-       mapBlockTopM,
+       mapBlockTop,    mapBlockTopM,
+       mapGenBlockTop, mapGenBlockTopM,
        stripLive,
+       spillNatBlock,
        slurpConflicts,
        lifetimeCount,
        eraseDeltasLive,
        patchEraseLive,
        patchRegsLiveInstr,
        regLiveness
+
   ) where
 
 #include "HsVersions.h"
@@ -153,11 +161,36 @@ mapBlockCompM f (BasicBlock i blocks)
        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) 
@@ -169,12 +202,18 @@ slurpConflicts live
        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.
@@ -196,7 +235,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
@@ -214,6 +260,33 @@ stripLive live
        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
@@ -234,6 +307,9 @@ lifetimeCount cmm
                | 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