+ -- list the arguments to the C function
+ arg_info :: [(SDoc, -- arg name
+ SDoc, -- C type
+ Type, -- Haskell type
+ MachRep)] -- the MachRep
+ arg_info = [ (text ('a':show n), showStgType ty, ty,
+ typeMachRep (getPrimTyOf ty))
+ | (ty,n) <- zip arg_htys [1..] ]
+
+ -- add some auxiliary args; the stable ptr in the wrapper case, and
+ -- a slot for the dummy return address in the wrapper + ccall case
+ aug_arg_info
+ | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info
+ | otherwise = arg_info
+
+ stable_ptr_arg =
+ (text "the_stableptr", text "StgStablePtr", undefined,
+ typeMachRep (mkStablePtrPrimTy alphaTy))
+
+ -- stuff to do with the return type of the C function
+ res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes
+
+ cResType | res_hty_is_unit = text "void"
+ | otherwise = showStgType res_hty
+
+ -- Now we can cook up the prototype for the exported function.
+ pprCconv = case cc of
+ CCallConv -> empty
+ StdCallConv -> text (ccallConvAttribute cc)
+
+ header_bits = ptext SLIT("extern") <+> fun_proto <> semi
+
+ fun_proto = cResType <+> pprCconv <+> ftext c_nm <>
+ parens (hsep (punctuate comma (map (\(nm,ty,_,_) -> ty <+> nm)
+ aug_arg_info)))
+
+ -- the target which will form the root of what we ask rts_evalIO to run
+ the_cfun
+ = case maybe_target of
+ 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 (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
+
+ -- various other bits for inside the fn
+ declareResult = text "HaskellObj ret;"
+ declareCResult | res_hty_is_unit = empty
+ | otherwise = cResType <+> text "cret;"
+
+ assignCResult | res_hty_is_unit = empty
+ | otherwise =
+ text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
+
+ -- an extern decl for the fn being called
+ extern_decl
+ = case maybe_target of
+ 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 $$
+ extern_decl $$
+ fun_proto $$
+ vcat
+ [ lbrace
+ , text "Capability *cap;"
+ , declareResult
+ , declareCResult
+ , text "cap = rts_lock();"
+ -- create the application + perform it.
+ , text "cap=rts_evalIO" <> parens (
+ cap <>
+ text "rts_apply" <> parens (
+ cap <>
+ text "(HaskellObj)"
+ <> text (if is_IO_res_ty
+ then "runIO_closure"
+ else "runNonIO_closure")
+ <> comma
+ <> expr_to_run
+ ) <+> comma
+ <> text "&ret"
+ ) <> semi
+ , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
+ <> comma <> text "cap") <> semi
+ , assignCResult
+ , text "rts_unlock(cap);"
+ , if res_hty_is_unit then empty
+ else text "return cret;"
+ , rbrace
+ ] $$
+ initialiser