X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmParse.y;h=51f29a85e7fd33d590bc777077ac059a7cba35f8;hp=ff6358da31dbf0aa5996aabf6cbb17fa2655b238;hb=8350c21760d8610b0b2f329095ffb80bb1bc20d9;hpb=2fe38b5fb0957f9428864afd69ad3ccd82fae3d0

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index ff6358d..51f29a8 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -8,7 +8,10 @@
 --
 -----------------------------------------------------------------------------
 
+-- TODO: Add support for interruptible/uninterruptible foreign call specification
+
 {
+{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6
 {-# OPTIONS -Wwarn -w #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
@@ -214,7 +217,7 @@ static 	:: { ExtFCode [CmmStatic] }
 	| 'CLOSURE' '(' NAME lits ')'
 		{ do lits <- sequence $4;
 		     return $ map CmmStaticLit $
-                       mkStaticClosure (mkForeignLabel $3 Nothing True IsData)
+                       mkStaticClosure (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
                          -- mkForeignLabel because these are only used
                          -- for CHARLIKE and INTLIKE closures in the RTS.
 			 dontCareCCS (map getLit lits) [] [] [] }
@@ -346,14 +349,21 @@ decl	:: { ExtCode }
 
 -- an imported function name, with optional packageId
 importNames  
-	:: { [(Maybe PackageId, FastString)] }
+	:: { [(FastString, CLabel)] }
 	: importName			{ [$1] }
 	| importName ',' importNames	{ $1 : $3 }		
 	
 importName
-	:: { (Maybe PackageId, FastString) }
-	: NAME				{ (Nothing, $1) }
-	| STRING NAME			{ (Just (fsToPackageId (mkFastString $1)), $2) }
+	:: { (FastString,  CLabel) }
+
+	-- A label imported without an explicit packageId.
+	--	These are taken to come frome some foreign, unnamed package.
+	: NAME	
+	{ ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
+
+	-- A label imported with an explicit packageId.
+	| STRING NAME
+	{ ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) }
 	
 	
 names 	:: { [FastString] }
@@ -394,7 +404,7 @@ stmt	:: { ExtCode }
         | 'return' maybe_actuals ';'
 		{ do e <- sequence $2; stmtEC (CmmReturn e) }
 	| 'if' bool_expr '{' body '}' else 	
-		{ ifThenElse $2 $4 $6 }
+		{ cmmIfThenElse $2 $4 $6 }
 
 opt_never_returns :: { CmmReturnInfo }
         :                               { CmmMayReturn }
@@ -719,6 +729,7 @@ callishMachOps = listToUFM $
 parseSafety :: String -> P CmmSafety
 parseSafety "safe"   = return (CmmSafe NoC_SRT)
 parseSafety "unsafe" = return CmmUnsafe
+parseSafety "interruptible" = return CmmInterruptible
 parseSafety str      = fail ("unrecognised safety: " ++ str)
 
 parseCmmHint :: String -> P ForeignHint
@@ -849,6 +860,9 @@ foreignCall conv_string results_code expr_code args_code vols safety ret
                 code (emitForeignCall' (PlaySafe unused) results 
                    (CmmCallee expr' convention) args vols NoC_SRT ret) where
 	        unused = panic "not used by emitForeignCall'"
+              CmmInterruptible ->
+                code (emitForeignCall' PlayInterruptible results 
+                   (CmmCallee expr' convention) args vols NoC_SRT ret)
 
 adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
 #ifdef mingw32_TARGET_OS
@@ -883,6 +897,9 @@ primCall results_code name args_code vols safety
 		    code (emitForeignCall' (PlaySafe unused) results 
 		      (CmmPrim p) args vols NoC_SRT CmmMayReturn) where
 		    unused = panic "not used by emitForeignCall'"
+		  CmmInterruptible ->
+		    code (emitForeignCall' PlayInterruptible results 
+		      (CmmPrim p) args vols NoC_SRT CmmMayReturn)
 
 doStore :: CmmType -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 doStore rep addr_code val_code
@@ -923,7 +940,7 @@ data BoolExpr
 
 -- ToDo: smart constructors which simplify the boolean expression.
 
-ifThenElse cond then_part else_part = do
+cmmIfThenElse cond then_part else_part = do
      then_id <- code newLabelC
      join_id <- code newLabelC
      c <- cond
@@ -1026,7 +1043,7 @@ parseCmmFile dflags filename = do
   buf <- hGetStringBuffer filename
   let
 	init_loc = mkSrcLoc (mkFastString filename) 1 1
-	init_state = (mkPState buf init_loc dflags) { lex_state = [0] }
+	init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
 		-- reset the lex_state: the Lexer monad leaves some stuff
 		-- in there we don't want.
   case unP cmmParse init_state of