/ghc-7.0.4/compiler/codeGen/CgExtCode.hs

-- | 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).

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 BasicTypes
import BlockId
import FastString
import Module
import UniqFM
import Unique


-- | The environment contains variable definitions or blockids.
data Named 	
	= Var 	CmmExpr		-- ^ Holds CmmLit(CmmLabel ..) which gives the label type,
				--	eg, RtsLabel, ForeignLabel, CmmLabel etc. 

	| Fun	PackageId	-- ^ A function name from this package
	| Label BlockId		-- ^ A blockid of some code or data.
	
-- | An environment of named things.
type Env   	= UniqFM Named

-- | Local declarations that are in scope during code generation.
type Decls 	= [(FastString,Named)]

-- | Does a computation in the FCode monad, with a current environment
--	and a list of local declarations. Returns the resulting list of declarations.
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


-- | Takes the variable decarations and imports from the monad
-- 	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.
--	Discards the local declaration contained within decl'
--
loopDecls :: ExtFCode a -> ExtFCode a
loopDecls (EC fcode) =
      EC $ \e globalDecls -> do
	(_, a) <- fixC (\ ~(decls, _) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls)
	return (globalDecls, a)


-- | Get the current environment from the monad.
getEnv :: ExtFCode Env
getEnv 	= EC $ \e s -> return (s, e)


-- | Add a new variable to the list of local declarations. 
--	The CmmExpr says where the value is stored. 
addVarDecl :: FastString -> CmmExpr -> ExtCode
addVarDecl var expr 
	= EC $ \_ s -> return ((var, Var expr):s, ())

-- | Add a new label to the list of local declarations.
addLabel :: FastString -> BlockId -> ExtCode
addLabel name block_id 
	= EC $ \_ s -> return ((name, Label block_id):s, ())


-- | Create a fresh local variable of a given type.
newLocal 
	:: CmmType 		-- ^ data type
	-> FastString 		-- ^ name of variable
	-> ExtFCode LocalReg	-- ^ register holding the value
	
newLocal ty name = do
   u <- code newUnique
   let reg = LocalReg u ty
   addVarDecl name (CmmReg (CmmLocal reg))
   return reg


-- | Allocate a fresh label.
newLabel :: FastString -> ExtFCode BlockId
newLabel name = do
   u <- code newUnique
   addLabel name (BlockId u)
   return (BlockId u)


-- | Add add a local function to the environment.
newFunctionName 
	:: FastString	-- ^ name of the function 
	-> PackageId 	-- ^ package of the current module
	-> ExtCode
	
newFunctionName name pkg
	= EC $ \_ s -> return ((name, Fun pkg):s, ())
	
	
-- | Add an imported foreign label to the list of local declarations.
--	If this is done at the start of the module the declaration will scope
--	over the whole module.
newImport 
	:: (FastString, CLabel) 
	-> ExtFCode ()

newImport (name, cmmLabel) 
   = addVarDecl name (CmmLit (CmmLabel cmmLabel))


-- | Lookup the BlockId bound to the label with this name.
--	If one hasn't been bound yet, create a fresh one based on the 
--	Unique of the name.
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')


-- | Lookup the location of a named variable.
--	Unknown names are treated as if they had been 'import'ed from the runtime system.
-- 	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
	Just (Fun pkg)	-> CmmLit (CmmLabel (mkCmmCodeLabel pkg          name))
	_other 		-> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name))


-- | Lift an FCode computation into the ExtFCode monad
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)


-- | Do nothing in the ExtFCode monad.
nopEC :: ExtFCode ()
nopEC = code nopC


-- | Accumulate a CmmStmt into the monad state.
stmtEC :: CmmStmt -> ExtFCode () 
stmtEC stmt = code (stmtC stmt)


-- | Accumulate some CmmStmts into the monad state.
stmtsEC :: [CmmStmt] -> ExtFCode ()
stmtsEC stmts = code (stmtsC stmts)


-- | Get the generated statements out of the monad state.
getCgStmtsEC :: ExtFCode a -> ExtFCode CgStmts
getCgStmtsEC = code2 getCgStmts'


-- | Get the generated statements, and the return value out of the monad state.
getCgStmtsEC' :: ExtFCode a -> ExtFCode (a, CgStmts)
getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f)
  where f ((decl, b), c) = return ((decl, b), (b, c))


-- | Emit a chunk of code outside the instruction stream, 
--	and return its block id. 
forkLabelledCodeEC :: ExtFCode a -> ExtFCode BlockId
forkLabelledCodeEC ec = do
  stmts <- getCgStmtsEC ec
  code (forkCgStmts stmts)