+
+-------------------------------------------------------------------------
+--
+-- Static Reference Tables
+--
+-------------------------------------------------------------------------
+
+-- There is just one SRT for each top level binding; all the nested
+-- bindings use sub-sections of this SRT. The label is passed down to
+-- the nested bindings via the monad.
+
+getSRTInfo :: FCode C_SRT
+getSRTInfo = do
+ srt_lbl <- getSRTLabel
+ srt <- getSRT
+ case srt of
+ -- TODO: Should we panic in this case?
+ -- Someone obviously thinks there should be an SRT
+ NoSRT -> return NoC_SRT
+ SRTEntries {} -> panic "getSRTInfo: SRTEntries. Perhaps you forgot to run SimplStg?"
+ SRT off len bmp
+ | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
+ -> do id <- newUnique
+ let srt_desc_lbl = mkLargeSRTLabel id
+ emitRODataLits "getSRTInfo" srt_desc_lbl
+ ( cmmLabelOffW srt_lbl off
+ : mkWordCLit (fromIntegral len)
+ : map mkWordCLit bmp)
+ return (C_SRT srt_desc_lbl 0 srt_escape)
+
+ SRT off len bmp
+ | otherwise
+ -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
+ -- The fromIntegral converts to StgHalfWord
+
+srt_escape = (-1) :: StgHalfWord
+
+clHasCafRefs :: ClosureInfo -> CafInfo
+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 (ListGraph blocks)) =
+ let blocks' = map fixStgRegBlock blocks
+ in CmmProc info lbl $ 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
+