{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
module GHC.StgToCmm.Monad (
FCode,
initC, runC, fixC,
newUnique,
emitLabel,
emit, emitDecl,
emitProcWithConvention, emitProcWithStackFrame,
emitOutOfLine, emitAssign, emitStore, emitStore',
emitComment, emitTick, emitUnwind,
getCmm, aGraphToGraph, getPlatform, getProfile,
getCodeR, getCode, getCodeScoped, getHeapUsage,
getCallOpts, getPtrOpts,
mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',
mkCall, mkCmmCall,
forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,
ConTagZ,
Sequel(..), ReturnKind(..),
withSequel, getSequel,
setTickyCtrLabel, getTickyCtrLabel,
tickScope, getTickScope,
withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,
HeapUsage(..), VirtualHpOffset, initHpUsage,
getHpUsage, setHpUsage, heapHWM,
setVirtHp, getVirtHp, setRealHp,
getModuleName,
getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags,
CgIdInfo(..),
getBinds, setBinds,
CgInfoDownwards(..), CgState(..)
) where
import GHC.Prelude hiding( sequence, succ )
import GHC.Platform
import GHC.Platform.Profile
import GHC.Cmm
import GHC.StgToCmm.Closure
import GHC.Driver.Session
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Graph as CmmGraph
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.Info
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.Misc
import GHC.Exts (oneShot)
import Control.Monad
import Data.List (mapAccumL)
newtype FCode a = FCode' { forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }
instance Functor FCode where
fmap :: forall a b. (a -> b) -> FCode a -> FCode b
fmap a -> b
f (FCode CgInfoDownwards -> CgState -> (a, CgState)
m) =
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode forall a b. (a -> b) -> a -> b
$ \CgInfoDownwards
info_down CgState
state ->
case CgInfoDownwards -> CgState -> (a, CgState)
m CgInfoDownwards
info_down CgState
state of
(a
x, CgState
state') -> (a -> b
f a
x, CgState
state')
{-# COMPLETE FCode #-}
pattern FCode :: (CgInfoDownwards -> CgState -> (a, CgState))
-> FCode a
pattern $mFCode :: forall {r} {a}.
FCode a
-> ((CgInfoDownwards -> CgState -> (a, CgState)) -> r)
-> ((# #) -> r)
-> r
$bFCode :: forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode m <- FCode' m
where
FCode CgInfoDownwards -> CgState -> (a, CgState)
m = forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode' forall a b. (a -> b) -> a -> b
$ oneShot :: forall a b. (a -> b) -> a -> b
oneShot (\CgInfoDownwards
cgInfoDown -> oneShot :: forall a b. (a -> b) -> a -> b
oneShot (\CgState
state ->CgInfoDownwards -> CgState -> (a, CgState)
m CgInfoDownwards
cgInfoDown CgState
state))
instance Applicative FCode where
pure :: forall a. a -> FCode a
pure a
val = forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode (\CgInfoDownwards
_info_down 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 CgInfoDownwards -> CgState -> (a, CgState)
m >>= :: forall a b. FCode a -> (a -> FCode b) -> FCode b
>>= a -> FCode b
k = forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode forall a b. (a -> b) -> a -> b
$
\CgInfoDownwards
info_down CgState
state ->
case CgInfoDownwards -> CgState -> (a, CgState)
m CgInfoDownwards
info_down CgState
state of
(a
m_result, CgState
new_state) ->
case a -> FCode b
k a
m_result of
FCode CgInfoDownwards -> CgState -> (b, CgState)
kcode -> CgInfoDownwards -> CgState -> (b, CgState)
kcode CgInfoDownwards
info_down 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. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode forall a b. (a -> b) -> a -> b
$ \CgInfoDownwards
_ 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 :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
runC :: forall a. DynFlags -> Module -> CgState -> FCode a -> (a, CgState)
runC DynFlags
dflags Module
mod CgState
st FCode a
fcode = forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode a
fcode (DynFlags -> Module -> CgInfoDownwards
initCgInfoDown DynFlags
dflags Module
mod) CgState
st
fixC :: (a -> FCode a) -> FCode a
fixC :: forall a. (a -> FCode a) -> FCode a
fixC a -> FCode a
fcode = forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode forall a b. (a -> b) -> a -> b
$
\CgInfoDownwards
info_down CgState
state -> let (a
v, CgState
s) = forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode (a -> FCode a
fcode a
v) CgInfoDownwards
info_down CgState
state
in (a
v, CgState
s)
data CgInfoDownwards
= MkCgInfoDown {
CgInfoDownwards -> DynFlags
cgd_dflags :: DynFlags,
CgInfoDownwards -> Module
cgd_mod :: Module,
CgInfoDownwards -> VirtualHpOffset
cgd_updfr_off :: UpdFrameOffset,
CgInfoDownwards -> CLabel
cgd_ticky :: CLabel,
CgInfoDownwards -> Sequel
cgd_sequel :: Sequel,
CgInfoDownwards -> Maybe SelfLoopInfo
cgd_self_loop :: Maybe SelfLoopInfo,
CgInfoDownwards -> CmmTickScope
cgd_tick_scope:: CmmTickScope
}
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 Sequel
= Return
| AssignTo
[LocalReg]
Bool
instance Outputable Sequel where
ppr :: Sequel -> SDoc
ppr Sequel
Return = String -> SDoc
text String
"Return"
ppr (AssignTo [LocalReg]
regs Bool
b) = String -> SDoc
text String
"AssignTo" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [LocalReg]
regs SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Bool
b
data ReturnKind
= AssignedDirectly
| ReturnedTo BlockId ByteOff
initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown DynFlags
dflags Module
mod
= MkCgInfoDown { cgd_dflags :: DynFlags
cgd_dflags = DynFlags
dflags
, cgd_mod :: Module
cgd_mod = Module
mod
, cgd_updfr_off :: VirtualHpOffset
cgd_updfr_off = Platform -> VirtualHpOffset
initUpdFrameOff (DynFlags -> Platform
targetPlatform DynFlags
dflags)
, cgd_ticky :: CLabel
cgd_ticky = CLabel
mkTopTickyCtrLabel
, cgd_sequel :: Sequel
cgd_sequel = Sequel
initSequel
, cgd_self_loop :: Maybe SelfLoopInfo
cgd_self_loop = forall a. Maybe a
Nothing
, cgd_tick_scope :: CmmTickScope
cgd_tick_scope= CmmTickScope
GlobalScope }
initSequel :: Sequel
initSequel :: Sequel
initSequel = Sequel
Return
initUpdFrameOff :: Platform -> UpdFrameOffset
initUpdFrameOff :: Platform -> VirtualHpOffset
initUpdFrameOff Platform
platform = Platform -> VirtualHpOffset
platformWordSizeInBytes Platform
platform
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 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. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode forall a b. (a -> b) -> a -> b
$ \CgInfoDownwards
_info_down CgState
state -> (CgState
state, CgState
state)
setState :: CgState -> FCode ()
setState :: CgState -> FCode ()
setState CgState
state = forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode forall a b. (a -> b) -> a -> b
$ \CgInfoDownwards
_info_down 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}
withState :: FCode a -> CgState -> FCode (a,CgState)
withState :: forall a. FCode a -> CgState -> FCode (a, CgState)
withState (FCode CgInfoDownwards -> CgState -> (a, CgState)
fcode) CgState
newstate = forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode forall a b. (a -> b) -> a -> b
$ \CgInfoDownwards
info_down CgState
state ->
case CgInfoDownwards -> CgState -> (a, CgState)
fcode CgInfoDownwards
info_down 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
getInfoDown :: FCode CgInfoDownwards
getInfoDown :: FCode CgInfoDownwards
getInfoDown = forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode forall a b. (a -> b) -> a -> b
$ \CgInfoDownwards
info_down CgState
state -> (CgInfoDownwards
info_down,CgState
state)
getSelfLoop :: FCode (Maybe SelfLoopInfo)
getSelfLoop :: FCode (Maybe SelfLoopInfo)
getSelfLoop = do
CgInfoDownwards
info_down <- FCode CgInfoDownwards
getInfoDown
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CgInfoDownwards -> Maybe SelfLoopInfo
cgd_self_loop CgInfoDownwards
info_down
withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a
withSelfLoop :: forall a. SelfLoopInfo -> FCode a -> FCode a
withSelfLoop SelfLoopInfo
self_loop FCode a
code = do
CgInfoDownwards
info_down <- FCode CgInfoDownwards
getInfoDown
forall a. FCode a -> CgInfoDownwards -> FCode a
withInfoDown FCode a
code (CgInfoDownwards
info_down {cgd_self_loop :: Maybe SelfLoopInfo
cgd_self_loop = forall a. a -> Maybe a
Just SelfLoopInfo
self_loop})
instance HasDynFlags FCode where
getDynFlags :: FCode DynFlags
getDynFlags = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM CgInfoDownwards -> DynFlags
cgd_dflags FCode CgInfoDownwards
getInfoDown
getProfile :: FCode Profile
getProfile :: FCode Profile
getProfile = DynFlags -> Profile
targetProfile forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
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
getCallOpts :: FCode CallOpts
getCallOpts :: FCode CallOpts
getCallOpts = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Profile
profile <- FCode Profile
getProfile
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ CallOpts
{ co_profile :: Profile
co_profile = Profile
profile
, co_loopification :: Bool
co_loopification = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Loopification DynFlags
dflags
, co_ticky :: Bool
co_ticky = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_Ticky DynFlags
dflags
}
getPtrOpts :: FCode PtrOpts
getPtrOpts :: FCode PtrOpts
getPtrOpts = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Profile
profile <- FCode Profile
getProfile
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PtrOpts
{ po_profile :: Profile
po_profile = Profile
profile
, po_align_check :: Bool
po_align_check = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AlignmentSanitisation DynFlags
dflags
}
withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
withInfoDown :: forall a. FCode a -> CgInfoDownwards -> FCode a
withInfoDown (FCode CgInfoDownwards -> CgState -> (a, CgState)
fcode) CgInfoDownwards
info_down = forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode forall a b. (a -> b) -> a -> b
$ \CgInfoDownwards
_ CgState
state -> CgInfoDownwards -> CgState -> (a, CgState)
fcode CgInfoDownwards
info_down CgState
state
getModuleName :: FCode Module
getModuleName :: FCode Module
getModuleName = do { CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown; forall (m :: * -> *) a. Monad m => a -> m a
return (CgInfoDownwards -> Module
cgd_mod CgInfoDownwards
info) }
withSequel :: Sequel -> FCode a -> FCode a
withSequel :: forall a. Sequel -> FCode a -> FCode a
withSequel Sequel
sequel FCode a
code
= do { CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
; forall a. FCode a -> CgInfoDownwards -> FCode a
withInfoDown FCode a
code (CgInfoDownwards
info {cgd_sequel :: Sequel
cgd_sequel = Sequel
sequel, cgd_self_loop :: Maybe SelfLoopInfo
cgd_self_loop = forall a. Maybe a
Nothing }) }
getSequel :: FCode Sequel
getSequel :: FCode Sequel
getSequel = do { CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
; forall (m :: * -> *) a. Monad m => a -> m a
return (CgInfoDownwards -> Sequel
cgd_sequel CgInfoDownwards
info) }
withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a
withUpdFrameOff :: forall a. VirtualHpOffset -> FCode a -> FCode a
withUpdFrameOff VirtualHpOffset
size FCode a
code
= do { CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
; forall a. FCode a -> CgInfoDownwards -> FCode a
withInfoDown FCode a
code (CgInfoDownwards
info {cgd_updfr_off :: VirtualHpOffset
cgd_updfr_off = VirtualHpOffset
size }) }
getUpdFrameOff :: FCode UpdFrameOffset
getUpdFrameOff :: FCode VirtualHpOffset
getUpdFrameOff
= do { CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CgInfoDownwards -> VirtualHpOffset
cgd_updfr_off CgInfoDownwards
info }
getTickyCtrLabel :: FCode CLabel
getTickyCtrLabel :: FCode CLabel
getTickyCtrLabel = do
CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
forall (m :: * -> *) a. Monad m => a -> m a
return (CgInfoDownwards -> CLabel
cgd_ticky CgInfoDownwards
info)
setTickyCtrLabel :: CLabel -> FCode a -> FCode a
setTickyCtrLabel :: forall a. CLabel -> FCode a -> FCode a
setTickyCtrLabel CLabel
ticky FCode a
code = do
CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
forall a. FCode a -> CgInfoDownwards -> FCode a
withInfoDown FCode a
code (CgInfoDownwards
info {cgd_ticky :: CLabel
cgd_ticky = CLabel
ticky})
getTickScope :: FCode CmmTickScope
getTickScope :: FCode CmmTickScope
getTickScope = do
CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
forall (m :: * -> *) a. Monad m => a -> m a
return (CgInfoDownwards -> CmmTickScope
cgd_tick_scope CgInfoDownwards
info)
tickScope :: FCode a -> FCode a
tickScope :: forall a. FCode a -> FCode a
tickScope FCode a
code = do
CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
if DynFlags -> VirtualHpOffset
debugLevel (CgInfoDownwards -> DynFlags
cgd_dflags CgInfoDownwards
info) forall a. Eq a => a -> a -> Bool
== VirtualHpOffset
0 then FCode a
code else do
Unique
u <- FCode Unique
newUnique
let scope' :: CmmTickScope
scope' = Unique -> CmmTickScope -> CmmTickScope
SubScope Unique
u (CgInfoDownwards -> CmmTickScope
cgd_tick_scope CgInfoDownwards
info)
forall a. FCode a -> CgInfoDownwards -> FCode a
withInfoDown FCode a
code CgInfoDownwards
info{ cgd_tick_scope :: CmmTickScope
cgd_tick_scope = CmmTickScope
scope' }
forkClosureBody :: FCode () -> FCode ()
forkClosureBody :: FCode () -> FCode ()
forkClosureBody FCode ()
body_code
= do { Platform
platform <- FCode Platform
getPlatform
; CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
; UniqSupply
us <- FCode UniqSupply
newUniqSupply
; CgState
state <- FCode CgState
getState
; let body_info_down :: CgInfoDownwards
body_info_down = CgInfoDownwards
info { cgd_sequel :: Sequel
cgd_sequel = Sequel
initSequel
, cgd_updfr_off :: VirtualHpOffset
cgd_updfr_off = Platform -> VirtualHpOffset
initUpdFrameOff Platform
platform
, cgd_self_loop :: Maybe SelfLoopInfo
cgd_self_loop = 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 -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode ()
body_code CgInfoDownwards
body_info_down 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 { CgInfoDownwards
info_down <- FCode CgInfoDownwards
getInfoDown
; UniqSupply
us <- FCode UniqSupply
newUniqSupply
; CgState
state <- FCode CgState
getState
; 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 -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode a
body_code CgInfoDownwards
info_down 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 { CgInfoDownwards
info_down <- FCode CgInfoDownwards
getInfoDown
; UniqSupply
us <- FCode UniqSupply
newUniqSupply
; CgState
state <- FCode CgState
getState
; 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 -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode ()
body_code CgInfoDownwards
info_down 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 { CgInfoDownwards
info_down <- FCode CgInfoDownwards
getInfoDown
; UniqSupply
us <- FCode UniqSupply
newUniqSupply
; CgState
state <- FCode CgState
getState
; let compile :: UniqSupply -> FCode a -> (UniqSupply, (a, CgState))
compile UniqSupply
us FCode a
branch
= (UniqSupply
us2, forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode a
branch CgInfoDownwards
info_down 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)
withState 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)
withState 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 { CgInfoDownwards
info_down <- FCode CgInfoDownwards
getInfoDown
; CgState
state <- FCode CgState
getState
; 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 -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode (VirtualHpOffset -> FCode a
fcode VirtualHpOffset
hp_hw) CgInfoDownwards
info_down 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
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> VirtualHpOffset
debugLevel DynFlags
dflags forall a. Ord a => a -> a -> Bool
> VirtualHpOffset
0) 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)
withState 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) }