From 98587f0c34b15ed307a9a6f8ebc50fb5339b4042 Mon Sep 17 00:00:00 2001
From: Ben Gamari <ben@smart-cactus.org>
Date: Wed, 15 Jul 2015 10:19:33 +0200
Subject: [PATCH] Do not treat prim and javascript imports as C imports in TH
and QQ
This fixes trac Trac #10638.
---
compiler/deSugar/DsMeta.hs | 8 +++++---
compiler/hsSyn/Convert.hs | 14 ++++++++++----
2 files changed, 15 insertions(+), 7 deletions(-)
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 63b65398eb64..6eeba5eb18e8 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -491,12 +491,14 @@ repForD (L loc (ForeignImport name typ _ (CImport (L _ cc) (L _ s) mch cis _)))
conv_cimportspec (CFunction (StaticTarget fs _ True)) = return (unpackFS fs)
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 03c9bf5024b0..8ffda3a91e66 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -476,16 +476,22 @@ noExistentials = []
cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
cvtForD (ImportF callconv safety from nm ty)
+ | callconv == TH.Prim || callconv == TH.JavaScript
+ = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing
+ (CFunction (StaticTarget (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
--
GitLab