Make calling conventions in template haskell Syntax.hs consistent with those in ghc...
authorLuite Stegeman <stegeman@gmail.com>
Thu, 20 Nov 2014 00:38:58 +0000 (18:38 -0600)
committerAustin Seipp <austin@well-typed.com>
Thu, 20 Nov 2014 01:49:42 +0000 (19:49 -0600)
this impliments #9703 from ghc trac

Test Plan: still needs tests

Reviewers: cmsaperstein, ekmett, goldfire, austin

Reviewed By: goldfire, austin

Subscribers: goldfire, thomie, carter, simonmar

Differential Revision: https://phabricator.haskell.org/D353

GHC Trac Issues: #9703

compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.lhs
compiler/prelude/ForeignCall.lhs
libraries/template-haskell/Language/Haskell/TH.hs
libraries/template-haskell/Language/Haskell/TH/Lib.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
testsuite/tests/th/TH_foreignCallingConventions.hs [new file with mode: 0644]
testsuite/tests/th/TH_foreignCallingConventions.stderr [new file with mode: 0644]
testsuite/tests/th/all.T

index 083c466..afdfae3 100644 (file)
@@ -488,9 +488,11 @@ repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
 repForD decl = notHandled "Foreign declaration" (ppr decl)
 
 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
-repCCallConv CCallConv = rep2 cCallName []
-repCCallConv StdCallConv = rep2 stdCallName []
-repCCallConv callConv    = notHandled "repCCallConv" (ppr callConv)
+repCCallConv CCallConv          = rep2 cCallName []
+repCCallConv StdCallConv        = rep2 stdCallName []
+repCCallConv CApiConv           = rep2 cApiCallName []
+repCCallConv PrimCallConv       = rep2 primCallName []
+repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
 
 repSafety :: Safety -> DsM (Core TH.Safety)
 repSafety PlayRisky = rep2 unsafeName []
@@ -2147,7 +2149,7 @@ templateHaskellNames = [
     varKName, conKName, tupleKName, arrowKName, listKName, appKName,
     starKName, constraintKName,
     -- Callconv
-    cCallName, stdCallName,
+    cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName,
     -- Safety
     unsafeName,
     safeName,
@@ -2456,9 +2458,12 @@ starKName       = libFun (fsLit "starK")        starKIdKey
 constraintKName = libFun (fsLit "constraintK")  constraintKIdKey
 
 -- data Callconv = ...
-cCallName, stdCallName :: Name
+cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name
 cCallName = libFun (fsLit "cCall") cCallIdKey
 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
+cApiCallName = libFun (fsLit "cApi") cApiCallIdKey
+primCallName = libFun (fsLit "prim") primCallIdKey
+javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey
 
 -- data Safety = ...
 unsafeName, safeName, interruptibleName :: Name
@@ -2819,15 +2824,19 @@ starKIdKey        = mkPreludeMiscIdUnique 410
 constraintKIdKey  = mkPreludeMiscIdUnique 411
 
 -- data Callconv = ...
-cCallIdKey, stdCallIdKey :: Unique
-cCallIdKey      = mkPreludeMiscIdUnique 412
-stdCallIdKey    = mkPreludeMiscIdUnique 413
+cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey,
+  javaScriptCallIdKey :: Unique
+cCallIdKey          = mkPreludeMiscIdUnique 420
+stdCallIdKey        = mkPreludeMiscIdUnique 421
+cApiCallIdKey       = mkPreludeMiscIdUnique 422
+primCallIdKey       = mkPreludeMiscIdUnique 423
+javaScriptCallIdKey = mkPreludeMiscIdUnique 424
 
 -- data Safety = ...
 unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
-unsafeIdKey        = mkPreludeMiscIdUnique 414
-safeIdKey          = mkPreludeMiscIdUnique 415
-interruptibleIdKey = mkPreludeMiscIdUnique 416
+unsafeIdKey        = mkPreludeMiscIdUnique 430
+safeIdKey          = mkPreludeMiscIdUnique 431
+interruptibleIdKey = mkPreludeMiscIdUnique 432
 
 -- data Inline = ...
 noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
@@ -2852,31 +2861,31 @@ tExpDataConKey = mkPreludeDataConUnique 48
 
 -- data FunDep = ...
 funDepIdKey :: Unique
-funDepIdKey = mkPreludeMiscIdUnique 419
+funDepIdKey = mkPreludeMiscIdUnique 440
 
 -- data FamFlavour = ...
 typeFamIdKey, dataFamIdKey :: Unique
-typeFamIdKey = mkPreludeMiscIdUnique 420
-dataFamIdKey = mkPreludeMiscIdUnique 421
+typeFamIdKey = mkPreludeMiscIdUnique 450
+dataFamIdKey = mkPreludeMiscIdUnique 451
 
 -- data TySynEqn = ...
 tySynEqnIdKey :: Unique
-tySynEqnIdKey = mkPreludeMiscIdUnique 422
+tySynEqnIdKey = mkPreludeMiscIdUnique 460
 
 -- quasiquoting
 quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
-quoteExpKey  = mkPreludeMiscIdUnique 423
-quotePatKey  = mkPreludeMiscIdUnique 424
-quoteDecKey  = mkPreludeMiscIdUnique 425
-quoteTypeKey = mkPreludeMiscIdUnique 426
+quoteExpKey  = mkPreludeMiscIdUnique 470
+quotePatKey  = mkPreludeMiscIdUnique 471
+quoteDecKey  = mkPreludeMiscIdUnique 472
+quoteTypeKey = mkPreludeMiscIdUnique 473
 
 -- data RuleBndr = ...
 ruleVarIdKey, typedRuleVarIdKey :: Unique
-ruleVarIdKey      = mkPreludeMiscIdUnique 427
-typedRuleVarIdKey = mkPreludeMiscIdUnique 428
+ruleVarIdKey      = mkPreludeMiscIdUnique 480
+typedRuleVarIdKey = mkPreludeMiscIdUnique 481
 
 -- data AnnTarget = ...
 valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique
-valueAnnotationIdKey  = mkPreludeMiscIdUnique 429
-typeAnnotationIdKey   = mkPreludeMiscIdUnique 430
-moduleAnnotationIdKey = mkPreludeMiscIdUnique 431
+valueAnnotationIdKey  = mkPreludeMiscIdUnique 490
+typeAnnotationIdKey   = mkPreludeMiscIdUnique 491
+moduleAnnotationIdKey = mkPreludeMiscIdUnique 492
index 9ad594c..83c286d 100644 (file)
@@ -483,8 +483,11 @@ cvtForD (ExportF callconv as nm ty)
         ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
 
 cvt_conv :: TH.Callconv -> CCallConv
-cvt_conv TH.CCall   = CCallConv
-cvt_conv TH.StdCall = StdCallConv
+cvt_conv TH.CCall      = CCallConv
+cvt_conv TH.StdCall    = StdCallConv
+cvt_conv TH.CApi       = CApiConv
+cvt_conv TH.Prim       = PrimCallConv
+cvt_conv TH.JavaScript = JavaScriptCallConv
 
 ------------------------------------------
 --              Pragmas
index 232f69f..0104343 100644 (file)
@@ -156,6 +156,7 @@ platforms.
 See: http://www.programmersheaven.com/2/Calling-conventions
 
 \begin{code}
+-- any changes here should be replicated in  the CallConv type in template haskell
 data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv
   deriving (Eq, Data, Typeable)
   {-! derive: Binary !-}
index e038a3b..050ac85 100644 (file)
@@ -133,7 +133,8 @@ module Language.Haskell.TH(
     newtypeInstD, tySynInstD,
     typeFam, dataFam, tySynEqn,
     -- **** Foreign Function Interface (FFI)
-    cCall, stdCall, unsafe, safe, forImpD,
+    cCall, stdCall, cApi, prim, javaScript,
+    unsafe, safe, forImpD,
     -- **** Pragmas
     ruleVar, typedRuleVar,
     pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD,
index efe5972..bfba99a 100644 (file)
@@ -638,9 +638,12 @@ inferR            = InferR
 -------------------------------------------------------------------------------
 -- *   Callconv
 
-cCall, stdCall :: Callconv
-cCall = CCall
-stdCall = StdCall
+cCall, stdCall, cApi, prim, javaScript :: Callconv
+cCall      = CCall
+stdCall    = StdCall
+cApi       = CApi
+prim       = Prim
+javaScript = JavaScript
 
 -------------------------------------------------------------------------------
 -- *   Safety
index 8c95045..0e5ced9 100644 (file)
@@ -1250,7 +1250,8 @@ data Foreign = ImportF Callconv Safety String Name Type
              | ExportF Callconv        String Name Type
          deriving( Show, Eq, Data, Typeable, Generic )
 
-data Callconv = CCall | StdCall
+-- keep Callconv in sync with module ForeignCall in ghc/compiler/prelude/ForeignCall.hs
+data Callconv = CCall | StdCall | CApi | Prim | JavaScript
           deriving( Show, Eq, Data, Typeable, Generic )
 
 data Safety = Unsafe | Safe | Interruptible
diff --git a/testsuite/tests/th/TH_foreignCallingConventions.hs b/testsuite/tests/th/TH_foreignCallingConventions.hs
new file mode 100644 (file)
index 0000000..ee39510
--- /dev/null
@@ -0,0 +1,24 @@
+{-# LANGUAGE ForeignFunctionInterface, CApiFFI, GHCForeignImportPrim,
+             QuasiQuotes, TemplateHaskell, JavaScriptFFI, MagicHash,
+             UnliftedFFITypes #-}
+
+module TH_foreignCallingConventions where
+
+import GHC.Prim
+import Control.Applicative
+import Language.Haskell.TH
+import System.IO
+import Foreign.Ptr
+
+$( do let fi cconv safety lbl name ty =
+            ForeignD (ImportF cconv safety lbl name ty)
+      dec1 <- fi CCall      Interruptible "&"   (mkName "foo") <$> [t| Ptr () |]
+      dec2 <- fi Prim       Safe          "bar" (mkName "bar") <$> [t| Int# -> Int# |]
+      -- the declarations below would result in warnings or errors when returned
+      dec3 <- fi CApi       Unsafe        "baz" (mkName "baz") <$> [t| Double -> IO () |]
+      dec4 <- fi StdCall    Safe          "bay" (mkName "bay") <$> [t| (Int -> Bool) -> IO Int |]
+      dec5 <- fi JavaScript Unsafe        "bax" (mkName "bax") <$> [t| Ptr Int -> IO String |]
+      runIO $
+        mapM_ (putStrLn . pprint) [dec1, dec2, dec3, dec4, dec5] >> hFlush stdout
+      return [dec1, dec2]
+ )
diff --git a/testsuite/tests/th/TH_foreignCallingConventions.stderr b/testsuite/tests/th/TH_foreignCallingConventions.stderr
new file mode 100644 (file)
index 0000000..bf1f8b8
--- /dev/null
@@ -0,0 +1,30 @@
+foreign import ccall interruptible "&" foo :: GHC.Ptr.Ptr ()
+foreign import prim safe "bar" bar :: GHC.Prim.Int# ->
+                                      GHC.Prim.Int#
+foreign import capi unsafe "baz" baz :: GHC.Types.Double ->
+                                        GHC.Types.IO ()
+foreign import stdcall safe "bay" bay :: (GHC.Types.Int ->
+                                          GHC.Types.Bool) ->
+                                         GHC.Types.IO GHC.Types.Int
+foreign import javascript unsafe "bax" bax :: GHC.Ptr.Ptr GHC.Types.Int ->
+                                              GHC.Types.IO GHC.Base.String
+TH_foreignCallingConventions.hs:1:1: Splicing declarations
+    do { let fi cconv safety lbl name ty
+               = ForeignD (ImportF cconv safety lbl name ty);
+         dec1 <- fi CCall Interruptible "&" (mkName "foo")
+                 <$> [t| Ptr () |];
+         dec2 <- fi Prim Safe "bar" (mkName "bar") <$> [t| Int# -> Int# |];
+         dec3 <- fi CApi Unsafe "baz" (mkName "baz")
+                 <$> [t| Double -> IO () |];
+         dec4 <- fi StdCall Safe "bay" (mkName "bay")
+                 <$> [t| (Int -> Bool) -> IO Int |];
+         dec5 <- fi JavaScript Unsafe "bax" (mkName "bax")
+                 <$> [t| Ptr Int -> IO String |];
+         runIO
+         $ mapM_ (putStrLn . pprint) [dec1, dec2, dec3, dec4, dec5]
+           >> hFlush stdout;
+         return [dec1, dec2] }
+  ======>
+    TH_foreignCallingConventions.hs:(13,4)-(23,25)
+    foreign import ccall interruptible "static &foo" foo :: Ptr ()
+    foreign import prim safe "static bar" bar :: Int# -> Int#
index 90efcbd..43eb438 100644 (file)
@@ -161,6 +161,9 @@ test('T3177a', normal, compile_fail, ['-v0'])
 
 test('T3319', normal, compile, ['-ddump-splices -v0'])
 test('TH_foreignInterruptible', normal, compile, ['-ddump-splices -v0'])
+test('TH_foreignCallingConventions', normal,
+                                     compile,
+                                     ['-ddump-splices -dsuppress-uniques -v0'])
 
 test('T3395', normal, compile_fail, ['-v0'])
 test('T3467', normal, compile, [''])