1 files changed, 231 insertions, 0 deletions
diff --git a/compiler/codeGen/CgExtCode.hs b/compiler/codeGen/CgExtCode.hs
new file mode 100644
index 0000000000..03ac75e0ba
--- /dev/null
+++ b/compiler/codeGen/CgExtCode.hs
@@ -0,0 +1,231 @@
+-- | 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.
+--	CLabel's labelDynamic classifies these labels as dynamic, hence the
+--	code generator emits PIC code for them.
+newImport :: (Maybe PackageId, FastString) -> ExtFCode ()
+newImport (Nothing, name)
+   = addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True IsFunction)))
+
+newImport (Just pkg, name)
+   = addVarDecl name (CmmLit (CmmLabel (mkCmmCodeLabel pkg name)))
+
+-- | 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)
+
+