module GHC.StgToCmm.Utils (
cgLit, mkSimpleLit,
emitDataLits, emitRODataLits,
emitDataCon,
emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
assignTemp, newTemp,
newUnboxedTupleRegs,
emitMultiAssign, emitCmmLitSwitch, emitSwitch,
tagToClosure, mkTaggedObjectLoad,
callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
callerSaveGlobalReg, callerRestoreGlobalReg,
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,
newStringCLit, newByteStringCLit,
whenUpdRemSetEnabled,
emitUpdRemSetPush,
emitUpdRemSetPushThunk,
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Closure
import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.Graph as CmmGraph
import GHC.Platform.Regs
import GHC.Cmm.CLabel
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.StgToCmm.CgUtils
import GHC.Types.ForeignCall
import GHC.Types.Id.Info
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Runtime.Heap.Layout
import GHC.Unit
import GHC.Types.Literal
import GHC.Data.Graph.Directed
import GHC.Utils.Misc
import GHC.Types.Unique
import GHC.Types.Unique.Supply (MonadUnique(..))
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Types.RepType
import GHC.Types.CostCentre
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 platform <- getPlatform
return (mkSimpleLit platform other_lit)
mkSimpleLit :: Platform -> Literal -> CmmLit
mkSimpleLit platform = \case
(LitChar c) -> CmmInt (fromIntegral (ord c))
(wordWidth platform)
LitNullAddr -> zeroCLit platform
(LitNumber LitNumInt i) -> CmmInt i (wordWidth platform)
(LitNumber LitNumInt64 i) -> CmmInt i W64
(LitNumber LitNumWord i) -> CmmInt i (wordWidth platform)
(LitNumber LitNumWord64 i) -> CmmInt i W64
(LitFloat r) -> CmmFloat r W32
(LitDouble r) -> CmmFloat r W64
(LitLabel fs ms fod)
-> let
labelSrc = ForeignLabelInThisPackage
in CmmLabel (mkForeignLabel fs ms labelSrc fod)
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
:: Platform -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
mkTaggedObjectLoad platform reg base offset tag
= mkAssign (CmmLocal reg)
(CmmLoad (cmmOffsetB platform
(CmmReg (CmmLocal base))
(offset tag))
(localRegType reg))
tagToClosure :: Platform -> TyCon -> CmmExpr -> CmmExpr
tagToClosure platform tycon tag
= CmmLoad (cmmOffsetExprW platform closure_tbl tag) (bWord platform)
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 dflags) regs_to_save)
caller_load = catAGraphs (map (callerRestoreGlobalReg dflags) regs_to_save)
system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
, BaseReg ]
regs_to_save = filter (callerSaves platform) system_regs
callerSaveGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph
callerSaveGlobalReg dflags reg
= mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
callerRestoreGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph
callerRestoreGlobalReg dflags reg
= mkAssign (CmmGlobal reg)
(CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType (targetPlatform 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)
emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()
emitDataCon lbl itbl ccs payload = emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload))
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 { platform <- getPlatform
; uniq <- newUnique
; let reg = LocalReg uniq (cmmExprType platform 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 { platform <- getPlatform
; sequel <- getSequel
; regs <- choose_regs platform sequel
; ASSERT( regs `equalLength` reps )
return (regs, map primRepForeignHint reps) }
where
reps = typePrimRep res_ty
choose_regs _ (AssignTo regs _) = return regs
choose_regs platform _ = mapM (newTemp . primRepCmmType platform) 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
platform <- getPlatform
ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )
unscramble platform ([1..] `zip` (regs `zip` rhss))
unscramble :: Platform -> [Vrtx] -> FCode ()
unscramble platform 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
u <- newUnique
let (to_tmp, from_tmp) = split u first_stmt
mk_graph to_tmp
unscramble platform rest
mk_graph from_tmp
split :: Unique -> Stmt -> (Stmt, Stmt)
split uniq (reg, rhs)
= ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
where
rep = cmmExprType platform 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 platform (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
platform <- getPlatform
let cmm_ty = cmmExprType platform scrut
rep = typeWidth cmm_ty
let signed = case head branches of
(LitNumber nt _, _) -> litNumIsSigned nt
_ -> False
let range | signed = (platformMinInt platform, platformMaxInt platform)
| otherwise = (0, platformMaxWord platform)
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 platform <- getPlatform
return $ mkCbranch (cond platform) deflt blk Nothing
where
cond platform = CmmMachOp ne [scrut, CmmLit cmm_lit]
where
cmm_lit = mkSimpleLit platform lit
ne = MO_F_Ne rep
mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches
= do platform <- getPlatform
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 platform) 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 platform = CmmMachOp lt [scrut, CmmLit cmm_lit]
where
cmm_lit = mkSimpleLit platform 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 CmmGraph.<*> mkBranch join_lbl, tsc)
return lbl
assignTemp' :: CmmExpr -> FCode CmmExpr
assignTemp' e
| isTrivialCmmExpr e = return e
| otherwise = do
platform <- getPlatform
lreg <- newTemp (cmmExprType platform e)
let reg = CmmLocal lreg
emitAssign reg e
return (CmmReg reg)
whenUpdRemSetEnabled :: FCode a -> FCode ()
whenUpdRemSetEnabled code = do
platform <- getPlatform
do_it <- getCode code
let
enabled = CmmLoad (CmmLit $ CmmLabel mkNonmovingWriteBarrierEnabledLabel) (bWord platform)
zero = zeroExpr platform
is_enabled = cmmNeWord platform enabled zero
the_if <- mkCmmIfThenElse' is_enabled do_it mkNop (Just False)
emit the_if
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