1{- 2(c) The University of Glasgow 2006 3(c) The AQUA Project, Glasgow University, 1998 4 5 6Desugaring foreign declarations (see also DsCCall). 7-} 8 9{-# LANGUAGE CPP #-} 10{-# LANGUAGE FlexibleContexts #-} 11{-# LANGUAGE TypeFamilies #-} 12{-# LANGUAGE ViewPatterns #-} 13 14module DsForeign ( dsForeigns ) where 15 16#include "HsVersions.h" 17import GhcPrelude 18 19import TcRnMonad -- temp 20 21import CoreSyn 22 23import DsCCall 24import DsMonad 25 26import GHC.Hs 27import DataCon 28import CoreUnfold 29import Id 30import Literal 31import Module 32import Name 33import Type 34import RepType 35import TyCon 36import Coercion 37import TcEnv 38import TcType 39 40import CmmExpr 41import CmmUtils 42import HscTypes 43import ForeignCall 44import TysWiredIn 45import TysPrim 46import PrelNames 47import BasicTypes 48import SrcLoc 49import Outputable 50import FastString 51import DynFlags 52import GHC.Platform 53import OrdList 54import Pair 55import Util 56import Hooks 57import Encoding 58 59import Data.Maybe 60import Data.List 61 62{- 63Desugaring of @foreign@ declarations is naturally split up into 64parts, an @import@ and an @export@ part. A @foreign import@ 65declaration 66\begin{verbatim} 67 foreign import cc nm f :: prim_args -> IO prim_res 68\end{verbatim} 69is the same as 70\begin{verbatim} 71 f :: prim_args -> IO prim_res 72 f a1 ... an = _ccall_ nm cc a1 ... an 73\end{verbatim} 74so we reuse the desugaring code in @DsCCall@ to deal with these. 75-} 76 77type Binding = (Id, CoreExpr) -- No rec/nonrec structure; 78 -- the occurrence analyser will sort it all out 79 80dsForeigns :: [LForeignDecl GhcTc] 81 -> DsM (ForeignStubs, OrdList Binding) 82dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos) 83 84dsForeigns' :: [LForeignDecl GhcTc] 85 -> DsM (ForeignStubs, OrdList Binding) 86dsForeigns' [] 87 = return (NoStubs, nilOL) 88dsForeigns' fos = do 89 mod <- getModule 90 fives <- mapM do_ldecl fos 91 let 92 (hs, cs, idss, bindss) = unzip4 fives 93 fe_ids = concat idss 94 fe_init_code = foreignExportsInitialiser mod fe_ids 95 -- 96 return (ForeignStubs 97 (vcat hs) 98 (vcat cs $$ fe_init_code), 99 foldr (appOL . toOL) nilOL bindss) 100 where 101 do_ldecl (dL->L loc decl) = putSrcSpanDs loc (do_decl decl) 102 103 do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do 104 traceIf (text "fi start" <+> ppr id) 105 let id' = unLoc id 106 (bs, h, c) <- dsFImport id' co spec 107 traceIf (text "fi end" <+> ppr id) 108 return (h, c, [], bs) 109 110 do_decl (ForeignExport { fd_name = (dL->L _ id) 111 , fd_e_ext = co 112 , fd_fe = CExport 113 (dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do 114 (h, c, _, _) <- dsFExport id co ext_nm cconv False 115 return (h, c, [id], []) 116 do_decl (XForeignDecl nec) = noExtCon nec 117 118{- 119************************************************************************ 120* * 121\subsection{Foreign import} 122* * 123************************************************************************ 124 125Desugaring foreign imports is just the matter of creating a binding 126that on its RHS unboxes its arguments, performs the external call 127(using the @CCallOp@ primop), before boxing the result up and returning it. 128 129However, we create a worker/wrapper pair, thus: 130 131 foreign import f :: Int -> IO Int 132==> 133 f x = IO ( \s -> case x of { I# x# -> 134 case fw s x# of { (# s1, y# #) -> 135 (# s1, I# y# #)}}) 136 137 fw s x# = ccall f s x# 138 139The strictness/CPR analyser won't do this automatically because it doesn't look 140inside returned tuples; but inlining this wrapper is a Really Good Idea 141because it exposes the boxing to the call site. 142-} 143 144dsFImport :: Id 145 -> Coercion 146 -> ForeignImport 147 -> DsM ([Binding], SDoc, SDoc) 148dsFImport id co (CImport cconv safety mHeader spec _) = 149 dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader 150 151dsCImport :: Id 152 -> Coercion 153 -> CImportSpec 154 -> CCallConv 155 -> Safety 156 -> Maybe Header 157 -> DsM ([Binding], SDoc, SDoc) 158dsCImport id co (CLabel cid) cconv _ _ = do 159 dflags <- getDynFlags 160 let ty = pFst $ coercionKind co 161 fod = case tyConAppTyCon_maybe (dropForAlls ty) of 162 Just tycon 163 | tyConUnique tycon == funPtrTyConKey -> 164 IsFunction 165 _ -> IsData 166 (resTy, foRhs) <- resultWrapper ty 167 ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this 168 let 169 rhs = foRhs (Lit (LitLabel cid stdcall_info fod)) 170 rhs' = Cast rhs co 171 stdcall_info = fun_type_arg_stdcall_info dflags cconv ty 172 in 173 return ([(id, rhs')], empty, empty) 174 175dsCImport id co (CFunction target) cconv@PrimCallConv safety _ 176 = dsPrimCall id co (CCall (mkCCallSpec target cconv safety 177 (panic "Missing Return PrimRep") 178 (panic "Missing Argument PrimReps"))) 179dsCImport id co (CFunction target) cconv safety mHeader 180 = dsFCall id co (CCall (mkCCallSpec target cconv safety 181 (panic "Missing Return PrimRep") 182 (panic "Missing Argument PrimReps"))) mHeader 183dsCImport id co CWrapper cconv _ _ 184 = dsFExportDynamic id co cconv 185 186-- For stdcall labels, if the type was a FunPtr or newtype thereof, 187-- then we need to calculate the size of the arguments in order to add 188-- the @n suffix to the label. 189fun_type_arg_stdcall_info :: DynFlags -> CCallConv -> Type -> Maybe Int 190fun_type_arg_stdcall_info dflags StdCallConv ty 191 | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty, 192 tyConUnique tc == funPtrTyConKey 193 = let 194 (bndrs, _) = tcSplitPiTys arg_ty 195 fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs 196 in Just $ sum (map (widthInBytes . typeWidth . typeCmmType dflags . getPrimTyOf) fe_arg_tys) 197fun_type_arg_stdcall_info _ _other_conv _ 198 = Nothing 199 200{- 201************************************************************************ 202* * 203\subsection{Foreign calls} 204* * 205************************************************************************ 206-} 207 208dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header 209 -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) 210dsFCall fn_id co (CCall (CCallSpec target cconv safety _ _)) mDeclHeader = do 211 let 212 ty = pFst $ coercionKind co 213 (tv_bndrs, rho) = tcSplitForAllVarBndrs ty 214 (arg_tys, io_res_ty) = tcSplitFunTys rho 215 216 args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism 217 (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) 218 219 let 220 work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars 221 222 (ccall_result_ty, res_wrapper) <- boxResult io_res_ty 223 224 ccall_uniq <- newUnique 225 work_uniq <- newUnique 226 227 dflags <- getDynFlags 228 229 let 230 fcall = CCall (mkCCallSpec target cconv safety io_res_ty arg_tys) 231 232 (fcall', cDoc) <- case fcall of 233 CCall (CCallSpec (StaticTarget _ cName mUnitId isFun) 234 CApiConv safety _ _) -> 235 do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName) 236 let fcall' = CCall (mkCCallSpec 237 (StaticTarget NoSourceText 238 wrapperName mUnitId 239 True) 240 CApiConv safety io_res_ty arg_tys) 241 c = includes 242 $$ fun_proto <+> braces (cRet <> semi) 243 includes = vcat [ text "#include \"" <> ftext h 244 <> text "\"" 245 | Header _ h <- nub headers ] 246 fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes 247 cRet 248 | isVoidRes = cCall 249 | otherwise = text "return" <+> cCall 250 cCall = if isFun 251 then ppr cName <> parens argVals 252 else if null arg_tys 253 then ppr cName 254 else panic "dsFCall: Unexpected arguments to FFI value import" 255 raw_res_ty = case tcSplitIOType_maybe io_res_ty of 256 Just (_ioTyCon, res_ty) -> res_ty 257 Nothing -> io_res_ty 258 isVoidRes = raw_res_ty `eqType` unitTy 259 (mHeader, cResType) 260 | isVoidRes = (Nothing, text "void") 261 | otherwise = toCType raw_res_ty 262 pprCconv = ccallConvAttribute CApiConv 263 mHeadersArgTypeList 264 = [ (header, cType <+> char 'a' <> int n) 265 | (t, n) <- zip arg_tys [1..] 266 , let (header, cType) = toCType t ] 267 (mHeaders, argTypeList) = unzip mHeadersArgTypeList 268 argTypes = if null argTypeList 269 then text "void" 270 else hsep $ punctuate comma argTypeList 271 mHeaders' = mDeclHeader : mHeader : mHeaders 272 headers = catMaybes mHeaders' 273 argVals = hsep $ punctuate comma 274 [ char 'a' <> int n 275 | (_, n) <- zip arg_tys [1..] ] 276 return (fcall', c) 277 _ -> 278 return (fcall, empty) 279 let 280 -- Build the worker 281 worker_ty = mkForAllTys tv_bndrs (mkVisFunTys (map idType work_arg_ids) ccall_result_ty) 282 tvs = map binderVar tv_bndrs 283 the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty 284 work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) 285 work_id = mkSysLocal (fsLit "$wccall") work_uniq worker_ty 286 287 -- Build the wrapper 288 work_app = mkApps (mkVarApps (Var work_id) tvs) val_args 289 wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers 290 wrap_rhs = mkLams (tvs ++ args) wrapper_body 291 wrap_rhs' = Cast wrap_rhs co 292 fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity 293 (length args) wrap_rhs' 294 295 return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], empty, cDoc) 296 297{- 298************************************************************************ 299* * 300\subsection{Primitive calls} 301* * 302************************************************************************ 303 304This is for `@foreign import prim@' declarations. 305 306Currently, at the core level we pretend that these primitive calls are 307foreign calls. It may make more sense in future to have them as a distinct 308kind of Id, or perhaps to bundle them with PrimOps since semantically and 309for calling convention they are really prim ops. 310-} 311 312dsPrimCall :: Id -> Coercion -> ForeignCall 313 -> DsM ([(Id, Expr TyVar)], SDoc, SDoc) 314dsPrimCall fn_id co (CCall (CCallSpec target cconv safety _ _)) = do 315 let 316 ty = pFst $ coercionKind co 317 (tvs, fun_ty) = tcSplitForAllTys ty 318 (arg_tys, io_res_ty) = tcSplitFunTys fun_ty 319 320 args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism 321 322 ccall_uniq <- newUnique 323 dflags <- getDynFlags 324 let 325 fcall = CCall (mkCCallSpec target cconv safety io_res_ty arg_tys) 326 call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty 327 rhs = mkLams tvs (mkLams args call_app) 328 rhs' = Cast rhs co 329 return ([(fn_id, rhs')], empty, empty) 330 331{- 332************************************************************************ 333* * 334\subsection{Foreign export} 335* * 336************************************************************************ 337 338The function that does most of the work for `@foreign export@' declarations. 339(see below for the boilerplate code a `@foreign export@' declaration expands 340 into.) 341 342For each `@foreign export foo@' in a module M we generate: 343\begin{itemize} 344\item a C function `@foo@', which calls 345\item a Haskell stub `@M.\$ffoo@', which calls 346\end{itemize} 347the user-written Haskell function `@M.foo@'. 348-} 349 350dsFExport :: Id -- Either the exported Id, 351 -- or the foreign-export-dynamic constructor 352 -> Coercion -- Coercion between the Haskell type callable 353 -- from C, and its representation type 354 -> CLabelString -- The name to export to C land 355 -> CCallConv 356 -> Bool -- True => foreign export dynamic 357 -- so invoke IO action that's hanging off 358 -- the first argument's stable pointer 359 -> DsM ( SDoc -- contents of Module_stub.h 360 , SDoc -- contents of Module_stub.c 361 , String -- string describing type to pass to createAdj. 362 , Int -- size of args to stub function 363 ) 364 365dsFExport fn_id co ext_name cconv isDyn = do 366 let 367 ty = pSnd $ coercionKind co 368 (bndrs, orig_res_ty) = tcSplitPiTys ty 369 fe_arg_tys' = mapMaybe binderRelevantType_maybe bndrs 370 -- We must use tcSplits here, because we want to see 371 -- the (IO t) in the corner of the type! 372 fe_arg_tys | isDyn = tail fe_arg_tys' 373 | otherwise = fe_arg_tys' 374 375 -- Look at the result type of the exported function, orig_res_ty 376 -- If it's IO t, return (t, True) 377 -- If it's plain t, return (t, False) 378 (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of 379 -- The function already returns IO t 380 Just (_ioTyCon, res_ty) -> (res_ty, True) 381 -- The function returns t 382 Nothing -> (orig_res_ty, False) 383 384 dflags <- getDynFlags 385 return $ 386 mkFExportCBits dflags ext_name 387 (if isDyn then Nothing else Just fn_id) 388 fe_arg_tys res_ty is_IO_res_ty cconv 389 390{- 391@foreign import "wrapper"@ (previously "foreign export dynamic") lets 392you dress up Haskell IO actions of some fixed type behind an 393externally callable interface (i.e., as a C function pointer). Useful 394for callbacks and stuff. 395 396\begin{verbatim} 397type Fun = Bool -> Int -> IO Int 398foreign import "wrapper" f :: Fun -> IO (FunPtr Fun) 399 400-- Haskell-visible constructor, which is generated from the above: 401-- SUP: No check for NULL from createAdjustor anymore??? 402 403f :: Fun -> IO (FunPtr Fun) 404f cback = 405 bindIO (newStablePtr cback) 406 (\StablePtr sp# -> IO (\s1# -> 407 case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of 408 (# s2#, a# #) -> (# s2#, A# a# #))) 409 410foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun) 411 412-- and the helper in C: (approximately; see `mkFExportCBits` below) 413 414f_helper(StablePtr s, HsBool b, HsInt i) 415{ 416 Capability *cap; 417 cap = rts_lock(); 418 rts_evalIO(&cap, 419 rts_apply(rts_apply(deRefStablePtr(s), 420 rts_mkBool(b)), rts_mkInt(i))); 421 rts_unlock(cap); 422} 423\end{verbatim} 424-} 425 426dsFExportDynamic :: Id 427 -> Coercion 428 -> CCallConv 429 -> DsM ([Binding], SDoc, SDoc) 430dsFExportDynamic id co0 cconv = do 431 mod <- getModule 432 dflags <- getDynFlags 433 let fe_nm = mkFastString $ zEncodeString 434 (moduleStableString mod ++ "$" ++ toCName dflags id) 435 -- Construct the label based on the passed id, don't use names 436 -- depending on Unique. See #13807 and Note [Unique Determinism]. 437 cback <- newSysLocalDs arg_ty 438 newStablePtrId <- dsLookupGlobalId newStablePtrName 439 stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName 440 let 441 stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] 442 export_ty = mkVisFunTy stable_ptr_ty arg_ty 443 bindIOId <- dsLookupGlobalId bindIOName 444 stbl_value <- newSysLocalDs stable_ptr_ty 445 (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True 446 let 447 {- 448 The arguments to the external function which will 449 create a little bit of (template) code on the fly 450 for allowing the (stable pointed) Haskell closure 451 to be entered using an external calling convention 452 (stdcall, ccall). 453 -} 454 adj_args = [ mkIntLitInt dflags (ccallConvToInt cconv) 455 , Var stbl_value 456 , Lit (LitLabel fe_nm mb_sz_args IsFunction) 457 , Lit (mkLitString typestring) 458 ] 459 -- name of external entry point providing these services. 460 -- (probably in the RTS.) 461 adjustor = fsLit "createAdjustor" 462 463 -- Determine the number of bytes of arguments to the stub function, 464 -- so that we can attach the '@N' suffix to its label if it is a 465 -- stdcall on Windows. 466 mb_sz_args = case cconv of 467 StdCallConv -> Just args_size 468 _ -> Nothing 469 470 ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) 471 -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback 472 473 let io_app = mkLams tvs $ 474 Lam cback $ 475 mkApps (Var bindIOId) 476 [ Type stable_ptr_ty 477 , Type res_ty 478 , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] 479 , Lam stbl_value ccall_adj 480 ] 481 482 fed = (id `setInlineActivation` NeverActive, Cast io_app co0) 483 -- Never inline the f.e.d. function, because the litlit 484 -- might not be in scope in other modules. 485 486 return ([fed], h_code, c_code) 487 488 where 489 ty = pFst (coercionKind co0) 490 (tvs,sans_foralls) = tcSplitForAllTys ty 491 ([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls 492 Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty 493 -- Must have an IO type; hence Just 494 495 496toCName :: DynFlags -> Id -> String 497toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i))) 498 499{- 500* 501 502\subsection{Generating @foreign export@ stubs} 503 504* 505 506For each @foreign export@ function, a C stub function is generated. 507The C stub constructs the application of the exported Haskell function 508using the hugs/ghc rts invocation API. 509-} 510 511mkFExportCBits :: DynFlags 512 -> FastString 513 -> Maybe Id -- Just==static, Nothing==dynamic 514 -> [Type] 515 -> Type 516 -> Bool -- True <=> returns an IO type 517 -> CCallConv 518 -> (SDoc, 519 SDoc, 520 String, -- the argument reps 521 Int -- total size of arguments 522 ) 523mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc 524 = (header_bits, c_bits, type_string, 525 sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args 526 -- NB. the calculation here isn't strictly speaking correct. 527 -- We have a primitive Haskell type (eg. Int#, Double#), and 528 -- we want to know the size, when passed on the C stack, of 529 -- the associated C type (eg. HsInt, HsDouble). We don't have 530 -- this information to hand, but we know what GHC's conventions 531 -- are for passing around the primitive Haskell types, so we 532 -- use that instead. I hope the two coincide --SDM 533 ) 534 where 535 -- list the arguments to the C function 536 arg_info :: [(SDoc, -- arg name 537 SDoc, -- C type 538 Type, -- Haskell type 539 CmmType)] -- the CmmType 540 arg_info = [ let stg_type = showStgType ty in 541 (arg_cname n stg_type, 542 stg_type, 543 ty, 544 typeCmmType dflags (getPrimTyOf ty)) 545 | (ty,n) <- zip arg_htys [1::Int ..] ] 546 547 arg_cname n stg_ty 548 | libffi = char '*' <> parens (stg_ty <> char '*') <> 549 text "args" <> brackets (int (n-1)) 550 | otherwise = text ('a':show n) 551 552 -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled 553 libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target 554 555 type_string 556 -- libffi needs to know the result type too: 557 | libffi = primTyDescChar dflags res_hty : arg_type_string 558 | otherwise = arg_type_string 559 560 arg_type_string = [primTyDescChar dflags ty | (_,_,ty,_) <- arg_info] 561 -- just the real args 562 563 -- add some auxiliary args; the stable ptr in the wrapper case, and 564 -- a slot for the dummy return address in the wrapper + ccall case 565 aug_arg_info 566 | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info 567 | otherwise = arg_info 568 569 stable_ptr_arg = 570 (text "the_stableptr", text "StgStablePtr", undefined, 571 typeCmmType dflags (mkStablePtrPrimTy alphaTy)) 572 573 -- stuff to do with the return type of the C function 574 res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes 575 576 cResType | res_hty_is_unit = text "void" 577 | otherwise = showStgType res_hty 578 579 -- when the return type is integral and word-sized or smaller, it 580 -- must be assigned as type ffi_arg (#3516). To see what type 581 -- libffi is expecting here, take a look in its own testsuite, e.g. 582 -- libffi/testsuite/libffi.call/cls_align_ulonglong.c 583 ffi_cResType 584 | is_ffi_arg_type = text "ffi_arg" 585 | otherwise = cResType 586 where 587 res_ty_key = getUnique (getName (typeTyCon res_hty)) 588 is_ffi_arg_type = res_ty_key `notElem` 589 [floatTyConKey, doubleTyConKey, 590 int64TyConKey, word64TyConKey] 591 592 -- Now we can cook up the prototype for the exported function. 593 pprCconv = ccallConvAttribute cc 594 595 header_bits = text "extern" <+> fun_proto <> semi 596 597 fun_args 598 | null aug_arg_info = text "void" 599 | otherwise = hsep $ punctuate comma 600 $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info 601 602 fun_proto 603 | libffi 604 = text "void" <+> ftext c_nm <> 605 parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr") 606 | otherwise 607 = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args 608 609 -- the target which will form the root of what we ask rts_evalIO to run 610 the_cfun 611 = case maybe_target of 612 Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)" 613 Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure" 614 615 cap = text "cap" <> comma 616 617 -- the expression we give to rts_evalIO 618 expr_to_run 619 = foldl' appArg the_cfun arg_info -- NOT aug_arg_info 620 where 621 appArg acc (arg_cname, _, arg_hty, _) 622 = text "rts_apply" 623 <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname)) 624 625 -- various other bits for inside the fn 626 declareResult = text "HaskellObj ret;" 627 declareCResult | res_hty_is_unit = empty 628 | otherwise = cResType <+> text "cret;" 629 630 assignCResult | res_hty_is_unit = empty 631 | otherwise = 632 text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi 633 634 -- an extern decl for the fn being called 635 extern_decl 636 = case maybe_target of 637 Nothing -> empty 638 Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi 639 640 641 -- finally, the whole darn thing 642 c_bits = 643 space $$ 644 extern_decl $$ 645 fun_proto $$ 646 vcat 647 [ lbrace 648 , text "Capability *cap;" 649 , declareResult 650 , declareCResult 651 , text "cap = rts_lock();" 652 -- create the application + perform it. 653 , text "rts_evalIO" <> parens ( 654 char '&' <> cap <> 655 text "rts_apply" <> parens ( 656 cap <> 657 text "(HaskellObj)" 658 <> ptext (if is_IO_res_ty 659 then (sLit "runIO_closure") 660 else (sLit "runNonIO_closure")) 661 <> comma 662 <> expr_to_run 663 ) <+> comma 664 <> text "&ret" 665 ) <> semi 666 , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm) 667 <> comma <> text "cap") <> semi 668 , assignCResult 669 , text "rts_unlock(cap);" 670 , ppUnless res_hty_is_unit $ 671 if libffi 672 then char '*' <> parens (ffi_cResType <> char '*') <> 673 text "resp = cret;" 674 else text "return cret;" 675 , rbrace 676 ] 677 678 679foreignExportsInitialiser :: Module -> [Id] -> SDoc 680foreignExportsInitialiser mod hs_fns = 681 -- Initialise foreign exports by registering a stable pointer from an 682 -- __attribute__((constructor)) function. 683 -- The alternative is to do this from stginit functions generated in 684 -- codeGen/CodeGen.hs; however, stginit functions have a negative impact 685 -- on binary sizes and link times because the static linker will think that 686 -- all modules that are imported directly or indirectly are actually used by 687 -- the program. 688 -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL) 689 -- 690 -- See Note [Tracking foreign exports] in rts/ForeignExports.c 691 vcat 692 [ text "static struct ForeignExportsList" <+> list_symbol <+> equals 693 <+> braces ( 694 text ".exports = " <+> export_list <> comma <+> 695 text ".n_entries = " <+> ppr (length hs_fns)) 696 <> semi 697 , text "static void " <> ctor_symbol <> text "(void)" 698 <+> text " __attribute__((constructor));" 699 , text "static void " <> ctor_symbol <> text "()" 700 , braces (text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi) 701 ] 702 where 703 mod_str = pprModuleName (moduleName mod) 704 ctor_symbol = text "stginit_export_" <> mod_str 705 list_symbol = text "stg_exports_" <> mod_str 706 export_list = braces $ pprWithCommas closure_ptr hs_fns 707 708 closure_ptr :: Id -> SDoc 709 closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure" 710 711 712mkHObj :: Type -> SDoc 713mkHObj t = text "rts_mk" <> text (showFFIType t) 714 715unpackHObj :: Type -> SDoc 716unpackHObj t = text "rts_get" <> text (showFFIType t) 717 718showStgType :: Type -> SDoc 719showStgType t = text "Hs" <> text (showFFIType t) 720 721showFFIType :: Type -> String 722showFFIType t = getOccString (getName (typeTyCon t)) 723 724toCType :: Type -> (Maybe Header, SDoc) 725toCType = f False 726 where f voidOK t 727 -- First, if we have (Ptr t) of (FunPtr t), then we need to 728 -- convert t to a C type and put a * after it. If we don't 729 -- know a type for t, then "void" is fine, though. 730 | Just (ptr, [t']) <- splitTyConApp_maybe t 731 , tyConName ptr `elem` [ptrTyConName, funPtrTyConName] 732 = case f True t' of 733 (mh, cType') -> 734 (mh, cType' <> char '*') 735 -- Otherwise, if we have a type constructor application, then 736 -- see if there is a C type associated with that constructor. 737 -- Note that we aren't looking through type synonyms or 738 -- anything, as it may be the synonym that is annotated. 739 | Just tycon <- tyConAppTyConPicky_maybe t 740 , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon 741 = (mHeader, ftext cType) 742 -- If we don't know a C type for this type, then try looking 743 -- through one layer of type synonym etc. 744 | Just t' <- coreView t 745 = f voidOK t' 746 -- This may be an 'UnliftedFFITypes'-style ByteArray# argument 747 -- (which is marshalled like a Ptr) 748 | Just byteArrayPrimTyCon == tyConAppTyConPicky_maybe t 749 = (Nothing, text "const void*") 750 | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t 751 = (Nothing, text "void*") 752 -- Otherwise we don't know the C type. If we are allowing 753 -- void then return that; otherwise something has gone wrong. 754 | voidOK = (Nothing, text "void") 755 | otherwise 756 = pprPanic "toCType" (ppr t) 757 758typeTyCon :: Type -> TyCon 759typeTyCon ty 760 | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) 761 = tc 762 | otherwise 763 = pprPanic "DsForeign.typeTyCon" (ppr ty) 764 765insertRetAddr :: DynFlags -> CCallConv 766 -> [(SDoc, SDoc, Type, CmmType)] 767 -> [(SDoc, SDoc, Type, CmmType)] 768insertRetAddr dflags CCallConv args 769 = case platformArch platform of 770 ArchX86_64 771 | platformOS platform == OSMinGW32 -> 772 -- On other Windows x86_64 we insert the return address 773 -- after the 4th argument, because this is the point 774 -- at which we need to flush a register argument to the stack 775 -- (See rts/Adjustor.c for details). 776 let go :: Int -> [(SDoc, SDoc, Type, CmmType)] 777 -> [(SDoc, SDoc, Type, CmmType)] 778 go 4 args = ret_addr_arg dflags : args 779 go n (arg:args) = arg : go (n+1) args 780 go _ [] = [] 781 in go 0 args 782 | otherwise -> 783 -- On other x86_64 platforms we insert the return address 784 -- after the 6th integer argument, because this is the point 785 -- at which we need to flush a register argument to the stack 786 -- (See rts/Adjustor.c for details). 787 let go :: Int -> [(SDoc, SDoc, Type, CmmType)] 788 -> [(SDoc, SDoc, Type, CmmType)] 789 go 6 args = ret_addr_arg dflags : args 790 go n (arg@(_,_,_,rep):args) 791 | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args 792 | otherwise = arg : go n args 793 go _ [] = [] 794 in go 0 args 795 _ -> 796 ret_addr_arg dflags : args 797 where platform = targetPlatform dflags 798insertRetAddr _ _ args = args 799 800ret_addr_arg :: DynFlags -> (SDoc, SDoc, Type, CmmType) 801ret_addr_arg dflags = (text "original_return_addr", text "void*", undefined, 802 typeCmmType dflags addrPrimTy) 803 804-- This function returns the primitive type associated with the boxed 805-- type argument to a foreign export (eg. Int ==> Int#). 806getPrimTyOf :: Type -> UnaryType 807getPrimTyOf ty 808 | isBoolTy rep_ty = intPrimTy 809 -- Except for Bool, the types we are interested in have a single constructor 810 -- with a single primitive-typed argument (see TcType.legalFEArgTyCon). 811 | otherwise = 812 case splitDataProductType_maybe rep_ty of 813 Just (_, _, data_con, [prim_ty]) -> 814 ASSERT(dataConSourceArity data_con == 1) 815 ASSERT2(isUnliftedType prim_ty, ppr prim_ty) 816 prim_ty 817 _other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty) 818 where 819 rep_ty = unwrapType ty 820 821-- represent a primitive type as a Char, for building a string that 822-- described the foreign function type. The types are size-dependent, 823-- e.g. 'W' is a signed 32-bit integer. 824primTyDescChar :: DynFlags -> Type -> Char 825primTyDescChar dflags ty 826 | ty `eqType` unitTy = 'v' 827 | otherwise 828 = case typePrimRep1 (getPrimTyOf ty) of 829 IntRep -> signed_word 830 WordRep -> unsigned_word 831 Int8Rep -> 'B' 832 Word8Rep -> 'b' 833 Int16Rep -> 'S' 834 Word16Rep -> 's' 835 Int32Rep -> 'W' 836 Word32Rep -> 'w' 837 Int64Rep -> 'L' 838 Word64Rep -> 'l' 839 AddrRep -> 'p' 840 FloatRep -> 'f' 841 DoubleRep -> 'd' 842 _ -> pprPanic "primTyDescChar" (ppr ty) 843 where 844 (signed_word, unsigned_word) 845 | wORD_SIZE dflags == 4 = ('W','w') 846 | wORD_SIZE dflags == 8 = ('L','l') 847 | otherwise = panic "primTyDescChar" 848