From: Duncan Coutts <duncan@well-typed.com>
Date: Tue, 9 Jun 2009 10:45:36 +0000 (+0000)
Subject: Lexing and parsing for "foreign import prim"
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=a4005d2d0c18ffa72ba7bd0fa052666e70e8c16e;hp=71aa4a4723e95b4f27fccf93dcc0a33000010974

Lexing and parsing for "foreign import prim"
We only allow simple function label imports, not the normal complicated
business with "wrapper" "dynamic" or data label "&var" imports.
---

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 4d8e0f0..5cc85ae 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -484,6 +484,7 @@ data Token
   | ITunsafe
   | ITstdcallconv
   | ITccallconv
+  | ITprimcallconv
   | ITdotnet
   | ITmdo
   | ITfamily
@@ -631,6 +632,7 @@ isSpecial ITthreadsafe 	= True
 isSpecial ITunsafe    	= True
 isSpecial ITccallconv   = True
 isSpecial ITstdcallconv = True
+isSpecial ITprimcallconv = True
 isSpecial ITmdo		= True
 isSpecial ITfamily	= True
 isSpecial ITgroup   = True
@@ -692,6 +694,7 @@ reservedWordsFM = listToUFM $
 	( "unsafe",	ITunsafe,	 bit ffiBit),
 	( "stdcall",    ITstdcallconv,	 bit ffiBit),
 	( "ccall",      ITccallconv,	 bit ffiBit),
+	( "prim",       ITprimcallconv,	 bit ffiBit),
 	( "dotnet",     ITdotnet,	 bit ffiBit),
 
 	( "rec",	ITrec,		 bit arrowsBit),
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 47b049e..ef48bb4 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -246,6 +246,7 @@ incorrect.
  'family'	{ L _ ITfamily }
  'stdcall'      { L _ ITstdcallconv }
  'ccall'        { L _ ITccallconv }
+ 'prim'         { L _ ITprimcallconv }
  'dotnet'       { L _ ITdotnet }
  'proc'		{ L _ ITproc }		-- for arrow notation extension
  'rec'		{ L _ ITrec }		-- for arrow notation extension
@@ -952,6 +953,7 @@ fdecl : 'import' callconv safety fspec
 callconv :: { CallConv }
 	  : 'stdcall'			{ CCall  StdCallConv }
 	  | 'ccall'			{ CCall  CCallConv   }
+	  | 'prim'			{ CCall  PrimCallConv}
 	  | 'dotnet'			{ DNCall	     }
 
 safety :: { Safety }
@@ -1902,6 +1904,7 @@ special_id
 	| 'dynamic'		{ L1 (fsLit "dynamic") }
 	| 'stdcall'             { L1 (fsLit "stdcall") }
 	| 'ccall'               { L1 (fsLit "ccall") }
+	| 'prim'                { L1 (fsLit "prim") }
 
 special_sym :: { Located FastString }
 special_sym : '!'	{ L1 (fsLit "!") }
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 3ca1b29..c1c5972 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -64,7 +64,7 @@ import BasicTypes	( maxPrecedence, Activation, RuleMatchInfo,
                           alwaysInlineSpec, neverInlineSpec )
 import Lexer		( P, failSpanMsgP, extension, standaloneDerivingEnabled, bangPatEnabled )
 import TysWiredIn	( unitTyCon ) 
-import ForeignCall	( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
+import ForeignCall	( CCallConv(..), Safety, CCallTarget(..), CExportSpec(..),
 			  DNCallSpec(..), DNKind(..), CLabelString )
 import OccName  	( srcDataName, varName, isDataOcc, isTcOcc, 
 			  occNameString )
@@ -957,6 +957,11 @@ mkImport :: CallConv
 	 -> Safety 
 	 -> (Located FastString, Located RdrName, LHsType RdrName) 
 	 -> P (HsDecl RdrName)
+mkImport (CCall  cconv) safety (entity, v, ty)
+  | cconv == PrimCallConv                      = do
+  let funcTarget = CFunction (StaticTarget (unLoc entity))
+      importSpec = CImport PrimCallConv safety nilFS nilFS funcTarget
+  return (ForD (ForeignImport v ty importSpec))
 mkImport (CCall  cconv) safety (entity, v, ty) = do
   importSpec <- parseCImport entity cconv safety v
   return (ForD (ForeignImport v ty importSpec))