where
(call_args, cmm_target)
= case target of
-
- -- A target label known to be in the current package.
- StaticTarget lbl
- -> ( args
- , CmmLit (CmmLabel
- (mkForeignLabel lbl call_size ForeignLabelInThisPackage IsFunction)))
-
-- If the packageId is Nothing then the label is taken to be in the
-- package currently being compiled.
- PackageTarget lbl mPkgId
+ StaticTarget lbl mPkgId
-> let labelSource
= case mPkgId of
Nothing -> ForeignLabelInThisPackage
= do { cmm_args <- getFCallArgs stg_args
; let ((call_args, arg_hints), cmm_target)
= case target of
- StaticTarget lbl ->
- (unzip cmm_args,
- CmmLit (CmmLabel (mkForeignLabel lbl (call_size cmm_args)
- ForeignLabelInThisPackage IsFunction)))
- DynamicTarget -> case cmm_args of
+ StaticTarget lbl mPkgId
+ -> let labelSource
+ = case mPkgId of
+ Nothing -> ForeignLabelInThisPackage
+ Just pkgId -> ForeignLabelInPackage pkgId
+ size = call_size cmm_args
+ in ( unzip cmm_args
+ , CmmLit (CmmLabel
+ (mkForeignLabel lbl size labelSource IsFunction)))
+
+ DynamicTarget -> case cmm_args of
(fn,_):rest -> (unzip rest, fn)
[] -> panic "cgForeignCall []"
fc = ForeignConvention cconv arg_hints result_hints
isLocal <- isALocal vName
return $
case idDetails v of
- FCallId (CCall (CCallSpec (StaticTarget nm) callconv _))
+ FCallId (CCall (CCallSpec (StaticTarget nm _) callconv _))
-> C.External (unpackFS nm) (showSDoc (ppr callconv)) (make_ty (varType v))
FCallId (CCall (CCallSpec DynamicTarget callconv _))
-> C.DynExternal (showSDoc (ppr callconv)) (make_ty (varType v))
(ccall_result_ty, res_wrapper) <- boxResult result_ty
uniq <- newUnique
let
- target = StaticTarget lbl
+ target = StaticTarget lbl Nothing
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)
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 _)) = return (unpackFS fs)
conv_cimportspec CWrapper = return "wrapper"
static = case cis of
- CFunction (StaticTarget _) -> "static "
+ CFunction (StaticTarget _ _) -> "static "
_ -> ""
repForD decl = notHandled "Foreign declaration" (ppr decl)
DynamicTarget
-> return (False, panic "ByteCodeGen.generateCCall(dyn)")
- PackageTarget target _
- -> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
- return (True, res)
- where
- stdcall_adj_target
-#ifdef mingw32_TARGET_OS
- | StdCallConv <- cconv
- = let size = fromIntegral a_reps_sizeW * wORD_SIZE in
- mkFastString (unpackFS target ++ '@':show size)
-#endif
- | otherwise
- = target
-
- StaticTarget target
+ StaticTarget target _
-> do res <- ioToBc (lookupStaticPtr stdcall_adj_target)
return (True, res)
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 (PackageTarget lbl _)) =
+ pprCEntity (CFunction (StaticTarget lbl _)) =
ptext (sLit "static") <+> pp_hdr <+> ppr lbl
pprCEntity (CFunction (DynamicTarget)) =
ptext (sLit "dynamic")
-- "InlineMe" -> IfaceNote IfaceInlineMe $3
-- }
| '%external' STRING aty { IfaceFCall (ForeignCall.CCall
- (CCallSpec (StaticTarget (mkFastString $2))
+ (CCallSpec (StaticTarget (mkFastString $2) Nothing)
CCallConv (PlaySafe False)))
$3 }
-> P (HsDecl RdrName)
mkImport cconv safety (L loc entity, v, ty)
| cconv == PrimCallConv = do
- let funcTarget = CFunction (PackageTarget entity Nothing)
+ let funcTarget = CFunction (StaticTarget entity Nothing)
importSpec = CImport PrimCallConv safety nilFS funcTarget
return (ForD (ForeignImport v ty importSpec))
id_char c = isAlphaNum c || c == '_'
cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)
- +++ ((\c -> CFunction (PackageTarget c Nothing)) <$> cid)
+ +++ ((\c -> CFunction (StaticTarget c Nothing)) <$> cid)
where
cid = return nm +++
(do c <- satisfy (\c -> isAlpha c || c == '_')
\begin{code}
--- | How to call a particular function in C land.
+-- | How to call a particular function in C-land.
data CCallTarget
- -- An "unboxed" ccall# to named function
- = StaticTarget CLabelString
+ -- An "unboxed" ccall# to named function in a particular package.
+ = StaticTarget
+ CLabelString -- C-land name of label.
+
+ (Maybe PackageId) -- What package the function is in.
+ -- If Nothing, then it's taken to be in the current package.
+ -- Note: This information is only used for PrimCalls on Windows.
+ -- See CLabel.labelDynamic and CoreToStg.coreToStgApp
+ -- for the difference in representation between PrimCalls
+ -- and ForeignCalls. If the CCallTarget is representing
+ -- a regular ForeignCall then it's safe to set this to Nothing.
-- 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" ..."
| DynamicTarget
-
- -- An "unboxed" ccall# to a named function from a particular package.
- | PackageTarget CLabelString (Maybe PackageId)
deriving( Eq )
{-! derive: Binary !-}
gc_suf | playSafe safety = text "_GC"
| otherwise = empty
- ppr_fun DynamicTarget
- = text "__dyn_ccall" <> gc_suf <+> text "\"\""
-
- ppr_fun (PackageTarget fn Nothing)
+ ppr_fun (StaticTarget fn Nothing)
= text "__pkg_ccall" <> gc_suf <+> pprCLabelString fn
- ppr_fun (PackageTarget fn (Just pkgId))
+ ppr_fun (StaticTarget fn (Just pkgId))
= text "__pkg_ccall" <> gc_suf <+> ppr pkgId <+> pprCLabelString fn
- ppr_fun (StaticTarget fn)
- = text "__ccall" <> gc_suf <+> pprCLabelString fn
+ ppr_fun DynamicTarget
+ = text "__dyn_ccall" <> gc_suf <+> text "\"\""
\end{code}
return (CCallSpec aa ab ac)
instance Binary CCallTarget where
- put_ bh (StaticTarget aa) = do
+ put_ bh (StaticTarget aa ab) = do
putByte bh 0
put_ bh aa
+ put_ bh ab
put_ bh DynamicTarget = do
putByte bh 1
- put_ bh (PackageTarget aa ab) = do
- putByte bh 2
- put_ bh aa
- put_ bh ab
get bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
- return (StaticTarget aa)
- 1 -> do return DynamicTarget
- _ -> do aa <- get bh
- ab <- get bh
- return (PackageTarget aa ab)
+ ab <- get bh
+ return (StaticTarget aa ab)
+ _ -> do return DynamicTarget
instance Binary CCallConv where
put_ bh CCallConv = do
patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget
patchCCallTarget packageId callTarget
= case callTarget of
- PackageTarget label Nothing
- -> PackageTarget label (Just packageId)
+ StaticTarget label Nothing
+ -> StaticTarget label (Just packageId)
_ -> callTarget
StgOpApp (StgPrimOp op) args' res_ty
-- A call to some primitive Cmm function.
- FCallId (CCall (CCallSpec (PackageTarget lbl (Just pkgId)) PrimCallConv _))
+ FCallId (CCall (CCallSpec (StaticTarget lbl (Just pkgId)) PrimCallConv _))
-> ASSERT( saturated )
StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty
-- This makes a convenient place to check
-- that the C identifier is valid for C
checkCTarget :: CCallTarget -> TcM ()
-checkCTarget (StaticTarget str) = do
- checkCg checkCOrAsmOrDotNetOrInterp
- check (isCLabelString str) (badCName str)
-
-checkCTarget (PackageTarget str _) = do
+checkCTarget (StaticTarget str _) = do
checkCg checkCOrAsmOrDotNetOrInterp
check (isCLabelString str) (badCName str)