content: {-# LANGUAGE PatternSynonyms, DeriveFunctor, DerivingVia #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE UnboxedTuples #-}
  
  -- | 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 GHC.CmmToAsm.Reg.Linear.State (
          RA_State(..),
          RegM,
          runR,
  
          spillR,
          loadR,
  
          getFreeRegsR,
          setFreeRegsR,
  
          getAssigR,
          setAssigR,
  
          getBlockAssigR,
          setBlockAssigR,
  
          setDeltaR,
          getDeltaR,
  
          getUniqueR,
          getConfig,
          getPlatform,
  
          recordSpill,
          recordFixupBlock
  )
  where
  
  import GHC.Prelude
  
  import GHC.CmmToAsm.Reg.Linear.Stats
  import GHC.CmmToAsm.Reg.Linear.StackMap
  import GHC.CmmToAsm.Reg.Linear.Base
  import GHC.CmmToAsm.Reg.Liveness
  import GHC.CmmToAsm.Format
  import GHC.CmmToAsm.Instr
  import GHC.CmmToAsm.Config
  import GHC.Cmm.BlockId
  
  import GHC.Platform
  import GHC.Types.Unique
  import GHC.Types.Unique.DSM
  import GHC.Exts (oneShot)
  
  import GHC.Utils.Monad.State.Strict as Strict
  
  type RA_Result freeRegs a = (# a, RA_State freeRegs #)
  
  pattern RA_Result :: a -> b -> (# b, a #)
  pattern RA_Result a b = (# b, a #)
  {-# COMPLETE RA_Result #-}
  
  -- | The register allocator monad type.
  newtype RegM freeRegs a
          = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }
          deriving (Functor, Applicative, Monad) via (Strict.State (RA_State freeRegs))
  
  -- | Smart constructor for 'RegM', as described in Note [The one-shot state
  -- monad trick] in GHC.Utils.Monad.
  mkRegM :: (RA_State freeRegs -> RA_Result freeRegs a) -> RegM freeRegs a
  mkRegM f = RegM (oneShot f)
  
  -- | Get native code generator configuration
  getConfig :: RegM a NCGConfig
  getConfig = mkRegM $ \s -> RA_Result s (ra_config s)
  
  -- | Get target platform from native code generator configuration
  getPlatform :: RegM a Platform
  getPlatform = ncgPlatform <$> getConfig
  
  -- | Run a computation in the RegM register allocator monad.
  runR    :: NCGConfig
          -> BlockAssignment freeRegs
          -> freeRegs
          -> RegMap Loc
          -> StackMap
          -> DUniqSupply
          -> RegM freeRegs a
          -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a, DUniqSupply)
  
  runR config 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     = []
                  , ra_config     = config
                  , ra_fixups     = [] })
     of
          RA_Result state returned_thing
           ->  (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing, ra_us state)
  
  
  -- | Make register allocator stats from its final state.
  makeRAStats :: RA_State freeRegs -> RegAllocStats
  makeRAStats state
          = RegAllocStats
          { ra_spillInstrs        = binSpillReasons (ra_spills state)
          , ra_fixupList          = ra_fixups state }
  
  
  spillR :: Instruction instr
         => RegWithFormat -> Unique -> RegM freeRegs ([instr], Int)
  
  spillR reg temp = mkRegM $ \s ->
    let (stack1,slots) = getStackSlotFor (ra_stack s) (regWithFormat_format reg) temp
        instr  = mkSpillInstr (ra_config s) reg (ra_delta s) slots
    in
    RA_Result s{ra_stack=stack1} (instr,slots)
  
  
  loadR :: Instruction instr
        => RegWithFormat -> Int -> RegM freeRegs [instr]
  
  loadR reg slot = mkRegM $ \s ->
    RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot)
  
  getFreeRegsR :: RegM freeRegs freeRegs
  getFreeRegsR = mkRegM $ \ s@RA_State{ra_freeregs = freeregs} ->
    RA_Result s freeregs
  
  setFreeRegsR :: freeRegs -> RegM freeRegs ()
  setFreeRegsR regs = mkRegM $ \ s ->
    RA_Result s{ra_freeregs = regs} ()
  
  getAssigR :: RegM freeRegs (RegMap Loc)
  getAssigR = mkRegM $ \ s@RA_State{ra_assig = assig} ->
    RA_Result s assig
  
  setAssigR :: RegMap Loc -> RegM freeRegs ()
  setAssigR assig = mkRegM $ \ s ->
    RA_Result s{ra_assig=assig} ()
  
  getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs)
  getBlockAssigR = mkRegM $ \ s@RA_State{ra_blockassig = assig} ->
    RA_Result s assig
  
  setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs ()
  setBlockAssigR assig = mkRegM $ \ s ->
    RA_Result s{ra_blockassig = assig} ()
  
  setDeltaR :: Int -> RegM freeRegs ()
  setDeltaR n = mkRegM $ \ s ->
    RA_Result s{ra_delta = n} ()
  
  getDeltaR :: RegM freeRegs Int
  getDeltaR = mkRegM $ \s -> RA_Result s (ra_delta s)
  
  getUniqueR :: RegM freeRegs Unique
  getUniqueR = mkRegM $ \s ->
    case takeUniqueFromDSupply (ra_us s) of
      (uniq, us) -> RA_Result s{ra_us = us} uniq
  
  
  -- | Record that a spill instruction was inserted, for profiling.
  recordSpill :: SpillReason -> RegM freeRegs ()
  recordSpill spill
      = mkRegM $ \s -> RA_Result (s { ra_spills = spill : ra_spills s }) ()
  
  -- | Record a created fixup block
  recordFixupBlock :: BlockId -> BlockId -> BlockId -> RegM freeRegs ()
  recordFixupBlock from between to
      = mkRegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()
  