X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmParse.y;h=5908314c870a2f5cf60e63004216a835b9f5ca1d;hb=273be06fa7cb1297284dbb553ecc9be7d07df6af;hp=73618bc35bd8e3ba87360e1d9d216ed6ef01cbe7;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 73618bc..5908314 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -103,6 +103,7 @@ import Data.Char	( ord )
 	'if'		{ L _ (CmmT_if) }
 	'jump'		{ L _ (CmmT_jump) }
 	'foreign'	{ L _ (CmmT_foreign) }
+	'prim'		{ L _ (CmmT_prim) }
 	'import'	{ L _ (CmmT_import) }
 	'switch'	{ L _ (CmmT_switch) }
 	'case'		{ L _ (CmmT_case) }
@@ -253,7 +254,8 @@ names 	:: { [FastString] }
 stmt	:: { ExtCode }
 	: ';'					{ nopEC }
 
-	| block_id ':'				{ code (labelC $1) }
+	| NAME ':'
+		{ do l <- newLabel $1; code (labelC l) }
 
 	| lreg '=' expr ';'			
 		{ do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
@@ -264,6 +266,11 @@ stmt	:: { ExtCode }
 	| lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
 		{% let result = do r <- $1; return (r,NoHint) in
 		   foreignCall $4 [result] $5 $7 $9 }
+	| 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
+		{% primCall [] $3 $5 $7 }
+	| lreg '=' 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
+		{% let result = do r <- $1; return (r,NoHint) in
+		   primCall [result] $5 $7 $9 }
 	| STRING lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
 		{% do h <- parseHint $1;
 		      let result = do r <- $2; return (r,h) in
@@ -274,8 +281,8 @@ stmt	:: { ExtCode }
 		{% stmtMacro $1 $3  }
 	| 'switch' maybe_range expr '{' arms default '}'
 		{ doSwitch $2 $3 $5 $6 }
-	| 'goto' block_id ';'
-		{ stmtEC (CmmBranch $2) }
+	| 'goto' NAME ';'
+		{ do l <- lookupLabel $2; stmtEC (CmmBranch l) }
 	| 'jump' expr {-maybe_actuals-} ';'
 		{ do e <- $2; stmtEC (CmmJump e []) }
 	| 'if' bool_expr '{' body '}' else 	
@@ -403,13 +410,6 @@ lreg	:: { ExtFCode CmmReg }
 					other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
 	| GLOBALREG		{ return (CmmGlobal $1) }
 
-block_id :: { BlockId }
-	: NAME			{ BlockId (newTagUnique (getUnique $1) 'L') }
-			-- TODO: ugh.  The unique of a FastString has a null
-			-- tag, so we have to put our own tag on.  We should
-			-- really make a new unique for every label, and keep
-			-- them in an environment.
-
 type	:: { MachRep }
 	: 'bits8'		{ I8 }
 	| typenot8		{ $1 }
@@ -536,6 +536,12 @@ machOps = listToUFM $
 	( "i2f64",    flip MO_S_Conv F64 )
 	]
 
+callishMachOps = listToUFM $
+	map (\(x, y) -> (mkFastString x, y)) [
+        ( "write_barrier", MO_WriteBarrier )
+        -- ToDo: the rest, maybe
+    ]
+
 parseHint :: String -> P MachHint
 parseHint "ptr"    = return PtrHint
 parseHint "signed" = return SignedHint
@@ -623,8 +629,9 @@ stmtMacros = listToUFM [
 -- to collect declarations as we parse the proc, and feed the environment
 -- back in circularly (to avoid a two-pass algorithm).
 
-type Decls = [(FastString,CmmExpr)]
-type Env   = UniqFM CmmExpr
+data Named = Var CmmExpr | Label BlockId
+type Decls = [(FastString,Named)]
+type Env   = UniqFM Named
 
 newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
 
@@ -649,13 +656,30 @@ getEnv :: ExtFCode Env
 getEnv = EC $ \e s -> return (s, e)
 
 addVarDecl :: FastString -> CmmExpr -> ExtCode
-addVarDecl var expr = EC $ \e s -> return ((var,expr):s, ())
+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 :: MachRep -> FastString -> ExtCode
 newLocal ty name  = do
    u <- code newUnique
    addVarDecl name (CmmReg (CmmLocal (LocalReg u ty)))
 
+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.
@@ -664,8 +688,8 @@ lookupName name = do
   env <- getEnv
   return $ 
      case lookupUFM env name of
-	Nothing -> CmmLit (CmmLabel (mkRtsCodeLabelFS name))
-	Just e  -> e
+	Just (Var e) -> e
+	_other -> CmmLit (CmmLabel (mkRtsCodeLabelFS name))
 
 -- Lifting FCode computations into the ExtFCode monad:
 code :: FCode a -> ExtFCode a
@@ -739,6 +763,19 @@ foreignCall "C" results_code expr_code args_code vols
 foreignCall conv _ _ _ _
   = fail ("unknown calling convention: " ++ conv)
 
+primCall
+	:: [ExtFCode (CmmReg,MachHint)]
+	-> FastString
+	-> [ExtFCode (CmmExpr,MachHint)]
+	-> Maybe [GlobalReg] -> P ExtCode
+primCall results_code name args_code vols
+  = case lookupUFM callishMachOps name of
+	Nothing -> fail ("unknown primitive " ++ unpackFS name)
+	Just p  -> return $ do
+		results <- sequence results_code
+		args <- sequence args_code
+        	code (emitForeignCall' PlayRisky results (CmmPrim p) args vols)
+
 doStore :: MachRep -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 doStore rep addr_code val_code
   = do addr <- addr_code
@@ -865,9 +902,9 @@ doSwitch mb_range scrut arms deflt
 initEnv :: Env
 initEnv = listToUFM [
   ( FSLIT("SIZEOF_StgHeader"), 
-	CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) ),
+    Var (CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )),
   ( FSLIT("SIZEOF_StgInfoTable"),
-        CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) )
+    Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) ))
   ]
 
 parseCmmFile :: DynFlags -> HomeModules -> FilePath -> IO (Maybe Cmm)