Refactor PackageTarget back into StaticTarget

parent 172b8549
......@@ -78,16 +78,9 @@ emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
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
......
......@@ -56,11 +56,17 @@ 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 ->
(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
......
......@@ -129,7 +129,7 @@ make_exp (Var v) = do
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))
......
......@@ -91,7 +91,7 @@ dsCCall lbl args may_gc result_ty
(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)
......
......@@ -338,10 +338,10 @@ repForD (L loc (ForeignImport name typ (CImport cc s ch 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 _)) = 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)
......
......@@ -1029,20 +1029,7 @@ generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
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
......
......@@ -940,9 +940,7 @@ 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 (PackageTarget lbl _)) =
pprCEntity (CFunction (StaticTarget lbl _)) =
ptext (sLit "static") <+> pp_hdr <+> ppr lbl
pprCEntity (CFunction (DynamicTarget)) =
ptext (sLit "dynamic")
......
......@@ -277,7 +277,7 @@ exp :: { IfaceExpr }
-- "InlineMe" -> IfaceNote IfaceInlineMe $3
-- }
| '%external' STRING aty { IfaceFCall (ForeignCall.CCall
(CCallSpec (StaticTarget (mkFastString $2))
(CCallSpec (StaticTarget (mkFastString $2) Nothing)
CCallConv (PlaySafe False)))
$3 }
......
......@@ -985,7 +985,7 @@ mkImport :: CCallConv
-> 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))
......@@ -1023,7 +1023,7 @@ parseCImport cconv safety nm str =
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 == '_')
......
......@@ -103,17 +103,23 @@ The call target:
\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 !-}
......@@ -197,17 +203,14 @@ instance Outputable CCallSpec where
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}
......@@ -257,24 +260,19 @@ instance Binary CCallSpec where
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
......
......@@ -412,8 +412,8 @@ patchCImportSpec packageId spec
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
......
......@@ -534,7 +534,7 @@ coreToStgApp _ f args = do
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
......
......@@ -162,11 +162,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar
-- 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)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment