X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgUtils.hs;h=d22fee1e7581d80b280d127c5e6c8eab893ab45c;hp=b14d318c66d3ab4f873344e04dc41bbaac5376cc;hb=49a8e5c021009430d373d6224b29004c7d18c408;hpb=0e4eef1e5c326750d1b94c9b365c0b3fab19e611 diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index b14d318..d22fee1 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -26,6 +26,7 @@ module CgUtils ( tagToClosure, callerSaveVolatileRegs, get_GlobalReg_addr, + activeStgRegs, fixStgRegisters, cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, cmmUGtWord, @@ -50,7 +51,7 @@ module CgUtils ( ) where #include "HsVersions.h" -#include "../includes/MachRegs.h" +#include "../includes/stg/MachRegs.h" import BlockId import CgMonad @@ -67,6 +68,7 @@ import CmmUtils import ForeignCall import ClosureInfo import StgSyn (SRT(..)) +import Module import Literal import Digraph import ListSetOps @@ -110,9 +112,11 @@ mkSimpleLit (MachWord i) = CmmInt i wordWidth mkSimpleLit (MachWord64 i) = CmmInt i W64 mkSimpleLit (MachFloat r) = CmmFloat r W32 mkSimpleLit (MachDouble r) = CmmFloat r W64 -mkSimpleLit (MachLabel fs ms) = CmmLabel (mkForeignLabel fs ms is_dyn) - where - is_dyn = False -- ToDo: fix me +mkSimpleLit (MachLabel fs ms fod) + = CmmLabel (mkForeignLabel fs ms labelSrc fod) + where + -- TODO: Literal labels might not actually be in the current package... + labelSrc = ForeignLabelInThisPackage mkLtOp :: Literal -> MachOp -- On signed literals we must do a signed comparison @@ -331,28 +335,39 @@ emitIfThenElse cond then_part else_part ; labelC join_id } -emitRtsCall :: LitString -> [CmmHinted CmmExpr] -> Bool -> Code -emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe + +-- | Emit code to call a Cmm function. +emitRtsCall + :: PackageId -- ^ package the function is in + -> FastString -- ^ name of function + -> [CmmHinted CmmExpr] -- ^ function args + -> Bool -- ^ whether this is a safe call + -> Code -- ^ cmm code + +emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe -- The 'Nothing' says "save all global registers" -emitRtsCallWithVols :: LitString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code -emitRtsCallWithVols fun args vols safe - = emitRtsCall' [] fun args (Just vols) safe +emitRtsCallWithVols :: PackageId -> FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code +emitRtsCallWithVols pkg fun args vols safe + = emitRtsCall' [] pkg fun args (Just vols) safe -emitRtsCallWithResult :: LocalReg -> ForeignHint -> LitString - -> [CmmHinted CmmExpr] -> Bool -> Code -emitRtsCallWithResult res hint fun args safe - = emitRtsCall' [CmmHinted res hint] fun args Nothing safe +emitRtsCallWithResult + :: LocalReg -> ForeignHint + -> PackageId -> FastString + -> [CmmHinted CmmExpr] -> Bool -> Code +emitRtsCallWithResult res hint pkg fun args safe + = emitRtsCall' [CmmHinted res hint] pkg fun args Nothing safe -- Make a call to an RTS C procedure emitRtsCall' :: [CmmHinted LocalReg] - -> LitString + -> PackageId + -> FastString -> [CmmHinted CmmExpr] -> Maybe [GlobalReg] -> Bool -- True <=> CmmSafe call -> Code -emitRtsCall' res fun args vols safe = do +emitRtsCall' res pkg fun args vols safe = do safety <- if safe then getSRTInfo >>= (return . CmmSafe) else return CmmUnsafe @@ -362,7 +377,7 @@ emitRtsCall' res fun args vols safe = do where (caller_save, caller_load) = callerSaveVolatileRegs vols target = CmmCallee fun_expr CCallConv - fun_expr = mkLblExpr (mkRtsCodeLabel fun) + fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun) ----------------------------------------------------------------------------- -- @@ -409,33 +424,6 @@ callerSaveVolatileRegs vols = (caller_save, caller_load) : next | otherwise = next --- ----------------------------------------------------------------------------- --- Global registers - --- 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. --- (See also get_GlobalReg_reg_or_addr in MachRegs) - -get_GlobalReg_addr :: GlobalReg -> CmmExpr -get_GlobalReg_addr BaseReg = regTableOffset 0 -get_GlobalReg_addr mid = get_Regtable_addr_from_offset - (globalRegType mid) (baseRegOffset mid) - --- Calculate a literal representing an offset into the register table. --- Used when we don't have an actual BaseReg to offset from. -regTableOffset n = - CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n)) - -get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr -get_Regtable_addr_from_offset rep offset = -#ifdef REG_Base - CmmRegOff (CmmGlobal BaseReg) offset -#else - regTableOffset offset -#endif - -- | Returns @True@ if this global register is stored in a caller-saves -- machine register. @@ -931,13 +919,6 @@ anySrc p (CmmComment _) = False anySrc p CmmNop = False anySrc p other = True -- Conservative -regUsedIn :: CmmReg -> CmmExpr -> Bool -reg `regUsedIn` CmmLit _ = False -reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e -reg `regUsedIn` CmmReg reg' = reg == reg' -reg `regUsedIn` CmmRegOff reg' _ = reg == reg' -reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es - locUsedIn :: CmmExpr -> CmmType -> CmmExpr -> Bool -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of -- 'e'. Returns True if it's not sure. @@ -1003,3 +984,181 @@ clHasCafRefs (ClosureInfo {closureSRT = srt}) = case srt of NoC_SRT -> NoCafRefs _ -> MayHaveCafRefs clHasCafRefs (ConInfo {}) = NoCafRefs + +-- ----------------------------------------------------------------------------- +-- +-- STG/Cmm GlobalReg +-- +-- ----------------------------------------------------------------------------- + +-- | Here is where the STG register map is defined for each target arch. +-- The order matters (for the llvm backend anyway)! We must make sure to +-- maintain the order here with the order used in the LLVM calling conventions. +-- Note that also, this isn't all registers, just the ones that are currently +-- possbily mapped to real registers. +activeStgRegs :: [GlobalReg] +activeStgRegs = [ +#ifdef REG_Base + BaseReg +#endif +#ifdef REG_Sp + ,Sp +#endif +#ifdef REG_Hp + ,Hp +#endif +#ifdef REG_R1 + ,VanillaReg 1 VGcPtr +#endif +#ifdef REG_R2 + ,VanillaReg 2 VGcPtr +#endif +#ifdef REG_R3 + ,VanillaReg 3 VGcPtr +#endif +#ifdef REG_R4 + ,VanillaReg 4 VGcPtr +#endif +#ifdef REG_R5 + ,VanillaReg 5 VGcPtr +#endif +#ifdef REG_R6 + ,VanillaReg 6 VGcPtr +#endif +#ifdef REG_R7 + ,VanillaReg 7 VGcPtr +#endif +#ifdef REG_R8 + ,VanillaReg 8 VGcPtr +#endif +#ifdef REG_SpLim + ,SpLim +#endif +#ifdef REG_F1 + ,FloatReg 1 +#endif +#ifdef REG_F2 + ,FloatReg 2 +#endif +#ifdef REG_F3 + ,FloatReg 3 +#endif +#ifdef REG_F4 + ,FloatReg 4 +#endif +#ifdef REG_D1 + ,DoubleReg 1 +#endif +#ifdef REG_D2 + ,DoubleReg 2 +#endif + ] + +-- | 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 :: GlobalReg -> CmmExpr +get_GlobalReg_addr BaseReg = regTableOffset 0 +get_GlobalReg_addr mid = get_Regtable_addr_from_offset + (globalRegType mid) (baseRegOffset mid) + +-- Calculate a literal representing an offset into the register table. +-- Used when we don't have an actual BaseReg to offset from. +regTableOffset n = + CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n)) + +get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr +get_Regtable_addr_from_offset rep offset = +#ifdef REG_Base + CmmRegOff (CmmGlobal BaseReg) offset +#else + regTableOffset offset +#endif + +-- | Fixup global registers so that they assign to locations within the +-- RegTable if they aren't pinned for the current target. +fixStgRegisters :: RawCmmTop -> RawCmmTop +fixStgRegisters top@(CmmData _ _) = top + +fixStgRegisters (CmmProc info lbl params (ListGraph blocks)) = + let blocks' = map fixStgRegBlock blocks + in CmmProc info lbl params $ ListGraph blocks' + +fixStgRegBlock :: CmmBasicBlock -> CmmBasicBlock +fixStgRegBlock (BasicBlock id stmts) = + let stmts' = map fixStgRegStmt stmts + in BasicBlock id stmts' + +fixStgRegStmt :: CmmStmt -> CmmStmt +fixStgRegStmt stmt + = case stmt of + CmmAssign (CmmGlobal reg) src -> + let src' = fixStgRegExpr src + baseAddr = get_GlobalReg_addr reg + in case reg `elem` activeStgRegs of + True -> CmmAssign (CmmGlobal reg) src' + False -> CmmStore baseAddr src' + + CmmAssign reg src -> + let src' = fixStgRegExpr src + in CmmAssign reg src' + + CmmStore addr src -> CmmStore (fixStgRegExpr addr) (fixStgRegExpr src) + + CmmCall target regs args srt returns -> + let target' = case target of + CmmCallee e conv -> CmmCallee (fixStgRegExpr e) conv + other -> other + args' = map (\(CmmHinted arg hint) -> + (CmmHinted (fixStgRegExpr arg) hint)) args + in CmmCall target' regs args' srt returns + + CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr test) dest + + CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr expr) ids + + CmmJump addr regs -> CmmJump (fixStgRegExpr addr) regs + + -- CmmNop, CmmComment, CmmBranch, CmmReturn + _other -> stmt + + +fixStgRegExpr :: CmmExpr -> CmmExpr +fixStgRegExpr expr + = case expr of + CmmLoad addr ty -> CmmLoad (fixStgRegExpr addr) ty + + CmmMachOp mop args -> CmmMachOp mop args' + where args' = map fixStgRegExpr args + + 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 of + True -> expr + False -> + let baseAddr = get_GlobalReg_addr reg + in case reg of + BaseReg -> fixStgRegExpr baseAddr + _other -> fixStgRegExpr + (CmmLoad baseAddr (globalRegType 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 of + True -> expr + False -> fixStgRegExpr (CmmMachOp (MO_Add wordWidth) [ + CmmReg (CmmGlobal reg), + CmmLit (CmmInt (fromIntegral offset) + wordWidth)]) + + -- CmmLit, CmmReg (CmmLocal), CmmStackSlot + _other -> expr +