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
......@@ -490,7 +490,9 @@ 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 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
......@@ -485,6 +485,9 @@ cvtForD (ExportF callconv as nm ty)
cvt_conv :: TH.Callconv -> CCallConv
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
......
......@@ -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 !-}
......
......@@ -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,
......
......@@ -638,9 +638,12 @@ inferR = InferR
-------------------------------------------------------------------------------
-- * Callconv
cCall, stdCall :: Callconv
cCall, stdCall, cApi, prim, javaScript :: Callconv
cCall = CCall
stdCall = StdCall
cApi = CApi
prim = Prim
javaScript = JavaScript
-------------------------------------------------------------------------------
-- * Safety
......
......@@ -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
......
{-# 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'])
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, [''])
......
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