module GHC.StgToCmm.Monad (
FCode,
initC, initFCodeState, runC, fixC,
newUnique,
emitLabel,
emit, emitDecl,
emitProcWithConvention, emitProcWithStackFrame,
emitOutOfLine, emitAssign, emitStore, emitStore',
emitComment, emitTick, emitUnwind,
newTemp,
getCmm, aGraphToGraph, getPlatform, getProfile,
getCodeR, getCode, getCodeScoped, getHeapUsage,
getContext,
mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',
mkCall, mkCmmCall,
forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,
ConTagZ,
Sequel(..), ReturnKind(..),
withSequel, getSequel,
setTickyCtrLabel, getTickyCtrLabel,
tickScope, getTickScope,
withUpdFrameOff, getUpdFrameOff,
HeapUsage(..), VirtualHpOffset, initHpUsage,
getHpUsage, setHpUsage, heapHWM,
setVirtHp, getVirtHp, setRealHp,
getModuleName,
getState, setState, getSelfLoop, withSelfLoop, getStgToCmmConfig,
CgIdInfo(..),
getBinds, setBinds,
StgToCmmConfig(..), CgState(..)
) where
import GHC.Prelude hiding( sequence, succ )
import GHC.Platform
import GHC.Platform.Profile
import GHC.Cmm
import GHC.StgToCmm.Config
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Sequel
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Graph as CmmGraph
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Runtime.Heap.Layout
import GHC.Unit
import GHC.Types.Id
import GHC.Types.Var.Env
import GHC.Data.OrdList
import GHC.Types.Basic( ConTagZ )
import GHC.Types.Unique
import GHC.Types.Unique.Supply
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Exts (oneShot)
import Control.Monad
import Data.List (mapAccumL)
newtype FCode a = FCode' { doFCode :: StgToCmmConfig -> FCodeState -> CgState -> (a, CgState) }
instance Functor FCode where
fmap f (FCode m) =
FCode $ \cfg fst state ->
case m cfg fst state of
(x, state') -> (f x, state')
pattern FCode :: (StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
pattern FCode m <- FCode' m
where
FCode m = FCode' $ oneShot (\cfg -> oneShot
(\fstate -> oneShot
(\state -> m cfg fstate state)))
instance Applicative FCode where
pure val = FCode (\_cfg _fstate state -> (val, state))
(<*>) = ap
instance Monad FCode where
FCode m >>= k = FCode $
\cfg fstate state ->
case m cfg fstate state of
(m_result, new_state) ->
case k m_result of
FCode kcode -> kcode cfg fstate new_state
instance MonadUnique FCode where
getUniqueSupplyM = cgs_uniqs <$> getState
getUniqueM = FCode $ \_ _ st ->
let (u, us') = takeUniqFromSupply (cgs_uniqs st)
in (u, st { cgs_uniqs = us' })
initC :: IO CgState
initC = do { uniqs <- mkSplitUniqSupply 'c'
; return (initCgState uniqs) }
runC :: StgToCmmConfig -> FCodeState -> CgState -> FCode a -> (a, CgState)
runC cfg fst st fcode = doFCode fcode cfg fst st
fixC :: (a -> FCode a) -> FCode a
fixC fcode = FCode $
\cfg fstate state ->
let (v, s) = doFCode (fcode v) cfg fstate state
in (v, s)
type CgBindings = IdEnv CgIdInfo
data CgIdInfo
= CgIdInfo
{ cg_id :: Id
, cg_lf :: LambdaFormInfo
, cg_loc :: CgLoc
}
instance OutputableP Platform CgIdInfo where
pdoc env (CgIdInfo { cg_id = id, cg_loc = loc })
= ppr id <+> text "-->" <+> pdoc env loc
data ReturnKind
= AssignedDirectly
| ReturnedTo BlockId ByteOff
data CgState
= MkCgState {
cgs_stmts :: CmmAGraph,
cgs_tops :: OrdList CmmDecl,
cgs_binds :: CgBindings,
cgs_hp_usg :: HeapUsage,
cgs_uniqs :: UniqSupply }
data FCodeState =
MkFCodeState { fcs_upframeoffset :: UpdFrameOffset
, fcs_sequel :: !Sequel
, fcs_selfloop :: Maybe SelfLoopInfo
, fcs_ticky :: !CLabel
, fcs_tickscope :: !CmmTickScope
}
data HeapUsage
= HeapUsage {
virtHp :: VirtualHpOffset,
realHp :: VirtualHpOffset
}
type VirtualHpOffset = WordOff
initCgState :: UniqSupply -> CgState
initCgState uniqs
= MkCgState { cgs_stmts = mkNop
, cgs_tops = nilOL
, cgs_binds = emptyVarEnv
, cgs_hp_usg = initHpUsage
, cgs_uniqs = uniqs }
stateIncUsage :: CgState -> CgState -> CgState
stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })
= s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg }
`addCodeBlocksFrom` s2
addCodeBlocksFrom :: CgState -> CgState -> CgState
s1 `addCodeBlocksFrom` s2
= s1 { cgs_stmts = cgs_stmts s1 CmmGraph.<*> cgs_stmts s2,
cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
heapHWM :: HeapUsage -> VirtualHpOffset
heapHWM = virtHp
initHpUsage :: HeapUsage
initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }
maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
getState :: FCode CgState
getState = FCode $ \_cfg _fstate state -> (state, state)
setState :: CgState -> FCode ()
setState state = FCode $ \_cfg _fstate _ -> ((), state)
getHpUsage :: FCode HeapUsage
getHpUsage = do
state <- getState
return $ cgs_hp_usg state
setHpUsage :: HeapUsage -> FCode ()
setHpUsage new_hp_usg = do
state <- getState
setState $ state {cgs_hp_usg = new_hp_usg}
setVirtHp :: VirtualHpOffset -> FCode ()
setVirtHp new_virtHp
= do { hp_usage <- getHpUsage
; setHpUsage (hp_usage {virtHp = new_virtHp}) }
getVirtHp :: FCode VirtualHpOffset
getVirtHp
= do { hp_usage <- getHpUsage
; return (virtHp hp_usage) }
setRealHp :: VirtualHpOffset -> FCode ()
setRealHp new_realHp
= do { hp_usage <- getHpUsage
; setHpUsage (hp_usage {realHp = new_realHp}) }
getBinds :: FCode CgBindings
getBinds = do
state <- getState
return $ cgs_binds state
setBinds :: CgBindings -> FCode ()
setBinds new_binds = do
state <- getState
setState $ state {cgs_binds = new_binds}
withCgState :: FCode a -> CgState -> FCode (a,CgState)
withCgState (FCode fcode) newstate = FCode $ \cfg fstate state ->
case fcode cfg fstate newstate of
(retval, state2) -> ((retval,state2), state)
newUniqSupply :: FCode UniqSupply
newUniqSupply = do
state <- getState
let (us1, us2) = splitUniqSupply (cgs_uniqs state)
setState $ state { cgs_uniqs = us1 }
return us2
newUnique :: FCode Unique
newUnique = do
state <- getState
let (u,us') = takeUniqFromSupply (cgs_uniqs state)
setState $ state { cgs_uniqs = us' }
return u
newTemp :: MonadUnique m => CmmType -> m LocalReg
newTemp rep = do { uniq <- getUniqueM
; return (LocalReg uniq rep) }
initFCodeState :: Platform -> FCodeState
initFCodeState p =
MkFCodeState { fcs_upframeoffset = platformWordSizeInBytes p
, fcs_sequel = Return
, fcs_selfloop = Nothing
, fcs_ticky = mkTopTickyCtrLabel
, fcs_tickscope = GlobalScope
}
getFCodeState :: FCode FCodeState
getFCodeState = FCode $ \_ fstate state -> (fstate,state)
withFCodeState :: FCode a -> FCodeState -> FCode a
withFCodeState (FCode fcode) fst = FCode $ \cfg _ state -> fcode cfg fst state
getSelfLoop :: FCode (Maybe SelfLoopInfo)
getSelfLoop = fcs_selfloop <$> getFCodeState
withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a
withSelfLoop self_loop code = do
fstate <- getFCodeState
withFCodeState code (fstate {fcs_selfloop = Just self_loop})
withSequel :: Sequel -> FCode a -> FCode a
withSequel sequel code
= do { fstate <- getFCodeState
; withFCodeState code (fstate { fcs_sequel = sequel
, fcs_selfloop = Nothing }) }
getSequel :: FCode Sequel
getSequel = fcs_sequel <$> getFCodeState
withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a
withUpdFrameOff size code
= do { fstate <- getFCodeState
; withFCodeState code (fstate {fcs_upframeoffset = size }) }
getUpdFrameOff :: FCode UpdFrameOffset
getUpdFrameOff = fcs_upframeoffset <$> getFCodeState
getTickyCtrLabel :: FCode CLabel
getTickyCtrLabel = fcs_ticky <$> getFCodeState
setTickyCtrLabel :: CLabel -> FCode a -> FCode a
setTickyCtrLabel ticky code = do
fstate <- getFCodeState
withFCodeState code (fstate {fcs_ticky = ticky})
getTickScope :: FCode CmmTickScope
getTickScope = fcs_tickscope <$> getFCodeState
tickScope :: FCode a -> FCode a
tickScope code = do
cfg <- getStgToCmmConfig
fstate <- getFCodeState
if stgToCmmDebugLevel cfg == 0 then code else do
u <- newUnique
let scope' = SubScope u (fcs_tickscope fstate)
withFCodeState code fstate{ fcs_tickscope = scope' }
getStgToCmmConfig :: FCode StgToCmmConfig
getStgToCmmConfig = FCode $ \cfg _ state -> (cfg,state)
getProfile :: FCode Profile
getProfile = stgToCmmProfile <$> getStgToCmmConfig
getPlatform :: FCode Platform
getPlatform = profilePlatform <$> getProfile
getContext :: FCode SDocContext
getContext = stgToCmmContext <$> getStgToCmmConfig
getModuleName :: FCode Module
getModuleName = stgToCmmThisModule <$> getStgToCmmConfig
forkClosureBody :: FCode () -> FCode ()
forkClosureBody body_code
= do { platform <- getPlatform
; cfg <- getStgToCmmConfig
; fstate <- getFCodeState
; us <- newUniqSupply
; state <- getState
; let fcs = fstate { fcs_sequel = Return
, fcs_upframeoffset = platformWordSizeInBytes platform
, fcs_selfloop = Nothing
}
fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
((),fork_state_out) = doFCode body_code cfg fcs fork_state_in
; setState $ state `addCodeBlocksFrom` fork_state_out }
forkLneBody :: FCode a -> FCode a
forkLneBody body_code
= do { cfg <- getStgToCmmConfig
; us <- newUniqSupply
; state <- getState
; fstate <- getFCodeState
; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
(result, fork_state_out) = doFCode body_code cfg fstate fork_state_in
; setState $ state `addCodeBlocksFrom` fork_state_out
; return result }
codeOnly :: FCode () -> FCode ()
codeOnly body_code
= do { cfg <- getStgToCmmConfig
; us <- newUniqSupply
; state <- getState
; fstate <- getFCodeState
; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state
, cgs_hp_usg = cgs_hp_usg state }
((), fork_state_out) = doFCode body_code cfg fstate fork_state_in
; setState $ state `addCodeBlocksFrom` fork_state_out }
forkAlts :: [FCode a] -> FCode [a]
forkAlts branch_fcodes
= do { cfg <- getStgToCmmConfig
; us <- newUniqSupply
; state <- getState
; fstate <- getFCodeState
; let compile us branch
= (us2, doFCode branch cfg fstate branch_state)
where
(us1,us2) = splitUniqSupply us
branch_state = (initCgState us1) {
cgs_binds = cgs_binds state
, cgs_hp_usg = cgs_hp_usg state }
(_us, results) = mapAccumL compile us branch_fcodes
(branch_results, branch_out_states) = unzip results
; setState $ foldl' stateIncUsage state branch_out_states
; return branch_results }
forkAltPair :: FCode a -> FCode a -> FCode (a,a)
forkAltPair x y = do
xy' <- forkAlts [x,y]
case xy' of
[x',y'] -> return (x',y')
_ -> panic "forkAltPair"
getCodeR :: FCode a -> FCode (a, CmmAGraph)
getCodeR fcode
= do { state1 <- getState
; (a, state2) <- withCgState fcode (state1 { cgs_stmts = mkNop })
; setState $ state2 { cgs_stmts = cgs_stmts state1 }
; return (a, cgs_stmts state2) }
getCode :: FCode a -> FCode CmmAGraph
getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }
getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped)
getCodeScoped fcode
= do { state1 <- getState
; ((a, tscope), state2) <-
tickScope $
flip withCgState state1 { cgs_stmts = mkNop } $
do { a <- fcode
; scp <- getTickScope
; return (a, scp) }
; setState $ state2 { cgs_stmts = cgs_stmts state1 }
; return (a, (cgs_stmts state2, tscope)) }
getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a
getHeapUsage fcode
= do { cfg <- getStgToCmmConfig
; state <- getState
; fcstate <- getFCodeState
; let fstate_in = state { cgs_hp_usg = initHpUsage }
(r, fstate_out) = doFCode (fcode hp_hw) cfg fcstate fstate_in
hp_hw = heapHWM (cgs_hp_usg fstate_out)
; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
; return r }
emitCgStmt :: CgStmt -> FCode ()
emitCgStmt stmt
= do { state <- getState
; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }
}
emitLabel :: BlockId -> FCode ()
emitLabel id = do tscope <- getTickScope
emitCgStmt (CgLabel id tscope)
emitComment :: FastString -> FCode ()
emitComment s
| debugIsOn = emitCgStmt (CgStmt (CmmComment s))
| otherwise = return ()
emitTick :: CmmTickish -> FCode ()
emitTick = emitCgStmt . CgStmt . CmmTick
emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode ()
emitUnwind regs = do
debug_level <- stgToCmmDebugLevel <$> getStgToCmmConfig
when (debug_level > 0) $
emitCgStmt $ CgStmt $ CmmUnwind regs
emitAssign :: CmmReg -> CmmExpr -> FCode ()
emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
emitStore :: CmmExpr -> CmmExpr -> FCode ()
emitStore = emitStore' NaturallyAligned
emitStore' :: AlignmentSpec -> CmmExpr -> CmmExpr -> FCode ()
emitStore' alignment l r = emitCgStmt (CgStmt (CmmStore l r alignment))
emit :: CmmAGraph -> FCode ()
emit ag
= do { state <- getState
; setState $ state { cgs_stmts = cgs_stmts state CmmGraph.<*> ag } }
emitDecl :: CmmDecl -> FCode ()
emitDecl decl
= do { state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }
emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()
emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope)
emitProcWithStackFrame
:: Convention
-> Maybe CmmInfoTable
-> CLabel
-> [CmmFormal]
-> [CmmFormal]
-> CmmAGraphScoped
-> Bool
-> FCode ()
emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
= do { platform <- getPlatform
; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth platform)) False
}
emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True
= do { profile <- getProfile
; let (offset, live, entry) = mkCallEntry profile conv args stk_args
graph' = entry CmmGraph.<*> graph
; emitProc mb_info lbl live (graph', tscope) offset True
}
emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"
emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
-> [CmmFormal]
-> CmmAGraphScoped
-> FCode ()
emitProcWithConvention conv mb_info lbl args blocks
= emitProcWithStackFrame conv mb_info lbl [] args blocks True
emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
-> Int -> Bool -> FCode ()
emitProc mb_info lbl live blocks offset do_layout
= do { l <- newBlockId
; let
blks :: CmmGraph
blks = labelAGraph l blocks
infos | Just info <- mb_info = mapSingleton (g_entry blks) info
| otherwise = mapEmpty
sinfo = StackInfo { arg_space = offset
, do_layout = do_layout }
tinfo = TopInfo { info_tbls = infos
, stack_info=sinfo}
proc_block = CmmProc tinfo lbl live blks
; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
getCmm :: FCode a -> FCode (a, CmmGroup)
getCmm code
= do { state1 <- getState
; (a, state2) <- withCgState code (state1 { cgs_tops = nilOL })
; setState $ state2 { cgs_tops = cgs_tops state1 }
; return (a, fromOL (cgs_tops state2)) }
mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThenElse e tbranch fbranch = mkCmmIfThenElse' e tbranch fbranch Nothing
mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph
-> Maybe Bool -> FCode CmmAGraph
mkCmmIfThenElse' e tbranch fbranch likely = do
tscp <- getTickScope
endif <- newBlockId
tid <- newBlockId
fid <- newBlockId
let
(test, then_, else_, likely') = case likely of
Just False | Just e' <- maybeInvertCmmExpr e
-> (e', fbranch, tbranch, Just True)
_ -> (e, tbranch, fbranch, likely)
return $ catAGraphs [ mkCbranch test tid fid likely'
, mkLabel tid tscp, then_, mkBranch endif
, mkLabel fid tscp, else_, mkLabel endif tscp ]
mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph
mkCmmIfGoto e tid = mkCmmIfGoto' e tid Nothing
mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph
mkCmmIfGoto' e tid l = do
endif <- newBlockId
tscp <- getTickScope
return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ]
mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThen e tbranch = mkCmmIfThen' e tbranch Nothing
mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
mkCmmIfThen' e tbranch l = do
endif <- newBlockId
tid <- newBlockId
tscp <- getTickScope
return $ catAGraphs [ mkCbranch e tid endif l
, mkLabel tid tscp, tbranch, mkLabel endif tscp ]
mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr]
-> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph
mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
profile <- getProfile
k <- newBlockId
tscp <- getTickScope
let area = Young k
(off, _, copyin) = copyInOflow profile retConv area results []
copyout = mkCallReturnsTo profile f callConv actuals k off updfr_off extra_stack
return $ catAGraphs [copyout, mkLabel k tscp, copyin]
mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset
-> FCode CmmAGraph
mkCmmCall f results actuals updfr_off
= mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []
aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph
aGraphToGraph stmts
= do { l <- newBlockId
; return (labelAGraph l stmts) }