X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmParse.y;h=a1cbbf51ed9bd824509e036ae5795a05c5d261c8;hb=3e83dfb21b2f2220dce97427fff5c19459ae68d1;hp=0701b4cfafa32d147111f7ee8ed76fa66af6e33f;hpb=ea16a2e5f05ec890679e70ccba13472fccc67db7;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 0701b4c..a1cbbf5 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -38,7 +38,6 @@ import Unique
 import UniqFM
 import SrcLoc
 import DynFlags		( DynFlags, DynFlag(..) )
-import Packages		( HomeModules )
 import StaticFlags	( opt_SccProfilingOn )
 import ErrUtils		( printError, dumpIfSet_dyn, showPass )
 import StringBuffer	( hGetStringBuffer )
@@ -103,6 +102,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) }
@@ -265,6 +265,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
@@ -530,6 +535,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
@@ -751,6 +762,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
@@ -882,8 +906,8 @@ initEnv = listToUFM [
     Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) ))
   ]
 
-parseCmmFile :: DynFlags -> HomeModules -> FilePath -> IO (Maybe Cmm)
-parseCmmFile dflags hmods filename = do
+parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
+parseCmmFile dflags filename = do
   showPass dflags "ParseCmm"
   buf <- hGetStringBuffer filename
   let
@@ -894,7 +918,7 @@ parseCmmFile dflags hmods filename = do
   case unP cmmParse init_state of
     PFailed span err -> do printError span err; return Nothing
     POk _ code -> do
-	cmm <- initC dflags hmods no_module (getCmm (unEC code initEnv [] >> return ()))
+	cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
 	dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
 	return (Just cmm)
   where