    {-# 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,
      ) 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 -> GlobalReg -> Int
    baseRegOffset Platform
    platform GlobalReg
    reg = case GlobalReg
    reg of
       VanillaReg Int
    1         -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rR1  PlatformConstants
    constants
       VanillaReg Int
    2         -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rR2  PlatformConstants
    constants
       VanillaReg Int
    3         -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rR3  PlatformConstants
    constants
       VanillaReg Int
    4         -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rR4  PlatformConstants
    constants
       VanillaReg Int
    5         -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rR5  PlatformConstants
    constants
       VanillaReg Int
    6         -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rR6  PlatformConstants
    constants
       VanillaReg Int
    7         -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rR7  PlatformConstants
    constants
       VanillaReg Int
    8         -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rR8  PlatformConstants
    constants
       VanillaReg Int
    9         -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rR9  PlatformConstants
    constants
       VanillaReg Int
    10        -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rR10 PlatformConstants
    constants
       VanillaReg Int
    n         -> String -> Int
    forall a. HasCallStack => String -> a
    panic (String
    "Registers above R10 are not supported (tried to use R" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")")
       FloatReg  Int
    1          -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rF1 PlatformConstants
    constants
       FloatReg  Int
    2          -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rF2 PlatformConstants
    constants
       FloatReg  Int
    3          -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rF3 PlatformConstants
    constants
       FloatReg  Int
    4          -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rF4 PlatformConstants
    constants
       FloatReg  Int
    5          -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rF5 PlatformConstants
    constants
       FloatReg  Int
    6          -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rF6 PlatformConstants
    constants
       FloatReg  Int
    n          -> String -> Int
    forall a. HasCallStack => String -> a
    panic (String
    "Registers above F6 are not supported (tried to use F" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")")
       DoubleReg Int
    1          -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rD1 PlatformConstants
    constants
       DoubleReg Int
    2          -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rD2 PlatformConstants
    constants
       DoubleReg Int
    3          -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rD3 PlatformConstants
    constants
       DoubleReg Int
    4          -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rD4 PlatformConstants
    constants
       DoubleReg Int
    5          -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rD5 PlatformConstants
    constants
       DoubleReg Int
    6          -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rD6 PlatformConstants
    constants
       DoubleReg Int
    n          -> String -> Int
    forall a. HasCallStack => String -> a
    panic (String
    "Registers above D6 are not supported (tried to use D" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")")
       XmmReg Int
    1             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rXMM1 PlatformConstants
    constants
       XmmReg Int
    2             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rXMM2 PlatformConstants
    constants
       XmmReg Int
    3             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rXMM3 PlatformConstants
    constants
       XmmReg Int
    4             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rXMM4 PlatformConstants
    constants
       XmmReg Int
    5             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rXMM5 PlatformConstants
    constants
       XmmReg Int
    6             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rXMM6 PlatformConstants
    constants
       XmmReg Int
    n             -> String -> Int
    forall a. HasCallStack => String -> a
    panic (String
    "Registers above XMM6 are not supported (tried to use XMM" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")")
       YmmReg Int
    1             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rYMM1 PlatformConstants
    constants
       YmmReg Int
    2             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rYMM2 PlatformConstants
    constants
       YmmReg Int
    3             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rYMM3 PlatformConstants
    constants
       YmmReg Int
    4             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rYMM4 PlatformConstants
    constants
       YmmReg Int
    5             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rYMM5 PlatformConstants
    constants
       YmmReg Int
    6             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rYMM6 PlatformConstants
    constants
       YmmReg Int
    n             -> String -> Int
    forall a. HasCallStack => String -> a
    panic (String
    "Registers above YMM6 are not supported (tried to use YMM" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")")
       ZmmReg Int
    1             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rZMM1 PlatformConstants
    constants
       ZmmReg Int
    2             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rZMM2 PlatformConstants
    constants
       ZmmReg Int
    3             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rZMM3 PlatformConstants
    constants
       ZmmReg Int
    4             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rZMM4 PlatformConstants
    constants
       ZmmReg Int
    5             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rZMM5 PlatformConstants
    constants
       ZmmReg Int
    6             -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rZMM6 PlatformConstants
    constants
       ZmmReg Int
    n             -> String -> Int
    forall a. HasCallStack => String -> a
    panic (String
    "Registers above ZMM6 are not supported (tried to use ZMM" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")")
       GlobalReg
    Sp                   -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rSp    PlatformConstants
    constants
       GlobalReg
    SpLim                -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rSpLim PlatformConstants
    constants
       LongReg Int
    1            -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rL1    PlatformConstants
    constants
       LongReg Int
    n            -> String -> Int
    forall a. HasCallStack => String -> a
    panic (String
    "Registers above L1 are not supported (tried to use L" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")")
       GlobalReg
    Hp                   -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rHp             PlatformConstants
    constants
       GlobalReg
    HpLim                -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rHpLim          PlatformConstants
    constants
       GlobalReg
    CCCS                 -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rCCCS           PlatformConstants
    constants
       GlobalReg
    CurrentTSO           -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rCurrentTSO     PlatformConstants
    constants
       GlobalReg
    CurrentNursery       -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rCurrentNursery PlatformConstants
    constants
       GlobalReg
    HpAlloc              -> PlatformConstants -> Int
    pc_OFFSET_StgRegTable_rHpAlloc        PlatformConstants
    constants
       GlobalReg
    EagerBlackholeInfo   -> PlatformConstants -> Int
    pc_OFFSET_stgEagerBlackholeInfo       PlatformConstants
    constants
       GlobalReg
    GCEnter1             -> PlatformConstants -> Int
    pc_OFFSET_stgGCEnter1                 PlatformConstants
    constants
       GlobalReg
    GCFun                -> PlatformConstants -> Int
    pc_OFFSET_stgGCFun                    PlatformConstants
    constants
       GlobalReg
    BaseReg              -> String -> Int
    forall a. HasCallStack => String -> a
    panic String
    "GHC.StgToCmm.CgUtils.baseRegOffset:BaseReg"
       GlobalReg
    PicBaseReg           -> String -> Int
    forall a. HasCallStack => String -> a
    panic String
    "GHC.StgToCmm.CgUtils.baseRegOffset:PicBaseReg"
       GlobalReg
    MachSp               -> String -> Int
    forall a. HasCallStack => String -> a
    panic String
    "GHC.StgToCmm.CgUtils.baseRegOffset:MachSp"
       GlobalReg
    UnwindReturnReg      -> String -> Int
    forall a. HasCallStack => String -> a
    panic String
    "GHC.StgToCmm.CgUtils.baseRegOffset:UnwindReturnReg"
     where
       !constants :: PlatformConstants
    constants = Platform -> PlatformConstants
    platformConstants Platform
    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 -> GlobalReg -> CmmExpr
    get_GlobalReg_addr Platform
    platform GlobalReg
    BaseReg = Platform -> Int -> CmmExpr
    regTableOffset Platform
    platform Int
    0
    get_GlobalReg_addr Platform
    platform GlobalReg
    mid
        = Platform -> Int -> CmmExpr
    get_Regtable_addr_from_offset Platform
    platform (Platform -> GlobalReg -> Int
    baseRegOffset Platform
    platform GlobalReg
    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 -> Int -> CmmExpr
    regTableOffset Platform
    platform Int
    n =
      CmmLit -> CmmExpr
    CmmLit (CLabel -> Int -> CmmLit
    CmmLabelOff CLabel
    mkMainCapabilityLabel (PlatformConstants -> Int
    pc_OFFSET_Capability_r (Platform -> PlatformConstants
    platformConstants Platform
    platform) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    n))

    get_Regtable_addr_from_offset :: Platform -> Int -> CmmExpr
    get_Regtable_addr_from_offset :: Platform -> Int -> CmmExpr
    get_Regtable_addr_from_offset Platform
    platform Int
    offset =
        if Platform -> Bool
    haveRegBase Platform
    platform
        then CmmReg -> Int -> CmmExpr
    cmmRegOff (Platform -> CmmReg
    baseReg Platform
    platform) Int
    offset
        else Platform -> Int -> CmmExpr
    regTableOffset Platform
    platform Int
    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 :: Platform -> RawCmmDecl -> RawCmmDecl
    fixStgRegisters Platform
    _ top :: RawCmmDecl
    top@(CmmData Section
    _ RawCmmStatics
    _) = RawCmmDecl
    top

    fixStgRegisters Platform
    platform (CmmProc LabelMap RawCmmStatics
    info CLabel
    lbl [GlobalReg]
    live CmmGraph
    graph) =
      let graph' :: CmmGraph
    graph' = (Graph CmmNode C C -> Graph CmmNode C C) -> CmmGraph -> CmmGraph
    forall (n :: Extensibility -> Extensibility -> *)
           (n' :: Extensibility -> Extensibility -> *).
    (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
    modifyGraph ((forall (e1 :: Extensibility) (x1 :: Extensibility).
     Block CmmNode e1 x1 -> Block CmmNode e1 x1)
    -> Graph CmmNode C C -> Graph CmmNode C C
    forall (block :: (Extensibility -> Extensibility -> *)
                     -> Extensibility -> Extensibility -> *)
           (n :: Extensibility -> Extensibility -> *)
           (block' :: (Extensibility -> Extensibility -> *)
                      -> Extensibility -> Extensibility -> *)
           (n' :: Extensibility -> Extensibility -> *) (e :: Extensibility)
           (x :: Extensibility).
    (forall (e1 :: Extensibility) (x1 :: Extensibility).
     block n e1 x1 -> block' n' e1 x1)
    -> Graph' block n e x -> Graph' block' n' e x
    mapGraphBlocks (Platform -> Block CmmNode e1 x1 -> Block CmmNode e1 x1
    forall (e :: Extensibility) (x :: Extensibility).
    Platform -> Block CmmNode e x -> Block CmmNode e x
    fixStgRegBlock Platform
    platform)) CmmGraph
    graph
      in LabelMap RawCmmStatics
    -> CLabel -> [GlobalReg] -> CmmGraph -> RawCmmDecl
    forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
    CmmProc LabelMap RawCmmStatics
    info CLabel
    lbl [GlobalReg]
    live CmmGraph
    graph'

    fixStgRegBlock :: Platform -> Block CmmNode e x -> Block CmmNode e x
    fixStgRegBlock :: forall (e :: Extensibility) (x :: Extensibility).
    Platform -> Block CmmNode e x -> Block CmmNode e x
    fixStgRegBlock Platform
    platform Block CmmNode e x
    block = (forall (e1 :: Extensibility) (x1 :: Extensibility).
     CmmNode e1 x1 -> CmmNode e1 x1)
    -> Block CmmNode e x -> Block CmmNode e x
    forall (n :: Extensibility -> Extensibility -> *)
           (n' :: Extensibility -> Extensibility -> *) (e :: Extensibility)
           (x :: Extensibility).
    (forall (e1 :: Extensibility) (x1 :: Extensibility).
     n e1 x1 -> n' e1 x1)
    -> Block n e x -> Block n' e x
    mapBlock (Platform -> CmmNode e1 x1 -> CmmNode e1 x1
    forall (e :: Extensibility) (x :: Extensibility).
    Platform -> CmmNode e x -> CmmNode e x
    fixStgRegStmt Platform
    platform) Block CmmNode e x
    block

    fixStgRegStmt :: Platform -> CmmNode e x -> CmmNode e x
    fixStgRegStmt :: forall (e :: Extensibility) (x :: Extensibility).
    Platform -> CmmNode e x -> CmmNode e x
    fixStgRegStmt Platform
    platform CmmNode e x
    stmt = CmmNode e x -> CmmNode e x
    fixAssign (CmmNode e x -> CmmNode e x) -> CmmNode e x -> CmmNode e x
    forall a b. (a -> b) -> a -> b
    $ (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
    forall (e :: Extensibility) (x :: Extensibility).
    (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
    mapExpDeep CmmExpr -> CmmExpr
    fixExpr CmmNode e x
    stmt
      where
        fixAssign :: CmmNode e x -> CmmNode e x
    fixAssign CmmNode e x
    stmt =
          case CmmNode e x
    stmt of
            CmmAssign (CmmGlobal GlobalRegUse
    reg_use) CmmExpr
    src
              -- MachSp isn't an STG register; it's merely here for tracking unwind
              -- information
              | GlobalReg
    reg GlobalReg -> GlobalReg -> Bool
    forall a. Eq a => a -> a -> Bool
    == GlobalReg
    MachSp -> CmmNode e x
    stmt
              | Bool
    otherwise ->
                let baseAddr :: CmmExpr
    baseAddr = Platform -> GlobalReg -> CmmExpr
    get_GlobalReg_addr Platform
    platform GlobalReg
    reg
                in case GlobalReg
    reg GlobalReg -> [GlobalReg] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` Platform -> [GlobalReg]
    activeStgRegs Platform
    platform of
                    Bool
    True  -> CmmReg -> CmmExpr -> CmmNode 'Open 'Open
    CmmAssign (GlobalRegUse -> CmmReg
    CmmGlobal GlobalRegUse
    reg_use) CmmExpr
    src
                    Bool
    False -> CmmExpr -> CmmExpr -> AlignmentSpec -> CmmNode 'Open 'Open
    CmmStore CmmExpr
    baseAddr CmmExpr
    src AlignmentSpec
    NaturallyAligned
              where reg :: GlobalReg
    reg = GlobalRegUse -> GlobalReg
    globalRegUseGlobalReg GlobalRegUse
    reg_use
            CmmNode e x
    other_stmt -> CmmNode e x
    other_stmt

        fixExpr :: CmmExpr -> CmmExpr
    fixExpr CmmExpr
    expr = case CmmExpr
    expr of
            -- MachSp isn't an STG; it's merely here for tracking unwind information
            CmmReg (CmmGlobal (GlobalRegUse GlobalReg
    MachSp CmmType
    _)) -> CmmExpr
    expr
            CmmReg (CmmGlobal GlobalRegUse
    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 :: GlobalReg
    reg = GlobalRegUse -> GlobalReg
    globalRegUseGlobalReg GlobalRegUse
    reg_use in
                case GlobalReg
    reg GlobalReg -> [GlobalReg] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` Platform -> [GlobalReg]
    activeStgRegs Platform
    platform of
                    Bool
    True  -> CmmExpr
    expr
                    Bool
    False ->
                        let baseAddr :: CmmExpr
    baseAddr = Platform -> GlobalReg -> CmmExpr
    get_GlobalReg_addr Platform
    platform GlobalReg
    reg
                        in case GlobalReg
    reg of
                            GlobalReg
    BaseReg -> CmmExpr
    baseAddr
                            GlobalReg
    _other  -> CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
    CmmLoad CmmExpr
    baseAddr
                                         (Platform -> GlobalReg -> CmmType
    globalRegSpillType Platform
    platform GlobalReg
    reg)
                                         AlignmentSpec
    NaturallyAligned

            CmmRegOff greg :: CmmReg
    greg@(CmmGlobal GlobalRegUse
    reg) Int
    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 -> GlobalReg
    globalRegUseGlobalReg GlobalRegUse
    reg GlobalReg -> [GlobalReg] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` Platform -> [GlobalReg]
    activeStgRegs Platform
    platform of
                    Bool
    True  -> CmmExpr
    expr
                    Bool
    False -> MachOp -> [CmmExpr] -> CmmExpr
    CmmMachOp (Width -> MachOp
    MO_Add (CmmReg -> Width
    cmmRegWidth CmmReg
    greg)) [
                                        CmmExpr -> CmmExpr
    fixExpr (CmmReg -> CmmExpr
    CmmReg CmmReg
    greg),
                                        CmmLit -> CmmExpr
    CmmLit (Integer -> Width -> CmmLit
    CmmInt (Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    offset)
                                                       (CmmReg -> Width
    cmmRegWidth CmmReg
    greg))]

            CmmExpr
    other_expr -> CmmExpr
    other_expr