Parameterise the RegM monad on the FreeRegs type

diff --git a/compiler/nativeGen/RegAlloc/Linear/Base.hs b/compiler/nativeGen/RegAlloc/Linear/Base.hs
index 087ab9c..fc8d4ed 100644 (file)
--- a/compiler/nativeGen/RegAlloc/Linear/Base.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Base.hs
@@ -101,7 +101,7 @@ data RegAllocStats
 
 
 -- | The register alloctor state
 
 
 -- | The register alloctor state

-data RA_State
+data RA_State freeRegs

         = RA_State
 
         {
         = RA_State
 
         {

@@ -110,7 +110,7 @@ data RA_State
           ra_blockassig :: BlockAssignment
 
         -- | free machine registers
           ra_blockassig :: BlockAssignment
 
         -- | free machine registers

-        , ra_freeregs   :: {-#UNPACK#-}!FreeRegs
+        , ra_freeregs   :: !freeRegs

 
         -- | assignment of temps to locations
         , ra_assig      :: RegMap Loc
 
         -- | assignment of temps to locations
         , ra_assig      :: RegMap Loc

@@ -131,7 +131,7 @@ data RA_State
 
 
 -- | The register allocator monad type.
 
 
 -- | The register allocator monad type.

-newtype RegM a
-        = RegM { unReg :: RA_State -> (# RA_State, a #) }
+newtype RegM freeRegs a
+        = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) }

 
 
 
 

diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
index ef6ae9b..6a62f07 100644 (file)
--- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs
@@ -42,7 +42,7 @@ joinToTargets
        -> BlockId                      -- ^ id of the current block
        -> instr                        -- ^ branch instr on the end of the source block.
 
        -> BlockId                      -- ^ id of the current block
        -> instr                        -- ^ branch instr on the end of the source block.
 

-       -> RegM ([NatBasicBlock instr]  --   fresh blocks of fixup code.
+       -> RegM FreeRegs ([NatBasicBlock instr] --   fresh blocks of fixup code.

                , instr)                --   the original branch instruction, but maybe patched to jump
                                        --      to a fixup block first.
 
                , instr)                --   the original branch instruction, but maybe patched to jump
                                        --      to a fixup block first.
 

@@ -68,7 +68,7 @@ joinToTargets'
 
        -> [BlockId]                    -- ^ branch destinations still to consider.
 
 
        -> [BlockId]                    -- ^ branch destinations still to consider.
 

-       -> RegM ( [NatBasicBlock instr]
+       -> RegM FreeRegs ( [NatBasicBlock instr]

                , instr)
 
 -- no more targets to consider. all done.
                , instr)
 
 -- no more targets to consider. all done.

@@ -262,7 +262,7 @@ expandNode vreg src dst
 --
 handleComponent 
        :: Instruction instr
 --
 handleComponent 
        :: Instruction instr

-       => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM [instr]
+       => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM FreeRegs [instr]

 
 -- If the graph is acyclic then we won't get the swapping problem below.
 --     In this case we can just do the moves directly, and avoid having to
 
 -- If the graph is acyclic then we won't get the swapping problem below.
 --     In this case we can just do the moves directly, and avoid having to

@@ -317,7 +317,7 @@ makeMove
        -> Unique       -- ^ unique of the vreg that we're moving.
        -> Loc          -- ^ source location.
        -> Loc          -- ^ destination location.
        -> Unique       -- ^ unique of the vreg that we're moving.
        -> Loc          -- ^ source location.
        -> Loc          -- ^ destination location.

-       -> RegM instr   -- ^ move instruction.
+       -> RegM FreeRegs instr  -- ^ move instruction.

 
 makeMove _     vreg (InReg src) (InReg dst)
  = do  recordSpill (SpillJoinRR vreg)
 
 makeMove _     vreg (InReg src) (InReg dst)
  = do  recordSpill (SpillJoinRR vreg)

diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs
index 8a8280e..ba8cdce 100644 (file)
--- a/compiler/nativeGen/RegAlloc/Linear/Main.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs
@@ -183,7 +183,7 @@ linearRA_SCCs :: (Instruction instr, Outputable instr)
               -> BlockMap RegSet
               -> [NatBasicBlock instr]
               -> [SCC (LiveBasicBlock instr)]
               -> BlockMap RegSet
               -> [NatBasicBlock instr]
               -> [SCC (LiveBasicBlock instr)]

-              -> RegM [NatBasicBlock instr]
+              -> RegM FreeRegs [NatBasicBlock instr]

 
 linearRA_SCCs _ _ blocksAcc []
         = return $ reverse blocksAcc
 
 linearRA_SCCs _ _ blocksAcc []
         = return $ reverse blocksAcc

@@ -220,7 +220,7 @@ process :: (Instruction instr, Outputable instr)
         -> [GenBasicBlock (LiveInstr instr)]
         -> [[NatBasicBlock instr]]
         -> Bool
         -> [GenBasicBlock (LiveInstr instr)]
         -> [[NatBasicBlock instr]]
         -> Bool

-        -> RegM [[NatBasicBlock instr]]
+        -> RegM FreeRegs [[NatBasicBlock instr]]

 
 process _ _ [] []         accum _
         = return $ reverse accum
 
 process _ _ [] []         accum _
         = return $ reverse accum

@@ -260,7 +260,7 @@ processBlock
         :: (Outputable instr, Instruction instr)
         => BlockMap RegSet              -- ^ live regs on entry to each basic block
         -> LiveBasicBlock instr         -- ^ block to do register allocation on
         :: (Outputable instr, Instruction instr)
         => BlockMap RegSet              -- ^ live regs on entry to each basic block
         -> LiveBasicBlock instr         -- ^ block to do register allocation on

-        -> RegM [NatBasicBlock instr]   -- ^ block with registers allocated
+        -> RegM FreeRegs [NatBasicBlock instr]   -- ^ block with registers allocated

 
 processBlock block_live (BasicBlock id instrs)
  = do   initBlock id
 
 processBlock block_live (BasicBlock id instrs)
  = do   initBlock id

@@ -271,7 +271,7 @@ processBlock block_live (BasicBlock id instrs)
 
 -- | Load the freeregs and current reg assignment into the RegM state
 --      for the basic block with this BlockId.
 
 -- | Load the freeregs and current reg assignment into the RegM state
 --      for the basic block with this BlockId.

-initBlock :: BlockId -> RegM ()
+initBlock :: BlockId -> RegM FreeRegs ()

 initBlock id
  = do   block_assig     <- getBlockAssigR
         case mapLookup id block_assig of
 initBlock id
  = do   block_assig     <- getBlockAssigR
         case mapLookup id block_assig of

@@ -298,7 +298,8 @@ linearRA
         -> BlockId                              -- ^ id of the current block, for debugging.
         -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.
 
         -> BlockId                              -- ^ id of the current block, for debugging.
         -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.
 

-        -> RegM ( [instr]                       --   instructions after register allocation
+        -> RegM FreeRegs
+                ( [instr]                       --   instructions after register allocation

                 , [NatBasicBlock instr])        --   fresh blocks of fixup code.
 
 
                 , [NatBasicBlock instr])        --   fresh blocks of fixup code.
 
 

@@ -323,7 +324,7 @@ raInsn
         -> [instr]                              -- ^ accumulator for instructions already processed.
         -> BlockId                              -- ^ the id of the current block, for debugging
         -> LiveInstr instr                      -- ^ the instr to have its regs allocated, with liveness info.
         -> [instr]                              -- ^ accumulator for instructions already processed.
         -> BlockId                              -- ^ the id of the current block, for debugging
         -> LiveInstr instr                      -- ^ the instr to have its regs allocated, with liveness info.

-        -> RegM
+        -> RegM FreeRegs

                 ( [instr]                       -- new instructions
                 , [NatBasicBlock instr])        -- extra fixup blocks
 
                 ( [instr]                       -- new instructions
                 , [NatBasicBlock instr])        -- extra fixup blocks
 

@@ -388,7 +389,7 @@ genRaInsn :: (Instruction instr, Outputable instr)
           -> instr
           -> [Reg]
           -> [Reg]
           -> instr
           -> [Reg]
           -> [Reg]

-          -> RegM ([instr], [NatBasicBlock instr])
+          -> RegM FreeRegs ([instr], [NatBasicBlock instr])

 
 genRaInsn block_live new_instrs block_id instr r_dying w_dying =
     case regUsageOfInstr instr              of { RU read written ->
 
 genRaInsn block_live new_instrs block_id instr r_dying w_dying =
     case regUsageOfInstr instr              of { RU read written ->

@@ -485,7 +486,7 @@ genRaInsn block_live new_instrs block_id instr r_dying w_dying =
 -- -----------------------------------------------------------------------------
 -- releaseRegs
 
 -- -----------------------------------------------------------------------------
 -- releaseRegs
 

-releaseRegs :: [Reg] -> RegM ()
+releaseRegs :: [Reg] -> RegM FreeRegs ()

 releaseRegs regs = do
   assig <- getAssigR
   free <- getFreeRegsR
 releaseRegs regs = do
   assig <- getAssigR
   free <- getFreeRegsR

@@ -523,7 +524,7 @@ saveClobberedTemps
         :: (Outputable instr, Instruction instr)
         => [RealReg]            -- real registers clobbered by this instruction
         -> [Reg]                -- registers which are no longer live after this insn
         :: (Outputable instr, Instruction instr)
         => [RealReg]            -- real registers clobbered by this instruction
         -> [Reg]                -- registers which are no longer live after this insn

-        -> RegM [instr]         -- return: instructions to spill any temps that will
+        -> RegM FreeRegs [instr]         -- return: instructions to spill any temps that will

                                 -- be clobbered.
 
 saveClobberedTemps [] _
                                 -- be clobbered.
 
 saveClobberedTemps [] _

@@ -562,7 +563,7 @@ saveClobberedTemps clobbered dying
 -- | Mark all these real regs as allocated,
 --      and kick out their vreg assignments.
 --
 -- | Mark all these real regs as allocated,
 --      and kick out their vreg assignments.
 --

-clobberRegs :: [RealReg] -> RegM ()
+clobberRegs :: [RealReg] -> RegM FreeRegs ()

 clobberRegs []
         = return ()
 
 clobberRegs []
         = return ()
 

@@ -618,8 +619,7 @@ allocateRegsAndSpill
         -> [instr]              -- spill insns
         -> [RealReg]            -- real registers allocated (accum.)
         -> [VirtualReg]         -- temps to allocate
         -> [instr]              -- spill insns
         -> [RealReg]            -- real registers allocated (accum.)
         -> [VirtualReg]         -- temps to allocate

-        -> RegM ( [instr]
-                , [RealReg])
+        -> RegM FreeRegs ( [instr] , [RealReg])

 
 allocateRegsAndSpill _       _    spills alloc []
         = return (spills, reverse alloc)
 
 allocateRegsAndSpill _       _    spills alloc []
         = return (spills, reverse alloc)

@@ -666,7 +666,7 @@ allocRegsAndSpill_spill :: (Instruction instr, Outputable instr)
                         -> [VirtualReg]
                         -> UniqFM Loc
                         -> SpillLoc
                         -> [VirtualReg]
                         -> UniqFM Loc
                         -> SpillLoc

-                        -> RegM ([instr], [RealReg])
+                        -> RegM FreeRegs ([instr], [RealReg])

 allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
  = do
         freeRegs                <- getFreeRegsR
 allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
  = do
         freeRegs                <- getFreeRegsR

@@ -767,7 +767,7 @@ loadTemp
         -> SpillLoc     -- the current location of this temp
         -> RealReg      -- the hreg to load the temp into
         -> [instr]
         -> SpillLoc     -- the current location of this temp
         -> RealReg      -- the hreg to load the temp into
         -> [instr]

-        -> RegM [instr]
+        -> RegM FreeRegs [instr]

 
 loadTemp vreg (ReadMem slot) hreg spills
  = do
 
 loadTemp vreg (ReadMem slot) hreg spills
  = do

diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs
index 234701c..7793fee 100644 (file)
--- a/compiler/nativeGen/RegAlloc/Linear/State.hs
+++ b/compiler/nativeGen/RegAlloc/Linear/State.hs
@@ -42,7 +42,7 @@ import UniqSupply
 
 
 -- | The RegM Monad
 
 
 -- | The RegM Monad

-instance Monad RegM where
+instance Monad (RegM freeRegs) where

   m >>= k   =  RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
   return a  =  RegM $ \s -> (# s, a #)
 
   m >>= k   =  RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
   return a  =  RegM $ \s -> (# s, a #)
 

@@ -53,7 +53,7 @@ runR  :: BlockAssignment
        -> RegMap Loc
        -> StackMap 
        -> UniqSupply
        -> RegMap Loc
        -> StackMap 
        -> UniqSupply

-       -> RegM a 
+       -> RegM FreeRegs a 

        -> (BlockAssignment, StackMap, RegAllocStats, a)
 
 runR block_assig freeregs assig stack us thing =
        -> (BlockAssignment, StackMap, RegAllocStats, a)
 
 runR block_assig freeregs assig stack us thing =

@@ -76,14 +76,14 @@ runR block_assig freeregs assig stack us thing =
 
 
 -- | Make register allocator stats from its final state.
 
 
 -- | Make register allocator stats from its final state.

-makeRAStats :: RA_State -> RegAllocStats
+makeRAStats :: RA_State FreeRegs -> RegAllocStats

 makeRAStats state
        = RegAllocStats
        { ra_spillInstrs        = binSpillReasons (ra_spills state) }
 
 
 spillR         :: Instruction instr
 makeRAStats state
        = RegAllocStats
        { ra_spillInstrs        = binSpillReasons (ra_spills state) }
 
 
 spillR         :: Instruction instr

-       => Reg -> Unique -> RegM (instr, Int)
+       => Reg -> Unique -> RegM FreeRegs (instr, Int)

 
 spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
   let (stack',slot) = getStackSlotFor stack temp
 
 spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
   let (stack',slot) = getStackSlotFor stack temp

@@ -93,49 +93,49 @@ spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
 
 
 loadR  :: Instruction instr
 
 
 loadR  :: Instruction instr

-       => Reg -> Int -> RegM instr
+       => Reg -> Int -> RegM FreeRegs instr

 
 loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
   (# s, mkLoadInstr reg delta slot #)
 
 
 loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
   (# s, mkLoadInstr reg delta slot #)
 

-getFreeRegsR :: RegM FreeRegs
+getFreeRegsR :: RegM FreeRegs FreeRegs

 getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
   (# s, freeregs #)
 
 getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
   (# s, freeregs #)
 

-setFreeRegsR :: FreeRegs -> RegM ()
+setFreeRegsR :: FreeRegs -> RegM FreeRegs ()

 setFreeRegsR regs = RegM $ \ s ->
   (# s{ra_freeregs = regs}, () #)
 
 setFreeRegsR regs = RegM $ \ s ->
   (# s{ra_freeregs = regs}, () #)
 

-getAssigR :: RegM (RegMap Loc)
+getAssigR :: RegM FreeRegs (RegMap Loc)

 getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
   (# s, assig #)
 
 getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
   (# s, assig #)
 

-setAssigR :: RegMap Loc -> RegM ()
+setAssigR :: RegMap Loc -> RegM FreeRegs ()

 setAssigR assig = RegM $ \ s ->
   (# s{ra_assig=assig}, () #)
 
 setAssigR assig = RegM $ \ s ->
   (# s{ra_assig=assig}, () #)
 

-getBlockAssigR :: RegM BlockAssignment
+getBlockAssigR :: RegM FreeRegs BlockAssignment

 getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
   (# s, assig #)
 
 getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
   (# s, assig #)
 

-setBlockAssigR :: BlockAssignment -> RegM ()
+setBlockAssigR :: BlockAssignment -> RegM FreeRegs ()

 setBlockAssigR assig = RegM $ \ s ->
   (# s{ra_blockassig = assig}, () #)
 
 setBlockAssigR assig = RegM $ \ s ->
   (# s{ra_blockassig = assig}, () #)
 

-setDeltaR :: Int -> RegM ()
+setDeltaR :: Int -> RegM FreeRegs ()

 setDeltaR n = RegM $ \ s ->
   (# s{ra_delta = n}, () #)
 
 setDeltaR n = RegM $ \ s ->
   (# s{ra_delta = n}, () #)
 

-getDeltaR :: RegM Int
+getDeltaR :: RegM FreeRegs Int

 getDeltaR = RegM $ \s -> (# s, ra_delta s #)
 
 getDeltaR = RegM $ \s -> (# s, ra_delta s #)
 

-getUniqueR :: RegM Unique
+getUniqueR :: RegM FreeRegs Unique

 getUniqueR = RegM $ \s ->
   case takeUniqFromSupply (ra_us s) of
     (uniq, us) -> (# s{ra_us = us}, uniq #)
 
 
 -- | Record that a spill instruction was inserted, for profiling.
 getUniqueR = RegM $ \s ->
   case takeUniqFromSupply (ra_us s) of
     (uniq, us) -> (# s{ra_us = us}, uniq #)
 
 
 -- | Record that a spill instruction was inserted, for profiling.

-recordSpill :: SpillReason -> RegM ()
+recordSpill :: SpillReason -> RegM FreeRegs ()

 recordSpill spill
        = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)
 recordSpill spill
        = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)