module CgExtCode (
ExtFCode(..),
ExtCode,
Named(..), Env,
loopDecls,
getEnv,
newLocal,
newLabel,
newFunctionName,
newImport,
lookupLabel,
lookupName,
code,
code2,
nopEC,
stmtEC,
stmtsEC,
getCgStmtsEC,
getCgStmtsEC',
forkLabelledCodeEC
)
where
import CgMonad
import CLabel
import Cmm
import BlockId
import FastString
import Module
import UniqFM
import Unique
data Named
= Var CmmExpr
| Fun PackageId
| Label BlockId
type Env = UniqFM Named
type Decls = [(FastString,Named)]
newtype ExtFCode a
= EC { unEC :: Env -> Decls -> FCode (Decls, a) }
type ExtCode = ExtFCode ()
returnExtFC :: a -> ExtFCode a
returnExtFC a = EC $ \_ s -> return (s, a)
thenExtFC :: ExtFCode a -> (a -> ExtFCode b) -> ExtFCode b
thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
instance Monad ExtFCode where
(>>=) = thenExtFC
return = returnExtFC
loopDecls :: ExtFCode a -> ExtFCode a
loopDecls (EC fcode) =
EC $ \e globalDecls -> do
(_, a) <- fixC (\ ~(decls, _) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls)
return (globalDecls, a)
getEnv :: ExtFCode Env
getEnv = EC $ \e s -> return (s, e)
addVarDecl :: FastString -> CmmExpr -> ExtCode
addVarDecl var expr
= EC $ \_ s -> return ((var, Var expr):s, ())
addLabel :: FastString -> BlockId -> ExtCode
addLabel name block_id
= EC $ \_ s -> return ((name, Label block_id):s, ())
newLocal
:: CmmType
-> FastString
-> ExtFCode LocalReg
newLocal ty name = do
u <- code newUnique
let reg = LocalReg u ty
addVarDecl name (CmmReg (CmmLocal reg))
return reg
newLabel :: FastString -> ExtFCode BlockId
newLabel name = do
u <- code newUnique
addLabel name (BlockId u)
return (BlockId u)
newFunctionName
:: FastString
-> PackageId
-> ExtCode
newFunctionName name pkg
= EC $ \_ s -> return ((name, Fun pkg):s, ())
newImport
:: (FastString, CLabel)
-> ExtFCode ()
newImport (name, cmmLabel)
= addVarDecl name (CmmLit (CmmLabel cmmLabel))
lookupLabel :: FastString -> ExtFCode BlockId
lookupLabel name = do
env <- getEnv
return $
case lookupUFM env name of
Just (Label l) -> l
_other -> BlockId (newTagUnique (getUnique name) 'L')
lookupName :: FastString -> ExtFCode CmmExpr
lookupName name = do
env <- getEnv
return $
case lookupUFM env name of
Just (Var e) -> e
Just (Fun pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg name))
_other -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name))
code :: FCode a -> ExtFCode a
code fc = EC $ \_ s -> do
r <- fc
return (s, r)
code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c)) -> ExtFCode b -> ExtFCode c
code2 f (EC ec)
= EC $ \e s -> do
((s', _),c) <- f (ec e s)
return (s',c)
nopEC :: ExtFCode ()
nopEC = code nopC
stmtEC :: CmmStmt -> ExtFCode ()
stmtEC stmt = code (stmtC stmt)
stmtsEC :: [CmmStmt] -> ExtFCode ()
stmtsEC stmts = code (stmtsC stmts)
getCgStmtsEC :: ExtFCode a -> ExtFCode CgStmts
getCgStmtsEC = code2 getCgStmts'
getCgStmtsEC' :: ExtFCode a -> ExtFCode (a, CgStmts)
getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f)
where f ((decl, b), c) = return ((decl, b), (b, c))
forkLabelledCodeEC :: ExtFCode a -> ExtFCode BlockId
forkLabelledCodeEC ec = do
stmts <- getCgStmtsEC ec
code (forkCgStmts stmts)