+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
-----------------------------------------------------------------------------
--
-- Code generator utilities; mostly monadic
emitRODataLits, mkRODataLits,
emitIf, emitIfThenElse,
emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
- assignNonPtrTemp, newNonPtrTemp,
- assignPtrTemp, newPtrTemp,
+ assignTemp, newTemp,
emitSimultaneously,
emitSwitch, emitLitSwitch,
tagToClosure,
callerSaveVolatileRegs, get_GlobalReg_addr,
+ activeStgRegs, fixStgRegisters,
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
cmmUGtWord,
packHalfWordsCLit,
blankWord,
- getSRTInfo
+ getSRTInfo, clHasCafRefs
) where
#include "HsVersions.h"
-#include "MachRegs.h"
+#include "../includes/stg/MachRegs.h"
+import BlockId
import CgMonad
import TyCon
import DataCon
import Id
+import IdInfo
import Constants
import SMRep
import PprCmm ( {- instances -} )
import Cmm
import CLabel
import CmmUtils
-import MachOp
import ForeignCall
import ClosureInfo
import StgSyn (SRT(..))
+import Module
import Literal
import Digraph
import ListSetOps
import DynFlags
import FastString
import PackageConfig
-#ifdef DEBUG
import Outputable
-#endif
import Data.Char
import Data.Bits
cgLit other_lit = return (mkSimpleLit other_lit)
mkSimpleLit :: Literal -> CmmLit
-mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordRep
+mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth
mkSimpleLit MachNullAddr = zeroCLit
-mkSimpleLit (MachInt i) = CmmInt i wordRep
-mkSimpleLit (MachInt64 i) = CmmInt i I64
-mkSimpleLit (MachWord i) = CmmInt i wordRep
-mkSimpleLit (MachWord64 i) = CmmInt i I64
-mkSimpleLit (MachFloat r) = CmmFloat r F32
-mkSimpleLit (MachDouble r) = CmmFloat r F64
-mkSimpleLit (MachLabel fs ms) = CmmLabel (mkForeignLabel fs ms is_dyn)
- where
- is_dyn = False -- ToDo: fix me
+mkSimpleLit (MachInt i) = CmmInt i wordWidth
+mkSimpleLit (MachInt64 i) = CmmInt i W64
+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 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
-mkLtOp (MachInt _) = MO_S_Lt wordRep
-mkLtOp (MachFloat _) = MO_S_Lt F32
-mkLtOp (MachDouble _) = MO_S_Lt F64
-mkLtOp lit = MO_U_Lt (cmmLitRep (mkSimpleLit lit))
+mkLtOp (MachInt _) = MO_S_Lt wordWidth
+mkLtOp (MachFloat _) = MO_F_Lt W32
+mkLtOp (MachDouble _) = MO_F_Lt W64
+mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit)))
---------------------------------------------------
cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
-- The second arg is a *word* offset; need to change it to bytes
cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
-cmmOffsetExprW e wd_off = cmmIndexExpr wordRep e wd_off
+cmmOffsetExprW e wd_off = cmmIndexExpr wordWidth e wd_off
cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)
cmmLabelOffW :: CLabel -> WordOff -> CmmLit
cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)
-cmmLoadIndexW :: CmmExpr -> Int -> CmmExpr
-cmmLoadIndexW base off
- = CmmLoad (cmmOffsetW base off) wordRep
+cmmLoadIndexW :: CmmExpr -> Int -> CmmType -> CmmExpr
+cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty
-----------------------
cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord :: CmmExpr -> CmmExpr -> CmmExpr
cmmNegate :: CmmExpr -> CmmExpr
cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
-cmmNegate e = CmmMachOp (MO_S_Neg (cmmExprRep e)) [e]
+cmmNegate e = CmmMachOp (MO_S_Neg (cmmExprWidth e)) [e]
blankWord :: CmmStatic
blankWord = CmmUninitialised wORD_SIZE
-- Making literals
mkWordCLit :: StgWord -> CmmLit
-mkWordCLit wd = CmmInt (fromIntegral wd) wordRep
+mkWordCLit wd = CmmInt (fromIntegral wd) wordWidth
packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
-- Make a single word literal in which the lower_half_word is
--
--------------------------------------------------------------------------
-addToMem :: MachRep -- rep of the counter
+addToMem :: Width -- rep of the counter
-> CmmExpr -- Address
-> Int -- What to add (a word)
-> CmmStmt
-addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) rep))
+addToMem width ptr n = addToMemE width ptr (CmmLit (CmmInt (toInteger n) width))
-addToMemE :: MachRep -- rep of the counter
+addToMemE :: Width -- rep of the counter
-> CmmExpr -- Address
-> CmmExpr -- What to add (a word-typed expression)
-> CmmStmt
-addToMemE rep ptr n
- = CmmStore ptr (CmmMachOp (MO_Add rep) [CmmLoad ptr rep, n])
+addToMemE width ptr n
+ = CmmStore ptr (CmmMachOp (MO_Add width) [CmmLoad ptr (cmmBits width), n])
-------------------------------------------------------------------------
--
tagToClosure :: TyCon -> CmmExpr -> CmmExpr
tagToClosure tycon tag
- = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep
+ = CmmLoad (cmmOffsetExprW closure_tbl tag) gcWord
where closure_tbl = CmmLit (CmmLabel lbl)
- lbl = mkClosureTableLabel (tyConName tycon)
+ lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
-------------------------------------------------------------------------
--
-- Emit (if e then x else y)
emitIfThenElse cond then_part else_part
= do { then_id <- newLabelC
- ; else_id <- newLabelC
; join_id <- newLabelC
; stmtC (CmmCondBranch cond then_id)
; else_part
; labelC join_id
}
-emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> 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 -> [(CmmExpr,MachHint)] -> [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 -> MachHint -> LitString
- -> [(CmmExpr,MachHint)] -> Bool -> Code
-emitRtsCallWithResult res hint fun args safe
- = emitRtsCall' [(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'
- :: CmmHintFormals
- -> LitString
- -> [(CmmExpr,MachHint)]
+ :: [CmmHinted LocalReg]
+ -> 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
stmtsC caller_save
- stmtC (CmmCall target res args safety)
+ stmtC (CmmCall target res args safety CmmMayReturn)
stmtsC caller_load
where
(caller_save, caller_load) = callerSaveVolatileRegs vols
- target = CmmForeignCall fun_expr CCallConv
- fun_expr = mkLblExpr (mkRtsCodeLabel fun)
+ target = CmmCallee fun_expr CCallConv
+ fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
-----------------------------------------------------------------------------
--
vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
- all_of_em = [ VanillaReg n | n <- [0..mAX_Vanilla_REG] ]
+ all_of_em = [ VanillaReg n VNonGcPtr | n <- [0..mAX_Vanilla_REG] ]
+ -- The VNonGcPtr is a lie, but I don't think it matters
++ [ FloatReg n | n <- [0..mAX_Float_REG] ]
++ [ DoubleReg n | n <- [0..mAX_Double_REG] ]
++ [ LongReg n | n <- [0..mAX_Long_REG] ]
callerRestoreGlobalReg reg next
| callerSaves reg =
CmmAssign (CmmGlobal reg)
- (CmmLoad (get_GlobalReg_addr reg) (globalRegRep reg))
+ (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
: 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
- (globalRegRep 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 :: MachRep -> 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
+-- | Returns @True@ if this global register is stored in a caller-saves
-- machine register.
callerSaves :: GlobalReg -> Bool
callerSaves BaseReg = True
#endif
#ifdef CALLER_SAVES_R1
-callerSaves (VanillaReg 1) = True
+callerSaves (VanillaReg 1 _) = True
#endif
#ifdef CALLER_SAVES_R2
-callerSaves (VanillaReg 2) = True
+callerSaves (VanillaReg 2 _) = True
#endif
#ifdef CALLER_SAVES_R3
-callerSaves (VanillaReg 3) = True
+callerSaves (VanillaReg 3 _) = True
#endif
#ifdef CALLER_SAVES_R4
-callerSaves (VanillaReg 4) = True
+callerSaves (VanillaReg 4 _) = True
#endif
#ifdef CALLER_SAVES_R5
-callerSaves (VanillaReg 5) = True
+callerSaves (VanillaReg 5 _) = True
#endif
#ifdef CALLER_SAVES_R6
-callerSaves (VanillaReg 6) = True
+callerSaves (VanillaReg 6 _) = True
#endif
#ifdef CALLER_SAVES_R7
-callerSaves (VanillaReg 7) = True
+callerSaves (VanillaReg 7 _) = True
#endif
#ifdef CALLER_SAVES_R8
-callerSaves (VanillaReg 8) = True
+callerSaves (VanillaReg 8 _) = True
#endif
#ifdef CALLER_SAVES_F1
callerSaves (FloatReg 1) = True
baseRegOffset :: GlobalReg -> Int
-baseRegOffset (VanillaReg 1) = oFFSET_StgRegTable_rR1
-baseRegOffset (VanillaReg 2) = oFFSET_StgRegTable_rR2
-baseRegOffset (VanillaReg 3) = oFFSET_StgRegTable_rR3
-baseRegOffset (VanillaReg 4) = oFFSET_StgRegTable_rR4
-baseRegOffset (VanillaReg 5) = oFFSET_StgRegTable_rR5
-baseRegOffset (VanillaReg 6) = oFFSET_StgRegTable_rR6
-baseRegOffset (VanillaReg 7) = oFFSET_StgRegTable_rR7
-baseRegOffset (VanillaReg 8) = oFFSET_StgRegTable_rR8
-baseRegOffset (VanillaReg 9) = oFFSET_StgRegTable_rR9
-baseRegOffset (VanillaReg 10) = oFFSET_StgRegTable_rR10
+baseRegOffset (VanillaReg 1 _) = oFFSET_StgRegTable_rR1
+baseRegOffset (VanillaReg 2 _) = oFFSET_StgRegTable_rR2
+baseRegOffset (VanillaReg 3 _) = oFFSET_StgRegTable_rR3
+baseRegOffset (VanillaReg 4 _) = oFFSET_StgRegTable_rR4
+baseRegOffset (VanillaReg 5 _) = oFFSET_StgRegTable_rR5
+baseRegOffset (VanillaReg 6 _) = oFFSET_StgRegTable_rR6
+baseRegOffset (VanillaReg 7 _) = oFFSET_StgRegTable_rR7
+baseRegOffset (VanillaReg 8 _) = oFFSET_StgRegTable_rR8
+baseRegOffset (VanillaReg 9 _) = oFFSET_StgRegTable_rR9
+baseRegOffset (VanillaReg 10 _) = oFFSET_StgRegTable_rR10
baseRegOffset (FloatReg 1) = oFFSET_StgRegTable_rF1
baseRegOffset (FloatReg 2) = oFFSET_StgRegTable_rF2
baseRegOffset (FloatReg 3) = oFFSET_StgRegTable_rF3
baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO
baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery
baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc
+baseRegOffset EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo
baseRegOffset GCEnter1 = oFFSET_stgGCEnter1
baseRegOffset GCFun = oFFSET_stgGCFun
-#ifdef DEBUG
baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
baseRegOffset _ = panic "baseRegOffset:other"
-#endif
-------------------------------------------------------------------------
emitDataLits lbl lits
= emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
-mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
+mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
-- Emit a data-segment data block
mkDataLits lbl lits
= CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
-emitRODataLits :: CLabel -> [CmmLit] -> Code
+emitRODataLits :: String -> CLabel -> [CmmLit] -> Code
-- Emit a read-only data block
-emitRODataLits lbl lits
+emitRODataLits caller lbl lits
= emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
- where section | any needsRelocation lits = RelocatableReadOnlyData
- | otherwise = ReadOnlyData
- needsRelocation (CmmLabel _) = True
- needsRelocation (CmmLabelOff _ _) = True
- needsRelocation _ = False
+ where section | any needsRelocation lits = RelocatableReadOnlyData
+ | otherwise = ReadOnlyData
+ needsRelocation (CmmLabel _) = True
+ needsRelocation (CmmLabelOff _ _) = True
+ needsRelocation _ = False
-mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
+mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
mkRODataLits lbl lits
= CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
where section | any needsRelocation lits = RelocatableReadOnlyData
--
-------------------------------------------------------------------------
-assignNonPtrTemp :: CmmExpr -> FCode CmmExpr
+assignTemp :: CmmExpr -> FCode CmmExpr
-- For a non-trivial expression, e, create a local
-- variable and assign the expression to it
-assignNonPtrTemp e
+assignTemp e
| isTrivialCmmExpr e = return e
- | otherwise = do { reg <- newNonPtrTemp (cmmExprRep e)
+ | otherwise = do { reg <- newTemp (cmmExprType e)
; stmtC (CmmAssign (CmmLocal reg) e)
; return (CmmReg (CmmLocal reg)) }
-assignPtrTemp :: CmmExpr -> FCode CmmExpr
--- For a non-trivial expression, e, create a local
--- variable and assign the expression to it
-assignPtrTemp e
- | isTrivialCmmExpr e = return e
- | otherwise = do { reg <- newPtrTemp (cmmExprRep e)
- ; stmtC (CmmAssign (CmmLocal reg) e)
- ; return (CmmReg (CmmLocal reg)) }
-
-newNonPtrTemp :: MachRep -> FCode LocalReg
-newNonPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindNonPtr) }
-
-newPtrTemp :: MachRep -> FCode LocalReg
-newPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindPtr) }
-
+newTemp :: CmmType -> FCode LocalReg
+newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
-------------------------------------------------------------------------
--
-- if we can knock off a bunch of default cases with one if, then do so
| Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
- = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
+ = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
branch = CmmCondBranch cond deflt
; stmts <- mk_switch tag_expr' branches mb_deflt
}
| Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
- = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
+ = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
branch = CmmCondBranch cond deflt
; stmts <- mk_switch tag_expr' branches mb_deflt
}
| otherwise -- Use an if-tree
- = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
+ = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
-- To avoid duplication
; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
lo_tag (mid_tag-1) via_C
is_lo (t,_) = t < mid_tag
-assignNonPtrTemp' e
+assignTemp' e
| isTrivialCmmExpr e = return (CmmNop, e)
- | otherwise = do { reg <- newNonPtrTemp (cmmExprRep e)
+ | otherwise = do { reg <- newTemp (cmmExprType e)
; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
emitLitSwitch :: CmmExpr -- Tag to switch on
emitLitSwitch scrut [] deflt
= emitCgStmts deflt
emitLitSwitch scrut branches deflt_blk
- = do { scrut' <- assignNonPtrTemp scrut
+ = do { scrut' <- assignTemp scrut
; deflt_blk_id <- forkCgStmts deflt_blk
; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
; emitCgStmts blk }
= return (consCgStmt if_stmt blk)
where
cmm_lit = mkSimpleLit lit
- rep = cmmLitRep cmm_lit
- cond = CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit]
+ rep = cmmLitType cmm_lit
+ ne = if isFloatType rep then MO_F_Ne else MO_Ne
+ cond = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit]
if_stmt = CmmCondBranch cond deflt_blk_id
mk_lit_switch scrut deflt_blk_id branches
edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
stmt1 `mustFollow` stmt2
]
- components = stronglyConnComp edges
+ components = stronglyConnCompFromEdgedVertices edges
-- do_components deal with one strongly-connected component
-- Not cyclic, or singleton? Just do it
; stmtC from_temp }
go_via_temp (CmmAssign dest src)
- = do { tmp <- newNonPtrTemp (cmmRegRep dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
+ = do { tmp <- newTemp (cmmRegType dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
; stmtC (CmmAssign (CmmLocal tmp) src)
; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
go_via_temp (CmmStore dest src)
- = do { tmp <- newNonPtrTemp (cmmExprRep src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong
+ = do { tmp <- newTemp (cmmExprType src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong
; stmtC (CmmAssign (CmmLocal tmp) src)
; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
in
mustFollow :: CmmStmt -> CmmStmt -> Bool
CmmAssign reg _ `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
-CmmStore loc e `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprRep e)) stmt
+CmmStore loc e `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprType e)) stmt
CmmNop `mustFollow` stmt = False
CmmComment _ `mustFollow` stmt = 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 -> MachRep -> CmmExpr -> Bool
+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.
locUsedIn loc rep (CmmLit _) = False
locUsedIn loc rep (CmmRegOff reg' _) = False
locUsedIn loc rep (CmmMachOp _ es) = any (locUsedIn loc rep) es
-possiblySameLoc :: CmmExpr -> MachRep -> CmmExpr -> MachRep -> Bool
+possiblySameLoc :: CmmExpr -> CmmType -> CmmExpr -> CmmType -> Bool
-- Assumes that distinct registers (eg Hp, Sp) do not
-- point to the same location, nor any offset thereof.
possiblySameLoc (CmmReg r1) rep1 (CmmReg r2) rep2 = r1==r2
possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
= r1==r2 && end1 > start2 && end2 > start1
where
- end1 = start1 + machRepByteWidth rep1
- end2 = start2 + machRepByteWidth rep2
+ end1 = start1 + widthInBytes (typeWidth rep1)
+ end2 = start2 + widthInBytes (typeWidth rep2)
possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
possiblySameLoc l1 rep1 l2 rep2 = True -- Conservative
-- 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 srt_desc_lbl
+ emitRODataLits "getSRTInfo" srt_desc_lbl
( cmmLabelOffW srt_lbl off
: mkWordCLit (fromIntegral len)
: map mkWordCLit 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 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
+
projects / ghc-hetmet.git / blobdiff