[commit: ghc] master: Do not treat prim and javascript imports as C imports in TH and QQ (4cd008b)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/4cd008b6c1751c5533ab7eac32d17c9749e4758e/ghc

>---------------------------------------------------------------

commit 4cd008b6c1751c5533ab7eac32d17c9749e4758e
Author: Luite Stegeman <stegeman at gmail.com>
Date:   Mon Jul 20 17:01:06 2015 +0200

    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


>---------------------------------------------------------------

4cd008b6c1751c5533ab7eac32d17c9749e4758e
 compiler/deSugar/DsMeta.hs       |  8 +++++---
 compiler/hsSyn/Convert.hs        | 17 +++++++++++++----
 testsuite/tests/th/T10638.hs     | 31 +++++++++++++++++++++++++++++++
 testsuite/tests/th/T10638.stderr |  6 ++++++
 testsuite/tests/th/all.T         |  1 +
 5 files changed, 56 insertions(+), 7 deletions(-)

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index d9dc02f..d4a811f 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -489,12 +489,14 @@ repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _)))
     conv_cimportspec (CFunction (StaticTarget _ _  _ False))
                             = panic "conv_cimportspec: values not supported yet"
     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
-                 CFunction (StaticTarget _ _ _ _) -> "static "
+                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "
                  _ -> ""
     chStr = case mch of
-            Nothing -> ""
-            Just (Header _ h) -> unpackFS h ++ " "
+            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "
+            _ -> ""
 repForD decl = notHandled "Foreign declaration" (ppr decl)
 
 repCCallConv :: CCallConv -> DsM (Core TH.Callconv)
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 7245a1d..4a0e013 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -473,16 +473,25 @@ noExistentials = []
 
 cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
 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')
                                  (mkFastString (TH.nameBase nm))
                                  from (noLoc from)
-  = do { nm' <- vNameL nm
-       ; ty' <- cvtType ty
-       ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
-       }
+  = mk_imp impspec
   | otherwise
   = failWith $ text (show from) <+> ptext (sLit "is not a valid ccall impent")
   where
+    mk_imp impspec
+      = do { nm' <- vNameL nm
+           ; ty' <- cvtType ty
+           ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec)
+           }
     safety' = case safety of
                      Unsafe     -> PlayRisky
                      Safe       -> PlaySafe
diff --git a/testsuite/tests/th/T10638.hs b/testsuite/tests/th/T10638.hs
new file mode 100644
index 0000000..7dd17eb
--- /dev/null
+++ b/testsuite/tests/th/T10638.hs
@@ -0,0 +1,31 @@
+{-# 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 |]
+         )
diff --git a/testsuite/tests/th/T10638.stderr b/testsuite/tests/th/T10638.stderr
new file mode 100644
index 0000000..3a626ce
--- /dev/null
+++ b/testsuite/tests/th/T10638.stderr
@@ -0,0 +1,6 @@
+
+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#
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 55627f0..9e8f92d 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -346,3 +346,4 @@ test('T10279', normal, compile_fail, ['-v0'])
 test('T10306', normal, compile, ['-v0'])
 test('T10596', normal, compile, ['-v0'])
 test('T10620', normal, compile_and_run, ['-v0'])
+test('T10638', normal, compile_fail, ['-v0'])