module GHC.StgToCmm.Utils (
cgLit, mkSimpleLit,
emitDataLits, mkDataLits,
emitRODataLits, mkRODataLits,
emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
assignTemp, newTemp,
newUnboxedTupleRegs,
emitMultiAssign, emitCmmLitSwitch, emitSwitch,
tagToClosure, mkTaggedObjectLoad,
callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
cmmOffsetExprW, cmmOffsetExprB,
cmmRegOffW, cmmRegOffB,
cmmLabelOffW, cmmLabelOffB,
cmmOffsetW, cmmOffsetB,
cmmOffsetLitW, cmmOffsetLitB,
cmmLoadIndexW,
cmmConstrTag1,
cmmUntag, cmmIsTagged,
addToMem, addToMemE, addToMemLblE, addToMemLbl,
mkWordCLit,
newStringCLit, newByteStringCLit,
blankWord,
whenUpdRemSetEnabled,
emitUpdRemSetPush,
emitUpdRemSetPushThunk,
) where
#include "HsVersions.h"
import GhcPrelude
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Closure
import Cmm
import BlockId
import MkGraph
import GHC.Platform.Regs
import CLabel
import CmmUtils
import CmmSwitch
import GHC.StgToCmm.CgUtils
import ForeignCall
import IdInfo
import Type
import TyCon
import SMRep
import Module
import Literal
import Digraph
import Util
import Unique
import UniqSupply (MonadUnique(..))
import DynFlags
import FastString
import Outputable
import RepType
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Map as M
import Data.Char
import Data.List
import Data.Ord
cgLit :: Literal -> FCode CmmLit
cgLit (LitString s) = newByteStringCLit s
cgLit other_lit = do dflags <- getDynFlags
return (mkSimpleLit dflags other_lit)
mkSimpleLit :: DynFlags -> Literal -> CmmLit
mkSimpleLit dflags (LitChar c) = CmmInt (fromIntegral (ord c))
(wordWidth dflags)
mkSimpleLit dflags LitNullAddr = zeroCLit dflags
mkSimpleLit dflags (LitNumber LitNumInt i _) = CmmInt i (wordWidth dflags)
mkSimpleLit _ (LitNumber LitNumInt64 i _) = CmmInt i W64
mkSimpleLit dflags (LitNumber LitNumWord i _) = CmmInt i (wordWidth dflags)
mkSimpleLit _ (LitNumber LitNumWord64 i _) = CmmInt i W64
mkSimpleLit _ (LitFloat r) = CmmFloat r W32
mkSimpleLit _ (LitDouble r) = CmmFloat r W64
mkSimpleLit _ (LitLabel fs ms fod)
= let
labelSrc = ForeignLabelInThisPackage
in CmmLabel (mkForeignLabel fs ms labelSrc fod)
mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other)
addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))
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
:: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
mkTaggedObjectLoad dflags reg base offset tag
= mkAssign (CmmLocal reg)
(CmmLoad (cmmOffsetB dflags
(CmmReg (CmmLocal base))
(offset tag))
(localRegType reg))
tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
tagToClosure dflags tycon tag
= CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)
where closure_tbl = CmmLit (CmmLabel lbl)
lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString
-> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCallWithResult res hint pkg fun args safe
= emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe
emitRtsCallGen
:: [(LocalReg,ForeignHint)]
-> CLabel
-> [(CmmExpr,ForeignHint)]
-> Bool
-> FCode ()
emitRtsCallGen res lbl args safe
= do { dflags <- getDynFlags
; updfr_off <- getUpdFrameOff
; let (caller_save, caller_load) = callerSaveVolatileRegs dflags
; emit caller_save
; call updfr_off
; emit caller_load }
where
call updfr_off =
if safe then
emit =<< mkCmmCall fun_expr res' args' updfr_off
else do
let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
(args', arg_hints) = unzip args
(res', res_hints) = unzip res
fun_expr = mkLblExpr lbl
callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs dflags = (caller_save, caller_load)
where
platform = targetPlatform dflags
caller_save = catAGraphs (map callerSaveGlobalReg regs_to_save)
caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
, BaseReg ]
regs_to_save = filter (callerSaves platform) system_regs
callerSaveGlobalReg reg
= mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
callerRestoreGlobalReg reg
= mkAssign (CmmGlobal reg)
(CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))
emitDataLits :: CLabel -> [CmmLit] -> FCode ()
emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)
emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
newStringCLit :: String -> FCode CmmLit
newStringCLit str = newByteStringCLit (BS8.pack str)
newByteStringCLit :: ByteString -> FCode CmmLit
newByteStringCLit bytes
= do { uniq <- newUnique
; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes
; emitDecl decl
; return lit }
assignTemp :: CmmExpr -> FCode LocalReg
assignTemp (CmmReg (CmmLocal reg)) = return reg
assignTemp e = do { dflags <- getDynFlags
; uniq <- newUnique
; let reg = LocalReg uniq (cmmExprType dflags e)
; emitAssign (CmmLocal reg) e
; return reg }
newTemp :: MonadUnique m => CmmType -> m LocalReg
newTemp rep = do { uniq <- getUniqueM
; return (LocalReg uniq rep) }
newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
newUnboxedTupleRegs res_ty
= ASSERT( isUnboxedTupleType res_ty )
do { dflags <- getDynFlags
; sequel <- getSequel
; regs <- choose_regs dflags sequel
; ASSERT( regs `equalLength` reps )
return (regs, map primRepForeignHint reps) }
where
reps = typePrimRep res_ty
choose_regs _ (AssignTo regs _) = return regs
choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps
emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
type Key = Int
type Vrtx = (Key, Stmt)
type Stmt = (LocalReg, CmmExpr)
emitMultiAssign [] [] = return ()
emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs
emitMultiAssign regs rhss = do
dflags <- getDynFlags
ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )
unscramble dflags ([1..] `zip` (regs `zip` rhss))
unscramble :: DynFlags -> [Vrtx] -> FCode ()
unscramble dflags vertices = mapM_ do_component components
where
edges :: [ Node Key Vrtx ]
edges = [ DigraphNode 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 = stronglyConnCompFromEdgedVerticesUniq edges
do_component :: SCC Vrtx -> FCode ()
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)) = do
dflags <- getDynFlags
u <- newUnique
let (to_tmp, from_tmp) = split dflags u first_stmt
mk_graph to_tmp
unscramble dflags rest
mk_graph from_tmp
split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)
split dflags uniq (reg, rhs)
= ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
where
rep = cmmExprType dflags rhs
tmp = LocalReg uniq rep
mk_graph :: Stmt -> FCode ()
mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs
mustFollow :: Stmt -> Stmt -> Bool
(reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs
emitSwitch :: CmmExpr
-> [(ConTagZ, CmmAGraphScoped)]
-> Maybe CmmAGraphScoped
-> ConTagZ -> ConTagZ
-> FCode ()
emitSwitch _ [] (Just code) _ _ = emit (fst code)
emitSwitch _ [(_,code)] Nothing _ _ = emit (fst code)
emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do
join_lbl <- newBlockId
mb_deflt_lbl <- label_default join_lbl mb_deflt
branches_lbls <- label_branches join_lbl branches
tag_expr' <- assignTemp' tag_expr
let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]
let range = (fromIntegral lo_tag, fromIntegral hi_tag)
emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range
emitLabel join_lbl
mk_discrete_switch :: Bool
-> CmmExpr
-> [(Integer, BlockId)]
-> Maybe BlockId
-> (Integer, Integer)
-> CmmAGraph
mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)
| lo_tag == hi_tag
= ASSERT( tag == lo_tag )
mkBranch lbl
mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _
= mkBranch lbl
mk_discrete_switch signed tag_expr branches mb_deflt range
= mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)
divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])
divideBranches branches = (lo_branches, mid, hi_branches)
where
(mid,_) = branches !! (length branches `div` 2)
(lo_branches, hi_branches) = span is_lo branches
is_lo (t,_) = t < mid
emitCmmLitSwitch :: CmmExpr
-> [(Literal, CmmAGraphScoped)]
-> CmmAGraphScoped
-> FCode ()
emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt
emitCmmLitSwitch scrut branches deflt = do
scrut' <- assignTemp' scrut
join_lbl <- newBlockId
deflt_lbl <- label_code join_lbl deflt
branches_lbls <- label_branches join_lbl branches
dflags <- getDynFlags
let cmm_ty = cmmExprType dflags scrut
rep = typeWidth cmm_ty
let signed = case head branches of
(LitNumber nt _ _, _) -> litNumIsSigned nt
_ -> False
let range | signed = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)
| otherwise = (0, tARGET_MAX_WORD dflags)
if isFloatType cmm_ty
then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls
else emit $ mk_discrete_switch
signed
scrut'
[(litValue lit,l) | (lit,l) <- branches_lbls]
(Just deflt_lbl)
range
emitLabel join_lbl
type LitBound = (Maybe Literal, Maybe Literal)
noBound :: LitBound
noBound = (Nothing, Nothing)
mk_float_switch :: Width -> CmmExpr -> BlockId
-> LitBound
-> [(Literal,BlockId)]
-> FCode CmmAGraph
mk_float_switch rep scrut deflt _bounds [(lit,blk)]
= do dflags <- getDynFlags
return $ mkCbranch (cond dflags) deflt blk Nothing
where
cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]
where
cmm_lit = mkSimpleLit dflags lit
ne = MO_F_Ne rep
mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches
= do dflags <- getDynFlags
lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches
hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches
mkCmmIfThenElse (cond dflags) lo_blk hi_blk
where
(lo_branches, mid_lit, hi_branches) = divideBranches branches
bounds_lo = (lo_bound, Just mid_lit)
bounds_hi = (Just mid_lit, hi_bound)
cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]
where
cmm_lit = mkSimpleLit dflags mid_lit
lt = MO_F_Lt rep
label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
label_default _ Nothing
= return Nothing
label_default join_lbl (Just code)
= do lbl <- label_code join_lbl code
return (Just lbl)
label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
label_branches _join_lbl []
= return []
label_branches join_lbl ((tag,code):branches)
= do lbl <- label_code join_lbl code
branches' <- label_branches join_lbl branches
return ((tag,lbl):branches')
label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
label_code join_lbl (code,tsc) = do
lbl <- newBlockId
emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)
return lbl
assignTemp' :: CmmExpr -> FCode CmmExpr
assignTemp' e
| isTrivialCmmExpr e = return e
| otherwise = do
dflags <- getDynFlags
lreg <- newTemp (cmmExprType dflags e)
let reg = CmmLocal lreg
emitAssign reg e
return (CmmReg reg)
whenUpdRemSetEnabled :: DynFlags -> FCode a -> FCode ()
whenUpdRemSetEnabled dflags code = do
do_it <- getCode code
the_if <- mkCmmIfThenElse' is_enabled do_it mkNop (Just False)
emit the_if
where
enabled = CmmLoad (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) (bWord dflags)
zero = zeroExpr dflags
is_enabled = cmmNeWord dflags enabled zero
emitUpdRemSetPush :: CmmExpr
-> FCode ()
emitUpdRemSetPush ptr = do
emitRtsCall
rtsUnitId
(fsLit "updateRemembSetPushClosure_")
[(CmmReg (CmmGlobal BaseReg), AddrHint),
(ptr, AddrHint)]
False
emitUpdRemSetPushThunk :: CmmExpr
-> FCode ()
emitUpdRemSetPushThunk ptr = do
emitRtsCall
rtsUnitId
(fsLit "updateRemembSetPushThunk_")
[(CmmReg (CmmGlobal BaseReg), AddrHint),
(ptr, AddrHint)]
False