Add {-# OPTIONS_GHC -w #-} and some blurb to all compiler modules

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

diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs
index 4acb3be..737ce5a 100644 (file)
--- a/compiler/nativeGen/RegLiveness.hs
+++ b/compiler/nativeGen/RegLiveness.hs
@@ -6,6 +6,12 @@
 --
 -----------------------------------------------------------------------------
 
+{-# 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,
@@ -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,6 +161,29 @@ mapBlockCompM f (BasicBlock i blocks)
        return  $ 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)
+
+mapGenBlockTop f cmm
+       = evalState (mapGenBlockTopM (\x -> return $ f x) 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))
+
+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 from this top level thing.
 
 slurpConflicts :: LiveCmmTop -> Bag (UniqSet Reg)
@@ -214,6 +245,33 @@ stripLive live
        stripLI    (Instr instr _)              = instr
 
 
+-- | Make real spill instructions out of SPILL, RELOAD pseudos
+
+spillNatBlock :: NatBasicBlock -> NatBasicBlock
+spillNatBlock (BasicBlock i instrs)
+ =     BasicBlock i instrs'
+ where         (instrs', _)
+               = runState (spillNat [] instrs) 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