GHC/StgToCmm/CgUtils.hs

    {-# LANGUAGE GADTs #-}
    {-# LANGUAGE BangPatterns #-}

    -----------------------------------------------------------------------------
    --
    -- 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,
      ) 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

    -- -----------------------------------------------------------------------------
    -- 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 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 -> RawCmmDecl -> RawCmmDecl
    fixStgRegisters _ top@(CmmData _ _) = top

    fixStgRegisters platform (CmmProc info lbl live graph) =
      let graph' = modifyGraph (mapGraphBlocks (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) 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) src
                    False -> CmmStore baseAddr src
            other_stmt -> other_stmt

        fixExpr expr = case expr of
            -- MachSp isn't an STG; it's merely here for tracking unwind information
            CmmReg (CmmGlobal MachSp) -> expr
            CmmReg (CmmGlobal reg) ->
                -- 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.
                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 (globalRegType platform reg)

            CmmRegOff (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.
                case reg `elem` activeStgRegs platform of
                    True  -> expr
                    False -> CmmMachOp (MO_Add (wordWidth platform)) [
                                        fixExpr (CmmReg (CmmGlobal reg)),
                                        CmmLit (CmmInt (fromIntegral offset)
                                                       (wordWidth platform))]

            other_expr -> other_expr