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 (file)
--- 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 (file)
--- 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 (file)
--- 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))