import CoreUtils ( exprType, mkInlineMe )
import Id ( Id, idType, idName, mkSysLocal, setInlinePragma )
import Literal ( Literal(..), mkStringLit )
-import Module ( moduleString )
+import Module ( moduleFS )
import Name ( getOccString, NamedThing(..) )
-import OccName ( encodeFS )
import Type ( repType, coreEqType )
import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp,
mkFunTy, tcSplitTyConApp_maybe,
dsForeigns fos
= foldlDs combine (ForeignStubs empty empty [] [], []) fos
where
- combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
- (L loc (ForeignImport id _ spec depr))
+ combine stubs (L loc decl) = putSrcSpanDs loc (combine1 stubs decl)
+
+ combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
+ (ForeignImport id _ spec depr)
= traceIf (text "fi start" <+> ppr id) `thenDs` \ _ ->
dsFImport (unLoc id) spec `thenDs` \ (bs, h, c, mbhd) ->
- warnDepr depr loc `thenDs` \ _ ->
+ warnDepr depr `thenDs` \ _ ->
traceIf (text "fi end" <+> ppr id) `thenDs` \ _ ->
returnDs (ForeignStubs (h $$ acc_h)
(c $$ acc_c)
acc_feb,
bs ++ acc_f)
- combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
- (L loc (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr))
+ combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
+ (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr)
= dsFExport id (idType id)
ext_nm cconv False `thenDs` \(h, c, _, _) ->
- warnDepr depr loc `thenDs` \_ ->
+ warnDepr depr `thenDs` \_ ->
returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb),
acc_f)
| e `elem` ls = ls
| otherwise = e:ls
- warnDepr False _ = returnDs ()
- warnDepr True loc = dsWarn (loc, msg)
+ warnDepr False = returnDs ()
+ warnDepr True = dsWarn msg
where
msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
\end{code}
= dsCImport id spec cconv safety no_hdrs `thenDs` \(ids, h, c) ->
returnDs (ids, h, c, if no_hdrs then Nothing else Just header)
where
- no_hdrs = nullFastString header
+ no_hdrs = nullFS header
-- FIXME: the `lib' field is needed for .NET ILX generation when invoking
-- routines that are external to the .NET runtime, but GHC doesn't
let
work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars
- -- These are the ids we pass to boxResult, which are used to decide
- -- whether to touch# an argument after the call (used to keep
- -- ForeignObj#s live across a 'safe' foreign import).
- maybe_arg_ids | unsafe_call fcall = work_arg_ids
- | otherwise = []
-
forDotnet =
case fcall of
DNCall{} -> True
in
augmentResultDs `thenDs` \ augment ->
topConDs `thenDs` \ topCon ->
- boxResult maybe_arg_ids augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
+ boxResult augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
newUnique `thenDs` \ ccall_uniq ->
newUnique `thenDs` \ work_uniq ->
the_ccall_app = mkFCall ccall_uniq fcall val_args ccall_result_ty
work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
work_id = setImpInline no_hdrs $ -- See comments with setImpInline
- mkSysLocal (encodeFS FSLIT("$wccall")) work_uniq worker_ty
+ mkSysLocal FSLIT("$wccall") work_uniq worker_ty
-- Build the wrapper
work_app = mkApps (mkVarApps (Var work_id) tvs) val_args
getModuleDs `thenDs` \ mod_name ->
let
-- hack: need to get at the name of the C stub we're about to generate.
- fe_nm = mkFastString (moduleString mod_name ++ "_" ++ toCName fe_id)
+ fe_nm = mkFastString (unpackFS (zEncodeFS (moduleFS mod_name)) ++ "_" ++ toCName fe_id)
in
newSysLocalDs arg_ty `thenDs` \ cback ->
dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId ->
Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
+ cap = text "cap" <> comma
+
-- the expression we give to rts_evalIO
expr_to_run
= foldl appArg the_cfun arg_info -- NOT aug_arg_info
where
appArg acc (arg_cname, _, arg_hty, _)
= text "rts_apply"
- <> parens (acc <> comma <> mkHObj arg_hty <> parens arg_cname)
+ <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
-- various other bits for inside the fn
declareResult = text "HaskellObj ret;"
Nothing -> empty
Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
+
+ -- Initialise foreign exports by registering a stable pointer from an
+ -- __attribute__((constructor)) function.
+ -- The alternative is to do this from stginit functions generated in
+ -- codeGen/CodeGen.lhs; however, stginit functions have a negative impact
+ -- on binary sizes and link times because the static linker will think that
+ -- all modules that are imported directly or indirectly are actually used by
+ -- the program.
+ -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
+
+ initialiser
+ = case maybe_target of
+ Nothing -> empty
+ Just hs_fn ->
+ vcat
+ [ text "static void stginit_export_" <> ppr hs_fn
+ <> text "() __attribute__((constructor));"
+ , text "static void stginit_export_" <> ppr hs_fn <> text "()"
+ , braces (text "getStablePtr"
+ <> parens (text "(StgPtr) &" <> ppr hs_fn <> text "_closure")
+ <> semi)
+ ]
+
-- finally, the whole darn thing
c_bits =
space $$
fun_proto $$
vcat
[ lbrace
- , text "SchedulerStatus rc;"
+ , text "Capability *cap;"
, declareResult
, declareCResult
- , text "rts_lock();"
+ , text "cap = rts_lock();"
-- create the application + perform it.
- , text "rc=rts_evalIO" <> parens (
+ , text "cap=rts_evalIO" <> parens (
+ cap <>
text "rts_apply" <> parens (
+ cap <>
text "(HaskellObj)"
<> text (if is_IO_res_ty
then "runIO_closure"
<> text "&ret"
) <> semi
, text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
- <> comma <> text "rc") <> semi
+ <> comma <> text "cap") <> semi
, assignCResult
- , text "rts_unlock();"
+ , text "rts_unlock(cap);"
, if res_hty_is_unit then empty
else text "return cret;"
, rbrace
- ]
+ ] $$
+ initialiser
-- NB. the calculation here isn't strictly speaking correct.
-- We have a primitive Haskell type (eg. Int#, Double#), and
projects / ghc-hetmet.git / blobdiff