diff options
Diffstat (limited to 'compiler/GHC/StgToCmm/CgUtils.hs')
| -rw-r--r-- | compiler/GHC/StgToCmm/CgUtils.hs | 186 |
1 files changed, 186 insertions, 0 deletions
diff --git a/compiler/GHC/StgToCmm/CgUtils.hs b/compiler/GHC/StgToCmm/CgUtils.hs new file mode 100644 index 0000000000..f3dccd9745 --- /dev/null +++ b/compiler/GHC/StgToCmm/CgUtils.hs @@ -0,0 +1,186 @@ +{-# 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 GhcPrelude + +import GHC.Platform.Regs +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 dflags (VanillaReg 1 _) = oFFSET_StgRegTable_rR1 dflags +baseRegOffset dflags (VanillaReg 2 _) = oFFSET_StgRegTable_rR2 dflags +baseRegOffset dflags (VanillaReg 3 _) = oFFSET_StgRegTable_rR3 dflags +baseRegOffset dflags (VanillaReg 4 _) = oFFSET_StgRegTable_rR4 dflags +baseRegOffset dflags (VanillaReg 5 _) = oFFSET_StgRegTable_rR5 dflags +baseRegOffset dflags (VanillaReg 6 _) = oFFSET_StgRegTable_rR6 dflags +baseRegOffset dflags (VanillaReg 7 _) = oFFSET_StgRegTable_rR7 dflags +baseRegOffset dflags (VanillaReg 8 _) = oFFSET_StgRegTable_rR8 dflags +baseRegOffset dflags (VanillaReg 9 _) = oFFSET_StgRegTable_rR9 dflags +baseRegOffset dflags (VanillaReg 10 _) = oFFSET_StgRegTable_rR10 dflags +baseRegOffset _ (VanillaReg n _) = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") +baseRegOffset dflags (FloatReg 1) = oFFSET_StgRegTable_rF1 dflags +baseRegOffset dflags (FloatReg 2) = oFFSET_StgRegTable_rF2 dflags +baseRegOffset dflags (FloatReg 3) = oFFSET_StgRegTable_rF3 dflags +baseRegOffset dflags (FloatReg 4) = oFFSET_StgRegTable_rF4 dflags +baseRegOffset dflags (FloatReg 5) = oFFSET_StgRegTable_rF5 dflags +baseRegOffset dflags (FloatReg 6) = oFFSET_StgRegTable_rF6 dflags +baseRegOffset _ (FloatReg n) = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")") +baseRegOffset dflags (DoubleReg 1) = oFFSET_StgRegTable_rD1 dflags +baseRegOffset dflags (DoubleReg 2) = oFFSET_StgRegTable_rD2 dflags +baseRegOffset dflags (DoubleReg 3) = oFFSET_StgRegTable_rD3 dflags +baseRegOffset dflags (DoubleReg 4) = oFFSET_StgRegTable_rD4 dflags +baseRegOffset dflags (DoubleReg 5) = oFFSET_StgRegTable_rD5 dflags +baseRegOffset dflags (DoubleReg 6) = oFFSET_StgRegTable_rD6 dflags +baseRegOffset _ (DoubleReg n) = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")") +baseRegOffset dflags (XmmReg 1) = oFFSET_StgRegTable_rXMM1 dflags +baseRegOffset dflags (XmmReg 2) = oFFSET_StgRegTable_rXMM2 dflags +baseRegOffset dflags (XmmReg 3) = oFFSET_StgRegTable_rXMM3 dflags +baseRegOffset dflags (XmmReg 4) = oFFSET_StgRegTable_rXMM4 dflags +baseRegOffset dflags (XmmReg 5) = oFFSET_StgRegTable_rXMM5 dflags +baseRegOffset dflags (XmmReg 6) = oFFSET_StgRegTable_rXMM6 dflags +baseRegOffset _ (XmmReg n) = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")") +baseRegOffset dflags (YmmReg 1) = oFFSET_StgRegTable_rYMM1 dflags +baseRegOffset dflags (YmmReg 2) = oFFSET_StgRegTable_rYMM2 dflags +baseRegOffset dflags (YmmReg 3) = oFFSET_StgRegTable_rYMM3 dflags +baseRegOffset dflags (YmmReg 4) = oFFSET_StgRegTable_rYMM4 dflags +baseRegOffset dflags (YmmReg 5) = oFFSET_StgRegTable_rYMM5 dflags +baseRegOffset dflags (YmmReg 6) = oFFSET_StgRegTable_rYMM6 dflags +baseRegOffset _ (YmmReg n) = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")") +baseRegOffset dflags (ZmmReg 1) = oFFSET_StgRegTable_rZMM1 dflags +baseRegOffset dflags (ZmmReg 2) = oFFSET_StgRegTable_rZMM2 dflags +baseRegOffset dflags (ZmmReg 3) = oFFSET_StgRegTable_rZMM3 dflags +baseRegOffset dflags (ZmmReg 4) = oFFSET_StgRegTable_rZMM4 dflags +baseRegOffset dflags (ZmmReg 5) = oFFSET_StgRegTable_rZMM5 dflags +baseRegOffset dflags (ZmmReg 6) = oFFSET_StgRegTable_rZMM6 dflags +baseRegOffset _ (ZmmReg n) = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")") +baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags +baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags +baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags +baseRegOffset _ (LongReg n) = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")") +baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags +baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags +baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags +baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags +baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags +baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags +baseRegOffset dflags EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo dflags +baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags +baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags +baseRegOffset _ BaseReg = panic "CgUtils.baseRegOffset:BaseReg" +baseRegOffset _ PicBaseReg = panic "CgUtils.baseRegOffset:PicBaseReg" +baseRegOffset _ MachSp = panic "CgUtils.baseRegOffset:MachSp" +baseRegOffset _ UnwindReturnReg = 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 dflags BaseReg = regTableOffset dflags 0 +get_GlobalReg_addr dflags mid + = get_Regtable_addr_from_offset dflags (baseRegOffset dflags 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 dflags n = + CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n)) + +get_Regtable_addr_from_offset :: DynFlags -> Int -> CmmExpr +get_Regtable_addr_from_offset dflags offset = + if haveRegBase (targetPlatform dflags) + then CmmRegOff baseReg offset + else regTableOffset dflags 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 _ top@(CmmData _ _) = top + +fixStgRegisters dflags (CmmProc info lbl live graph) = + let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph + in CmmProc info lbl live graph' + +fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x +fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block + +fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x +fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt + where + platform = targetPlatform dflags + + 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 dflags reg + in case reg `elem` activeStgRegs (targetPlatform dflags) 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 dflags reg + in case reg of + BaseReg -> baseAddr + _other -> CmmLoad baseAddr (globalRegType dflags 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 dflags)) [ + fixExpr (CmmReg (CmmGlobal reg)), + CmmLit (CmmInt (fromIntegral offset) + (wordWidth dflags))] + + other_expr -> other_expr |