{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
module GHC.StgToCmm.Monad (
FCode,
initC, runC, fixC,
newUnique,
emitLabel,
emit, emitDecl,
emitProcWithConvention, emitProcWithStackFrame,
emitOutOfLine, emitAssign, emitStore,
emitComment, emitTick, emitUnwind,
getCmm, aGraphToGraph,
getCodeR, getCode, getCodeScoped, getHeapUsage,
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, getThisPackage,
CgIdInfo(..),
getBinds, setBinds,
CgInfoDownwards(..), CgState(..)
) where
import GhcPrelude hiding( sequence, succ )
import Cmm
import GHC.StgToCmm.Closure
import DynFlags
import Hoopl.Collections
import MkGraph
import BlockId
import CLabel
import SMRep
import Module
import Id
import VarEnv
import OrdList
import BasicTypes( ConTagZ )
import Unique
import UniqSupply
import FastString
import Outputable
import Util
import Control.Monad
import Data.List
newtype FCode a = FCode { FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }
deriving (a -> FCode b -> FCode a
(a -> b) -> FCode a -> FCode b
(forall a b. (a -> b) -> FCode a -> FCode b)
-> (forall a b. a -> FCode b -> FCode a) -> Functor FCode
forall a b. a -> FCode b -> FCode a
forall a b. (a -> b) -> FCode a -> FCode b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FCode b -> FCode a
$c<$ :: forall a b. a -> FCode b -> FCode a
fmap :: (a -> b) -> FCode a -> FCode b
$cfmap :: forall a b. (a -> b) -> FCode a -> FCode b
Functor)
instance Applicative FCode where
pure :: a -> FCode a
pure a
val = (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode (\CgInfoDownwards
_info_down CgState
state -> (a
val, CgState
state))
{-# INLINE pure #-}
<*> :: 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 CgInfoDownwards -> CgState -> (a, CgState)
m >>= :: FCode a -> (a -> FCode b) -> FCode b
>>= a -> FCode b
k = (CgInfoDownwards -> CgState -> (b, CgState)) -> FCode b
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> (b, CgState)) -> FCode b)
-> (CgInfoDownwards -> CgState -> (b, CgState)) -> FCode b
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 (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 = (CgInfoDownwards -> CgState -> (Unique, CgState)) -> FCode Unique
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> (Unique, CgState)) -> FCode Unique)
-> (CgInfoDownwards -> CgState -> (Unique, CgState))
-> FCode Unique
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'
; CgState -> IO CgState
forall (m :: * -> *) a. Monad m => a -> m a
return (UniqSupply -> CgState
initCgState UniqSupply
uniqs) }
runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)
runC :: DynFlags -> Module -> CgState -> FCode a -> (a, CgState)
runC DynFlags
dflags Module
mod CgState
st FCode a
fcode = FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
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 :: (a -> FCode a) -> FCode a
fixC a -> FCode a
fcode = (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a)
-> (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
forall a b. (a -> b) -> a -> b
$
\CgInfoDownwards
info_down CgState
state -> let (a
v, CgState
s) = FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
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 -> UpdFrameOffset
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 Outputable CgIdInfo where
ppr :: CgIdInfo -> SDoc
ppr (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
<+> String -> SDoc
text String
"-->" SDoc -> SDoc -> SDoc
<+> CgLoc -> SDoc
forall a. Outputable a => a -> SDoc
ppr 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
<+> [LocalReg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [LocalReg]
regs SDoc -> SDoc -> SDoc
<+> Bool -> 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 :: DynFlags
-> Module
-> UpdFrameOffset
-> CLabel
-> Sequel
-> Maybe SelfLoopInfo
-> CmmTickScope
-> CgInfoDownwards
MkCgInfoDown { cgd_dflags :: DynFlags
cgd_dflags = DynFlags
dflags
, cgd_mod :: Module
cgd_mod = Module
mod
, cgd_updfr_off :: UpdFrameOffset
cgd_updfr_off = DynFlags -> UpdFrameOffset
initUpdFrameOff DynFlags
dflags
, cgd_ticky :: CLabel
cgd_ticky = CLabel
mkTopTickyCtrLabel
, cgd_sequel :: Sequel
cgd_sequel = Sequel
initSequel
, cgd_self_loop :: Maybe SelfLoopInfo
cgd_self_loop = Maybe SelfLoopInfo
forall a. Maybe a
Nothing
, cgd_tick_scope :: CmmTickScope
cgd_tick_scope= CmmTickScope
GlobalScope }
initSequel :: Sequel
initSequel :: Sequel
initSequel = Sequel
Return
initUpdFrameOff :: DynFlags -> UpdFrameOffset
initUpdFrameOff :: DynFlags -> UpdFrameOffset
initUpdFrameOff DynFlags
dflags = Width -> UpdFrameOffset
widthInBytes (DynFlags -> Width
wordWidth DynFlags
dflags)
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 -> UpdFrameOffset
virtHp :: VirtualHpOffset,
HeapUsage -> UpdFrameOffset
realHp :: VirtualHpOffset
}
type VirtualHpOffset = WordOff
initCgState :: UniqSupply -> CgState
initCgState :: UniqSupply -> CgState
initCgState UniqSupply
uniqs
= MkCgState :: CmmAGraph
-> OrdList CmmDecl
-> CgBindings
-> HeapUsage
-> UniqSupply
-> CgState
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 :: HeapUsage
cgs_hp_usg = CgState -> HeapUsage
cgs_hp_usg CgState
s1 HeapUsage -> UpdFrameOffset -> HeapUsage
`maxHpHw` HeapUsage -> UpdFrameOffset
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
MkGraph.<*> CgState -> CmmAGraph
cgs_stmts CgState
s2,
cgs_tops :: OrdList CmmDecl
cgs_tops = CgState -> OrdList CmmDecl
cgs_tops CgState
s1 OrdList CmmDecl -> OrdList CmmDecl -> OrdList CmmDecl
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` CgState -> OrdList CmmDecl
cgs_tops CgState
s2 }
heapHWM :: HeapUsage -> VirtualHpOffset
heapHWM :: HeapUsage -> UpdFrameOffset
heapHWM = HeapUsage -> UpdFrameOffset
virtHp
initHpUsage :: HeapUsage
initHpUsage :: HeapUsage
initHpUsage = HeapUsage :: UpdFrameOffset -> UpdFrameOffset -> HeapUsage
HeapUsage { virtHp :: UpdFrameOffset
virtHp = UpdFrameOffset
0, realHp :: UpdFrameOffset
realHp = UpdFrameOffset
0 }
maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
HeapUsage
hp_usg maxHpHw :: HeapUsage -> UpdFrameOffset -> HeapUsage
`maxHpHw` UpdFrameOffset
hw = HeapUsage
hp_usg { virtHp :: UpdFrameOffset
virtHp = HeapUsage -> UpdFrameOffset
virtHp HeapUsage
hp_usg UpdFrameOffset -> UpdFrameOffset -> UpdFrameOffset
forall a. Ord a => a -> a -> a
`max` UpdFrameOffset
hw }
getState :: FCode CgState
getState :: FCode CgState
getState = (CgInfoDownwards -> CgState -> (CgState, CgState)) -> FCode CgState
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> (CgState, CgState))
-> FCode CgState)
-> (CgInfoDownwards -> CgState -> (CgState, CgState))
-> FCode CgState
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 = (CgInfoDownwards -> CgState -> ((), CgState)) -> FCode ()
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> ((), CgState)) -> FCode ())
-> (CgInfoDownwards -> CgState -> ((), CgState)) -> 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
HeapUsage -> FCode HeapUsage
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 :: HeapUsage
cgs_hp_usg = HeapUsage
new_hp_usg}
setVirtHp :: VirtualHpOffset -> FCode ()
setVirtHp :: UpdFrameOffset -> FCode ()
setVirtHp UpdFrameOffset
new_virtHp
= do { HeapUsage
hp_usage <- FCode HeapUsage
getHpUsage
; HeapUsage -> FCode ()
setHpUsage (HeapUsage
hp_usage {virtHp :: UpdFrameOffset
virtHp = UpdFrameOffset
new_virtHp}) }
getVirtHp :: FCode VirtualHpOffset
getVirtHp :: FCode UpdFrameOffset
getVirtHp
= do { HeapUsage
hp_usage <- FCode HeapUsage
getHpUsage
; UpdFrameOffset -> FCode UpdFrameOffset
forall (m :: * -> *) a. Monad m => a -> m a
return (HeapUsage -> UpdFrameOffset
virtHp HeapUsage
hp_usage) }
setRealHp :: VirtualHpOffset -> FCode ()
setRealHp :: UpdFrameOffset -> FCode ()
setRealHp UpdFrameOffset
new_realHp
= do { HeapUsage
hp_usage <- FCode HeapUsage
getHpUsage
; HeapUsage -> FCode ()
setHpUsage (HeapUsage
hp_usage {realHp :: UpdFrameOffset
realHp = UpdFrameOffset
new_realHp}) }
getBinds :: FCode CgBindings
getBinds :: FCode CgBindings
getBinds = do
CgState
state <- FCode CgState
getState
CgBindings -> FCode CgBindings
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 :: CgBindings
cgs_binds = CgBindings
new_binds}
withState :: FCode a -> CgState -> FCode (a,CgState)
withState :: FCode a -> CgState -> FCode (a, CgState)
withState (FCode CgInfoDownwards -> CgState -> (a, CgState)
fcode) CgState
newstate = (CgInfoDownwards -> CgState -> ((a, CgState), CgState))
-> FCode (a, CgState)
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> ((a, CgState), CgState))
-> FCode (a, CgState))
-> (CgInfoDownwards -> CgState -> ((a, CgState), CgState))
-> FCode (a, CgState)
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 (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
state { cgs_uniqs :: UniqSupply
cgs_uniqs = UniqSupply
us1 }
UniqSupply -> FCode UniqSupply
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 :: UniqSupply
cgs_uniqs = UniqSupply
us' }
Unique -> FCode Unique
forall (m :: * -> *) a. Monad m => a -> m a
return Unique
u
getInfoDown :: FCode CgInfoDownwards
getInfoDown :: FCode CgInfoDownwards
getInfoDown = (CgInfoDownwards -> CgState -> (CgInfoDownwards, CgState))
-> FCode CgInfoDownwards
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> (CgInfoDownwards, CgState))
-> FCode CgInfoDownwards)
-> (CgInfoDownwards -> CgState -> (CgInfoDownwards, CgState))
-> FCode CgInfoDownwards
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
Maybe SelfLoopInfo -> FCode (Maybe SelfLoopInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SelfLoopInfo -> FCode (Maybe SelfLoopInfo))
-> Maybe SelfLoopInfo -> FCode (Maybe SelfLoopInfo)
forall a b. (a -> b) -> a -> b
$ CgInfoDownwards -> Maybe SelfLoopInfo
cgd_self_loop CgInfoDownwards
info_down
withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a
withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a
withSelfLoop SelfLoopInfo
self_loop FCode a
code = do
CgInfoDownwards
info_down <- FCode CgInfoDownwards
getInfoDown
FCode a -> CgInfoDownwards -> FCode a
forall a. FCode a -> CgInfoDownwards -> FCode a
withInfoDown FCode a
code (CgInfoDownwards
info_down {cgd_self_loop :: Maybe SelfLoopInfo
cgd_self_loop = SelfLoopInfo -> Maybe SelfLoopInfo
forall a. a -> Maybe a
Just SelfLoopInfo
self_loop})
instance HasDynFlags FCode where
getDynFlags :: FCode DynFlags
getDynFlags = (CgInfoDownwards -> DynFlags)
-> FCode CgInfoDownwards -> FCode DynFlags
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM CgInfoDownwards -> DynFlags
cgd_dflags FCode CgInfoDownwards
getInfoDown
getThisPackage :: FCode UnitId
getThisPackage :: FCode UnitId
getThisPackage = (DynFlags -> UnitId) -> FCode DynFlags -> FCode UnitId
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM DynFlags -> UnitId
thisPackage FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
withInfoDown (FCode CgInfoDownwards -> CgState -> (a, CgState)
fcode) CgInfoDownwards
info_down = (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
forall a. (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
FCode ((CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a)
-> (CgInfoDownwards -> CgState -> (a, CgState)) -> FCode a
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; Module -> FCode Module
forall (m :: * -> *) a. Monad m => a -> m a
return (CgInfoDownwards -> Module
cgd_mod CgInfoDownwards
info) }
withSequel :: Sequel -> FCode a -> FCode a
withSequel :: Sequel -> FCode a -> FCode a
withSequel Sequel
sequel FCode a
code
= do { CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
; FCode a -> CgInfoDownwards -> FCode a
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 = Maybe SelfLoopInfo
forall a. Maybe a
Nothing }) }
getSequel :: FCode Sequel
getSequel :: FCode Sequel
getSequel = do { CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
; Sequel -> FCode Sequel
forall (m :: * -> *) a. Monad m => a -> m a
return (CgInfoDownwards -> Sequel
cgd_sequel CgInfoDownwards
info) }
withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a
withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a
withUpdFrameOff UpdFrameOffset
size FCode a
code
= do { CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
; FCode a -> CgInfoDownwards -> FCode a
forall a. FCode a -> CgInfoDownwards -> FCode a
withInfoDown FCode a
code (CgInfoDownwards
info {cgd_updfr_off :: UpdFrameOffset
cgd_updfr_off = UpdFrameOffset
size }) }
getUpdFrameOff :: FCode UpdFrameOffset
getUpdFrameOff :: FCode UpdFrameOffset
getUpdFrameOff
= do { CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
; UpdFrameOffset -> FCode UpdFrameOffset
forall (m :: * -> *) a. Monad m => a -> m a
return (UpdFrameOffset -> FCode UpdFrameOffset)
-> UpdFrameOffset -> FCode UpdFrameOffset
forall a b. (a -> b) -> a -> b
$ CgInfoDownwards -> UpdFrameOffset
cgd_updfr_off CgInfoDownwards
info }
getTickyCtrLabel :: FCode CLabel
getTickyCtrLabel :: FCode CLabel
getTickyCtrLabel = do
CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
CLabel -> FCode CLabel
forall (m :: * -> *) a. Monad m => a -> m a
return (CgInfoDownwards -> CLabel
cgd_ticky CgInfoDownwards
info)
setTickyCtrLabel :: CLabel -> FCode a -> FCode a
setTickyCtrLabel :: CLabel -> FCode a -> FCode a
setTickyCtrLabel CLabel
ticky FCode a
code = do
CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
FCode a -> CgInfoDownwards -> FCode a
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
CmmTickScope -> FCode CmmTickScope
forall (m :: * -> *) a. Monad m => a -> m a
return (CgInfoDownwards -> CmmTickScope
cgd_tick_scope CgInfoDownwards
info)
tickScope :: FCode a -> FCode a
tickScope :: FCode a -> FCode a
tickScope FCode a
code = do
CgInfoDownwards
info <- FCode CgInfoDownwards
getInfoDown
if DynFlags -> UpdFrameOffset
debugLevel (CgInfoDownwards -> DynFlags
cgd_dflags CgInfoDownwards
info) UpdFrameOffset -> UpdFrameOffset -> Bool
forall a. Eq a => a -> a -> Bool
== UpdFrameOffset
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)
FCode a -> CgInfoDownwards -> FCode a
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 { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; 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 :: UpdFrameOffset
cgd_updfr_off = DynFlags -> UpdFrameOffset
initUpdFrameOff DynFlags
dflags
, cgd_self_loop :: Maybe SelfLoopInfo
cgd_self_loop = Maybe SelfLoopInfo
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) = FCode () -> CgInfoDownwards -> CgState -> ((), CgState)
forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode ()
body_code CgInfoDownwards
body_info_down 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 :: 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) = FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode a
body_code CgInfoDownwards
info_down 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 (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) = FCode () -> CgInfoDownwards -> CgState -> ((), CgState)
forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode FCode ()
body_code CgInfoDownwards
info_down 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 :: [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, FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
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) = (UniqSupply -> FCode a -> (UniqSupply, (a, CgState)))
-> UniqSupply -> [FCode a] -> (UniqSupply, [(a, CgState)])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
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 (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 (m :: * -> *) a. Monad m => a -> m a
return [a]
branch_results }
forkAltPair :: FCode a -> FCode a -> FCode (a,a)
forkAltPair :: 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 (m :: * -> *) a. Monad m => a -> m a
return (a
x',a
y')
[a]
_ -> String -> FCode (a, a)
forall a. String -> a
panic String
"forkAltPair"
getCodeR :: FCode a -> FCode (a, CmmAGraph)
getCodeR :: 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)
withState FCode a
fcode (CgState
state1 { cgs_stmts :: CmmAGraph
cgs_stmts = CmmAGraph
mkNop })
; CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
state2 { cgs_stmts :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
state1 }
; (a, CmmAGraph) -> FCode (a, CmmAGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, CgState -> CmmAGraph
cgs_stmts CgState
state2) }
getCode :: FCode a -> FCode CmmAGraph
getCode :: 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 (m :: * -> *) a. Monad m => a -> m a
return CmmAGraph
stmts }
getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped)
getCodeScoped :: 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)
withState CgState
state1 { cgs_stmts :: CmmAGraph
cgs_stmts = CmmAGraph
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 (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 :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
state1 }
; (a, CmmAGraphScoped) -> FCode (a, CmmAGraphScoped)
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 :: (UpdFrameOffset -> FCode a) -> FCode a
getHeapUsage UpdFrameOffset -> 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) = FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
forall a. FCode a -> CgInfoDownwards -> CgState -> (a, CgState)
doFCode (UpdFrameOffset -> FCode a
fcode UpdFrameOffset
hp_hw) CgInfoDownwards
info_down CgState
fstate_in
hp_hw :: UpdFrameOffset
hp_hw = HeapUsage -> UpdFrameOffset
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 :: HeapUsage
cgs_hp_usg = CgState -> HeapUsage
cgs_hp_usg CgState
state }
; 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 :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
state CmmAGraph -> CgStmt -> CmmAGraph
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 = () -> FCode ()
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
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> UpdFrameOffset
debugLevel DynFlags
dflags UpdFrameOffset -> UpdFrameOffset -> Bool
forall a. Ord a => a -> a -> Bool
> UpdFrameOffset
0) (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
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 CmmExpr
l CmmExpr
r = CgStmt -> FCode ()
emitCgStmt (CmmNode O O -> CgStmt
CgStmt (CmmExpr -> CmmExpr -> CmmNode O O
CmmStore CmmExpr
l CmmExpr
r))
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 :: CmmAGraph
cgs_stmts = CgState -> CmmAGraph
cgs_stmts CgState
state CmmAGraph -> CmmAGraph -> CmmAGraph
MkGraph.<*> CmmAGraph
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 :: OrdList CmmDecl
cgs_tops = CgState -> OrdList CmmDecl
cgs_tops CgState
state OrdList CmmDecl -> CmmDecl -> OrdList CmmDecl
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 { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Maybe CmmInfoTable
-> CLabel
-> [GlobalReg]
-> CmmAGraphScoped
-> UpdFrameOffset
-> Bool
-> FCode ()
emitProc Maybe CmmInfoTable
mb_info CLabel
lbl [] CmmAGraphScoped
blocks (Width -> UpdFrameOffset
widthInBytes (DynFlags -> Width
wordWidth DynFlags
dflags)) Bool
False
}
emitProcWithStackFrame Convention
conv Maybe CmmInfoTable
mb_info CLabel
lbl [LocalReg]
stk_args [LocalReg]
args (CmmAGraph
graph, CmmTickScope
tscope) Bool
True
= do { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let (UpdFrameOffset
offset, [GlobalReg]
live, CmmAGraph
entry) = DynFlags
-> Convention
-> [LocalReg]
-> [LocalReg]
-> (UpdFrameOffset, [GlobalReg], CmmAGraph)
mkCallEntry DynFlags
dflags Convention
conv [LocalReg]
args [LocalReg]
stk_args
graph' :: CmmAGraph
graph' = CmmAGraph
entry CmmAGraph -> CmmAGraph -> CmmAGraph
MkGraph.<*> CmmAGraph
graph
; Maybe CmmInfoTable
-> CLabel
-> [GlobalReg]
-> CmmAGraphScoped
-> UpdFrameOffset
-> Bool
-> FCode ()
emitProc Maybe CmmInfoTable
mb_info CLabel
lbl [GlobalReg]
live (CmmAGraph
graph', CmmTickScope
tscope) UpdFrameOffset
offset Bool
True
}
emitProcWithStackFrame Convention
_ Maybe CmmInfoTable
_ CLabel
_ [LocalReg]
_ [LocalReg]
_ CmmAGraphScoped
_ Bool
_ = String -> FCode ()
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
-> UpdFrameOffset
-> Bool
-> FCode ()
emitProc Maybe CmmInfoTable
mb_info CLabel
lbl [GlobalReg]
live CmmAGraphScoped
blocks UpdFrameOffset
offset Bool
do_layout
= do { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; 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 (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 (map :: * -> *) a. IsMap map => map a
mapEmpty
sinfo :: CmmStackInfo
sinfo = StackInfo :: UpdFrameOffset -> Maybe UpdFrameOffset -> Bool -> CmmStackInfo
StackInfo { arg_space :: UpdFrameOffset
arg_space = UpdFrameOffset
offset
, updfr_space :: Maybe UpdFrameOffset
updfr_space = UpdFrameOffset -> Maybe UpdFrameOffset
forall a. a -> Maybe a
Just (DynFlags -> UpdFrameOffset
initUpdFrameOff DynFlags
dflags)
, do_layout :: Bool
do_layout = Bool
do_layout }
tinfo :: CmmTopInfo
tinfo = TopInfo :: LabelMap CmmInfoTable -> CmmStackInfo -> CmmTopInfo
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 :: OrdList CmmDecl
cgs_tops = CgState -> OrdList CmmDecl
cgs_tops CgState
state OrdList CmmDecl -> CmmDecl -> OrdList CmmDecl
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmDecl
proc_block } }
getCmm :: FCode () -> FCode CmmGroup
getCmm :: FCode () -> FCode CmmGroup
getCmm FCode ()
code
= do { CgState
state1 <- FCode CgState
getState
; ((), CgState
state2) <- FCode () -> CgState -> FCode ((), CgState)
forall a. FCode a -> CgState -> FCode (a, CgState)
withState FCode ()
code (CgState
state1 { cgs_tops :: OrdList CmmDecl
cgs_tops = OrdList CmmDecl
forall a. OrdList a
nilOL })
; CgState -> FCode ()
setState (CgState -> FCode ()) -> CgState -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgState
state2 { cgs_tops :: OrdList CmmDecl
cgs_tops = CgState -> OrdList CmmDecl
cgs_tops CgState
state1 }
; CmmGroup -> FCode CmmGroup
forall (m :: * -> *) a. Monad m => a -> m a
return (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 (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 (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 (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]
-> UpdFrameOffset
-> [CmmExpr]
-> FCode CmmAGraph
mkCall CmmExpr
f (Convention
callConv, Convention
retConv) [LocalReg]
results [CmmExpr]
actuals UpdFrameOffset
updfr_off [CmmExpr]
extra_stack = do
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
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
(UpdFrameOffset
off, [GlobalReg]
_, CmmAGraph
copyin) = DynFlags
-> Convention
-> Area
-> [LocalReg]
-> [LocalReg]
-> (UpdFrameOffset, [GlobalReg], CmmAGraph)
copyInOflow DynFlags
dflags Convention
retConv Area
area [LocalReg]
results []
copyout :: CmmAGraph
copyout = DynFlags
-> CmmExpr
-> Convention
-> [CmmExpr]
-> BlockId
-> UpdFrameOffset
-> UpdFrameOffset
-> [CmmExpr]
-> CmmAGraph
mkCallReturnsTo DynFlags
dflags CmmExpr
f Convention
callConv [CmmExpr]
actuals BlockId
k UpdFrameOffset
off UpdFrameOffset
updfr_off [CmmExpr]
extra_stack
CmmAGraph -> FCode CmmAGraph
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] -> UpdFrameOffset -> FCode CmmAGraph
mkCmmCall CmmExpr
f [LocalReg]
results [CmmExpr]
actuals UpdFrameOffset
updfr_off
= CmmExpr
-> (Convention, Convention)
-> [LocalReg]
-> [CmmExpr]
-> UpdFrameOffset
-> [CmmExpr]
-> FCode CmmAGraph
mkCall CmmExpr
f (Convention
NativeDirectCall, Convention
NativeReturn) [LocalReg]
results [CmmExpr]
actuals UpdFrameOffset
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 (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> CmmAGraphScoped -> CmmGraph
labelAGraph BlockId
l CmmAGraphScoped
stmts) }