module CgUtils (
addIdReps,
cgLit,
emitDataLits, mkDataLits,
emitRODataLits, mkRODataLits,
emitIf, emitIfThenElse,
emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
assignTemp, newTemp,
emitSimultaneously,
emitSwitch, emitLitSwitch,
tagToClosure,
callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
activeStgRegs, fixStgRegisters,
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
cmmUGtWord,
cmmOffsetExprW, cmmOffsetExprB,
cmmRegOffW, cmmRegOffB,
cmmLabelOffW, cmmLabelOffB,
cmmOffsetW, cmmOffsetB,
cmmOffsetLitW, cmmOffsetLitB,
cmmLoadIndexW,
cmmConstrTag, cmmConstrTag1,
tagForCon, tagCons, isSmallFamily,
cmmUntag, cmmIsTagged, cmmGetTag,
addToMem, addToMemE,
mkWordCLit,
mkStringCLit, mkByteStringCLit,
packHalfWordsCLit,
blankWord,
getSRTInfo, clHasCafRefs
) where
#include "HsVersions.h"
#include "../includes/stg/MachRegs.h"
import BlockId
import CgMonad
import TyCon
import DataCon
import Id
import IdInfo
import Constants
import SMRep
import PprCmm ( )
import Cmm
import CLabel
import CmmUtils
import ForeignCall
import ClosureInfo
import StgSyn (SRT(..))
import Module
import Literal
import Digraph
import ListSetOps
import Util
import DynFlags
import FastString
import PackageConfig
import Outputable
import Data.Char
import Data.Bits
import Data.Word
import Data.Maybe
addIdReps :: [Id] -> [(CgRep, Id)]
addIdReps ids = [(idCgRep id, id) | id <- ids]
cgLit :: Literal -> FCode CmmLit
cgLit (MachStr s) = mkByteStringCLit (bytesFS s)
cgLit other_lit = return (mkSimpleLit other_lit)
mkSimpleLit :: Literal -> CmmLit
mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth
mkSimpleLit MachNullAddr = zeroCLit
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
labelSrc = ForeignLabelInThisPackage
mkLtOp :: Literal -> MachOp
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)))
cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
cmmRegOffB = cmmRegOff
cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB = cmmOffset
cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprB = cmmOffsetExpr
cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
cmmLabelOffB = cmmLabelOff
cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
cmmOffsetLitB = cmmOffsetLit
cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
cmmOffsetExprW e wd_off = cmmIndexExpr wordWidth e wd_off
cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)
cmmRegOffW :: CmmReg -> WordOff -> CmmExpr
cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE)
cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit
cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off)
cmmLabelOffW :: CLabel -> WordOff -> CmmLit
cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)
cmmLoadIndexW :: CmmExpr -> Int -> CmmType -> CmmExpr
cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty
cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord :: CmmExpr -> CmmExpr -> CmmExpr
cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2]
cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
cmmNeWord e1 e2 = CmmMachOp mo_wordNe [e1, e2]
cmmEqWord e1 e2 = CmmMachOp mo_wordEq [e1, e2]
cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
cmmNegate :: CmmExpr -> CmmExpr
cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (n) rep)
cmmNegate e = CmmMachOp (MO_S_Neg (cmmExprWidth e)) [e]
blankWord :: CmmStatic
blankWord = CmmUninitialised wORD_SIZE
cmmTagMask = CmmLit (mkIntCLit tAG_MASK)
cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK))
cmmUntag e@(CmmLit (CmmLabel _)) = e
cmmUntag e = (e `cmmAndWord` cmmPointerMask)
cmmGetTag e = (e `cmmAndWord` cmmTagMask)
cmmIsTagged e = (e `cmmAndWord` cmmTagMask)
`cmmNeWord` CmmLit zeroCLit
cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1))
cmmConstrTag1 e = e `cmmAndWord` cmmTagMask
isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
tagForCon con = tag
where
con_tag = dataConTagZ con
fam_size = tyConFamilySize (dataConTyCon con)
tag | isSmallFamily fam_size = con_tag + 1
| otherwise = 1
tagCons con expr = cmmOffsetB expr (tagForCon con)
dataConTagZ :: DataCon -> ConTagZ
dataConTagZ con = dataConTag con fIRST_TAG
mkWordCLit :: StgWord -> CmmLit
mkWordCLit wd = CmmInt (fromIntegral wd) wordWidth
packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
packHalfWordsCLit lower_half_word upper_half_word
#ifdef WORDS_BIGENDIAN
= mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
.|. fromIntegral upper_half_word)
#else
= mkWordCLit ((fromIntegral lower_half_word)
.|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
#endif
addToMem :: Width
-> CmmExpr
-> Int
-> CmmStmt
addToMem width ptr n = addToMemE width ptr (CmmLit (CmmInt (toInteger n) width))
addToMemE :: Width
-> CmmExpr
-> CmmExpr
-> CmmStmt
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) gcWord
where closure_tbl = CmmLit (CmmLabel lbl)
lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
emitIf :: CmmExpr
-> Code
-> Code
emitIf cond then_part
= do { then_id <- newLabelC
; join_id <- newLabelC
; stmtC (CmmCondBranch cond then_id)
; stmtC (CmmBranch join_id)
; labelC then_id
; then_part
; labelC join_id
}
emitIfThenElse :: CmmExpr
-> Code
-> Code
-> Code
emitIfThenElse cond then_part else_part
= do { then_id <- newLabelC
; join_id <- newLabelC
; stmtC (CmmCondBranch cond then_id)
; else_part
; stmtC (CmmBranch join_id)
; labelC then_id
; then_part
; labelC join_id
}
emitRtsCall
:: PackageId
-> FastString
-> [CmmHinted CmmExpr]
-> Bool
-> Code
emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing 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
-> PackageId -> FastString
-> [CmmHinted CmmExpr] -> Bool -> Code
emitRtsCallWithResult res hint pkg fun args safe
= emitRtsCall' [CmmHinted res hint] pkg fun args Nothing safe
emitRtsCall'
:: [CmmHinted LocalReg]
-> PackageId
-> FastString
-> [CmmHinted CmmExpr]
-> Maybe [GlobalReg]
-> Bool
-> Code
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 CmmMayReturn)
stmtsC caller_load
where
(caller_save, caller_load) = callerSaveVolatileRegs vols
target = CmmCallee fun_expr CCallConv
fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
callerSaveVolatileRegs vols = (caller_save, caller_load)
where
caller_save = foldr ($!) [] (map callerSaveGlobalReg regs_to_save)
caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save)
system_regs = [Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery,
BaseReg ]
regs_to_save = system_regs ++ vol_list
vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
all_of_em = [ VanillaReg n VNonGcPtr | n <- [0..mAX_Vanilla_REG] ]
++ [ FloatReg n | n <- [0..mAX_Float_REG] ]
++ [ DoubleReg n | n <- [0..mAX_Double_REG] ]
++ [ LongReg n | n <- [0..mAX_Long_REG] ]
callerSaveGlobalReg reg next
| callerSaves reg =
CmmStore (get_GlobalReg_addr reg)
(CmmReg (CmmGlobal reg)) : next
| otherwise = next
callerRestoreGlobalReg reg next
| callerSaves reg =
CmmAssign (CmmGlobal reg)
(CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
: next
| otherwise = next
callerSaves :: GlobalReg -> Bool
#ifdef CALLER_SAVES_Base
callerSaves BaseReg = True
#endif
#ifdef CALLER_SAVES_R1
callerSaves (VanillaReg 1 _) = True
#endif
#ifdef CALLER_SAVES_R2
callerSaves (VanillaReg 2 _) = True
#endif
#ifdef CALLER_SAVES_R3
callerSaves (VanillaReg 3 _) = True
#endif
#ifdef CALLER_SAVES_R4
callerSaves (VanillaReg 4 _) = True
#endif
#ifdef CALLER_SAVES_R5
callerSaves (VanillaReg 5 _) = True
#endif
#ifdef CALLER_SAVES_R6
callerSaves (VanillaReg 6 _) = True
#endif
#ifdef CALLER_SAVES_R7
callerSaves (VanillaReg 7 _) = True
#endif
#ifdef CALLER_SAVES_R8
callerSaves (VanillaReg 8 _) = True
#endif
#ifdef CALLER_SAVES_F1
callerSaves (FloatReg 1) = True
#endif
#ifdef CALLER_SAVES_F2
callerSaves (FloatReg 2) = True
#endif
#ifdef CALLER_SAVES_F3
callerSaves (FloatReg 3) = True
#endif
#ifdef CALLER_SAVES_F4
callerSaves (FloatReg 4) = True
#endif
#ifdef CALLER_SAVES_D1
callerSaves (DoubleReg 1) = True
#endif
#ifdef CALLER_SAVES_D2
callerSaves (DoubleReg 2) = True
#endif
#ifdef CALLER_SAVES_L1
callerSaves (LongReg 1) = True
#endif
#ifdef CALLER_SAVES_Sp
callerSaves Sp = True
#endif
#ifdef CALLER_SAVES_SpLim
callerSaves SpLim = True
#endif
#ifdef CALLER_SAVES_Hp
callerSaves Hp = True
#endif
#ifdef CALLER_SAVES_HpLim
callerSaves HpLim = True
#endif
#ifdef CALLER_SAVES_CurrentTSO
callerSaves CurrentTSO = True
#endif
#ifdef CALLER_SAVES_CurrentNursery
callerSaves CurrentNursery = True
#endif
callerSaves _ = False
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 (FloatReg 1) = oFFSET_StgRegTable_rF1
baseRegOffset (FloatReg 2) = oFFSET_StgRegTable_rF2
baseRegOffset (FloatReg 3) = oFFSET_StgRegTable_rF3
baseRegOffset (FloatReg 4) = oFFSET_StgRegTable_rF4
baseRegOffset (DoubleReg 1) = oFFSET_StgRegTable_rD1
baseRegOffset (DoubleReg 2) = oFFSET_StgRegTable_rD2
baseRegOffset Sp = oFFSET_StgRegTable_rSp
baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim
baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1
baseRegOffset Hp = oFFSET_StgRegTable_rHp
baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim
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
baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
baseRegOffset _ = panic "baseRegOffset:other"
emitDataLits :: CLabel -> [CmmLit] -> Code
emitDataLits lbl lits
= emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
mkDataLits lbl lits
= CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
emitRODataLits :: String -> CLabel -> [CmmLit] -> Code
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
mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
mkRODataLits lbl lits
= CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
where section | any needsRelocation lits = RelocatableReadOnlyData
| otherwise = ReadOnlyData
needsRelocation (CmmLabel _) = True
needsRelocation (CmmLabelOff _ _) = True
needsRelocation _ = False
mkStringCLit :: String -> FCode CmmLit
mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str)
mkByteStringCLit :: [Word8] -> FCode CmmLit
mkByteStringCLit bytes
= do { uniq <- newUnique
; let lbl = mkStringLitLabel uniq
; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
; return (CmmLabel lbl) }
assignTemp :: CmmExpr -> FCode CmmExpr
assignTemp e
| isTrivialCmmExpr e = return e
| otherwise = do { reg <- newTemp (cmmExprType e)
; stmtC (CmmAssign (CmmLocal reg) e)
; return (CmmReg (CmmLocal reg)) }
newTemp :: CmmType -> FCode LocalReg
newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
emitSwitch
:: CmmExpr
-> [(ConTagZ, CgStmts)]
-> Maybe CgStmts
-> ConTagZ -> ConTagZ
-> Code
emitSwitch tag_expr [] (Just stmts) _ _
= emitCgStmts stmts
emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
=
do { mb_deflt_id <-
case mb_deflt of
Nothing -> return Nothing
Just stmts -> do id <- forkCgStmts stmts; return (Just id)
; dflags <- getDynFlags
; let via_C | HscC <- hscTarget dflags = True
| otherwise = False
; stmts <- mk_switch tag_expr (sortLe le branches)
mb_deflt_id lo_tag hi_tag via_C
; emitCgStmts stmts
}
where
(t1,_) `le` (t2,_) = t1 <= t2
mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
-> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
-> FCode CgStmts
mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
| lo_tag == hi_tag
= ASSERT( tag == lo_tag )
return stmts
mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
= return stmts
mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
= return (CmmCondBranch cond deflt `consCgStmt` stmts)
where
cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
| use_switch
= do { branch_ids <- mapM forkCgStmts (map snd branches)
; let
tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
find_branch :: ConTagZ -> Maybe BlockId
find_branch i = assocDefault mb_deflt tagged_blk_ids i
arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
switch_stmt = CmmSwitch (cmmOffset tag_expr ( real_lo_tag)) arms
; ASSERT(not (all isNothing arms))
return (oneCgStmt switch_stmt)
}
| Just deflt <- mb_deflt, (lowest_branch lo_tag) >= n_branches
= 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
lowest_branch hi_tag via_C
; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
}
| Just deflt <- mb_deflt, (hi_tag highest_branch) >= n_branches
= 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
lo_tag highest_branch via_C
; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
}
| otherwise
= do { (assign_tag, tag_expr') <- assignTemp' tag_expr
; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
lo_tag (mid_tag1) via_C
; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
mid_tag hi_tag via_C
; hi_id <- forkCgStmts hi_stmts
; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
branch_stmt = CmmCondBranch cond hi_id
; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
}
where
use_switch =
ASSERT( n_branches > 1 && n_tags > 1 )
n_tags > 2 && (via_C || (dense && big_enough))
big_enough = n_branches > 4
dense = n_branches > (n_tags `div` 2)
n_branches = length branches
lowest_branch = fst (head branches)
highest_branch = fst (last branches)
real_lo_tag
| isNothing mb_deflt = lowest_branch
| otherwise = lo_tag
real_hi_tag
| isNothing mb_deflt = highest_branch
| otherwise = hi_tag
n_tags = real_hi_tag real_lo_tag + 1
(mid_tag,_) = branches !! (n_branches `div` 2)
(lo_branches, hi_branches) = span is_lo branches
is_lo (t,_) = t < mid_tag
assignTemp' e
| isTrivialCmmExpr e = return (CmmNop, e)
| otherwise = do { reg <- newTemp (cmmExprType e)
; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
emitLitSwitch :: CmmExpr
-> [(Literal, CgStmts)]
-> CgStmts
-> Code
emitLitSwitch scrut [] deflt
= emitCgStmts deflt
emitLitSwitch scrut branches deflt_blk
= do { scrut' <- assignTemp scrut
; deflt_blk_id <- forkCgStmts deflt_blk
; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
; emitCgStmts blk }
where
le (t1,_) (t2,_) = t1 <= t2
mk_lit_switch :: CmmExpr -> BlockId
-> [(Literal,CgStmts)]
-> FCode CgStmts
mk_lit_switch scrut deflt_blk_id [(lit,blk)]
= return (consCgStmt if_stmt blk)
where
cmm_lit = mkSimpleLit 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
= do { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
; lo_blk_id <- forkCgStmts lo_blk
; let if_stmt = CmmCondBranch cond lo_blk_id
; return (if_stmt `consCgStmt` hi_blk) }
where
n_branches = length branches
(mid_lit,_) = branches !! (n_branches `div` 2)
(lo_branches, hi_branches) = span is_lo branches
is_lo (t,_) = t < mid_lit
cond = CmmMachOp (mkLtOp mid_lit)
[scrut, CmmLit (mkSimpleLit mid_lit)]
emitSimultaneously :: CmmStmts -> Code
type CVertex = (Int, CmmStmt)
emitSimultaneously stmts
= codeOnly $
case filterOut isNopStmt (stmtList stmts) of
[] -> nopC
[stmt] -> stmtC stmt
stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
doSimultaneously1 :: [CVertex] -> Code
doSimultaneously1 vertices
= let
edges = [ (vertex, key1, edges_from stmt1)
| vertex@(key1, stmt1) <- vertices
]
edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
stmt1 `mustFollow` stmt2
]
components = stronglyConnCompFromEdgedVertices edges
do_component (AcyclicSCC (n,stmt)) = stmtC stmt
do_component (CyclicSCC [(n,stmt)]) = stmtC stmt
do_component (CyclicSCC ((n,first_stmt) : rest))
= do { from_temp <- go_via_temp first_stmt
; doSimultaneously1 rest
; stmtC from_temp }
go_via_temp (CmmAssign dest src)
= do { tmp <- newTemp (cmmRegType dest)
; stmtC (CmmAssign (CmmLocal tmp) src)
; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
go_via_temp (CmmStore dest src)
= do { tmp <- newTemp (cmmExprType src)
; stmtC (CmmAssign (CmmLocal tmp) src)
; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
in
mapCs do_component components
mustFollow :: CmmStmt -> CmmStmt -> Bool
CmmAssign reg _ `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
CmmStore loc e `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprType e)) stmt
CmmNop `mustFollow` stmt = False
CmmComment _ `mustFollow` stmt = False
anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
anySrc p (CmmAssign _ e) = p e
anySrc p (CmmStore e1 e2) = p e1 || p e2
anySrc p (CmmComment _) = False
anySrc p CmmNop = False
anySrc p other = True
locUsedIn :: CmmExpr -> CmmType -> CmmExpr -> Bool
locUsedIn loc rep (CmmLit _) = False
locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
locUsedIn loc rep (CmmReg reg') = False
locUsedIn loc rep (CmmRegOff reg' _) = False
locUsedIn loc rep (CmmMachOp _ es) = any (locUsedIn loc rep) es
possiblySameLoc :: CmmExpr -> CmmType -> CmmExpr -> CmmType -> Bool
possiblySameLoc (CmmReg r1) rep1 (CmmReg r2) rep2 = r1==r2
possiblySameLoc (CmmReg r1) rep1 (CmmRegOff r2 0) rep2 = r1==r2
possiblySameLoc (CmmRegOff r1 0) rep1 (CmmReg r2) rep2 = r1==r2
possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
= r1==r2 && end1 > start2 && end2 > start1
where
end1 = start1 + widthInBytes (typeWidth rep1)
end2 = start2 + widthInBytes (typeWidth rep2)
possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
possiblySameLoc l1 rep1 l2 rep2 = True
getSRTInfo :: FCode C_SRT
getSRTInfo = do
srt_lbl <- getSRTLabel
srt <- getSRT
case srt of
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)))
srt_escape = (1) :: StgHalfWord
clHasCafRefs :: ClosureInfo -> CafInfo
clHasCafRefs (ClosureInfo {closureSRT = srt}) =
case srt of NoC_SRT -> NoCafRefs
_ -> MayHaveCafRefs
clHasCafRefs (ConInfo {}) = NoCafRefs
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
]
get_GlobalReg_addr :: GlobalReg -> CmmExpr
get_GlobalReg_addr BaseReg = regTableOffset 0
get_GlobalReg_addr mid = get_Regtable_addr_from_offset
(globalRegType mid) (baseRegOffset mid)
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
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
_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) ->
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 ->
case reg `elem` activeStgRegs of
True -> expr
False -> fixStgRegExpr (CmmMachOp (MO_Add wordWidth) [
CmmReg (CmmGlobal reg),
CmmLit (CmmInt (fromIntegral offset)
wordWidth)])
_other -> expr