* Refactor CLabel.RtsLabel to CLabel.CmmLabel

The type of the CmmLabel ctor is now
  CmmLabel :: PackageId -> FastString -> CmmLabelInfo -> CLabel
  
 - When you construct a CmmLabel you have to explicitly say what
   package it is in. Many of these will just use rtsPackageId, but
   I've left it this way to remind people not to pretend labels are
   in the RTS package when they're not. 
   
 - When parsing a Cmm file, labels that are not defined in the 
   current file are assumed to be in the RTS package. 
   
   Labels imported like
      import label
   are assumed to be in a generic "foreign" package, which is different
   from the current one.
   
   Labels imported like
      import "package-name" label
   are marked as coming from the named package.
   
   This last one is needed for the integer-gmp library as we want to
   refer to labels that are not in the same compilation unit, but
   are in the same non-rts package.
   
   This should help remove the nasty #ifdef __PIC__ stuff from
   integer-gmp/cbits/gmp-wrappers.cmm
   

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