{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1998 Desugaring foreign declarations (see also GHC.HsToCore.Foreign.Call). -} module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where #include "HsVersions.h" import GHC.Prelude import GHC.Tc.Utils.Monad -- temp import GHC.Core import GHC.HsToCore.Foreign.Call import GHC.HsToCore.Monad import GHC.Hs import GHC.Core.DataCon import GHC.Core.Unfold.Make import GHC.Types.Id import GHC.Types.Literal import GHC.Types.ForeignStubs import GHC.Types.SourceText import GHC.Unit.Module import GHC.Types.Name import GHC.Core.Type import GHC.Types.RepType import GHC.Core.TyCon import GHC.Core.Coercion import GHC.Core.Multiplicity import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcType import GHC.Cmm.Expr import GHC.Cmm.Utils import GHC.Driver.Ppr import GHC.Types.ForeignCall import GHC.Builtin.Types import GHC.Builtin.Types.Prim import GHC.Builtin.Names import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Driver.Session import GHC.Driver.Config import GHC.Platform import GHC.Data.OrdList import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Driver.Hooks import GHC.Utils.Encoding import Data.Maybe import Data.List (unzip4, nub) {- Desugaring of @foreign@ declarations is naturally split up into parts, an @import@ and an @export@ part. A @foreign import@ declaration \begin{verbatim} foreign import cc nm f :: prim_args -> IO prim_res \end{verbatim} is the same as \begin{verbatim} f :: prim_args -> IO prim_res f a1 ... an = _ccall_ nm cc a1 ... an \end{verbatim} so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with these. -} type Binding = (Id, CoreExpr) -- No rec/nonrec structure; -- the occurrence analyser will sort it all out dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding) dsForeigns fos = do hooks <- getHooks case dsForeignsHook hooks of Nothing -> dsForeigns' fos Just h -> h fos dsForeigns' :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding) dsForeigns' [] = return (NoStubs, nilOL) dsForeigns' fos = do mod <- getModule fives <- mapM do_ldecl fos let (hs, cs, idss, bindss) = unzip4 fives fe_ids = concat idss fe_init_code = foreignExportsInitialiser mod fe_ids -- return (ForeignStubs (mconcat hs) (mconcat cs `mappend` fe_init_code), foldr (appOL . toOL) nilOL bindss) where do_ldecl (L loc decl) = putSrcSpanDs (locA loc) (do_decl decl) do_decl :: ForeignDecl GhcTc -> DsM (CHeader, CStub, [Id], [Binding]) do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do traceIf (text "fi start" <+> ppr id) let id' = unLoc id (bs, h, c) <- dsFImport id' co spec traceIf (text "fi end" <+> ppr id) return (h, c, [], bs) do_decl (ForeignExport { fd_name = L _ id , fd_e_ext = co , fd_fe = CExport (L _ (CExportStatic _ ext_nm cconv)) _ }) = do (h, c, _, _) <- dsFExport id co ext_nm cconv False return (h, c, [id], []) {- ************************************************************************ * * \subsection{Foreign import} * * ************************************************************************ Desugaring foreign imports is just the matter of creating a binding that on its RHS unboxes its arguments, performs the external call (using the @CCallOp@ primop), before boxing the result up and returning it. However, we create a worker/wrapper pair, thus: foreign import f :: Int -> IO Int ==> f x = IO ( \s -> case x of { I# x# -> case fw s x# of { (# s1, y# #) -> (# s1, I# y# #)}}) fw s x# = ccall f s x# The strictness/CPR analyser won't do this automatically because it doesn't look inside returned tuples; but inlining this wrapper is a Really Good Idea because it exposes the boxing to the call site. -} dsFImport :: Id -> Coercion -> ForeignImport -> DsM ([Binding], CHeader, CStub) dsFImport id co (CImport cconv safety mHeader spec _) = dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader dsCImport :: Id -> Coercion -> CImportSpec -> CCallConv -> Safety -> Maybe Header -> DsM ([Binding], CHeader, CStub) dsCImport id co (CLabel cid) cconv _ _ = do dflags <- getDynFlags let ty = coercionLKind co platform = targetPlatform dflags fod = case tyConAppTyCon_maybe (dropForAlls ty) of Just tycon | tyConUnique tycon == funPtrTyConKey -> IsFunction _ -> IsData (resTy, foRhs) <- resultWrapper ty ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this let rhs = foRhs (Lit (LitLabel cid stdcall_info fod)) rhs' = Cast rhs co stdcall_info = fun_type_arg_stdcall_info platform cconv ty in return ([(id, rhs')], mempty, mempty) dsCImport id co (CFunction target) cconv@PrimCallConv safety _ = dsPrimCall id co (CCall (CCallSpec target cconv safety)) dsCImport id co (CFunction target) cconv safety mHeader = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader dsCImport id co CWrapper cconv _ _ = dsFExportDynamic id co cconv -- For stdcall labels, if the type was a FunPtr or newtype thereof, -- then we need to calculate the size of the arguments in order to add -- the @n suffix to the label. fun_type_arg_stdcall_info :: Platform -> CCallConv -> Type -> Maybe Int fun_type_arg_stdcall_info platform StdCallConv ty | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty, tyConUnique tc == funPtrTyConKey = let (bndrs, _) = tcSplitPiTys arg_ty fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys) fun_type_arg_stdcall_info _ _other_conv _ = Nothing {- ************************************************************************ * * \subsection{Foreign calls} * * ************************************************************************ -} dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header -> DsM ([(Id, Expr TyVar)], CHeader, CStub) dsFCall fn_id co fcall mDeclHeader = do let ty = coercionLKind co (tv_bndrs, rho) = tcSplitForAllTyVarBinders ty (arg_tys, io_res_ty) = tcSplitFunTys rho args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args) let work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars (ccall_result_ty, res_wrapper) <- boxResult io_res_ty ccall_uniq <- newUnique work_uniq <- newUnique dflags <- getDynFlags (fcall', cDoc) <- case fcall of CCall (CCallSpec (StaticTarget _ cName mUnitId isFun) CApiConv safety) -> do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName) let fcall' = CCall (CCallSpec (StaticTarget NoSourceText wrapperName mUnitId True) CApiConv safety) c = includes $$ fun_proto <+> braces (cRet <> semi) includes = vcat [ text "#include \"" <> ftext h <> text "\"" | Header _ h <- nub headers ] fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes cRet | isVoidRes = cCall | otherwise = text "return" <+> cCall cCall = if isFun then ppr cName <> parens argVals else if null arg_tys then ppr cName else panic "dsFCall: Unexpected arguments to FFI value import" raw_res_ty = case tcSplitIOType_maybe io_res_ty of Just (_ioTyCon, res_ty) -> res_ty Nothing -> io_res_ty isVoidRes = raw_res_ty `eqType` unitTy (mHeader, cResType) | isVoidRes = (Nothing, text "void") | otherwise = toCType raw_res_ty pprCconv = ccallConvAttribute CApiConv mHeadersArgTypeList = [ (header, cType <+> char 'a' <> int n) | (t, n) <- zip arg_tys [1..] , let (header, cType) = toCType (scaledThing t) ] (mHeaders, argTypeList) = unzip mHeadersArgTypeList argTypes = if null argTypeList then text "void" else hsep $ punctuate comma argTypeList mHeaders' = mDeclHeader : mHeader : mHeaders headers = catMaybes mHeaders' argVals = hsep $ punctuate comma [ char 'a' <> int n | (_, n) <- zip arg_tys [1..] ] return (fcall', c) _ -> return (fcall, empty) let -- Build the worker worker_ty = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty) tvs = map binderVar tv_bndrs the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app) work_id = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty -- Build the wrapper work_app = mkApps (mkVarApps (Var work_id) tvs) val_args wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers wrap_rhs = mkLams (tvs ++ args) wrapper_body wrap_rhs' = Cast wrap_rhs co simpl_opts = initSimpleOpts dflags fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity (length args) simpl_opts wrap_rhs' return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc) {- ************************************************************************ * * \subsection{Primitive calls} * * ************************************************************************ This is for `@foreign import prim@' declarations. Currently, at the core level we pretend that these primitive calls are foreign calls. It may make more sense in future to have them as a distinct kind of Id, or perhaps to bundle them with PrimOps since semantically and for calling convention they are really prim ops. -} dsPrimCall :: Id -> Coercion -> ForeignCall -> DsM ([(Id, Expr TyVar)], CHeader, CStub) dsPrimCall fn_id co fcall = do let ty = coercionLKind co (tvs, fun_ty) = tcSplitForAllInvisTyVars ty (arg_tys, io_res_ty) = tcSplitFunTys fun_ty args <- newSysLocalsDs arg_tys -- no FFI levity-polymorphism ccall_uniq <- newUnique dflags <- getDynFlags let call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty rhs = mkLams tvs (mkLams args call_app) rhs' = Cast rhs co return ([(fn_id, rhs')], mempty, mempty) {- ************************************************************************ * * \subsection{Foreign export} * * ************************************************************************ The function that does most of the work for `@foreign export@' declarations. (see below for the boilerplate code a `@foreign export@' declaration expands into.) For each `@foreign export foo@' in a module M we generate: \begin{itemize} \item a C function `@foo@', which calls \item a Haskell stub `@M.\$ffoo@', which calls \end{itemize} the user-written Haskell function `@M.foo@'. -} dsFExport :: Id -- Either the exported Id, -- or the foreign-export-dynamic constructor -> Coercion -- Coercion between the Haskell type callable -- from C, and its representation type -> CLabelString -- The name to export to C land -> CCallConv -> Bool -- True => foreign export dynamic -- so invoke IO action that's hanging off -- the first argument's stable pointer -> DsM ( CHeader -- contents of Module_stub.h , CStub -- contents of Module_stub.c , String -- string describing type to pass to createAdj. , Int -- size of args to stub function ) dsFExport fn_id co ext_name cconv isDyn = do let ty = coercionRKind co (bndrs, orig_res_ty) = tcSplitPiTys ty fe_arg_tys' = mapMaybe binderRelevantType_maybe bndrs -- We must use tcSplits here, because we want to see -- the (IO t) in the corner of the type! fe_arg_tys | isDyn = tail fe_arg_tys' | otherwise = fe_arg_tys' -- Look at the result type of the exported function, orig_res_ty -- If it's IO t, return (t, True) -- If it's plain t, return (t, False) (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of -- The function already returns IO t Just (_ioTyCon, res_ty) -> (res_ty, True) -- The function returns t Nothing -> (orig_res_ty, False) dflags <- getDynFlags return $ mkFExportCBits dflags ext_name (if isDyn then Nothing else Just fn_id) fe_arg_tys res_ty is_IO_res_ty cconv {- @foreign import "wrapper"@ (previously "foreign export dynamic") lets you dress up Haskell IO actions of some fixed type behind an externally callable interface (i.e., as a C function pointer). Useful for callbacks and stuff. \begin{verbatim} type Fun = Bool -> Int -> IO Int foreign import "wrapper" f :: Fun -> IO (FunPtr Fun) -- Haskell-visible constructor, which is generated from the above: -- SUP: No check for NULL from createAdjustor anymore??? f :: Fun -> IO (FunPtr Fun) f cback = bindIO (newStablePtr cback) (\StablePtr sp# -> IO (\s1# -> case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of (# s2#, a# #) -> (# s2#, A# a# #))) foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun) -- and the helper in C: (approximately; see `mkFExportCBits` below) f_helper(StablePtr s, HsBool b, HsInt i) { Capability *cap; cap = rts_lock(); rts_inCall(&cap, rts_apply(rts_apply(deRefStablePtr(s), rts_mkBool(b)), rts_mkInt(i))); rts_unlock(cap); } \end{verbatim} -} dsFExportDynamic :: Id -> Coercion -> CCallConv -> DsM ([Binding], CHeader, CStub) dsFExportDynamic id co0 cconv = do mod <- getModule dflags <- getDynFlags let platform = targetPlatform dflags let fe_nm = mkFastString $ zEncodeString (moduleStableString mod ++ "$" ++ toCName dflags id) -- Construct the label based on the passed id, don't use names -- depending on Unique. See #13807 and Note [Unique Determinism]. cback <- newSysLocalDs arg_mult arg_ty newStablePtrId <- dsLookupGlobalId newStablePtrName stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName let stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty] export_ty = mkVisFunTyMany stable_ptr_ty arg_ty bindIOId <- dsLookupGlobalId bindIOName stbl_value <- newSysLocalDs Many stable_ptr_ty (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True let {- The arguments to the external function which will create a little bit of (template) code on the fly for allowing the (stable pointed) Haskell closure to be entered using an external calling convention (stdcall, ccall). -} adj_args = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv)) , Var stbl_value , Lit (LitLabel fe_nm mb_sz_args IsFunction) , Lit (mkLitString typestring) ] -- name of external entry point providing these services. -- (probably in the RTS.) adjustor = fsLit "createAdjustor" -- Determine the number of bytes of arguments to the stub function, -- so that we can attach the '@N' suffix to its label if it is a -- stdcall on Windows. mb_sz_args = case cconv of StdCallConv -> Just args_size _ -> Nothing ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback let io_app = mkLams tvs $ Lam cback $ mkApps (Var bindIOId) [ Type stable_ptr_ty , Type res_ty , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] , Lam stbl_value ccall_adj ] fed = (id `setInlineActivation` NeverActive, Cast io_app co0) -- Never inline the f.e.d. function, because the litlit -- might not be in scope in other modules. return ([fed], h_code, c_code) where ty = coercionLKind co0 (tvs,sans_foralls) = tcSplitForAllInvisTyVars ty ([Scaled arg_mult arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty -- Must have an IO type; hence Just toCName :: DynFlags -> Id -> String toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i))) {- * \subsection{Generating @foreign export@ stubs} * For each @foreign export@ function, a C stub function is generated. The C stub constructs the application of the exported Haskell function using the hugs/ghc rts invocation API. -} mkFExportCBits :: DynFlags -> FastString -> Maybe Id -- Just==static, Nothing==dynamic -> [Type] -> Type -> Bool -- True <=> returns an IO type -> CCallConv -> (CHeader, CStub, String, -- the argument reps Int -- total size of arguments ) mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc = (header_bits, c_bits, type_string, sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args -- NB. the calculation here isn't strictly speaking correct. -- We have a primitive Haskell type (eg. Int#, Double#), and -- we want to know the size, when passed on the C stack, of -- the associated C type (eg. HsInt, HsDouble). We don't have -- this information to hand, but we know what GHC's conventions -- are for passing around the primitive Haskell types, so we -- use that instead. I hope the two coincide --SDM ) where platform = targetPlatform dflags -- list the arguments to the C function arg_info :: [(SDoc, -- arg name SDoc, -- C type Type, -- Haskell type CmmType)] -- the CmmType arg_info = [ let stg_type = showStgType ty in (arg_cname n stg_type, stg_type, ty, typeCmmType platform (getPrimTyOf ty)) | (ty,n) <- zip arg_htys [1::Int ..] ] arg_cname n stg_ty | libffi = char '*' <> parens (stg_ty <> char '*') <> text "args" <> brackets (int (n-1)) | otherwise = text ('a':show n) -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target type_string -- libffi needs to know the result type too: | libffi = primTyDescChar platform res_hty : arg_type_string | otherwise = arg_type_string arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info] -- just the real args -- 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 platform cc arg_info | otherwise = arg_info stable_ptr_arg = (text "the_stableptr", text "StgStablePtr", undefined, typeCmmType platform (mkStablePtrPrimTy alphaTy)) -- stuff to do with the return type of the C function res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes cResType | res_hty_is_unit = text "void" | otherwise = showStgType res_hty -- when the return type is integral and word-sized or smaller, it -- must be assigned as type ffi_arg (#3516). To see what type -- libffi is expecting here, take a look in its own testsuite, e.g. -- libffi/testsuite/libffi.call/cls_align_ulonglong.c ffi_cResType | is_ffi_arg_type = text "ffi_arg" | otherwise = cResType where res_ty_key = getUnique (getName (typeTyCon res_hty)) is_ffi_arg_type = res_ty_key `notElem` [floatTyConKey, doubleTyConKey, int64TyConKey, word64TyConKey] -- Now we can cook up the prototype for the exported function. pprCconv = ccallConvAttribute cc header_bits = CHeader (text "extern" <+> fun_proto <> semi) fun_args | null aug_arg_info = text "void" | otherwise = hsep $ punctuate comma $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info fun_proto | libffi = text "void" <+> ftext c_nm <> parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr") | otherwise = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args -- the target which will form the root of what we ask rts_inCall 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_inCall 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 -- finally, the whole darn thing c_bits = CStub $ space $$ extern_decl $$ fun_proto $$ vcat [ lbrace , text "Capability *cap;" , declareResult , declareCResult , text "cap = rts_lock();" -- create the application + perform it. , text "rts_inCall" <> parens ( char '&' <> cap <> text "rts_apply" <> parens ( cap <> text "(HaskellObj)" <> ptext (if is_IO_res_ty then (sLit "runIO_closure") else (sLit "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);" , ppUnless res_hty_is_unit $ if libffi then char '*' <> parens (ffi_cResType <> char '*') <> text "resp = cret;" else text "return cret;" , rbrace ] foreignExportsInitialiser :: Module -> [Id] -> CStub foreignExportsInitialiser mod hs_fns = -- 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.hs; 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) -- -- See Note [Tracking foreign exports] in rts/ForeignExports.c CStub $ vcat [ text "static struct ForeignExportsList" <+> list_symbol <+> equals <+> braces ( text ".exports = " <+> export_list <> comma <+> text ".n_entries = " <+> ppr (length hs_fns)) <> semi , text "static void " <> ctor_symbol <> text "(void)" <+> text " __attribute__((constructor));" , text "static void " <> ctor_symbol <> text "()" , braces (text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi) ] where mod_str = pprModuleName (moduleName mod) ctor_symbol = text "stginit_export_" <> mod_str list_symbol = text "stg_exports_" <> mod_str export_list = braces $ pprWithCommas closure_ptr hs_fns closure_ptr :: Id -> SDoc closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure" mkHObj :: Type -> SDoc mkHObj t = text "rts_mk" <> text (showFFIType t) unpackHObj :: Type -> SDoc unpackHObj t = text "rts_get" <> text (showFFIType t) showStgType :: Type -> SDoc showStgType t = text "Hs" <> text (showFFIType t) showFFIType :: Type -> String showFFIType t = getOccString (getName (typeTyCon t)) toCType :: Type -> (Maybe Header, SDoc) toCType = f False where f voidOK t -- First, if we have (Ptr t) of (FunPtr t), then we need to -- convert t to a C type and put a * after it. If we don't -- know a type for t, then "void" is fine, though. | Just (ptr, [t']) <- splitTyConApp_maybe t , tyConName ptr `elem` [ptrTyConName, funPtrTyConName] = case f True t' of (mh, cType') -> (mh, cType' <> char '*') -- Otherwise, if we have a type constructor application, then -- see if there is a C type associated with that constructor. -- Note that we aren't looking through type synonyms or -- anything, as it may be the synonym that is annotated. | Just tycon <- tyConAppTyConPicky_maybe t , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon = (mHeader, ftext cType) -- If we don't know a C type for this type, then try looking -- through one layer of type synonym etc. | Just t' <- coreView t = f voidOK t' -- This may be an 'UnliftedFFITypes'-style ByteArray# argument -- (which is marshalled like a Ptr) | Just byteArrayPrimTyCon == tyConAppTyConPicky_maybe t = (Nothing, text "const void*") | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t = (Nothing, text "void*") -- Otherwise we don't know the C type. If we are allowing -- void then return that; otherwise something has gone wrong. | voidOK = (Nothing, text "void") | otherwise = pprPanic "toCType" (ppr t) typeTyCon :: Type -> TyCon typeTyCon ty | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty) = tc | otherwise = pprPanic "GHC.HsToCore.Foreign.Decl.typeTyCon" (ppr ty) insertRetAddr :: Platform -> CCallConv -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)] insertRetAddr platform CCallConv args = case platformArch platform of ArchX86_64 | platformOS platform == OSMinGW32 -> -- On other Windows x86_64 we insert the return address -- after the 4th argument, because this is the point -- at which we need to flush a register argument to the stack -- (See rts/Adjustor.c for details). let go :: Int -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)] go 4 args = ret_addr_arg platform : args go n (arg:args) = arg : go (n+1) args go _ [] = [] in go 0 args | otherwise -> -- On other x86_64 platforms we insert the return address -- after the 6th integer argument, because this is the point -- at which we need to flush a register argument to the stack -- (See rts/Adjustor.c for details). let go :: Int -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)] go 6 args = ret_addr_arg platform : args go n (arg@(_,_,_,rep):args) | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args | otherwise = arg : go n args go _ [] = [] in go 0 args _ -> ret_addr_arg platform : args insertRetAddr _ _ args = args ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType) ret_addr_arg platform = (text "original_return_addr", text "void*", undefined, typeCmmType platform addrPrimTy) -- This function returns the primitive type associated with the boxed -- type argument to a foreign export (eg. Int ==> Int#). getPrimTyOf :: Type -> UnaryType getPrimTyOf ty | isBoolTy rep_ty = intPrimTy -- Except for Bool, the types we are interested in have a single constructor -- with a single primitive-typed argument (see TcType.legalFEArgTyCon). | otherwise = case splitDataProductType_maybe rep_ty of Just (_, _, data_con, [Scaled _ prim_ty]) -> ASSERT(dataConSourceArity data_con == 1) ASSERT2(isUnliftedType prim_ty, ppr prim_ty) prim_ty _other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty) where rep_ty = unwrapType ty -- represent a primitive type as a Char, for building a string that -- described the foreign function type. The types are size-dependent, -- e.g. 'W' is a signed 32-bit integer. primTyDescChar :: Platform -> Type -> Char primTyDescChar platform ty | ty `eqType` unitTy = 'v' | otherwise = case typePrimRep1 (getPrimTyOf ty) of IntRep -> signed_word WordRep -> unsigned_word Int8Rep -> 'B' Word8Rep -> 'b' Int16Rep -> 'S' Word16Rep -> 's' Int32Rep -> 'W' Word32Rep -> 'w' Int64Rep -> 'L' Word64Rep -> 'l' AddrRep -> 'p' FloatRep -> 'f' DoubleRep -> 'd' _ -> pprPanic "primTyDescChar" (ppr ty) where (signed_word, unsigned_word) = case platformWordSize platform of PW4 -> ('W','w') PW8 -> ('L','l')