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

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 0701b4c..05ec274 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -1,6 +1,6 @@
 -----------------------------------------------------------------------------
 --
--- (c) The University of Glasgow, 2004
+-- (c) The University of Glasgow, 2004-2006
 --
 -- Parser for concrete Cmm.
 --
@@ -16,38 +16,37 @@ import CgProf
 import CgTicky
 import CgInfoTbls
 import CgForeignCall
-import CgTailCall	( pushUnboxedTuple )
-import CgStackery	( emitPushUpdateFrame )
-import ClosureInfo	( C_SRT(..) )
-import CgCallConv	( smallLiveness )
-import CgClosure	( emitBlackHoleCode )
-import CostCentre	( dontCareCCS )
+import CgTailCall
+import CgStackery
+import ClosureInfo
+import CgCallConv
+import CgClosure
+import CostCentre
 
 import Cmm
 import PprCmm
-import CmmUtils		( mkIntCLit )
+import CmmUtils
 import CmmLex
 import CLabel
 import MachOp
-import SMRep		( fixedHdrSize, CgRep(..) )
+import SMRep
 import Lexer
 
-import ForeignCall	( CCallConv(..), Safety(..) )
-import Literal		( mkMachInt )
+import ForeignCall
+import Literal
 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 )
+import DynFlags
+import StaticFlags
+import ErrUtils
+import StringBuffer
 import FastString
-import Panic		( panic )
-import Constants	( wORD_SIZE )
+import Panic
+import Constants
 import Outputable
 
-import Monad		( when )
+import Control.Monad	( when )
 import Data.Char	( ord )
 
 #include "HsVersions.h"
@@ -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