--- -----------------------------------------------------------------------------
--- Our extended FCode monad.
-
--- We add a mapping from names to CmmExpr, to support local variable names in
--- the concrete C-- code. The unique supply of the underlying FCode monad
--- is used to grab a new unique for each local variable.
-
--- In C--, a local variable can be declared anywhere within a proc,
--- and it scopes from the beginning of the proc to the end. Hence, we have
--- to collect declarations as we parse the proc, and feed the environment
--- back in circularly (to avoid a two-pass algorithm).
-
-data Named = Var CmmExpr | Label BlockId
-type Decls = [(FastString,Named)]
-type Env = UniqFM Named
-
-newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
-
-type ExtCode = ExtFCode ()
-
-returnExtFC a = EC $ \e s -> return (s, a)
-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
-
--- This function takes the variable decarations and imports and makes
--- an environment, which is looped back into the computation. In this
--- way, we can have embedded declarations that scope over the whole
--- procedure, and imports that scope over the entire module.
-loopDecls :: ExtFCode a -> ExtFCode a
-loopDecls (EC fcode) =
- EC $ \e s -> fixC (\ ~(decls,a) -> fcode (addListToUFM e decls) [])
-
-getEnv :: ExtFCode Env
-getEnv = EC $ \e s -> return (s, e)
-
-addVarDecl :: FastString -> CmmExpr -> ExtCode
-addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ())
-
-addLabel :: FastString -> BlockId -> ExtCode
-addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ())
-
-newLocal :: Kind -> MachRep -> FastString -> ExtFCode LocalReg
-newLocal kind ty name = do
- u <- code newUnique
- let reg = LocalReg u ty kind
- addVarDecl name (CmmReg (CmmLocal reg))
- return reg
-
-newLabel :: FastString -> ExtFCode BlockId
-newLabel name = do
- u <- code newUnique
- addLabel name (BlockId u)
- return (BlockId u)
-
-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')
-
--- Unknown names are treated as if they had been 'import'ed.
--- This saves us a lot of bother in the RTS sources, at the expense of
--- deferring some errors to link time.
-lookupName :: FastString -> ExtFCode CmmExpr
-lookupName name = do
- env <- getEnv
- return $
- case lookupUFM env name of
- Just (Var e) -> e
- _other -> CmmLit (CmmLabel (mkRtsCodeLabelFS name))
-
--- Lifting FCode computations into the ExtFCode monad:
-code :: FCode a -> ExtFCode a
-code fc = EC $ \e 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',b),c) <- f (ec e s); return (s',c)
-
-nopEC = code nopC
-stmtEC stmt = code (stmtC stmt)
-stmtsEC stmts = code (stmtsC stmts)
-getCgStmtsEC = code2 getCgStmts'
-
-forkLabelledCodeEC ec = do
- stmts <- getCgStmtsEC ec
- code (forkCgStmts stmts)