never executed always true always false
    1 {-# LANGUAGE PatternSynonyms, DeriveFunctor #-}
    2 {-# LANGUAGE ScopedTypeVariables #-}
    3 {-# LANGUAGE UnboxedTuples #-}
    4 
    5 -- | State monad for the linear register allocator.
    6 
    7 --      Here we keep all the state that the register allocator keeps track
    8 --      of as it walks the instructions in a basic block.
    9 
   10 module GHC.CmmToAsm.Reg.Linear.State (
   11         RA_State(..),
   12         RegM,
   13         runR,
   14 
   15         spillR,
   16         loadR,
   17 
   18         getFreeRegsR,
   19         setFreeRegsR,
   20 
   21         getAssigR,
   22         setAssigR,
   23 
   24         getBlockAssigR,
   25         setBlockAssigR,
   26 
   27         setDeltaR,
   28         getDeltaR,
   29 
   30         getUniqueR,
   31         getConfig,
   32         getPlatform,
   33 
   34         recordSpill,
   35         recordFixupBlock
   36 )
   37 where
   38 
   39 import GHC.Prelude
   40 
   41 import GHC.CmmToAsm.Reg.Linear.Stats
   42 import GHC.CmmToAsm.Reg.Linear.StackMap
   43 import GHC.CmmToAsm.Reg.Linear.Base
   44 import GHC.CmmToAsm.Reg.Liveness
   45 import GHC.CmmToAsm.Instr
   46 import GHC.CmmToAsm.Config
   47 import GHC.Platform.Reg
   48 import GHC.Cmm.BlockId
   49 
   50 import GHC.Platform
   51 import GHC.Types.Unique
   52 import GHC.Types.Unique.Supply
   53 import GHC.Exts (oneShot)
   54 
   55 import Control.Monad (ap)
   56 
   57 type RA_Result freeRegs a = (# RA_State freeRegs, a #)
   58 
   59 pattern RA_Result :: a -> b -> (# a, b #)
   60 pattern RA_Result a b = (# a, b #)
   61 {-# COMPLETE RA_Result #-}
   62 
   63 -- | The register allocator monad type.
   64 newtype RegM freeRegs a
   65         = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }
   66         deriving (Functor)
   67 
   68 -- | Smart constructor for 'RegM', as described in Note [The one-shot state
   69 -- monad trick] in GHC.Utils.Monad.
   70 mkRegM :: (RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
   71 mkRegM f = RegM (oneShot f)
   72 
   73 instance Applicative (RegM freeRegs) where
   74       pure a  =  mkRegM $ \s -> RA_Result s a
   75       (<*>) = ap
   76 
   77 instance Monad (RegM freeRegs) where
   78   m >>= k   =  mkRegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }
   79 
   80 -- | Get native code generator configuration
   81 getConfig :: RegM a NCGConfig
   82 getConfig = mkRegM $ \s -> RA_Result s (ra_config s)
   83 
   84 -- | Get target platform from native code generator configuration
   85 getPlatform :: RegM a Platform
   86 getPlatform = ncgPlatform <$> getConfig
   87 
   88 -- | Run a computation in the RegM register allocator monad.
   89 runR    :: NCGConfig
   90         -> BlockAssignment freeRegs
   91         -> freeRegs
   92         -> RegMap Loc
   93         -> StackMap
   94         -> UniqSupply
   95         -> RegM freeRegs a
   96         -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)
   97 
   98 runR config block_assig freeregs assig stack us thing =
   99   case unReg thing
  100         (RA_State
  101                 { ra_blockassig = block_assig
  102                 , ra_freeregs   = freeregs
  103                 , ra_assig      = assig
  104                 , ra_delta      = 0{-???-}
  105                 , ra_stack      = stack
  106                 , ra_us         = us
  107                 , ra_spills     = []
  108                 , ra_config     = config
  109                 , ra_fixups     = [] })
  110    of
  111         RA_Result state returned_thing
  112          ->     (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing)
  113 
  114 
  115 -- | Make register allocator stats from its final state.
  116 makeRAStats :: RA_State freeRegs -> RegAllocStats
  117 makeRAStats state
  118         = RegAllocStats
  119         { ra_spillInstrs        = binSpillReasons (ra_spills state)
  120         , ra_fixupList          = ra_fixups state }
  121 
  122 
  123 spillR :: Instruction instr
  124        => Reg -> Unique -> RegM freeRegs ([instr], Int)
  125 
  126 spillR reg temp = mkRegM $ \s ->
  127   let (stack1,slot) = getStackSlotFor (ra_stack s) temp
  128       instr  = mkSpillInstr (ra_config s) reg (ra_delta s) slot
  129   in
  130   RA_Result s{ra_stack=stack1} (instr,slot)
  131 
  132 
  133 loadR :: Instruction instr
  134       => Reg -> Int -> RegM freeRegs [instr]
  135 
  136 loadR reg slot = mkRegM $ \s ->
  137   RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot)
  138 
  139 getFreeRegsR :: RegM freeRegs freeRegs
  140 getFreeRegsR = mkRegM $ \ s@RA_State{ra_freeregs = freeregs} ->
  141   RA_Result s freeregs
  142 
  143 setFreeRegsR :: freeRegs -> RegM freeRegs ()
  144 setFreeRegsR regs = mkRegM $ \ s ->
  145   RA_Result s{ra_freeregs = regs} ()
  146 
  147 getAssigR :: RegM freeRegs (RegMap Loc)
  148 getAssigR = mkRegM $ \ s@RA_State{ra_assig = assig} ->
  149   RA_Result s assig
  150 
  151 setAssigR :: RegMap Loc -> RegM freeRegs ()
  152 setAssigR assig = mkRegM $ \ s ->
  153   RA_Result s{ra_assig=assig} ()
  154 
  155 getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
  156 getBlockAssigR = mkRegM $ \ s@RA_State{ra_blockassig = assig} ->
  157   RA_Result s assig
  158 
  159 setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()
  160 setBlockAssigR assig = mkRegM $ \ s ->
  161   RA_Result s{ra_blockassig = assig} ()
  162 
  163 setDeltaR :: Int -> RegM freeRegs ()
  164 setDeltaR n = mkRegM $ \ s ->
  165   RA_Result s{ra_delta = n} ()
  166 
  167 getDeltaR :: RegM freeRegs Int
  168 getDeltaR = mkRegM $ \s -> RA_Result s (ra_delta s)
  169 
  170 getUniqueR :: RegM freeRegs Unique
  171 getUniqueR = mkRegM $ \s ->
  172   case takeUniqFromSupply (ra_us s) of
  173     (uniq, us) -> RA_Result s{ra_us = us} uniq
  174 
  175 
  176 -- | Record that a spill instruction was inserted, for profiling.
  177 recordSpill :: SpillReason -> RegM freeRegs ()
  178 recordSpill spill
  179     = mkRegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) ()
  180 
  181 -- | Record a created fixup block
  182 recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs ()
  183 recordFixupBlock from between to
  184     = mkRegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()