summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/codeGen/CgForeignCall.hs4
-rw-r--r--compiler/codeGen/StgCmmForeign.hs4
-rw-r--r--compiler/coreSyn/MkExternalCore.lhs4
-rw-r--r--compiler/deSugar/DsCCall.lhs2
-rw-r--r--compiler/deSugar/DsForeign.lhs10
-rw-r--r--compiler/deSugar/DsMeta.hs5
-rw-r--r--compiler/ghci/ByteCodeGen.lhs4
-rw-r--r--compiler/hsSyn/HsDecls.lhs7
-rw-r--r--compiler/parser/ParserCore.y2
-rw-r--r--compiler/parser/RdrHsSyn.lhs20
-rw-r--r--compiler/prelude/ForeignCall.lhs22
-rw-r--r--compiler/rename/RnSource.lhs4
-rw-r--r--compiler/stgSyn/CoreToStg.lhs2
-rw-r--r--compiler/typecheck/TcForeign.lhs7
14 files changed, 68 insertions, 29 deletions
diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs
index 09636bc6b2..16e77eca35 100644
--- a/compiler/codeGen/CgForeignCall.hs
+++ b/compiler/codeGen/CgForeignCall.hs
@@ -78,9 +78,11 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
where
(call_args, cmm_target)
= case target of
+ StaticTarget _ _ False ->
+ panic "emitForeignCall: unexpected FFI value import"
-- If the packageId is Nothing then the label is taken to be in the
-- package currently being compiled.
- StaticTarget lbl mPkgId
+ StaticTarget lbl mPkgId True
-> let labelSource
= case mPkgId of
Nothing -> ForeignLabelInThisPackage
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index af88ba848a..c41832a0ab 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -56,7 +56,9 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a
= do { cmm_args <- getFCallArgs stg_args
; let ((call_args, arg_hints), cmm_target)
= case target of
- StaticTarget lbl mPkgId
+ StaticTarget _ _ False ->
+ panic "cgForeignCall: unexpected FFI value import"
+ StaticTarget lbl mPkgId True
-> let labelSource
= case mPkgId of
Nothing -> ForeignLabelInThisPackage
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index cb12973a60..89c0c911d9 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -138,8 +138,10 @@ make_exp (Var v) = do
isLocal <- isALocal vName
return $
case idDetails v of
- FCallId (CCall (CCallSpec (StaticTarget nm _) callconv _))
+ FCallId (CCall (CCallSpec (StaticTarget nm _ True) callconv _))
-> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (varType v))
+ FCallId (CCall (CCallSpec (StaticTarget _ _ False) _ _)) ->
+ panic "make_exp: FFI values not supported"
FCallId (CCall (CCallSpec DynamicTarget callconv _))
-> C.DynExternal (showSDoc (ppr callconv)) (make_ty (varType v))
-- Constructors are always exported, so make sure to declare them
diff --git a/compiler/deSugar/DsCCall.lhs b/compiler/deSugar/DsCCall.lhs
index 06a41bcd1a..2fff5fdb56 100644
--- a/compiler/deSugar/DsCCall.lhs
+++ b/compiler/deSugar/DsCCall.lhs
@@ -98,7 +98,7 @@ dsCCall lbl args may_gc result_ty
(ccall_result_ty, res_wrapper) <- boxResult result_ty
uniq <- newUnique
let
- target = StaticTarget lbl Nothing
+ target = StaticTarget lbl Nothing True
the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs
index 46c4a54a5c..88caaef875 100644
--- a/compiler/deSugar/DsForeign.lhs
+++ b/compiler/deSugar/DsForeign.lhs
@@ -207,13 +207,13 @@ dsFCall fn_id co fcall mDeclHeader = do
(fcall', cDoc) <-
case fcall of
- CCall (CCallSpec (StaticTarget cName mPackageId) CApiConv safety) ->
+ CCall (CCallSpec (StaticTarget cName mPackageId isFun) CApiConv safety) ->
do fcall_uniq <- newUnique
let wrapperName = mkFastString "ghc_wrapper_" `appendFS`
mkFastString (showSDoc (ppr fcall_uniq)) `appendFS`
mkFastString "_" `appendFS`
cName
- fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId) CApiConv safety)
+ fcall' = CCall (CCallSpec (StaticTarget wrapperName mPackageId True) CApiConv safety)
c = includes
$$ fun_proto <+> braces (cRet <> semi)
includes = vcat [ text "#include <" <> ftext h <> text ">"
@@ -222,7 +222,11 @@ dsFCall fn_id co fcall mDeclHeader = do
cRet
| isVoidRes = cCall
| otherwise = text "return" <+> cCall
- cCall = ppr cName <> parens argVals
+ cCall = if isFun
+ then ppr cName <> parens argVals
+ else if null arg_tys
+ then ppr cName
+ else panic "dsFCall: Unexpected arguments to FFI value import"
raw_res_ty = case tcSplitIOType_maybe io_res_ty of
Just (_ioTyCon, res_ty) -> res_ty
Nothing -> io_res_ty
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 181a25eb4d..7daa037395 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -350,10 +350,11 @@ repForD (L loc (ForeignImport name typ _ (CImport cc s mch cis)))
where
conv_cimportspec (CLabel cls) = notHandled "Foreign label" (doubleQuotes (ppr cls))
conv_cimportspec (CFunction DynamicTarget) = return "dynamic"
- conv_cimportspec (CFunction (StaticTarget fs _)) = return (unpackFS fs)
+ 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"
static = case cis of
- CFunction (StaticTarget _ _) -> "static "
+ CFunction (StaticTarget _ _ _) -> "static "
_ -> ""
chStr = case mch of
Nothing -> ""
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index afc51163e3..046d6ec132 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -986,7 +986,9 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
DynamicTarget
-> return (False, panic "ByteCodeGen.generateCCall(dyn)")
- StaticTarget target _
+ StaticTarget _ _ False ->
+ panic "generateCCall: unexpected FFI value import"
+ StaticTarget target _ True
-> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
return (True, res)
where
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 4d8c01d196..49a5b91717 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -1024,8 +1024,11 @@ instance Outputable ForeignImport where
pprCEntity (CLabel lbl) =
ptext (sLit "static") <+> pp_hdr <+> char '&' <> ppr lbl
- pprCEntity (CFunction (StaticTarget lbl _)) =
- ptext (sLit "static") <+> pp_hdr <+> ppr lbl
+ pprCEntity (CFunction (StaticTarget lbl _ isFun)) =
+ ptext (sLit "static")
+ <+> pp_hdr
+ <+> (if isFun then empty else ptext (sLit "value"))
+ <+> ppr lbl
pprCEntity (CFunction (DynamicTarget)) =
ptext (sLit "dynamic")
pprCEntity (CWrapper) = ptext (sLit "wrapper")
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index 3a786ea04b..80d49430eb 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -278,7 +278,7 @@ exp :: { IfaceExpr }
-- "InlineMe" -> IfaceNote IfaceInlineMe $3
-- }
| '%external' STRING aty { IfaceFCall (ForeignCall.CCall
- (CCallSpec (StaticTarget (mkFastString $2) Nothing)
+ (CCallSpec (StaticTarget (mkFastString $2) Nothing True)
CCallConv PlaySafe))
$3 }
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 3ba967352f..59e6727535 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -914,7 +914,7 @@ mkImport :: CCallConv
-> P (HsDecl RdrName)
mkImport cconv safety (L loc entity, v, ty)
| cconv == PrimCallConv = do
- let funcTarget = CFunction (StaticTarget entity Nothing)
+ let funcTarget = CFunction (StaticTarget entity Nothing True)
importSpec = CImport PrimCallConv safety Nothing funcTarget
return (ForD (ForeignImport v ty noForeignImportCoercionYet importSpec))
@@ -937,9 +937,11 @@ parseCImport cconv safety nm str =
r <- choice [
string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),
string "wrapper" >> return (mk Nothing CWrapper),
- optional (token "static" >> skipSpaces) >>
- (mk Nothing <$> cimp nm) +++
- (do h <- munch1 hdr_char; skipSpaces; mk (Just (Header (mkFastString h))) <$> cimp nm)
+ do optional (token "static" >> skipSpaces)
+ ((mk Nothing <$> cimp nm) +++
+ (do h <- munch1 hdr_char
+ skipSpaces
+ mk (Just (Header (mkFastString h))) <$> cimp nm))
]
skipSpaces
return r
@@ -960,7 +962,15 @@ parseCImport cconv safety nm str =
id_char c = isAlphaNum c || c == '_'
cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
- +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
+ +++ (do isFun <- case cconv of
+ CApiConv ->
+ option True
+ (do token "value"
+ skipSpaces
+ return False)
+ _ -> return True
+ cid' <- cid
+ return (CFunction (StaticTarget cid' Nothing isFun)))
where
cid = return nm +++
(do c <- satisfy id_first_char
diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs
index b245e8314a..b3a2ad3ff1 100644
--- a/compiler/prelude/ForeignCall.lhs
+++ b/compiler/prelude/ForeignCall.lhs
@@ -127,6 +127,9 @@ data CCallTarget
-- The first argument of the import is the name of a function pointer (an Addr#).
-- Used when importing a label as "foreign import ccall "dynamic" ..."
+ Bool -- True => really a function
+ -- False => a value; only
+ -- allowed in CAPI imports
| DynamicTarget
deriving( Eq, Data, Typeable )
@@ -219,11 +222,14 @@ instance Outputable CCallSpec where
gc_suf | playSafe safety = text "_GC"
| otherwise = empty
- ppr_fun (StaticTarget fn Nothing)
- = text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn
-
- ppr_fun (StaticTarget fn (Just pkgId))
- = text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn
+ ppr_fun (StaticTarget fn mPkgId isFun)
+ = text (if isFun then "__pkg_ccall"
+ else "__pkg_ccall_value")
+ <> gc_suf
+ <+> (case mPkgId of
+ Nothing -> empty
+ Just pkgId -> ppr pkgId)
+ <+> pprCLabelString fn
ppr_fun DynamicTarget
= text "__dyn_ccall" <> gc_suf <+> text "\"\""
@@ -297,10 +303,11 @@ instance Binary CCallSpec where
return (CCallSpec aa ab ac)
instance Binary CCallTarget where
- put_ bh (StaticTarget aa ab) = do
+ put_ bh (StaticTarget aa ab ac) = do
putByte bh 0
put_ bh aa
put_ bh ab
+ put_ bh ac
put_ bh DynamicTarget = do
putByte bh 1
get bh = do
@@ -308,7 +315,8 @@ instance Binary CCallTarget where
case h of
0 -> do aa <- get bh
ab <- get bh
- return (StaticTarget aa ab)
+ ac <- get bh
+ return (StaticTarget aa ab ac)
_ -> do return DynamicTarget
instance Binary CCallConv where
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index e747b85719..1969229321 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -407,8 +407,8 @@ patchCImportSpec packageId spec
patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget
patchCCallTarget packageId callTarget
= case callTarget of
- StaticTarget label Nothing
- -> StaticTarget label (Just packageId)
+ StaticTarget label Nothing isFun
+ -> StaticTarget label (Just packageId) isFun
_ -> callTarget
diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index 98e5303b02..71bdfe97c9 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -545,7 +545,7 @@ coreToStgApp _ f args = do
StgOpApp (StgPrimOp op) args' res_ty
-- A call to some primitive Cmm function.
- FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _))
+ FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId) True) PrimCallConv _))
-> ASSERT( saturated )
StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 9fbcff62e8..ab850399c8 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -263,13 +263,18 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
checkMissingAmpersand dflags arg_tys res_ty
+ case target of
+ StaticTarget _ _ False
+ | not (null arg_tys) ->
+ addErrTc (text "`value' imports cannot have function types")
+ _ -> return ()
return idecl
-- This makes a convenient place to check
-- that the C identifier is valid for C
checkCTarget :: CCallTarget -> TcM ()
-checkCTarget (StaticTarget str _) = do
+checkCTarget (StaticTarget str _ _) = do
checkCg checkCOrAsmOrLlvmOrDotNetOrInterp
check (isCLabelString str) (badCName str)
View Lorry Controller Status