{-# 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 -> 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 [GlobalRegUse]
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 a b. (a -> b) -> LabelMap a -> LabelMap b)
-> (forall (e1 :: Extensibility) (x1 :: Extensibility).
    Block CmmNode e1 x1 -> Block CmmNode e1 x1)
-> Graph CmmNode C C
-> Graph CmmNode C C
forall (s :: * -> *)
       (block :: (Extensibility -> Extensibility -> *)
                 -> Extensibility -> Extensibility -> *)
       (n :: Extensibility -> Extensibility -> *)
       (block' :: (Extensibility -> Extensibility -> *)
                  -> Extensibility -> Extensibility -> *)
       (n' :: Extensibility -> Extensibility -> *) (e :: Extensibility)
       (x :: Extensibility).
(forall a b. (a -> b) -> s a -> s b)
-> (forall (e1 :: Extensibility) (x1 :: Extensibility).
    block n e1 x1 -> block' n' e1 x1)
-> Graph' s block n e x
-> Graph' s block' n' e x
mapGraphBlocks (a -> b) -> LabelMap a -> LabelMap b
forall a b. (a -> b) -> LabelMap a -> LabelMap b
mapMap (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 -> [GlobalRegUse] -> CmmGraph -> RawCmmDecl
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalRegUse]
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
globalRegUse_reg 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
globalRegUse_reg 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
                                     (GlobalRegUse -> CmmType
globalRegUse_type GlobalRegUse
reg_use)
                                     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
globalRegUse_reg 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