Commit 4cd008b6 authored by Luite Stegeman's avatar Luite Stegeman Committed by Ben Gamari

Do not treat prim and javascript imports as C imports in TH and QQ

Reviewers: austin, hvr, goldfire, bgamari

Reviewed By: bgamari

Subscribers: thomie

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

GHC Trac Issues: #10638
parent c526e095
...@@ -489,12 +489,14 @@ repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _))) ...@@ -489,12 +489,14 @@ repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _)))
conv_cimportspec (CFunction (StaticTarget _ _ _ False)) conv_cimportspec (CFunction (StaticTarget _ _ _ False))
= panic "conv_cimportspec: values not supported yet" = panic "conv_cimportspec: values not supported yet"
conv_cimportspec CWrapper = return "wrapper" conv_cimportspec CWrapper = return "wrapper"
-- these calling conventions do not support headers and the static keyword
raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv
static = case cis of static = case cis of
CFunction (StaticTarget _ _ _ _) -> "static " CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
_ -> "" _ -> ""
chStr = case mch of chStr = case mch of
Nothing -> "" Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
Just (Header _ h) -> unpackFS h ++ " " _ -> ""
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)
......
...@@ -473,16 +473,25 @@ noExistentials = [] ...@@ -473,16 +473,25 @@ noExistentials = []
cvtForD :: Foreign -> CvtM (ForeignDecl RdrName) cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
cvtForD (ImportF callconv safety from nm ty) cvtForD (ImportF callconv safety from nm ty)
-- the prim and javascript calling conventions do not support headers
-- and are inserted verbatim, analogous to mkImport in RdrHsSyn
| callconv == TH.Prim || callconv == TH.JavaScript
= mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing
(CFunction (StaticTarget from (mkFastString from) Nothing
True))
(noLoc from))
| Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety') | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')
(mkFastString (TH.nameBase nm)) (mkFastString (TH.nameBase nm))
from (noLoc from) from (noLoc from)
= do { nm' <- vNameL nm = mk_imp impspec
; ty' <- cvtType ty
; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
}
| otherwise | otherwise
= failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent") = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent")
where where
mk_imp impspec
= do { nm' <- vNameL nm
; ty' <- cvtType ty
; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
}
safety' = case safety of safety' = case safety of
Unsafe -> PlayRisky Unsafe -> PlayRisky
Safe -> PlaySafe Safe -> PlaySafe
......
{-# LANGUAGE GHCForeignImportPrim, UnliftedFFITypes, QuasiQuotes, MagicHash #-}
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import GHC.Exts
{-
the prim and javascript calling conventions do not support
headers and the static keyword.
-}
-- check that quasiquoting roundtrips succesfully and that the declaration
-- does not include the static keyword
test1 :: String
test1 = $(do (ds@[ForeignD (ImportF _ _ p _ _)]) <-
[d| foreign import prim "test1" cmm_test1 :: Int# -> Int# |]
addTopDecls ds
case p of
"test1" -> return (LitE . stringL $ p)
_ -> error $ "unexpected value: " ++ show p
)
-- check that constructed prim imports with the static keyword are rejected
test2 :: String
test2 = $(do t <- [t| Int# -> Int# |]
cmm_test2 <- newName "cmm_test2"
addTopDecls
[ForeignD (ImportF Prim Safe "static test2" cmm_test2 t)]
[| test1 |]
)
T10638.hs:26:11:
‘static test2’ is not a valid C identifier
When checking declaration:
foreign import prim safe "static static test2" cmm_test2
:: Int# -> Int#
...@@ -346,3 +346,4 @@ test('T10279', normal, compile_fail, ['-v0']) ...@@ -346,3 +346,4 @@ test('T10279', normal, compile_fail, ['-v0'])
test('T10306', normal, compile, ['-v0']) test('T10306', normal, compile, ['-v0'])
test('T10596', normal, compile, ['-v0']) test('T10596', normal, compile, ['-v0'])
test('T10620', normal, compile_and_run, ['-v0']) test('T10620', normal, compile_and_run, ['-v0'])
test('T10638', normal, compile_fail, ['-v0'])
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