module StgCmmMonad (
FCode,
initC, thenC, thenFC, listCs, listFCs, mapCs, mapFCs,
returnFC, fixC, fixC_, nopC, whenC,
newUnique, newUniqSupply,
emit, emitData, emitProc, emitProcWithConvention, emitSimpleProc,
getCmm, cgStmtsToBlocks,
getCodeR, getCode, getHeapUsage,
forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly,
ConTagZ,
Sequel(..),
withSequel, getSequel,
setSRTLabel, getSRTLabel,
setTickyCtrLabel, getTickyCtrLabel,
withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,
HeapUsage(..), VirtualHpOffset, initHpUsage,
getHpUsage, setHpUsage, heapHWM,
setVirtHp, getVirtHp, setRealHp,
getModuleName,
getState, setState, getInfoDown, getDynFlags, getThisPackage,
CgIdInfo(..), CgLoc(..),
getBinds, setBinds, getStaticBinds,
CgInfoDownwards(..), CgState(..)
) where
#include "HsVersions.h"
import StgCmmClosure
import DynFlags
import MkZipCfgCmm
import ZipCfgCmmRep (UpdFrameOffset)
import BlockId
import Cmm
import CLabel
import TyCon ( PrimRep )
import SMRep
import Module
import Id
import VarEnv
import OrdList
import Unique
import Util()
import UniqSupply
import FastString(sLit)
import Outputable
import Control.Monad
import Data.List
import Prelude hiding( sequence )
import qualified Prelude( sequence )
infixr 9 `thenC`
infixr 9 `thenFC`
newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
instance Monad FCode where
(>>=) = thenFC
return = returnFC
initC :: DynFlags -> Module -> FCode a -> IO a
initC dflags mod (FCode code)
= do { uniqs <- mkSplitUniqSupply 'c'
; case code (initCgInfoDown dflags mod) (initCgState uniqs) of
(res, _) -> return res
}
returnFC :: a -> FCode a
returnFC val = FCode (\_info_down state -> (val, state))
thenC :: FCode () -> FCode a -> FCode a
thenC (FCode m) (FCode k) =
FCode (\info_down state -> let (_,new_state) = m info_down state in
k info_down new_state)
nopC :: FCode ()
nopC = return ()
whenC :: Bool -> FCode () -> FCode ()
whenC True code = code
whenC False _code = nopC
listCs :: [FCode ()] -> FCode ()
listCs [] = return ()
listCs (fc:fcs) = do
fc
listCs fcs
mapCs :: (a -> FCode ()) -> [a] -> FCode ()
mapCs = mapM_
thenFC :: FCode a -> (a -> FCode c) -> FCode c
thenFC (FCode m) k = FCode (
\info_down state ->
let
(m_result, new_state) = m info_down state
(FCode kcode) = k m_result
in
kcode info_down new_state
)
listFCs :: [FCode a] -> FCode [a]
listFCs = Prelude.sequence
mapFCs :: (a -> FCode b) -> [a] -> FCode [b]
mapFCs = mapM
fixC :: (a -> FCode a) -> FCode a
fixC fcode = FCode (
\info_down state ->
let
FCode fc = fcode v
result@(v,_) = fc info_down state
in
result
)
fixC_ :: (a -> FCode a) -> FCode ()
fixC_ fcode = fixC fcode >> return ()
data CgInfoDownwards
= MkCgInfoDown {
cgd_dflags :: DynFlags,
cgd_mod :: Module,
cgd_statics :: CgBindings,
cgd_srt_lbl :: CLabel,
cgd_updfr_off :: UpdFrameOffset,
cgd_ticky :: CLabel,
cgd_sequel :: Sequel
}
type CgBindings = IdEnv CgIdInfo
data CgIdInfo
= CgIdInfo
{ cg_id :: Id
, cg_lf :: LambdaFormInfo
, cg_loc :: CgLoc
, cg_rep :: PrimRep
, cg_tag :: !DynTag
}
data CgLoc
= CmmLoc CmmExpr
| LneLoc BlockId [LocalReg]
instance Outputable CgIdInfo where
ppr (CgIdInfo { cg_id = id, cg_loc = loc })
= ppr id <+> ptext (sLit "-->") <+> ppr loc
instance Outputable CgLoc where
ppr (CmmLoc e) = ptext (sLit "cmm") <+> ppr e
ppr (LneLoc b rs) = ptext (sLit "lne") <+> ppr b <+> ppr rs
data Sequel
= Return Bool
| AssignTo
[LocalReg]
Bool
instance Show Sequel where
show (Return _) = "Sequel: Return"
show (AssignTo _ _) = "Sequel: Assign"
initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards
initCgInfoDown dflags mod
= MkCgInfoDown { cgd_dflags = dflags,
cgd_mod = mod,
cgd_statics = emptyVarEnv,
cgd_srt_lbl = error "initC: srt_lbl",
cgd_updfr_off = initUpdFrameOff,
cgd_ticky = mkTopTickyCtrLabel,
cgd_sequel = initSequel }
initSequel :: Sequel
initSequel = Return False
initUpdFrameOff :: UpdFrameOffset
initUpdFrameOff = widthInBytes wordWidth
data CgState
= MkCgState {
cgs_stmts :: CmmAGraph,
cgs_tops :: OrdList CmmTopZ,
cgs_binds :: CgBindings,
cgs_hp_usg :: HeapUsage,
cgs_uniqs :: UniqSupply }
data HeapUsage =
HeapUsage {
virtHp :: VirtualHpOffset,
realHp :: VirtualHpOffset
}
type VirtualHpOffset = WordOff
initCgState :: UniqSupply -> CgState
initCgState uniqs
= MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL,
cgs_binds = emptyVarEnv,
cgs_hp_usg = initHpUsage,
cgs_uniqs = uniqs }
stateIncUsage :: CgState -> CgState -> CgState
stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })
= s1 { cgs_hp_usg = cgs_hp_usg s1 `maxHpHw` virtHp hp_usg }
`addCodeBlocksFrom` s2
addCodeBlocksFrom :: CgState -> CgState -> CgState
s1 `addCodeBlocksFrom` s2
= s1 { cgs_stmts = cgs_stmts s1 <*> cgs_stmts s2,
cgs_tops = cgs_tops s1 `appOL` cgs_tops s2 }
heapHWM :: HeapUsage -> VirtualHpOffset
heapHWM = virtHp
initHpUsage :: HeapUsage
initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }
maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage
hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }
getState :: FCode CgState
getState = FCode $ \_info_down state -> (state,state)
setState :: CgState -> FCode ()
setState state = FCode $ \_info_down _ -> ((),state)
getHpUsage :: FCode HeapUsage
getHpUsage = do
state <- getState
return $ cgs_hp_usg state
setHpUsage :: HeapUsage -> FCode ()
setHpUsage new_hp_usg = do
state <- getState
setState $ state {cgs_hp_usg = new_hp_usg}
setVirtHp :: VirtualHpOffset -> FCode ()
setVirtHp new_virtHp
= do { hp_usage <- getHpUsage
; setHpUsage (hp_usage {virtHp = new_virtHp}) }
getVirtHp :: FCode VirtualHpOffset
getVirtHp
= do { hp_usage <- getHpUsage
; return (virtHp hp_usage) }
setRealHp :: VirtualHpOffset -> FCode ()
setRealHp new_realHp
= do { hp_usage <- getHpUsage
; setHpUsage (hp_usage {realHp = new_realHp}) }
getBinds :: FCode CgBindings
getBinds = do
state <- getState
return $ cgs_binds state
setBinds :: CgBindings -> FCode ()
setBinds new_binds = do
state <- getState
setState $ state {cgs_binds = new_binds}
getStaticBinds :: FCode CgBindings
getStaticBinds = do
info <- getInfoDown
return (cgd_statics info)
withState :: FCode a -> CgState -> FCode (a,CgState)
withState (FCode fcode) newstate = FCode $ \info_down state ->
let (retval, state2) = fcode info_down newstate in ((retval,state2), state)
newUniqSupply :: FCode UniqSupply
newUniqSupply = do
state <- getState
let (us1, us2) = splitUniqSupply (cgs_uniqs state)
setState $ state { cgs_uniqs = us1 }
return us2
newUnique :: FCode Unique
newUnique = do
us <- newUniqSupply
return (uniqFromSupply us)
getInfoDown :: FCode CgInfoDownwards
getInfoDown = FCode $ \info_down state -> (info_down,state)
getDynFlags :: FCode DynFlags
getDynFlags = liftM cgd_dflags getInfoDown
getThisPackage :: FCode PackageId
getThisPackage = liftM thisPackage getDynFlags
withInfoDown :: FCode a -> CgInfoDownwards -> FCode a
withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state
doFCode :: FCode a -> CgInfoDownwards -> CgState -> (a,CgState)
doFCode (FCode fcode) info_down state = fcode info_down state
getModuleName :: FCode Module
getModuleName = do { info <- getInfoDown; return (cgd_mod info) }
withSequel :: Sequel -> FCode () -> FCode ()
withSequel sequel code
= do { info <- getInfoDown
; withInfoDown code (info {cgd_sequel = sequel }) }
getSequel :: FCode Sequel
getSequel = do { info <- getInfoDown
; return (cgd_sequel info) }
getSRTLabel :: FCode CLabel
getSRTLabel = do info <- getInfoDown
return (cgd_srt_lbl info)
setSRTLabel :: CLabel -> FCode a -> FCode a
setSRTLabel srt_lbl code
= do info <- getInfoDown
withInfoDown code (info { cgd_srt_lbl = srt_lbl})
withUpdFrameOff :: UpdFrameOffset -> FCode () -> FCode ()
withUpdFrameOff size code
= do { info <- getInfoDown
; withInfoDown code (info {cgd_updfr_off = size }) }
getUpdFrameOff :: FCode UpdFrameOffset
getUpdFrameOff
= do { info <- getInfoDown
; return $ cgd_updfr_off info }
getTickyCtrLabel :: FCode CLabel
getTickyCtrLabel = do
info <- getInfoDown
return (cgd_ticky info)
setTickyCtrLabel :: CLabel -> FCode () -> FCode ()
setTickyCtrLabel ticky code = do
info <- getInfoDown
withInfoDown code (info {cgd_ticky = ticky})
forkClosureBody :: FCode () -> FCode ()
forkClosureBody body_code
= do { info <- getInfoDown
; us <- newUniqSupply
; state <- getState
; let body_info_down = info { cgd_sequel = initSequel
, cgd_updfr_off = initUpdFrameOff }
fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
((),fork_state_out)
= doFCode body_code body_info_down fork_state_in
; setState $ state `addCodeBlocksFrom` fork_state_out }
forkStatics :: FCode a -> FCode a
forkStatics body_code
= do { info <- getInfoDown
; us <- newUniqSupply
; state <- getState
; let rhs_info_down = info { cgd_statics = cgs_binds state
, cgd_sequel = initSequel
, cgd_updfr_off = initUpdFrameOff }
(result, fork_state_out) = doFCode body_code rhs_info_down
(initCgState us)
; setState (state `addCodeBlocksFrom` fork_state_out)
; return result }
forkProc :: FCode a -> FCode a
forkProc body_code
= do { info_down <- getInfoDown
; us <- newUniqSupply
; state <- getState
; let info_down' = info_down
fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }
(result, fork_state_out) = doFCode body_code info_down' fork_state_in
; setState $ state `addCodeBlocksFrom` fork_state_out
; return result }
codeOnly :: FCode () -> FCode ()
codeOnly body_code
= do { info_down <- getInfoDown
; us <- newUniqSupply
; state <- getState
; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state,
cgs_hp_usg = cgs_hp_usg state }
((), fork_state_out) = doFCode body_code info_down fork_state_in
; setState $ state `addCodeBlocksFrom` fork_state_out }
forkAlts :: [FCode a] -> FCode [a]
forkAlts branch_fcodes
= do { info_down <- getInfoDown
; us <- newUniqSupply
; state <- getState
; let compile us branch
= (us2, doFCode branch info_down branch_state)
where
(us1,us2) = splitUniqSupply us
branch_state = (initCgState us1) {
cgs_binds = cgs_binds state,
cgs_hp_usg = cgs_hp_usg state }
(_us, results) = mapAccumL compile us branch_fcodes
(branch_results, branch_out_states) = unzip results
; setState $ foldl stateIncUsage state branch_out_states
; return branch_results }
getCodeR :: FCode a -> FCode (a, CmmAGraph)
getCodeR fcode
= do { state1 <- getState
; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })
; setState $ state2 { cgs_stmts = cgs_stmts state1 }
; return (a, cgs_stmts state2) }
getCode :: FCode a -> FCode CmmAGraph
getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }
getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a
getHeapUsage fcode
= do { info_down <- getInfoDown
; state <- getState
; let fstate_in = state { cgs_hp_usg = initHpUsage }
(r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in
hp_hw = heapHWM (cgs_hp_usg fstate_out)
; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }
; return r }
emit :: CmmAGraph -> FCode ()
emit ag
= do { state <- getState
; setState $ state { cgs_stmts = cgs_stmts state <*> ag } }
emitData :: Section -> [CmmStatic] -> FCode ()
emitData sect lits
= do { state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } }
where
data_block = CmmData sect lits
emitProcWithConvention :: Convention -> CmmInfo -> CLabel -> CmmFormals ->
CmmAGraph -> FCode ()
emitProcWithConvention conv info lbl args blocks
= do { us <- newUniqSupply
; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) conv args
blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
; let proc_block = CmmProc info lbl args ((offset, Just initUpdFrameOff), blks)
; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
emitProc = emitProcWithConvention NativeNodeCall
emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
emitSimpleProc lbl code =
emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code
getCmm :: FCode () -> FCode CmmZ
getCmm code
= do { state1 <- getState
; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
; setState $ state2 { cgs_tops = cgs_tops state1 }
; return (Cmm (fromOL (cgs_tops state2))) }
cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph
cgStmtsToBlocks stmts
= do { us <- newUniqSupply
; return (initUs_ us (lgraphOfAGraph stmts)) }