{-# 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) =
forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode 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 $bFCode :: forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
$mFCode :: forall {r} {a}.
FCode a
-> ((StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)) -> r)
-> ((# #) -> r)
-> r
FCode m <- FCode' m
where
FCode StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
m = forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode' forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot (\StgToCmmConfig
cfg -> oneShot :: forall a b. (a -> b) -> a -> b
oneShot
(\FCodeState
fstate -> oneShot :: 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 = 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
(<*>) = 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 = forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode CgState
getState
getUniqueM :: FCode Unique
getUniqueM = forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode 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 :: UniqSupply
cgs_uniqs = UniqSupply
us' })
initC :: IO CgState
initC :: IO CgState
initC = do { UniqSupply
uniqs <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'c'
; 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 = 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 = forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode forall a b. (a -> b) -> a -> b
$
\StgToCmmConfig
cfg FCodeState
fstate CgState
state ->
let (a
v, CgState
s) = 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 })
= forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"-->" SDoc -> SDoc -> 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 = forall a. OrdList a
nilOL
, cgs_binds :: CgBindings
cgs_binds = 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 :: HeapUsage
cgs_hp_usg = CgState -> HeapUsage
cgs_hp_usg CgState
s1 HeapUsage -> VirtualHpOffset -> HeapUsage
`maxHpHw` HeapUsage -> VirtualHpOffset
virtHp HeapUsage
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 :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
s1 CmmAGraph -> CmmAGraph -> CmmAGraph
CmmGraph.<*> CgState -> CmmAGraph
cgs_stmts CgState
s2,
cgs_tops :: OrdList CmmDecl
cgs_tops = CgState -> OrdList CmmDecl
cgs_tops CgState
s1 forall a. OrdList a -> OrdList a -> OrdList a
`appOL` CgState -> OrdList CmmDecl
cgs_tops CgState
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 :: VirtualHpOffset
virtHp = HeapUsage -> VirtualHpOffset
virtHp HeapUsage
hp_usg forall a. Ord a => a -> a -> a
`max` VirtualHpOffset
hw }
getState :: FCode CgState
getState :: FCode CgState
getState = forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode 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 = forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
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
forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a b. (a -> b) -> a -> b
$ CgState
state {cgs_hp_usg :: HeapUsage
cgs_hp_usg = HeapUsage
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 :: VirtualHpOffset
virtHp = VirtualHpOffset
new_virtHp}) }
getVirtHp :: FCode VirtualHpOffset
getVirtHp :: FCode VirtualHpOffset
getVirtHp
= do { HeapUsage
hp_usage <- FCode HeapUsage
getHpUsage
; 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 :: VirtualHpOffset
realHp = VirtualHpOffset
new_realHp}) }
getBinds :: FCode CgBindings
getBinds :: FCode CgBindings
getBinds = do
CgState
state <- FCode CgState
getState
forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a b. (a -> b) -> a -> b
$ CgState
state {cgs_binds :: CgBindings
cgs_binds = CgBindings
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 = forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode 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 forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_uniqs :: UniqSupply
cgs_uniqs = UniqSupply
us1 }
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 forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_uniqs :: UniqSupply
cgs_uniqs = UniqSupply
us' }
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 <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; 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 = 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 = forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode 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 = forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode 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 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
forall a. FCode a -> FCodeState -> FCode a
withFCodeState FCode a
code (FCodeState
fstate {fcs_selfloop :: Maybe SelfLoopInfo
fcs_selfloop = forall a. a -> Maybe a
Just SelfLoopInfo
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
; forall a. FCode a -> FCodeState -> FCode a
withFCodeState FCode a
code (FCodeState
fstate { fcs_sequel :: Sequel
fcs_sequel = Sequel
sequel
, fcs_selfloop :: Maybe SelfLoopInfo
fcs_selfloop = forall a. Maybe a
Nothing }) }
getSequel :: FCode Sequel
getSequel :: FCode Sequel
getSequel = FCodeState -> Sequel
fcs_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
; forall a. FCode a -> FCodeState -> FCode a
withFCodeState FCode a
code (FCodeState
fstate {fcs_upframeoffset :: VirtualHpOffset
fcs_upframeoffset = VirtualHpOffset
size }) }
getUpdFrameOff :: FCode UpdFrameOffset
getUpdFrameOff :: FCode VirtualHpOffset
getUpdFrameOff = FCodeState -> VirtualHpOffset
fcs_upframeoffset 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 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
forall a. FCode a -> FCodeState -> FCode a
withFCodeState FCode a
code (FCodeState
fstate {fcs_ticky :: CLabel
fcs_ticky = CLabel
ticky})
getTickScope :: FCode CmmTickScope
getTickScope :: FCode CmmTickScope
getTickScope = FCodeState -> CmmTickScope
fcs_tickscope 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 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)
forall a. FCode a -> FCodeState -> FCode a
withFCodeState FCode a
code FCodeState
fstate{ fcs_tickscope :: CmmTickScope
fcs_tickscope = CmmTickScope
scope' }
getStgToCmmConfig :: FCode StgToCmmConfig
getStgToCmmConfig :: FCode StgToCmmConfig
getStgToCmmConfig = forall a.
(StgToCmmConfig -> FCodeState -> CgState -> (a, CgState))
-> FCode a
FCode 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 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 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 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 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 :: Sequel
fcs_sequel = Sequel
Return
, fcs_upframeoffset :: VirtualHpOffset
fcs_upframeoffset = Platform -> VirtualHpOffset
platformWordSizeInBytes Platform
platform
, fcs_selfloop :: Maybe SelfLoopInfo
fcs_selfloop = forall a. Maybe a
Nothing
}
fork_state_in :: CgState
fork_state_in = (UniqSupply -> CgState
initCgState UniqSupply
us) { cgs_binds :: CgBindings
cgs_binds = CgState -> CgBindings
cgs_binds CgState
state }
((),CgState
fork_state_out) = forall a.
FCode a -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
doFCode FCode ()
body_code StgToCmmConfig
cfg FCodeState
fcs CgState
fork_state_in
; CgState -> FCode ()
setState 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 :: CgBindings
cgs_binds = CgState -> CgBindings
cgs_binds CgState
state }
(a
result, CgState
fork_state_out) = 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 forall a b. (a -> b) -> a -> b
$ CgState
state CgState -> CgState -> CgState
`addCodeBlocksFrom` CgState
fork_state_out
; 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 :: CgBindings
cgs_binds = CgState -> CgBindings
cgs_binds CgState
state
, cgs_hp_usg :: HeapUsage
cgs_hp_usg = CgState -> HeapUsage
cgs_hp_usg CgState
state }
((), CgState
fork_state_out) = forall a.
FCode a -> StgToCmmConfig -> FCodeState -> CgState -> (a, CgState)
doFCode FCode ()
body_code StgToCmmConfig
cfg FCodeState
fstate CgState
fork_state_in
; CgState -> FCode ()
setState 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, 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 :: CgBindings
cgs_binds = CgState -> CgBindings
cgs_binds CgState
state
, cgs_hp_usg :: HeapUsage
cgs_hp_usg = CgState -> HeapUsage
cgs_hp_usg CgState
state }
(UniqSupply
_us, [(a, CgState)]
results) = 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) = forall a b. [(a, b)] -> ([a], [b])
unzip [(a, CgState)]
results
; CgState -> FCode ()
setState forall a b. (a -> 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
; 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' <- forall a. [FCode a] -> FCode [a]
forkAlts [FCode a
x,FCode a
y]
case [a]
xy' of
[a
x',a
y'] -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
x',a
y')
[a]
_ -> forall a. 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) <- forall a. FCode a -> CgState -> FCode (a, CgState)
withCgState FCode a
fcode (CgState
state1 { cgs_stmts :: CmmAGraph
cgs_stmts = CmmAGraph
mkNop })
; CgState -> FCode ()
setState forall a b. (a -> b) -> a -> b
$ CgState
state2 { cgs_stmts :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
state1 }
; 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) <- forall a. FCode a -> FCode (a, CmmAGraph)
getCodeR FCode a
fcode; 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) <-
forall a. FCode a -> FCode a
tickScope forall a b. (a -> b) -> a -> b
$
forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. FCode a -> CgState -> FCode (a, CgState)
withCgState CgState
state1 { cgs_stmts :: CmmAGraph
cgs_stmts = CmmAGraph
mkNop } forall a b. (a -> b) -> a -> b
$
do { a
a <- FCode a
fcode
; CmmTickScope
scp <- FCode CmmTickScope
getTickScope
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, CmmTickScope
scp) }
; CgState -> FCode ()
setState forall a b. (a -> b) -> a -> b
$ CgState
state2 { cgs_stmts :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
state1 }
; 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 :: HeapUsage
cgs_hp_usg = HeapUsage
initHpUsage }
(a
r, CgState
fstate_out) = 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 forall a b. (a -> b) -> a -> b
$ CgState
fstate_out { cgs_hp_usg :: HeapUsage
cgs_hp_usg = CgState -> HeapUsage
cgs_hp_usg CgState
state }
; 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 forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_stmts :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
state forall a. OrdList a -> a -> OrdList a
`snocOL` CgStmt
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 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
emitTick :: CmmTickish -> FCode ()
emitTick :: CmmTickish -> FCode ()
emitTick = CgStmt -> FCode ()
emitCgStmt forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmNode O O -> CgStmt
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$
CgStmt -> FCode ()
emitCgStmt forall a b. (a -> b) -> a -> b
$ CmmNode O O -> CgStmt
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 forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_stmts :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
state CmmAGraph -> CmmAGraph -> CmmAGraph
CmmGraph.<*> CmmAGraph
ag } }
emitDecl :: CmmDecl -> FCode ()
emitDecl :: CmmDecl -> FCode ()
emitDecl CmmDecl
decl
= do { CgState
state <- FCode CgState
getState
; CgState -> FCode ()
setState forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_tops :: OrdList CmmDecl
cgs_tops = CgState -> OrdList CmmDecl
cgs_tops CgState
state forall a. OrdList a -> a -> OrdList a
`snocOL` CmmDecl
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
_ = forall a. 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 <- 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 = forall (map :: * -> *) a. IsMap map => KeyOf map -> a -> map a
mapSingleton (forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> BlockId
g_entry CmmGraph
blks) CmmInfoTable
info
| Bool
otherwise = 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 = 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 forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_tops :: OrdList CmmDecl
cgs_tops = CgState -> OrdList CmmDecl
cgs_tops CgState
state forall a. OrdList a -> a -> OrdList a
`snocOL` CmmDecl
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) <- forall a. FCode a -> CgState -> FCode (a, CgState)
withCgState FCode a
code (CgState
state1 { cgs_tops :: OrdList CmmDecl
cgs_tops = forall a. OrdList a
nilOL })
; CgState -> FCode ()
setState forall a b. (a -> b) -> a -> b
$ CgState
state2 { cgs_tops :: OrdList CmmDecl
cgs_tops = CgState -> OrdList CmmDecl
cgs_tops CgState
state1 }
; forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, 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 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 <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
BlockId
tid <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
BlockId
fid <- 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, forall a. a -> Maybe a
Just Bool
True)
Maybe Bool
_ -> (CmmExpr
e, CmmAGraph
tbranch, CmmAGraph
fbranch, Maybe Bool
likely)
forall (m :: * -> *) a. Monad m => a -> m a
return 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 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 <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
CmmTickScope
tscp <- FCode CmmTickScope
getTickScope
forall (m :: * -> *) a. Monad m => a -> m a
return 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 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 <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
BlockId
tid <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
CmmTickScope
tscp <- FCode CmmTickScope
getTickScope
forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- 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
forall (m :: * -> *) a. Monad m => a -> m a
return 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 <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
; forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> CmmAGraphScoped -> CmmGraph
labelAGraph BlockId
l CmmAGraphScoped
stmts) }