Commit c6e12e69 authored by Luite Stegeman's avatar Luite Stegeman Committed by Austin Seipp

Make calling conventions in template haskell Syntax.hs consistent with those in ghc ForeignCall.hs

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
parent bc2289e1
...@@ -488,9 +488,11 @@ repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis))) ...@@ -488,9 +488,11 @@ repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
repForD decl = notHandled "Foreign declaration" (ppr decl) repForD decl = notHandled "Foreign declaration" (ppr decl)
repCCallConv :: CCallConv -> DsM (Core TH.Callconv) repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
repCCallConv CCallConv = rep2 cCallName [] repCCallConv CCallConv = rep2 cCallName []
repCCallConv StdCallConv = rep2 stdCallName [] repCCallConv StdCallConv = rep2 stdCallName []
repCCallConv callConv = notHandled "repCCallConv" (ppr callConv) repCCallConv CApiConv = rep2 cApiCallName []
repCCallConv PrimCallConv = rep2 primCallName []
repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []
repSafety :: Safety -> DsM (Core TH.Safety) repSafety :: Safety -> DsM (Core TH.Safety)
repSafety PlayRisky = rep2 unsafeName [] repSafety PlayRisky = rep2 unsafeName []
...@@ -2147,7 +2149,7 @@ templateHaskellNames = [ ...@@ -2147,7 +2149,7 @@ templateHaskellNames = [
varKName, conKName, tupleKName, arrowKName, listKName, appKName, varKName, conKName, tupleKName, arrowKName, listKName, appKName,
starKName, constraintKName, starKName, constraintKName,
-- Callconv -- Callconv
cCallName, stdCallName, cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName,
-- Safety -- Safety
unsafeName, unsafeName,
safeName, safeName,
...@@ -2456,9 +2458,12 @@ starKName = libFun (fsLit "starK") starKIdKey ...@@ -2456,9 +2458,12 @@ starKName = libFun (fsLit "starK") starKIdKey
constraintKName = libFun (fsLit "constraintK") constraintKIdKey constraintKName = libFun (fsLit "constraintK") constraintKIdKey
-- data Callconv = ... -- data Callconv = ...
cCallName, stdCallName :: Name cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name
cCallName = libFun (fsLit "cCall") cCallIdKey cCallName = libFun (fsLit "cCall") cCallIdKey
stdCallName = libFun (fsLit "stdCall") stdCallIdKey stdCallName = libFun (fsLit "stdCall") stdCallIdKey
cApiCallName = libFun (fsLit "cApi") cApiCallIdKey
primCallName = libFun (fsLit "prim") primCallIdKey
javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey
-- data Safety = ... -- data Safety = ...
unsafeName, safeName, interruptibleName :: Name unsafeName, safeName, interruptibleName :: Name
...@@ -2819,15 +2824,19 @@ starKIdKey = mkPreludeMiscIdUnique 410 ...@@ -2819,15 +2824,19 @@ starKIdKey = mkPreludeMiscIdUnique 410
constraintKIdKey = mkPreludeMiscIdUnique 411 constraintKIdKey = mkPreludeMiscIdUnique 411
-- data Callconv = ... -- data Callconv = ...
cCallIdKey, stdCallIdKey :: Unique cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey,
cCallIdKey = mkPreludeMiscIdUnique 412 javaScriptCallIdKey :: Unique
stdCallIdKey = mkPreludeMiscIdUnique 413 cCallIdKey = mkPreludeMiscIdUnique 420
stdCallIdKey = mkPreludeMiscIdUnique 421
cApiCallIdKey = mkPreludeMiscIdUnique 422
primCallIdKey = mkPreludeMiscIdUnique 423
javaScriptCallIdKey = mkPreludeMiscIdUnique 424
-- data Safety = ... -- data Safety = ...
unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
unsafeIdKey = mkPreludeMiscIdUnique 414 unsafeIdKey = mkPreludeMiscIdUnique 430
safeIdKey = mkPreludeMiscIdUnique 415 safeIdKey = mkPreludeMiscIdUnique 431
interruptibleIdKey = mkPreludeMiscIdUnique 416 interruptibleIdKey = mkPreludeMiscIdUnique 432
-- data Inline = ... -- data Inline = ...
noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
...@@ -2852,31 +2861,31 @@ tExpDataConKey = mkPreludeDataConUnique 48 ...@@ -2852,31 +2861,31 @@ tExpDataConKey = mkPreludeDataConUnique 48
-- data FunDep = ... -- data FunDep = ...
funDepIdKey :: Unique funDepIdKey :: Unique
funDepIdKey = mkPreludeMiscIdUnique 419 funDepIdKey = mkPreludeMiscIdUnique 440
-- data FamFlavour = ... -- data FamFlavour = ...
typeFamIdKey, dataFamIdKey :: Unique typeFamIdKey, dataFamIdKey :: Unique
typeFamIdKey = mkPreludeMiscIdUnique 420 typeFamIdKey = mkPreludeMiscIdUnique 450
dataFamIdKey = mkPreludeMiscIdUnique 421 dataFamIdKey = mkPreludeMiscIdUnique 451
-- data TySynEqn = ... -- data TySynEqn = ...
tySynEqnIdKey :: Unique tySynEqnIdKey :: Unique
tySynEqnIdKey = mkPreludeMiscIdUnique 422 tySynEqnIdKey = mkPreludeMiscIdUnique 460
-- quasiquoting -- quasiquoting
quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique
quoteExpKey = mkPreludeMiscIdUnique 423 quoteExpKey = mkPreludeMiscIdUnique 470
quotePatKey = mkPreludeMiscIdUnique 424 quotePatKey = mkPreludeMiscIdUnique 471
quoteDecKey = mkPreludeMiscIdUnique 425 quoteDecKey = mkPreludeMiscIdUnique 472
quoteTypeKey = mkPreludeMiscIdUnique 426 quoteTypeKey = mkPreludeMiscIdUnique 473
-- data RuleBndr = ... -- data RuleBndr = ...
ruleVarIdKey, typedRuleVarIdKey :: Unique ruleVarIdKey, typedRuleVarIdKey :: Unique
ruleVarIdKey = mkPreludeMiscIdUnique 427 ruleVarIdKey = mkPreludeMiscIdUnique 480
typedRuleVarIdKey = mkPreludeMiscIdUnique 428 typedRuleVarIdKey = mkPreludeMiscIdUnique 481
-- data AnnTarget = ... -- data AnnTarget = ...
valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique
valueAnnotationIdKey = mkPreludeMiscIdUnique 429 valueAnnotationIdKey = mkPreludeMiscIdUnique 490
typeAnnotationIdKey = mkPreludeMiscIdUnique 430 typeAnnotationIdKey = mkPreludeMiscIdUnique 491
moduleAnnotationIdKey = mkPreludeMiscIdUnique 431 moduleAnnotationIdKey = mkPreludeMiscIdUnique 492
...@@ -483,8 +483,11 @@ cvtForD (ExportF callconv as nm ty) ...@@ -483,8 +483,11 @@ cvtForD (ExportF callconv as nm ty)
; return $ ForeignExport nm' ty' noForeignExportCoercionYet e } ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e }
cvt_conv :: TH.Callconv -> CCallConv cvt_conv :: TH.Callconv -> CCallConv
cvt_conv TH.CCall = CCallConv cvt_conv TH.CCall = CCallConv
cvt_conv TH.StdCall = StdCallConv cvt_conv TH.StdCall = StdCallConv
cvt_conv TH.CApi = CApiConv
cvt_conv TH.Prim = PrimCallConv
cvt_conv TH.JavaScript = JavaScriptCallConv
------------------------------------------ ------------------------------------------
-- Pragmas -- Pragmas
......
...@@ -156,6 +156,7 @@ platforms. ...@@ -156,6 +156,7 @@ platforms.
See: http://www.programmersheaven.com/2/Calling-conventions See: http://www.programmersheaven.com/2/Calling-conventions
\begin{code} \begin{code}
-- any changes here should be replicated in the CallConv type in template haskell
data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv
deriving (Eq, Data, Typeable) deriving (Eq, Data, Typeable)
{-! derive: Binary !-} {-! derive: Binary !-}
......
...@@ -133,7 +133,8 @@ module Language.Haskell.TH( ...@@ -133,7 +133,8 @@ module Language.Haskell.TH(
newtypeInstD, tySynInstD, newtypeInstD, tySynInstD,
typeFam, dataFam, tySynEqn, typeFam, dataFam, tySynEqn,
-- **** Foreign Function Interface (FFI) -- **** Foreign Function Interface (FFI)
cCall, stdCall, unsafe, safe, forImpD, cCall, stdCall, cApi, prim, javaScript,
unsafe, safe, forImpD,
-- **** Pragmas -- **** Pragmas
ruleVar, typedRuleVar, ruleVar, typedRuleVar,
pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD, pragInlD, pragSpecD, pragSpecInlD, pragSpecInstD, pragRuleD, pragAnnD,
......
...@@ -638,9 +638,12 @@ inferR = InferR ...@@ -638,9 +638,12 @@ inferR = InferR
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- * Callconv -- * Callconv
cCall, stdCall :: Callconv cCall, stdCall, cApi, prim, javaScript :: Callconv
cCall = CCall cCall = CCall
stdCall = StdCall stdCall = StdCall
cApi = CApi
prim = Prim
javaScript = JavaScript
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- * Safety -- * Safety
......
...@@ -1250,7 +1250,8 @@ data Foreign = ImportF Callconv Safety String Name Type ...@@ -1250,7 +1250,8 @@ data Foreign = ImportF Callconv Safety String Name Type
| ExportF Callconv String Name Type | ExportF Callconv String Name Type
deriving( Show, Eq, Data, Typeable, Generic ) 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 ) deriving( Show, Eq, Data, Typeable, Generic )
data Safety = Unsafe | Safe | Interruptible data Safety = Unsafe | Safe | Interruptible
......
{-# 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]
)
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#
...@@ -161,6 +161,9 @@ test('T3177a', normal, compile_fail, ['-v0']) ...@@ -161,6 +161,9 @@ test('T3177a', normal, compile_fail, ['-v0'])
test('T3319', normal, compile, ['-ddump-splices -v0']) test('T3319', normal, compile, ['-ddump-splices -v0'])
test('TH_foreignInterruptible', 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('T3395', normal, compile_fail, ['-v0'])
test('T3467', normal, compile, ['']) test('T3467', normal, compile, [''])
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment