diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 8 | ||||
| -rw-r--r-- | compiler/hsSyn/Convert.hs | 17 |
2 files changed, 18 insertions, 7 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index d9dc02f82b..d4a811ff1b 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 7245a1d676..4a0e013cf9 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 |