{-# LANGUAGE GADTs #-}

-----------------------------------------------------------------------------
--
-- Code generator utilities; mostly monadic
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

module CgUtils ( fixStgRegisters ) where

import GhcPrelude

import CodeGen.Platform
import Cmm
import Hoopl.Block
import Hoopl.Graph
import CmmUtils
import CLabel
import DynFlags
import Outputable

-- -----------------------------------------------------------------------------
-- Information about global registers

baseRegOffset :: DynFlags -> GlobalReg -> Int

baseRegOffset :: DynFlags -> GlobalReg -> Int
baseRegOffset dflags :: DynFlags
dflags (VanillaReg 1 _)    = DynFlags -> Int
oFFSET_StgRegTable_rR1 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (VanillaReg 2 _)    = DynFlags -> Int
oFFSET_StgRegTable_rR2 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (VanillaReg 3 _)    = DynFlags -> Int
oFFSET_StgRegTable_rR3 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (VanillaReg 4 _)    = DynFlags -> Int
oFFSET_StgRegTable_rR4 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (VanillaReg 5 _)    = DynFlags -> Int
oFFSET_StgRegTable_rR5 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (VanillaReg 6 _)    = DynFlags -> Int
oFFSET_StgRegTable_rR6 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (VanillaReg 7 _)    = DynFlags -> Int
oFFSET_StgRegTable_rR7 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (VanillaReg 8 _)    = DynFlags -> Int
oFFSET_StgRegTable_rR8 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (VanillaReg 9 _)    = DynFlags -> Int
oFFSET_StgRegTable_rR9 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (VanillaReg 10 _)   = DynFlags -> Int
oFFSET_StgRegTable_rR10 DynFlags
dflags
baseRegOffset _      (VanillaReg n :: Int
n _)    = String -> Int
forall a. String -> a
panic ("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]
++ ")")
baseRegOffset dflags :: DynFlags
dflags (FloatReg  1)       = DynFlags -> Int
oFFSET_StgRegTable_rF1 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (FloatReg  2)       = DynFlags -> Int
oFFSET_StgRegTable_rF2 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (FloatReg  3)       = DynFlags -> Int
oFFSET_StgRegTable_rF3 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (FloatReg  4)       = DynFlags -> Int
oFFSET_StgRegTable_rF4 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (FloatReg  5)       = DynFlags -> Int
oFFSET_StgRegTable_rF5 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (FloatReg  6)       = DynFlags -> Int
oFFSET_StgRegTable_rF6 DynFlags
dflags
baseRegOffset _      (FloatReg  n :: Int
n)       = String -> Int
forall a. String -> a
panic ("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]
++ ")")
baseRegOffset dflags :: DynFlags
dflags (DoubleReg 1)       = DynFlags -> Int
oFFSET_StgRegTable_rD1 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (DoubleReg 2)       = DynFlags -> Int
oFFSET_StgRegTable_rD2 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (DoubleReg 3)       = DynFlags -> Int
oFFSET_StgRegTable_rD3 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (DoubleReg 4)       = DynFlags -> Int
oFFSET_StgRegTable_rD4 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (DoubleReg 5)       = DynFlags -> Int
oFFSET_StgRegTable_rD5 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (DoubleReg 6)       = DynFlags -> Int
oFFSET_StgRegTable_rD6 DynFlags
dflags
baseRegOffset _      (DoubleReg n :: Int
n)       = String -> Int
forall a. String -> a
panic ("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]
++ ")")
baseRegOffset dflags :: DynFlags
dflags (XmmReg 1)          = DynFlags -> Int
oFFSET_StgRegTable_rXMM1 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (XmmReg 2)          = DynFlags -> Int
oFFSET_StgRegTable_rXMM2 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (XmmReg 3)          = DynFlags -> Int
oFFSET_StgRegTable_rXMM3 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (XmmReg 4)          = DynFlags -> Int
oFFSET_StgRegTable_rXMM4 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (XmmReg 5)          = DynFlags -> Int
oFFSET_StgRegTable_rXMM5 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (XmmReg 6)          = DynFlags -> Int
oFFSET_StgRegTable_rXMM6 DynFlags
dflags
baseRegOffset _      (XmmReg n :: Int
n)          = String -> Int
forall a. String -> a
panic ("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]
++ ")")
baseRegOffset dflags :: DynFlags
dflags (YmmReg 1)          = DynFlags -> Int
oFFSET_StgRegTable_rYMM1 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (YmmReg 2)          = DynFlags -> Int
oFFSET_StgRegTable_rYMM2 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (YmmReg 3)          = DynFlags -> Int
oFFSET_StgRegTable_rYMM3 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (YmmReg 4)          = DynFlags -> Int
oFFSET_StgRegTable_rYMM4 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (YmmReg 5)          = DynFlags -> Int
oFFSET_StgRegTable_rYMM5 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (YmmReg 6)          = DynFlags -> Int
oFFSET_StgRegTable_rYMM6 DynFlags
dflags
baseRegOffset _      (YmmReg n :: Int
n)          = String -> Int
forall a. String -> a
panic ("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]
++ ")")
baseRegOffset dflags :: DynFlags
dflags (ZmmReg 1)          = DynFlags -> Int
oFFSET_StgRegTable_rZMM1 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (ZmmReg 2)          = DynFlags -> Int
oFFSET_StgRegTable_rZMM2 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (ZmmReg 3)          = DynFlags -> Int
oFFSET_StgRegTable_rZMM3 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (ZmmReg 4)          = DynFlags -> Int
oFFSET_StgRegTable_rZMM4 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (ZmmReg 5)          = DynFlags -> Int
oFFSET_StgRegTable_rZMM5 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (ZmmReg 6)          = DynFlags -> Int
oFFSET_StgRegTable_rZMM6 DynFlags
dflags
baseRegOffset _      (ZmmReg n :: Int
n)          = String -> Int
forall a. String -> a
panic ("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]
++ ")")
baseRegOffset dflags :: DynFlags
dflags Sp                  = DynFlags -> Int
oFFSET_StgRegTable_rSp DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags SpLim               = DynFlags -> Int
oFFSET_StgRegTable_rSpLim DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags (LongReg 1)         = DynFlags -> Int
oFFSET_StgRegTable_rL1 DynFlags
dflags
baseRegOffset _      (LongReg n :: Int
n)         = String -> Int
forall a. String -> a
panic ("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]
++ ")")
baseRegOffset dflags :: DynFlags
dflags Hp                  = DynFlags -> Int
oFFSET_StgRegTable_rHp DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags HpLim               = DynFlags -> Int
oFFSET_StgRegTable_rHpLim DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags CCCS                = DynFlags -> Int
oFFSET_StgRegTable_rCCCS DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags CurrentTSO          = DynFlags -> Int
oFFSET_StgRegTable_rCurrentTSO DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags CurrentNursery      = DynFlags -> Int
oFFSET_StgRegTable_rCurrentNursery DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags HpAlloc             = DynFlags -> Int
oFFSET_StgRegTable_rHpAlloc DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags EagerBlackholeInfo  = DynFlags -> Int
oFFSET_stgEagerBlackholeInfo DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags GCEnter1            = DynFlags -> Int
oFFSET_stgGCEnter1 DynFlags
dflags
baseRegOffset dflags :: DynFlags
dflags GCFun               = DynFlags -> Int
oFFSET_stgGCFun DynFlags
dflags
baseRegOffset _      BaseReg             = String -> Int
forall a. String -> a
panic "CgUtils.baseRegOffset:BaseReg"
baseRegOffset _      PicBaseReg          = String -> Int
forall a. String -> a
panic "CgUtils.baseRegOffset:PicBaseReg"
baseRegOffset _      MachSp              = String -> Int
forall a. String -> a
panic "CgUtils.baseRegOffset:MachSp"
baseRegOffset _      UnwindReturnReg     = String -> Int
forall a. String -> a
panic "CgUtils.baseRegOffset:UnwindReturnReg"


-- -----------------------------------------------------------------------------
--
-- 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 :: DynFlags -> GlobalReg -> CmmExpr
get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr
get_GlobalReg_addr dflags :: DynFlags
dflags BaseReg = DynFlags -> Int -> CmmExpr
regTableOffset DynFlags
dflags 0
get_GlobalReg_addr dflags :: DynFlags
dflags mid :: GlobalReg
mid
    = DynFlags -> CmmType -> Int -> CmmExpr
get_Regtable_addr_from_offset DynFlags
dflags
                                    (DynFlags -> GlobalReg -> CmmType
globalRegType DynFlags
dflags GlobalReg
mid) (DynFlags -> GlobalReg -> Int
baseRegOffset DynFlags
dflags 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 :: DynFlags -> Int -> CmmExpr
regTableOffset :: DynFlags -> Int -> CmmExpr
regTableOffset dflags :: DynFlags
dflags n :: Int
n =
  CmmLit -> CmmExpr
CmmLit (CLabel -> Int -> CmmLit
CmmLabelOff CLabel
mkMainCapabilityLabel (DynFlags -> Int
oFFSET_Capability_r DynFlags
dflags Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n))

get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
get_Regtable_addr_from_offset dflags :: DynFlags
dflags _ offset :: Int
offset =
    if Platform -> Bool
haveRegBase (DynFlags -> Platform
targetPlatform DynFlags
dflags)
    then CmmReg -> Int -> CmmExpr
CmmRegOff CmmReg
baseReg Int
offset
    else DynFlags -> Int -> CmmExpr
regTableOffset DynFlags
dflags Int
offset

-- | Fixup global registers so that they assign to locations within the
-- RegTable if they aren't pinned for the current target.
fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl
fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl
fixStgRegisters _ top :: RawCmmDecl
top@(CmmData _ _) = RawCmmDecl
top

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

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

fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x
fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x
fixStgRegStmt dflags :: DynFlags
dflags stmt :: 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 x. (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
mapExpDeep CmmExpr -> CmmExpr
fixExpr CmmNode e x
stmt
  where
    platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

    fixAssign :: CmmNode e x -> CmmNode e x
fixAssign stmt :: CmmNode e x
stmt =
      case CmmNode e x
stmt of
        CmmAssign (CmmGlobal reg :: GlobalReg
reg) src :: 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 = DynFlags -> GlobalReg -> CmmExpr
get_GlobalReg_addr DynFlags
dflags GlobalReg
reg
            in case GlobalReg
reg GlobalReg -> [GlobalReg] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Platform -> [GlobalReg]
activeStgRegs (DynFlags -> Platform
targetPlatform DynFlags
dflags) of
                True  -> CmmReg -> CmmExpr -> CmmNode O O
CmmAssign (GlobalReg -> CmmReg
CmmGlobal GlobalReg
reg) CmmExpr
src
                False -> CmmExpr -> CmmExpr -> CmmNode O O
CmmStore CmmExpr
baseAddr CmmExpr
src
        other_stmt :: CmmNode e x
other_stmt -> CmmNode e x
other_stmt

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

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

        other_expr :: CmmExpr
other_expr -> CmmExpr
other_expr