content: {-# LANGUAGE GADTs #-}
  
  -----------------------------------------------------------------------------
  --
  -- Code generator utilities; mostly monadic
  --
  -- (c) The University of Glasgow 2004-2006
  --
  -----------------------------------------------------------------------------
  
  module GHC.StgToCmm.CgUtils (
          fixStgRegisters,
          baseRegOffset,
          get_Regtable_addr_from_offset,
          regTableOffset,
          get_GlobalReg_addr,
  
          -- * Streaming for CG
          CgStream
    ) where
  
  import GHC.Prelude
  
  import GHC.Platform.Regs
  import GHC.Platform
  import GHC.Cmm
  import GHC.Cmm.Dataflow.Block
  import GHC.Cmm.Dataflow.Graph
  import GHC.Cmm.Utils
  import GHC.Cmm.CLabel
  import GHC.Utils.Panic
  import GHC.Cmm.Dataflow.Label
  
  import GHC.Data.Stream (Stream)
  import GHC.Types.Unique.DSM (UniqDSMT)
  
  -- -----------------------------------------------------------------------------
  -- Streaming
  
  -- | The Stream instantiation used for code generation.
  -- Note the underlying monad is @UniqDSMT IO@, where @UniqDSMT@ is a transformer
  -- that propagates a deterministic unique supply (essentially an incrementing
  -- counter) from which new uniques are deterministically created during the
  -- code generation stages following StgToCmm.
  -- See Note [Object determinism].
  type CgStream = Stream (UniqDSMT IO)
  
  
  -- -----------------------------------------------------------------------------
  -- Information about global registers
  
  baseRegOffset :: Platform -> GlobalReg -> Int
  baseRegOffset platform reg = case reg of
     VanillaReg 1         -> pc_OFFSET_StgRegTable_rR1  constants
     VanillaReg 2         -> pc_OFFSET_StgRegTable_rR2  constants
     VanillaReg 3         -> pc_OFFSET_StgRegTable_rR3  constants
     VanillaReg 4         -> pc_OFFSET_StgRegTable_rR4  constants
     VanillaReg 5         -> pc_OFFSET_StgRegTable_rR5  constants
     VanillaReg 6         -> pc_OFFSET_StgRegTable_rR6  constants
     VanillaReg 7         -> pc_OFFSET_StgRegTable_rR7  constants
     VanillaReg 8         -> pc_OFFSET_StgRegTable_rR8  constants
     VanillaReg 9         -> pc_OFFSET_StgRegTable_rR9  constants
     VanillaReg 10        -> pc_OFFSET_StgRegTable_rR10 constants
     VanillaReg n         -> panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")
     FloatReg  1          -> pc_OFFSET_StgRegTable_rF1 constants
     FloatReg  2          -> pc_OFFSET_StgRegTable_rF2 constants
     FloatReg  3          -> pc_OFFSET_StgRegTable_rF3 constants
     FloatReg  4          -> pc_OFFSET_StgRegTable_rF4 constants
     FloatReg  5          -> pc_OFFSET_StgRegTable_rF5 constants
     FloatReg  6          -> pc_OFFSET_StgRegTable_rF6 constants
     FloatReg  n          -> panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")
     DoubleReg 1          -> pc_OFFSET_StgRegTable_rD1 constants
     DoubleReg 2          -> pc_OFFSET_StgRegTable_rD2 constants
     DoubleReg 3          -> pc_OFFSET_StgRegTable_rD3 constants
     DoubleReg 4          -> pc_OFFSET_StgRegTable_rD4 constants
     DoubleReg 5          -> pc_OFFSET_StgRegTable_rD5 constants
     DoubleReg 6          -> pc_OFFSET_StgRegTable_rD6 constants
     DoubleReg n          -> panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")
     XmmReg 1             -> pc_OFFSET_StgRegTable_rXMM1 constants
     XmmReg 2             -> pc_OFFSET_StgRegTable_rXMM2 constants
     XmmReg 3             -> pc_OFFSET_StgRegTable_rXMM3 constants
     XmmReg 4             -> pc_OFFSET_StgRegTable_rXMM4 constants
     XmmReg 5             -> pc_OFFSET_StgRegTable_rXMM5 constants
     XmmReg 6             -> pc_OFFSET_StgRegTable_rXMM6 constants
     XmmReg n             -> panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")
     YmmReg 1             -> pc_OFFSET_StgRegTable_rYMM1 constants
     YmmReg 2             -> pc_OFFSET_StgRegTable_rYMM2 constants
     YmmReg 3             -> pc_OFFSET_StgRegTable_rYMM3 constants
     YmmReg 4             -> pc_OFFSET_StgRegTable_rYMM4 constants
     YmmReg 5             -> pc_OFFSET_StgRegTable_rYMM5 constants
     YmmReg 6             -> pc_OFFSET_StgRegTable_rYMM6 constants
     YmmReg n             -> panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")
     ZmmReg 1             -> pc_OFFSET_StgRegTable_rZMM1 constants
     ZmmReg 2             -> pc_OFFSET_StgRegTable_rZMM2 constants
     ZmmReg 3             -> pc_OFFSET_StgRegTable_rZMM3 constants
     ZmmReg 4             -> pc_OFFSET_StgRegTable_rZMM4 constants
     ZmmReg 5             -> pc_OFFSET_StgRegTable_rZMM5 constants
     ZmmReg 6             -> pc_OFFSET_StgRegTable_rZMM6 constants
     ZmmReg n             -> panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")
     Sp                   -> pc_OFFSET_StgRegTable_rSp    constants
     SpLim                -> pc_OFFSET_StgRegTable_rSpLim constants
     LongReg 1            -> pc_OFFSET_StgRegTable_rL1    constants
     LongReg n            -> panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")
     Hp                   -> pc_OFFSET_StgRegTable_rHp             constants
     HpLim                -> pc_OFFSET_StgRegTable_rHpLim          constants
     CCCS                 -> pc_OFFSET_StgRegTable_rCCCS           constants
     CurrentTSO           -> pc_OFFSET_StgRegTable_rCurrentTSO     constants
     CurrentNursery       -> pc_OFFSET_StgRegTable_rCurrentNursery constants
     HpAlloc              -> pc_OFFSET_StgRegTable_rHpAlloc        constants
     EagerBlackholeInfo   -> pc_OFFSET_stgEagerBlackholeInfo       constants
     GCEnter1             -> pc_OFFSET_stgGCEnter1                 constants
     GCFun                -> pc_OFFSET_stgGCFun                    constants
     BaseReg              -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:BaseReg"
     PicBaseReg           -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:PicBaseReg"
     MachSp               -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:MachSp"
     UnwindReturnReg      -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:UnwindReturnReg"
   where
     !constants = platformConstants platform
  
  
  -- -----------------------------------------------------------------------------
  --
  -- STG/Cmm GlobalReg
  --
  -- -----------------------------------------------------------------------------
  
  -- | We map STG registers onto appropriate CmmExprs.  Either they map
  -- to real machine registers or stored as offsets from BaseReg.  Given
  -- a GlobalReg, get_GlobalReg_addr always produces the
  -- register table address for it.
  get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr
  get_GlobalReg_addr platform BaseReg = regTableOffset platform 0
  get_GlobalReg_addr platform mid
      = get_Regtable_addr_from_offset platform (baseRegOffset platform mid)
  
  -- Calculate a literal representing an offset into the register table.
  -- Used when we don't have an actual BaseReg to offset from.
  regTableOffset :: Platform -> Int -> CmmExpr
  regTableOffset platform n =
    CmmLit (CmmLabelOff mkMainCapabilityLabel (pc_OFFSET_Capability_r (platformConstants platform) + n))
  
  get_Regtable_addr_from_offset :: Platform -> Int -> CmmExpr
  get_Regtable_addr_from_offset platform offset =
      if haveRegBase platform
      then cmmRegOff (baseReg platform) offset
      else regTableOffset platform offset
  
  -- | Fixup global registers so that they assign to locations within the
  -- RegTable if they aren't pinned for the current target.
  fixStgRegisters :: Platform -> GenCmmDecl d h (GenCmmGraph CmmNode) -> GenCmmDecl d h (GenCmmGraph CmmNode)
  fixStgRegisters _ top@(CmmData _ _) = top
  
  fixStgRegisters platform (CmmProc info lbl live graph) =
    let graph' = modifyGraph (mapGraphBlocks mapMap (fixStgRegBlock platform)) graph
    in CmmProc info lbl live graph'
  
  fixStgRegBlock :: Platform -> Block CmmNode e x -> Block CmmNode e x
  fixStgRegBlock platform block = mapBlock (fixStgRegStmt platform) block
  
  fixStgRegStmt :: Platform -> CmmNode e x -> CmmNode e x
  fixStgRegStmt platform stmt = fixAssign $ mapExpDeep fixExpr stmt
    where
      fixAssign stmt =
        case stmt of
          CmmAssign (CmmGlobal reg_use) src
            -- MachSp isn't an STG register; it's merely here for tracking unwind
            -- information
            | reg == MachSp -> stmt
            | otherwise ->
              let baseAddr = get_GlobalReg_addr platform reg
              in case reg `elem` activeStgRegs platform of
                  True  -> CmmAssign (CmmGlobal reg_use) src
                  False -> CmmStore baseAddr src NaturallyAligned
            where reg = globalRegUse_reg reg_use
          other_stmt -> other_stmt
  
      fixExpr expr = case expr of
          -- MachSp isn't an STG; it's merely here for tracking unwind information
          CmmReg (CmmGlobal (GlobalRegUse MachSp _)) -> expr
          CmmReg (CmmGlobal reg_use) ->
              -- Replace register leaves with appropriate StixTrees for
              -- the given target.  MagicIds which map to a reg on this
              -- arch are left unchanged.  For the rest, BaseReg is taken
              -- to mean the address of the reg table in MainCapability,
              -- and for all others we generate an indirection to its
              -- location in the register table.
              let reg = globalRegUse_reg reg_use in
              case reg `elem` activeStgRegs platform of
                  True  -> expr
                  False ->
                      let baseAddr = get_GlobalReg_addr platform reg
                      in case reg of
                          BaseReg -> baseAddr
                          _other  -> CmmLoad baseAddr
                                       (globalRegUse_type reg_use)
                                       NaturallyAligned
  
          CmmRegOff greg@(CmmGlobal reg) offset ->
              -- RegOf leaves are just a shorthand form. If the reg maps
              -- to a real reg, we keep the shorthand, otherwise, we just
              -- expand it and defer to the above code.
              -- NB: to ensure type correctness we need to ensure the Add
              --     as well as the Int need to be of the same size as the
              --     register.
              case globalRegUse_reg reg `elem` activeStgRegs platform of
                  True  -> expr
                  False -> CmmMachOp (MO_Add (cmmRegWidth greg)) [
                                      fixExpr (CmmReg greg),
                                      CmmLit (CmmInt (fromIntegral offset)
                                                     (cmmRegWidth greg))]
  
          other_expr -> other_expr
  