compiler/nativeGen/RegAlloc/Linear/State.hs

   1 -- | State monad for the linear register allocator.
   2
   3 --      Here we keep all the state that the register allocator keeps track
   4 --      of as it walks the instructions in a basic block.
   5
   6 module RegAlloc.Linear.State (
   7         RA_State(..),
   8         RegM,
   9         runR,
  10
  11         spillR,
  12         loadR,
  13
  14         getFreeRegsR,
  15         setFreeRegsR,
  16
  17         getAssigR,
  18         setAssigR,
  19
  20         getBlockAssigR,
  21         setBlockAssigR,
  22
  23         setDeltaR,
  24         getDeltaR,
  25
  26         getUniqueR,
  27
  28         recordSpill
  29 )
  30 where
  31
  32 import RegAlloc.Linear.Stats
  33 import RegAlloc.Linear.StackMap
  34 import RegAlloc.Linear.Base
  35 import RegAlloc.Liveness
  36 import Instruction
  37 import Reg
  38
  39 import Unique
  40 import UniqSupply
  41
  42
  43 -- | The RegM Monad
  44 instance Monad (RegM freeRegs) where
  45   m >>= k   =  RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }
  46   return a  =  RegM $ \s -> (# s, a #)
  47
  48
  49 -- | Run a computation in the RegM register allocator monad.
  50 runR    :: BlockAssignment freeRegs
  51         -> freeRegs
  52         -> RegMap Loc
  53         -> StackMap
  54         -> UniqSupply
  55         -> RegM freeRegs a
  56         -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)
  57
  58 runR block_assig freeregs assig stack us thing =
  59   case unReg thing
  60         (RA_State
  61                 { ra_blockassig = block_assig
  62                 , ra_freeregs   = freeregs
  63                 , ra_assig      = assig
  64                 , ra_delta      = 0{-???-}
  65                 , ra_stack      = stack
  66                 , ra_us         = us
  67                 , ra_spills     = [] })
  68    of
  69         (# state'@RA_State
  70                 { ra_blockassig = block_assig
  71                 , ra_stack      = stack' }
  72                 , returned_thing #)
  73
  74          ->     (block_assig, stack', makeRAStats state', returned_thing)
  75
  76
  77 -- | Make register allocator stats from its final state.
  78 makeRAStats :: RA_State freeRegs -> RegAllocStats
  79 makeRAStats state
  80         = RegAllocStats
  81         { ra_spillInstrs        = binSpillReasons (ra_spills state) }
  82
  83
  84 spillR  :: Instruction instr
  85         => Reg -> Unique -> RegM freeRegs (instr, Int)
  86
  87 spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->
  88   let (stack',slot) = getStackSlotFor stack temp
  89       instr  = mkSpillInstr reg delta slot
  90   in
  91   (# s{ra_stack=stack'}, (instr,slot) #)
  92
  93
  94 loadR   :: Instruction instr
  95         => Reg -> Int -> RegM freeRegs instr
  96
  97 loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->
  98   (# s, mkLoadInstr reg delta slot #)
  99
 100 getFreeRegsR :: RegM freeRegs freeRegs
 101 getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->
 102   (# s, freeregs #)
 103
 104 setFreeRegsR :: freeRegs -> RegM freeRegs ()
 105 setFreeRegsR regs = RegM $ \ s ->
 106   (# s{ra_freeregs = regs}, () #)
 107
 108 getAssigR :: RegM freeRegs (RegMap Loc)
 109 getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->
 110   (# s, assig #)
 111
 112 setAssigR :: RegMap Loc -> RegM freeRegs ()
 113 setAssigR assig = RegM $ \ s ->
 114   (# s{ra_assig=assig}, () #)
 115
 116 getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
 117 getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->
 118   (# s, assig #)
 119
 120 setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()
 121 setBlockAssigR assig = RegM $ \ s ->
 122   (# s{ra_blockassig = assig}, () #)
 123
 124 setDeltaR :: Int -> RegM freeRegs ()
 125 setDeltaR n = RegM $ \ s ->
 126   (# s{ra_delta = n}, () #)
 127
 128 getDeltaR :: RegM freeRegs Int
 129 getDeltaR = RegM $ \s -> (# s, ra_delta s #)
 130
 131 getUniqueR :: RegM freeRegs Unique
 132 getUniqueR = RegM $ \s ->
 133   case takeUniqFromSupply (ra_us s) of
 134     (uniq, us) -> (# s{ra_us = us}, uniq #)
 135
 136
 137 -- | Record that a spill instruction was inserted, for profiling.
 138 recordSpill :: SpillReason -> RegM freeRegs ()
 139 recordSpill spill
 140         = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #)