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