NCG: Split linear allocator into separate modules.

[ghc-hetmet.git] / compiler / nativeGen / RegAlloc / Linear / State.hs

diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs
new file mode 100644 (file)
index 0000000..428b0ca
--- /dev/null
+++ b/compiler/nativeGen/RegAlloc/Linear/State.hs
@@ -0,0 +1,139 @@
+-- | State monad for the linear register allocator.
+
+--     Here we keep all the state that the register allocator keeps track
+--     of as it walks the instructions in a basic block.
+
+module RegAlloc.Linear.State (
+       RA_State(..),
+       RegM,
+       runR,
+
+       spillR,
+       loadR,
+
+       getFreeRegsR,
+       setFreeRegsR,
+
+       getAssigR,
+       setAssigR,
+       
+       getBlockAssigR,
+       setBlockAssigR,
+       
+       setDeltaR,
+       getDeltaR,
+       
+       getUniqueR,
+       
+       recordSpill
+)
+where
+
+import RegAlloc.Linear.Stats
+import RegAlloc.Linear.StackMap
+import RegAlloc.Linear.Base
+import RegAlloc.Linear.FreeRegs
+
+
+import MachInstrs
+import MachRegs
+import RegAllocInfo
+import RegLiveness
+
+import Unique
+import UniqSupply
+
+
+-- | The RegM Monad
+instance Monad RegM where
+  m >>= k   =  RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
+  return a  =  RegM $ \s -> (# s, a #)
+
+
+-- | Run a computation in the RegM register allocator monad.
+runR   :: BlockAssignment 
+       -> FreeRegs 
+       -> RegMap Loc
+       -> StackMap 
+       -> UniqSupply
+       -> RegM a 
+       -> (BlockAssignment, StackMap, RegAllocStats, a)
+
+runR block_assig freeregs assig stack us thing =
+  case unReg thing 
+       (RA_State
+               { ra_blockassig = block_assig
+               , ra_freeregs   = freeregs
+               , ra_assig      = assig
+               , ra_delta      = 0{-???-}
+               , ra_stack      = stack
+               , ra_us         = us
+               , ra_spills     = [] }) 
+   of
+       (# state'@RA_State
+               { ra_blockassig = block_assig
+               , ra_stack      = stack' }
+               , returned_thing #)
+               
+        ->     (block_assig, stack', makeRAStats state', returned_thing)
+
+
+-- | Make register allocator stats from its final state.
+makeRAStats :: RA_State -> RegAllocStats
+makeRAStats state
+       = RegAllocStats
+       { ra_spillInstrs        = binSpillReasons (ra_spills state) }
+
+
+spillR :: Reg -> Unique -> RegM (Instr, Int)
+spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
+  let (stack',slot) = getStackSlotFor stack temp
+      instr  = mkSpillInstr reg delta slot
+  in
+  (# s{ra_stack=stack'}, (instr,slot) #)
+
+loadR :: Reg -> Int -> RegM Instr
+loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
+  (# s, mkLoadInstr reg delta slot #)
+
+getFreeRegsR :: RegM FreeRegs
+getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
+  (# s, freeregs #)
+
+setFreeRegsR :: FreeRegs -> RegM ()
+setFreeRegsR regs = RegM $ \ s ->
+  (# s{ra_freeregs = regs}, () #)
+
+getAssigR :: RegM (RegMap Loc)
+getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
+  (# s, assig #)
+
+setAssigR :: RegMap Loc -> RegM ()
+setAssigR assig = RegM $ \ s ->
+  (# s{ra_assig=assig}, () #)
+
+getBlockAssigR :: RegM BlockAssignment
+getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
+  (# s, assig #)
+
+setBlockAssigR :: BlockAssignment -> RegM ()
+setBlockAssigR assig = RegM $ \ s ->
+  (# s{ra_blockassig = assig}, () #)
+
+setDeltaR :: Int -> RegM ()
+setDeltaR n = RegM $ \ s ->
+  (# s{ra_delta = n}, () #)
+
+getDeltaR :: RegM Int
+getDeltaR = RegM $ \s -> (# s, ra_delta s #)
+
+getUniqueR :: RegM Unique
+getUniqueR = RegM $ \s ->
+  case splitUniqSupply (ra_us s) of
+    (us1, us2) -> (# s{ra_us = us2}, uniqFromSupply us1 #)
+
+
+-- | Record that a spill instruction was inserted, for profiling.
+recordSpill :: SpillReason -> RegM ()
+recordSpill spill
+       = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)