module StgCmmUtils (
cgLit, mkSimpleLit,
emitDataLits, mkDataLits,
emitRODataLits, mkRODataLits,
emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
assignTemp, newTemp, withTemp,
newUnboxedTupleRegs,
mkMultiAssign, mkCmmSwitch, mkCmmLitSwitch,
emitSwitch,
tagToClosure, mkTaggedObjectLoad,
callerSaveVolatileRegs, get_GlobalReg_addr,
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
cmmUGtWord,
cmmOffsetExprW, cmmOffsetExprB,
cmmRegOffW, cmmRegOffB,
cmmLabelOffW, cmmLabelOffB,
cmmOffsetW, cmmOffsetB,
cmmOffsetLitW, cmmOffsetLitB,
cmmLoadIndexW,
cmmConstrTag, cmmConstrTag1,
cmmUntag, cmmIsTagged, cmmGetTag,
addToMem, addToMemE, addToMemLbl,
mkWordCLit,
mkStringCLit, mkByteStringCLit,
packHalfWordsCLit,
blankWord,
getSRTInfo, clHasCafRefs, srt_escape
) where
#include "HsVersions.h"
#include "../includes/stg/MachRegs.h"
import StgCmmMonad
import StgCmmClosure
import BlockId
import Cmm hiding (regUsedIn)
import MkZipCfgCmm
import CLabel
import CmmUtils
import PprCmm ( )
import ForeignCall
import IdInfo
import Type
import TyCon
import Constants
import SMRep
import StgSyn ( SRT(..) )
import Module
import Literal
import Digraph
import ListSetOps
import Util
import Unique
import DynFlags
import FastString
import Outputable
import Data.Char
import Data.Bits
import Data.Word
import Data.Maybe
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
mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other)
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
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
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, cmmPointerMask :: CmmExpr
cmmTagMask = CmmLit (mkIntCLit tAG_MASK)
cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK))
cmmUntag, cmmGetTag :: CmmExpr -> CmmExpr
cmmUntag e@(CmmLit (CmmLabel _)) = e
cmmUntag e = (e `cmmAndWord` cmmPointerMask)
cmmGetTag e = (e `cmmAndWord` cmmTagMask)
cmmIsTagged :: CmmExpr -> CmmExpr
cmmIsTagged e = (e `cmmAndWord` cmmTagMask)
`cmmNeWord` CmmLit zeroCLit
cmmConstrTag, cmmConstrTag1 :: CmmExpr -> CmmExpr
cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1))
cmmConstrTag1 e = e `cmmAndWord` cmmTagMask
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
addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
addToMem :: CmmType
-> CmmExpr
-> Int
-> CmmAGraph
addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))
addToMemE :: CmmType
-> CmmExpr
-> CmmExpr
-> CmmAGraph
addToMemE rep ptr n
= mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])
mkTaggedObjectLoad :: LocalReg -> LocalReg -> WordOff -> DynTag -> CmmAGraph
mkTaggedObjectLoad reg base offset tag
= mkAssign (CmmLocal reg)
(CmmLoad (cmmOffsetB (CmmReg (CmmLocal base))
(wORD_SIZE*offset tag))
(localRegType reg))
tagToClosure :: TyCon -> CmmExpr -> CmmExpr
tagToClosure tycon tag
= CmmLoad (cmmOffsetExprW closure_tbl tag) bWord
where closure_tbl = CmmLit (CmmLabel lbl)
lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe
emitRtsCallWithVols :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
emitRtsCallWithVols pkg fun args vols safe
= emitRtsCall' [] pkg fun args (Just vols) safe
emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString
-> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCallWithResult res hint pkg fun args safe
= emitRtsCall' [(res,hint)] pkg fun args Nothing safe
emitRtsCall'
:: [(LocalReg,ForeignHint)]
-> PackageId
-> FastString
-> [(CmmExpr,ForeignHint)]
-> Maybe [GlobalReg]
-> Bool
-> FCode ()
emitRtsCall' res pkg fun args _vols safe
=
do { updfr_off <- getUpdFrameOff
; emit caller_save
; emit $ call updfr_off
; emit caller_load }
where
call updfr_off =
if safe then
mkCmmCall fun_expr res' args' updfr_off
else
mkUnsafeCall (ForeignTarget fun_expr
(ForeignConvention CCallConv arg_hints res_hints)) res' args'
(args', arg_hints) = unzip args
(res', res_hints) = unzip res
(caller_save, caller_load) = callerSaveVolatileRegs
fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
callerSaveVolatileRegs :: (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs = (caller_save, caller_load)
where
caller_save = catAGraphs (map callerSaveGlobalReg regs_to_save)
caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
system_regs = [ Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery
, BaseReg ]
regs_to_save = filter callerSaves system_regs
callerSaveGlobalReg reg
= mkStore (get_GlobalReg_addr reg) (CmmReg (CmmGlobal reg))
callerRestoreGlobalReg reg
= mkAssign (CmmGlobal reg)
(CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
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 :: Int -> CmmExpr
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
callerSaves :: GlobalReg -> Bool
#ifdef CALLER_SAVES_Base
callerSaves BaseReg = 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 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 GCEnter1 = oFFSET_stgGCEnter1
baseRegOffset GCFun = oFFSET_stgGCFun
baseRegOffset reg = pprPanic "baseRegOffset:" (ppr reg)
emitDataLits :: CLabel -> [CmmLit] -> FCode ()
emitDataLits lbl lits
= emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
mkDataLits lbl lits
= CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
emitRODataLits 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 stmt
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 LocalReg
assignTemp (CmmReg (CmmLocal reg)) = return reg
assignTemp e = do { uniq <- newUnique
; let reg = LocalReg uniq (cmmExprType e)
; emit (mkAssign (CmmLocal reg) e)
; return reg }
newTemp :: CmmType -> FCode LocalReg
newTemp rep = do { uniq <- newUnique
; return (LocalReg uniq rep) }
newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
newUnboxedTupleRegs res_ty
= ASSERT( isUnboxedTupleType res_ty )
do { sequel <- getSequel
; regs <- choose_regs sequel
; ASSERT( regs `equalLength` reps )
return (regs, map primRepForeignHint reps) }
where
ty_args = tyConAppArgs (repType res_ty)
reps = [ rep
| ty <- ty_args
, let rep = typePrimRep ty
, not (isVoidRep rep) ]
choose_regs (AssignTo regs _) = return regs
choose_regs _other = mapM (newTemp . primRepCmmType) reps
mkMultiAssign :: [LocalReg] -> [CmmExpr] -> CmmAGraph
type Key = Int
type Vrtx = (Key, Stmt)
type Stmt = (LocalReg, CmmExpr)
mkMultiAssign [] [] = mkNop
mkMultiAssign [reg] [rhs] = mkAssign (CmmLocal reg) rhs
mkMultiAssign regs rhss = ASSERT( equalLength regs rhss )
unscramble ([1..] `zip` (regs `zip` rhss))
unscramble :: [Vrtx] -> CmmAGraph
unscramble vertices
= catAGraphs (map do_component components)
where
edges :: [ (Vrtx, Key, [Key]) ]
edges = [ (vertex, key1, edges_from stmt1)
| vertex@(key1, stmt1) <- vertices ]
edges_from :: Stmt -> [Key]
edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
stmt1 `mustFollow` stmt2 ]
components :: [SCC Vrtx]
components = stronglyConnCompFromEdgedVertices edges
do_component :: SCC Vrtx -> CmmAGraph
do_component (AcyclicSCC (_,stmt)) = mk_graph stmt
do_component (CyclicSCC []) = panic "do_component"
do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt
do_component (CyclicSCC ((_,first_stmt) : rest))
= withUnique $ \u ->
let (to_tmp, from_tmp) = split u first_stmt
in mk_graph to_tmp
<*> unscramble rest
<*> mk_graph from_tmp
split :: Unique -> Stmt -> (Stmt, Stmt)
split uniq (reg, rhs)
= ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
where
rep = cmmExprType rhs
tmp = LocalReg uniq rep
mk_graph :: Stmt -> CmmAGraph
mk_graph (reg, rhs) = mkAssign (CmmLocal reg) rhs
mustFollow :: Stmt -> Stmt -> Bool
(reg, _) `mustFollow` (_, rhs) = reg `regUsedIn` rhs
regUsedIn :: LocalReg -> CmmExpr -> Bool
reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
reg `regUsedIn` CmmReg (CmmLocal reg') = reg == reg'
reg `regUsedIn` CmmRegOff (CmmLocal reg') _ = reg == reg'
reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
_reg `regUsedIn` _other = False
emitSwitch :: CmmExpr
-> [(ConTagZ, CmmAGraph)]
-> Maybe CmmAGraph
-> ConTagZ -> ConTagZ
-> FCode ()
emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
= do { dflags <- getDynFlags
; emit (mkCmmSwitch (via_C dflags) tag_expr branches mb_deflt lo_tag hi_tag) }
where
via_C dflags | HscC <- hscTarget dflags = True
| otherwise = False
mkCmmSwitch :: Bool
-> CmmExpr
-> [(ConTagZ, CmmAGraph)]
-> Maybe CmmAGraph
-> ConTagZ -> ConTagZ
-> CmmAGraph
mkCmmSwitch _ _ [] (Just code) _ _ = code
mkCmmSwitch _ _ [(_,code)] Nothing _ _ = code
mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag
= withFreshLabel "switch join" $ \ join_lbl ->
label_default join_lbl mb_deflt $ \ mb_deflt ->
label_branches join_lbl branches $ \ branches ->
assignTemp' tag_expr $ \tag_expr' ->
mk_switch tag_expr' (sortLe le branches) mb_deflt
lo_tag hi_tag via_C
<*> mkLabel join_lbl
where
(t1,_) `le` (t2,_) = t1 <= t2
mk_switch :: CmmExpr -> [(ConTagZ, BlockId)]
-> Maybe BlockId
-> ConTagZ -> ConTagZ -> Bool
-> CmmAGraph
mk_switch _tag_expr [(tag, lbl)] _ lo_tag hi_tag _via_C
| lo_tag == hi_tag
= ASSERT( tag == lo_tag )
mkBranch lbl
mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _
= mkBranch lbl
mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _
= mkCbranch cond deflt lbl
where
cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
| use_switch
= let
find_branch :: ConTagZ -> Maybe BlockId
find_branch i = case (assocMaybe branches i) of
Just lbl -> Just lbl
Nothing -> mb_deflt
arms :: [Maybe BlockId]
arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
in
mkSwitch (cmmOffset tag_expr ( real_lo_tag)) arms
| Just deflt <- mb_deflt, (lowest_branch lo_tag) >= n_branches
= mkCmmIfThenElse
(cmmULtWord tag_expr (CmmLit (mkIntCLit lowest_branch)))
(mkBranch deflt)
(mk_switch tag_expr branches mb_deflt
lowest_branch hi_tag via_C)
| Just deflt <- mb_deflt, (hi_tag highest_branch) >= n_branches
= mkCmmIfThenElse
(cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch)))
(mkBranch deflt)
(mk_switch tag_expr branches mb_deflt
lo_tag highest_branch via_C)
| otherwise
= mkCmmIfThenElse
(cmmUGeWord tag_expr (CmmLit (mkIntCLit mid_tag)))
(mk_switch tag_expr hi_branches mb_deflt
mid_tag hi_tag via_C)
(mk_switch tag_expr lo_branches mb_deflt
lo_tag (mid_tag1) via_C)
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
mkCmmLitSwitch :: CmmExpr
-> [(Literal, CmmAGraph)]
-> CmmAGraph
-> CmmAGraph
mkCmmLitSwitch _scrut [] deflt = deflt
mkCmmLitSwitch scrut branches deflt
= assignTemp' scrut $ \ scrut' ->
withFreshLabel "switch join" $ \ join_lbl ->
label_code join_lbl deflt $ \ deflt ->
label_branches join_lbl branches $ \ branches ->
mk_lit_switch scrut' deflt (sortLe le branches)
<*> mkLabel join_lbl
where
le (t1,_) (t2,_) = t1 <= t2
mk_lit_switch :: CmmExpr -> BlockId
-> [(Literal,BlockId)]
-> CmmAGraph
mk_lit_switch scrut deflt [(lit,blk)]
= mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk
where
cmm_lit = mkSimpleLit lit
cmm_ty = cmmLitType cmm_lit
rep = typeWidth cmm_ty
ne = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep
mk_lit_switch scrut deflt_blk_id branches
= mkCmmIfThenElse cond
(mk_lit_switch scrut deflt_blk_id lo_branches)
(mk_lit_switch scrut deflt_blk_id hi_branches)
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)]
label_default :: BlockId -> Maybe CmmAGraph
-> (Maybe BlockId -> CmmAGraph)
-> CmmAGraph
label_default _ Nothing thing_inside
= thing_inside Nothing
label_default join_lbl (Just code) thing_inside
= label_code join_lbl code $ \ lbl ->
thing_inside (Just lbl)
label_branches :: BlockId -> [(a,CmmAGraph)]
-> ([(a,BlockId)] -> CmmAGraph)
-> CmmAGraph
label_branches _join_lbl [] thing_inside
= thing_inside []
label_branches join_lbl ((tag,code):branches) thing_inside
= label_code join_lbl code $ \ lbl ->
label_branches join_lbl branches $ \ branches' ->
thing_inside ((tag,lbl):branches')
label_code :: BlockId -> CmmAGraph -> (BlockId -> CmmAGraph) -> CmmAGraph
label_code join_lbl code thing_inside
= withFreshLabel "switch" $ \lbl ->
outOfLine (mkLabel lbl <*> code <*> mkBranch join_lbl)
<*> thing_inside lbl
assignTemp' :: CmmExpr -> (CmmExpr -> CmmAGraph) -> CmmAGraph
assignTemp' e thing_inside
| isTrivialCmmExpr e = thing_inside e
| otherwise = withTemp (cmmExprType e) $ \ lreg ->
let reg = CmmLocal lreg in
mkAssign reg e <*> thing_inside (CmmReg reg)
withTemp :: CmmType -> (LocalReg -> CmmAGraph) -> CmmAGraph
withTemp rep thing_inside
= withUnique $ \uniq -> thing_inside (LocalReg uniq rep)
getSRTInfo :: SRT -> FCode C_SRT
getSRTInfo (SRTEntries {}) = panic "getSRTInfo"
getSRTInfo (SRT off len bmp)
| len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
= do { id <- newUnique
; let srt_desc_lbl = mkLargeSRTLabel id
; return (C_SRT srt_desc_lbl 0 srt_escape) }
| otherwise
= do { top_srt <- getSRTLabel
; return (C_SRT top_srt off (fromIntegral (head bmp))) }
getSRTInfo NoSRT
=
return NoC_SRT
srt_escape :: StgHalfWord
srt_escape = 1