    {-# 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 :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
    dsForeigns [LForeignDecl GhcTc]
    fos = do
        Hooks
    hooks <- IOEnv (Env DsGblEnv DsLclEnv) Hooks
    forall (m :: * -> *). HasHooks m => m Hooks
    getHooks
        case Hooks -> Maybe DsForeignsHook
    dsForeignsHook Hooks
    hooks of
            Maybe DsForeignsHook
    Nothing -> [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
    dsForeigns' [LForeignDecl GhcTc]
    fos
            Just DsForeignsHook
    h  -> DsForeignsHook
    [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
    -> DsM (ForeignStubs, OrdList Binding)
    h [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
    [LForeignDecl GhcTc]
    fos

    dsForeigns' :: [LForeignDecl GhcTc]
                -> DsM (ForeignStubs, OrdList Binding)
    dsForeigns' :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
    dsForeigns' []
      = (ForeignStubs, OrdList Binding)
    -> DsM (ForeignStubs, OrdList Binding)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ForeignStubs
    NoStubs, OrdList Binding
    forall a. OrdList a
    nilOL)
    dsForeigns' [LForeignDecl GhcTc]
    fos = do
        Module
    mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
    forall (m :: * -> *). HasModule m => m Module
    getModule
        [(CHeader, CStub, [Id], [Binding])]
    fives <- (GenLocated SrcSpanAnnA (ForeignDecl GhcTc)
     -> IOEnv (Env DsGblEnv DsLclEnv) (CHeader, CStub, [Id], [Binding]))
    -> [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
    -> IOEnv
         (Env DsGblEnv DsLclEnv) [(CHeader, CStub, [Id], [Binding])]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM GenLocated SrcSpanAnnA (ForeignDecl GhcTc)
    -> IOEnv (Env DsGblEnv DsLclEnv) (CHeader, CStub, [Id], [Binding])
    forall {a}.
    GenLocated (SrcSpanAnn' a) (ForeignDecl GhcTc)
    -> IOEnv (Env DsGblEnv DsLclEnv) (CHeader, CStub, [Id], [Binding])
    do_ldecl [GenLocated SrcSpanAnnA (ForeignDecl GhcTc)]
    [LForeignDecl GhcTc]
    fos
        let
            ([CHeader]
    hs, [CStub]
    cs, [[Id]]
    idss, [[Binding]]
    bindss) = [(CHeader, CStub, [Id], [Binding])]
    -> ([CHeader], [CStub], [[Id]], [[Binding]])
    forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
    unzip4 [(CHeader, CStub, [Id], [Binding])]
    fives
            fe_ids :: [Id]
    fe_ids = [[Id]] -> [Id]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Id]]
    idss
            fe_init_code :: CStub
    fe_init_code = Module -> [Id] -> CStub
    foreignExportsInitialiser Module
    mod [Id]
    fe_ids
        --
        (ForeignStubs, OrdList Binding)
    -> DsM (ForeignStubs, OrdList Binding)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CHeader -> CStub -> ForeignStubs
    ForeignStubs
                 ([CHeader] -> CHeader
    forall a. Monoid a => [a] -> a
    mconcat [CHeader]
    hs)
                 ([CStub] -> CStub
    forall a. Monoid a => [a] -> a
    mconcat [CStub]
    cs CStub -> CStub -> CStub
    forall a. Monoid a => a -> a -> a
    `mappend` CStub
    fe_init_code),
                ([Binding] -> OrdList Binding -> OrdList Binding)
    -> OrdList Binding -> [[Binding]] -> OrdList Binding
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (OrdList Binding -> OrdList Binding -> OrdList Binding
    forall a. OrdList a -> OrdList a -> OrdList a
    appOL (OrdList Binding -> OrdList Binding -> OrdList Binding)
    -> ([Binding] -> OrdList Binding)
    -> [Binding]
    -> OrdList Binding
    -> OrdList Binding
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Binding] -> OrdList Binding
    forall a. [a] -> OrdList a
    toOL) OrdList Binding
    forall a. OrdList a
    nilOL [[Binding]]
    bindss)
      where
       do_ldecl :: GenLocated (SrcSpanAnn' a) (ForeignDecl GhcTc)
    -> IOEnv (Env DsGblEnv DsLclEnv) (CHeader, CStub, [Id], [Binding])
    do_ldecl (L SrcSpanAnn' a
    loc ForeignDecl GhcTc
    decl) = SrcSpan
    -> IOEnv (Env DsGblEnv DsLclEnv) (CHeader, CStub, [Id], [Binding])
    -> IOEnv (Env DsGblEnv DsLclEnv) (CHeader, CStub, [Id], [Binding])
    forall a. SrcSpan -> DsM a -> DsM a
    putSrcSpanDs (SrcSpanAnn' a -> SrcSpan
    forall a. SrcSpanAnn' a -> SrcSpan
    locA SrcSpanAnn' a
    loc) (ForeignDecl GhcTc
    -> IOEnv (Env DsGblEnv DsLclEnv) (CHeader, CStub, [Id], [Binding])
    do_decl ForeignDecl GhcTc
    decl)

       do_decl :: ForeignDecl GhcTc -> DsM (CHeader, CStub, [Id], [Binding])
       do_decl :: ForeignDecl GhcTc
    -> IOEnv (Env DsGblEnv DsLclEnv) (CHeader, CStub, [Id], [Binding])
    do_decl (ForeignImport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
    fd_name = LIdP GhcTc
    id, fd_i_ext :: forall pass. ForeignDecl pass -> XForeignImport pass
    fd_i_ext = XForeignImport GhcTc
    co, fd_fi :: forall pass. ForeignDecl pass -> ForeignImport
    fd_fi = ForeignImport
    spec }) = do
          SDoc -> TcRnIf DsGblEnv DsLclEnv ()
    forall m n. SDoc -> TcRnIf m n ()
    traceIf (String -> SDoc
    text String
    "fi start" SDoc -> SDoc -> SDoc
    <+> GenLocated SrcSpanAnnN Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr GenLocated SrcSpanAnnN Id
    LIdP GhcTc
    id)
          let id' :: Id
    id' = GenLocated SrcSpanAnnN Id -> Id
    forall l e. GenLocated l e -> e
    unLoc GenLocated SrcSpanAnnN Id
    LIdP GhcTc
    id
          ([Binding]
    bs, CHeader
    h, CStub
    c) <- Id -> Coercion -> ForeignImport -> DsM ([Binding], CHeader, CStub)
    dsFImport Id
    id' Coercion
    XForeignImport GhcTc
    co ForeignImport
    spec
          SDoc -> TcRnIf DsGblEnv DsLclEnv ()
    forall m n. SDoc -> TcRnIf m n ()
    traceIf (String -> SDoc
    text String
    "fi end" SDoc -> SDoc -> SDoc
    <+> GenLocated SrcSpanAnnN Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr GenLocated SrcSpanAnnN Id
    LIdP GhcTc
    id)
          (CHeader, CStub, [Id], [Binding])
    -> IOEnv (Env DsGblEnv DsLclEnv) (CHeader, CStub, [Id], [Binding])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CHeader
    h, CStub
    c, [], [Binding]
    bs)

       do_decl (ForeignExport { fd_name :: forall pass. ForeignDecl pass -> LIdP pass
    fd_name = L SrcSpanAnnN
    _ Id
    id
                              , fd_e_ext :: forall pass. ForeignDecl pass -> XForeignExport pass
    fd_e_ext = XForeignExport GhcTc
    co
                              , fd_fe :: forall pass. ForeignDecl pass -> ForeignExport
    fd_fe = CExport
                                  (L SrcSpan
    _ (CExportStatic SourceText
    _ CLabelString
    ext_nm CCallConv
    cconv)) Located SourceText
    _ }) = do
          (CHeader
    h, CStub
    c, String
    _, Arity
    _) <- Id
    -> Coercion
    -> CLabelString
    -> CCallConv
    -> Bool
    -> DsM (CHeader, CStub, String, Arity)
    dsFExport Id
    id Coercion
    XForeignExport GhcTc
    co CLabelString
    ext_nm CCallConv
    cconv Bool
    False
          (CHeader, CStub, [Id], [Binding])
    -> IOEnv (Env DsGblEnv DsLclEnv) (CHeader, CStub, [Id], [Binding])
    forall (m :: * -> *) a. Monad m => a -> m a
    return (CHeader
    h, CStub
    c, [Id
    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 -> Coercion -> ForeignImport -> DsM ([Binding], CHeader, CStub)
    dsFImport Id
    id Coercion
    co (CImport Located CCallConv
    cconv Located Safety
    safety Maybe Header
    mHeader CImportSpec
    spec Located SourceText
    _) =
        Id
    -> Coercion
    -> CImportSpec
    -> CCallConv
    -> Safety
    -> Maybe Header
    -> DsM ([Binding], CHeader, CStub)
    dsCImport Id
    id Coercion
    co CImportSpec
    spec (Located CCallConv -> CCallConv
    forall l e. GenLocated l e -> e
    unLoc Located CCallConv
    cconv) (Located Safety -> Safety
    forall l e. GenLocated l e -> e
    unLoc Located Safety
    safety) Maybe Header
    mHeader

    dsCImport :: Id
              -> Coercion
              -> CImportSpec
              -> CCallConv
              -> Safety
              -> Maybe Header
              -> DsM ([Binding], CHeader, CStub)
    dsCImport :: Id
    -> Coercion
    -> CImportSpec
    -> CCallConv
    -> Safety
    -> Maybe Header
    -> DsM ([Binding], CHeader, CStub)
    dsCImport Id
    id Coercion
    co (CLabel CLabelString
    cid) CCallConv
    cconv Safety
    _ Maybe Header
    _ = do
       DynFlags
    dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
       let ty :: Type
    ty  = Coercion -> Type
    coercionLKind Coercion
    co
           platform :: Platform
    platform = DynFlags -> Platform
    targetPlatform DynFlags
    dflags
           fod :: FunctionOrData
    fod = case Type -> Maybe TyCon
    tyConAppTyCon_maybe (Type -> Type
    dropForAlls Type
    ty) of
                 Just TyCon
    tycon
                  | TyCon -> Unique
    tyConUnique TyCon
    tycon Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    funPtrTyConKey ->
                     FunctionOrData
    IsFunction
                 Maybe TyCon
    _ -> FunctionOrData
    IsData
       (Maybe Type
    resTy, CoreExpr -> CoreExpr
    foRhs) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
    resultWrapper Type
    ty
       ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
        let
            rhs :: CoreExpr
    rhs = CoreExpr -> CoreExpr
    foRhs (Literal -> CoreExpr
    forall b. Literal -> Expr b
    Lit (CLabelString -> Maybe Arity -> FunctionOrData -> Literal
    LitLabel CLabelString
    cid Maybe Arity
    stdcall_info FunctionOrData
    fod))
            rhs' :: CoreExpr
    rhs' = CoreExpr -> Coercion -> CoreExpr
    forall b. Expr b -> Coercion -> Expr b
    Cast CoreExpr
    rhs Coercion
    co
            stdcall_info :: Maybe Arity
    stdcall_info = Platform -> CCallConv -> Type -> Maybe Arity
    fun_type_arg_stdcall_info Platform
    platform CCallConv
    cconv Type
    ty
        in
        ([Binding], CHeader, CStub) -> DsM ([Binding], CHeader, CStub)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([(Id
    id, CoreExpr
    rhs')], CHeader
    forall a. Monoid a => a
    mempty, CStub
    forall a. Monoid a => a
    mempty)

    dsCImport Id
    id Coercion
    co (CFunction CCallTarget
    target) cconv :: CCallConv
    cconv@CCallConv
    PrimCallConv Safety
    safety Maybe Header
    _
      = Id -> Coercion -> ForeignCall -> DsM ([Binding], CHeader, CStub)
    dsPrimCall Id
    id Coercion
    co (CCallSpec -> ForeignCall
    CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
    CCallSpec CCallTarget
    target CCallConv
    cconv Safety
    safety))
    dsCImport Id
    id Coercion
    co (CFunction CCallTarget
    target) CCallConv
    cconv Safety
    safety Maybe Header
    mHeader
      = Id
    -> Coercion
    -> ForeignCall
    -> Maybe Header
    -> DsM ([Binding], CHeader, CStub)
    dsFCall Id
    id Coercion
    co (CCallSpec -> ForeignCall
    CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
    CCallSpec CCallTarget
    target CCallConv
    cconv Safety
    safety)) Maybe Header
    mHeader
    dsCImport Id
    id Coercion
    co CImportSpec
    CWrapper CCallConv
    cconv Safety
    _ Maybe Header
    _
      = Id -> Coercion -> CCallConv -> DsM ([Binding], CHeader, CStub)
    dsFExportDynamic Id
    id Coercion
    co CCallConv
    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 -> CCallConv -> Type -> Maybe Arity
    fun_type_arg_stdcall_info Platform
    platform CCallConv
    StdCallConv Type
    ty
      | Just (TyCon
    tc,[Type
    arg_ty]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    splitTyConApp_maybe Type
    ty,
        TyCon -> Unique
    tyConUnique TyCon
    tc Unique -> Unique -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unique
    funPtrTyConKey
      = let
           ([TyBinder]
    bndrs, Type
    _) = Type -> ([TyBinder], Type)
    tcSplitPiTys Type
    arg_ty
           fe_arg_tys :: [Type]
    fe_arg_tys = (TyBinder -> Maybe Type) -> [TyBinder] -> [Type]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe TyBinder -> Maybe Type
    binderRelevantType_maybe [TyBinder]
    bndrs
        in Arity -> Maybe Arity
    forall a. a -> Maybe a
    Just (Arity -> Maybe Arity) -> Arity -> Maybe Arity
    forall a b. (a -> b) -> a -> b
    $ [Arity] -> Arity
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum ((Type -> Arity) -> [Type] -> [Arity]
    forall a b. (a -> b) -> [a] -> [b]
    map (Width -> Arity
    widthInBytes (Width -> Arity) -> (Type -> Width) -> Type -> Arity
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . CmmType -> Width
    typeWidth (CmmType -> Width) -> (Type -> CmmType) -> Type -> Width
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Platform -> Type -> CmmType
    typeCmmType Platform
    platform (Type -> CmmType) -> (Type -> Type) -> Type -> CmmType
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> Type
    getPrimTyOf) [Type]
    fe_arg_tys)
    fun_type_arg_stdcall_info Platform
    _ CCallConv
    _other_conv Type
    _
      = Maybe Arity
    forall a. Maybe a
    Nothing

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Foreign calls}
    *                                                                      *
    ************************************************************************
    -}

    dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
            -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
    dsFCall :: Id
    -> Coercion
    -> ForeignCall
    -> Maybe Header
    -> DsM ([Binding], CHeader, CStub)
    dsFCall Id
    fn_id Coercion
    co ForeignCall
    fcall Maybe Header
    mDeclHeader = do
        let
            ty :: Type
    ty                   = Coercion -> Type
    coercionLKind Coercion
    co
            ([TyVarBinder]
    tv_bndrs, Type
    rho)      = Type -> ([TyVarBinder], Type)
    tcSplitForAllTyVarBinders Type
    ty
            ([Scaled Type]
    arg_tys, Type
    io_res_ty) = Type -> ([Scaled Type], Type)
    tcSplitFunTys Type
    rho

        [Id]
    args <- [Scaled Type] -> DsM [Id]
    newSysLocalsDs [Scaled Type]
    arg_tys  -- no FFI levity-polymorphism
        ([CoreExpr]
    val_args, [CoreExpr -> CoreExpr]
    arg_wrappers) <- (CoreExpr
     -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr))
    -> [CoreExpr]
    -> IOEnv
         (Env DsGblEnv DsLclEnv) ([CoreExpr], [CoreExpr -> CoreExpr])
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> m (b, c)) -> [a] -> m ([b], [c])
    mapAndUnzipM CoreExpr
    -> IOEnv (Env DsGblEnv DsLclEnv) (CoreExpr, CoreExpr -> CoreExpr)
    unboxArg ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> CoreExpr
    forall b. Id -> Expr b
    Var [Id]
    args)

        let
            work_arg_ids :: [Id]
    work_arg_ids  = [Id
    v | Var Id
    v <- [CoreExpr]
    val_args] -- All guaranteed to be vars

        (Type
    ccall_result_ty, CoreExpr -> CoreExpr
    res_wrapper) <- Type -> DsM (Type, CoreExpr -> CoreExpr)
    boxResult Type
    io_res_ty

        Unique
    ccall_uniq <- TcRnIf DsGblEnv DsLclEnv Unique
    forall gbl lcl. TcRnIf gbl lcl Unique
    newUnique
        Unique
    work_uniq  <- TcRnIf DsGblEnv DsLclEnv Unique
    forall gbl lcl. TcRnIf gbl lcl Unique
    newUnique

        DynFlags
    dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        (ForeignCall
    fcall', SDoc
    cDoc) <-
                  case ForeignCall
    fcall of
                  CCall (CCallSpec (StaticTarget SourceText
    _ CLabelString
    cName Maybe Unit
    mUnitId Bool
    isFun)
                                   CCallConv
    CApiConv Safety
    safety) ->
                   do CLabelString
    wrapperName <- String -> String -> IOEnv (Env DsGblEnv DsLclEnv) CLabelString
    forall (m :: * -> *).
    (MonadIO m, HasDynFlags m, HasModule m) =>
    String -> String -> m CLabelString
    mkWrapperName String
    "ghc_wrapper" (CLabelString -> String
    unpackFS CLabelString
    cName)
                      let fcall' :: ForeignCall
    fcall' = CCallSpec -> ForeignCall
    CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
    CCallSpec
                                          (SourceText -> CLabelString -> Maybe Unit -> Bool -> CCallTarget
    StaticTarget SourceText
    NoSourceText
                                                        CLabelString
    wrapperName Maybe Unit
    mUnitId
                                                        Bool
    True)
                                          CCallConv
    CApiConv Safety
    safety)
                          c :: SDoc
    c = SDoc
    includes
                           SDoc -> SDoc -> SDoc
    $$ SDoc
    fun_proto SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    braces (SDoc
    cRet SDoc -> SDoc -> SDoc
    <> SDoc
    semi)
                          includes :: SDoc
    includes = [SDoc] -> SDoc
    vcat [ String -> SDoc
    text String
    "#include \"" SDoc -> SDoc -> SDoc
    <> CLabelString -> SDoc
    ftext CLabelString
    h
                                            SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    "\""
                                          | Header SourceText
    _ CLabelString
    h <- [Header] -> [Header]
    forall a. Eq a => [a] -> [a]
    nub [Header]
    headers ]
                          fun_proto :: SDoc
    fun_proto = SDoc
    cResType SDoc -> SDoc -> SDoc
    <+> SDoc
    pprCconv SDoc -> SDoc -> SDoc
    <+> CLabelString -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CLabelString
    wrapperName SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    parens SDoc
    argTypes
                          cRet :: SDoc
    cRet
                           | Bool
    isVoidRes =                   SDoc
    cCall
                           | Bool
    otherwise = String -> SDoc
    text String
    "return" SDoc -> SDoc -> SDoc
    <+> SDoc
    cCall
                          cCall :: SDoc
    cCall = if Bool
    isFun
                                  then CLabelString -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CLabelString
    cName SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    parens SDoc
    argVals
                                  else if [Scaled Type] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Scaled Type]
    arg_tys
                                        then CLabelString -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CLabelString
    cName
                                        else String -> SDoc
    forall a. String -> a
    panic String
    "dsFCall: Unexpected arguments to FFI value import"
                          raw_res_ty :: Type
    raw_res_ty = case Type -> Maybe (TyCon, Type)
    tcSplitIOType_maybe Type
    io_res_ty of
                                       Just (TyCon
    _ioTyCon, Type
    res_ty) -> Type
    res_ty
                                       Maybe (TyCon, Type)
    Nothing                 -> Type
    io_res_ty
                          isVoidRes :: Bool
    isVoidRes = Type
    raw_res_ty Type -> Type -> Bool
    `eqType` Type
    unitTy
                          (Maybe Header
    mHeader, SDoc
    cResType)
                           | Bool
    isVoidRes = (Maybe Header
    forall a. Maybe a
    Nothing, String -> SDoc
    text String
    "void")
                           | Bool
    otherwise = Type -> (Maybe Header, SDoc)
    toCType Type
    raw_res_ty
                          pprCconv :: SDoc
    pprCconv = CCallConv -> SDoc
    ccallConvAttribute CCallConv
    CApiConv
                          mHeadersArgTypeList :: [(Maybe Header, SDoc)]
    mHeadersArgTypeList
                              = [ (Maybe Header
    header, SDoc
    cType SDoc -> SDoc -> SDoc
    <+> Char -> SDoc
    char Char
    'a' SDoc -> SDoc -> SDoc
    <> Arity -> SDoc
    int Arity
    n)
                                | (Scaled Type
    t, Arity
    n) <- [Scaled Type] -> [Arity] -> [(Scaled Type, Arity)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Scaled Type]
    arg_tys [Arity
    1..]
                                , let (Maybe Header
    header, SDoc
    cType) = Type -> (Maybe Header, SDoc)
    toCType (Scaled Type -> Type
    forall a. Scaled a -> a
    scaledThing Scaled Type
    t) ]
                          ([Maybe Header]
    mHeaders, [SDoc]
    argTypeList) = [(Maybe Header, SDoc)] -> ([Maybe Header], [SDoc])
    forall a b. [(a, b)] -> ([a], [b])
    unzip [(Maybe Header, SDoc)]
    mHeadersArgTypeList
                          argTypes :: SDoc
    argTypes = if [SDoc] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [SDoc]
    argTypeList
                                     then String -> SDoc
    text String
    "void"
                                     else [SDoc] -> SDoc
    hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> [SDoc] -> [SDoc]
    punctuate SDoc
    comma [SDoc]
    argTypeList
                          mHeaders' :: [Maybe Header]
    mHeaders' = Maybe Header
    mDeclHeader Maybe Header -> [Maybe Header] -> [Maybe Header]
    forall a. a -> [a] -> [a]
    : Maybe Header
    mHeader Maybe Header -> [Maybe Header] -> [Maybe Header]
    forall a. a -> [a] -> [a]
    : [Maybe Header]
    mHeaders
                          headers :: [Header]
    headers = [Maybe Header] -> [Header]
    forall a. [Maybe a] -> [a]
    catMaybes [Maybe Header]
    mHeaders'
                          argVals :: SDoc
    argVals = [SDoc] -> SDoc
    hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> [SDoc] -> [SDoc]
    punctuate SDoc
    comma
                                        [ Char -> SDoc
    char Char
    'a' SDoc -> SDoc -> SDoc
    <> Arity -> SDoc
    int Arity
    n
                                        | (Scaled Type
    _, Arity
    n) <- [Scaled Type] -> [Arity] -> [(Scaled Type, Arity)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Scaled Type]
    arg_tys [Arity
    1..] ]
                      (ForeignCall, SDoc)
    -> IOEnv (Env DsGblEnv DsLclEnv) (ForeignCall, SDoc)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ForeignCall
    fcall', SDoc
    c)
                  ForeignCall
    _ ->
                      (ForeignCall, SDoc)
    -> IOEnv (Env DsGblEnv DsLclEnv) (ForeignCall, SDoc)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ForeignCall
    fcall, SDoc
    empty)
        let
            -- Build the worker
            worker_ty :: Type
    worker_ty     = [TyVarBinder] -> Type -> Type
    mkForAllTys [TyVarBinder]
    tv_bndrs ([Type] -> Type -> Type
    mkVisFunTysMany ((Id -> Type) -> [Id] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> Type
    idType [Id]
    work_arg_ids) Type
    ccall_result_ty)
            tvs :: [Id]
    tvs           = (TyVarBinder -> Id) -> [TyVarBinder] -> [Id]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBinder -> Id
    forall tv argf. VarBndr tv argf -> tv
    binderVar [TyVarBinder]
    tv_bndrs
            the_ccall_app :: CoreExpr
    the_ccall_app = DynFlags -> Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
    mkFCall DynFlags
    dflags Unique
    ccall_uniq ForeignCall
    fcall' [CoreExpr]
    val_args Type
    ccall_result_ty
            work_rhs :: CoreExpr
    work_rhs      = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id]
    tvs ([Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id]
    work_arg_ids CoreExpr
    the_ccall_app)
            work_id :: Id
    work_id       = CLabelString -> Unique -> Type -> Type -> Id
    mkSysLocal (String -> CLabelString
    fsLit String
    "$wccall") Unique
    work_uniq Type
    Many Type
    worker_ty

            -- Build the wrapper
            work_app :: CoreExpr
    work_app     = CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (CoreExpr -> [Id] -> CoreExpr
    forall b. Expr b -> [Id] -> Expr b
    mkVarApps (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    work_id) [Id]
    tvs) [CoreExpr]
    val_args
            wrapper_body :: CoreExpr
    wrapper_body = ((CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
    -> CoreExpr -> [CoreExpr -> CoreExpr] -> CoreExpr
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    ($) (CoreExpr -> CoreExpr
    res_wrapper CoreExpr
    work_app) [CoreExpr -> CoreExpr]
    arg_wrappers
            wrap_rhs :: CoreExpr
    wrap_rhs     = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams ([Id]
    tvs [Id] -> [Id] -> [Id]
    forall a. [a] -> [a] -> [a]
    ++ [Id]
    args) CoreExpr
    wrapper_body
            wrap_rhs' :: CoreExpr
    wrap_rhs'    = CoreExpr -> Coercion -> CoreExpr
    forall b. Expr b -> Coercion -> Expr b
    Cast CoreExpr
    wrap_rhs Coercion
    co
            simpl_opts :: SimpleOpts
    simpl_opts   = DynFlags -> SimpleOpts
    initSimpleOpts DynFlags
    dflags
            fn_id_w_inl :: Id
    fn_id_w_inl  = Id
    fn_id Id -> Unfolding -> Id
    `setIdUnfolding` Arity -> SimpleOpts -> CoreExpr -> Unfolding
    mkInlineUnfoldingWithArity
                                                    ([Id] -> Arity
    forall (t :: * -> *) a. Foldable t => t a -> Arity
    length [Id]
    args)
                                                    SimpleOpts
    simpl_opts
                                                    CoreExpr
    wrap_rhs'

        ([Binding], CHeader, CStub) -> DsM ([Binding], CHeader, CStub)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([(Id
    work_id, CoreExpr
    work_rhs), (Id
    fn_id_w_inl, CoreExpr
    wrap_rhs')], CHeader
    forall a. Monoid a => a
    mempty, SDoc -> CStub
    CStub SDoc
    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 :: Id -> Coercion -> ForeignCall -> DsM ([Binding], CHeader, CStub)
    dsPrimCall Id
    fn_id Coercion
    co ForeignCall
    fcall = do
        let
            ty :: Type
    ty                   = Coercion -> Type
    coercionLKind Coercion
    co
            ([Id]
    tvs, Type
    fun_ty)        = Type -> ([Id], Type)
    tcSplitForAllInvisTyVars Type
    ty
            ([Scaled Type]
    arg_tys, Type
    io_res_ty) = Type -> ([Scaled Type], Type)
    tcSplitFunTys Type
    fun_ty

        [Id]
    args <- [Scaled Type] -> DsM [Id]
    newSysLocalsDs [Scaled Type]
    arg_tys  -- no FFI levity-polymorphism

        Unique
    ccall_uniq <- TcRnIf DsGblEnv DsLclEnv Unique
    forall gbl lcl. TcRnIf gbl lcl Unique
    newUnique
        DynFlags
    dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        let
            call_app :: CoreExpr
    call_app = DynFlags -> Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
    mkFCall DynFlags
    dflags Unique
    ccall_uniq ForeignCall
    fcall ((Id -> CoreExpr) -> [Id] -> [CoreExpr]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> CoreExpr
    forall b. Id -> Expr b
    Var [Id]
    args) Type
    io_res_ty
            rhs :: CoreExpr
    rhs      = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id]
    tvs ([Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id]
    args CoreExpr
    call_app)
            rhs' :: CoreExpr
    rhs'     = CoreExpr -> Coercion -> CoreExpr
    forall b. Expr b -> Coercion -> Expr b
    Cast CoreExpr
    rhs Coercion
    co
        ([Binding], CHeader, CStub) -> DsM ([Binding], CHeader, CStub)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([(Id
    fn_id, CoreExpr
    rhs')], CHeader
    forall a. Monoid a => a
    mempty, CStub
    forall a. Monoid a => a
    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 :: Id
    -> Coercion
    -> CLabelString
    -> CCallConv
    -> Bool
    -> DsM (CHeader, CStub, String, Arity)
    dsFExport Id
    fn_id Coercion
    co CLabelString
    ext_name CCallConv
    cconv Bool
    isDyn = do
        let
           ty :: Type
    ty                     = Coercion -> Type
    coercionRKind Coercion
    co
           ([TyBinder]
    bndrs, Type
    orig_res_ty)   = Type -> ([TyBinder], Type)
    tcSplitPiTys Type
    ty
           fe_arg_tys' :: [Type]
    fe_arg_tys'            = (TyBinder -> Maybe Type) -> [TyBinder] -> [Type]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe TyBinder -> Maybe Type
    binderRelevantType_maybe [TyBinder]
    bndrs
           -- We must use tcSplits here, because we want to see
           -- the (IO t) in the corner of the type!
           fe_arg_tys :: [Type]
    fe_arg_tys | Bool
    isDyn     = [Type] -> [Type]
    forall a. [a] -> [a]
    tail [Type]
    fe_arg_tys'
                      | Bool
    otherwise = [Type]
    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)
           (Type
    res_ty, Bool
    is_IO_res_ty) = case Type -> Maybe (TyCon, Type)
    tcSplitIOType_maybe Type
    orig_res_ty of
                                    -- The function already returns IO t
                                    Just (TyCon
    _ioTyCon, Type
    res_ty) -> (Type
    res_ty, Bool
    True)
                                    -- The function returns t
                                    Maybe (TyCon, Type)
    Nothing                 -> (Type
    orig_res_ty, Bool
    False)

        DynFlags
    dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        (CHeader, CStub, String, Arity)
    -> DsM (CHeader, CStub, String, Arity)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ((CHeader, CStub, String, Arity)
     -> DsM (CHeader, CStub, String, Arity))
    -> (CHeader, CStub, String, Arity)
    -> DsM (CHeader, CStub, String, Arity)
    forall a b. (a -> b) -> a -> b
    $
          DynFlags
    -> CLabelString
    -> Maybe Id
    -> [Type]
    -> Type
    -> Bool
    -> CCallConv
    -> (CHeader, CStub, String, Arity)
    mkFExportCBits DynFlags
    dflags CLabelString
    ext_name
                         (if Bool
    isDyn then Maybe Id
    forall a. Maybe a
    Nothing else Id -> Maybe Id
    forall a. a -> Maybe a
    Just Id
    fn_id)
                         [Type]
    fe_arg_tys Type
    res_ty Bool
    is_IO_res_ty CCallConv
    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'' <arg info> 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 -> Coercion -> CCallConv -> DsM ([Binding], CHeader, CStub)
    dsFExportDynamic Id
    id Coercion
    co0 CCallConv
    cconv = do
        Module
    mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
    forall (m :: * -> *). HasModule m => m Module
    getModule
        DynFlags
    dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        let platform :: Platform
    platform = DynFlags -> Platform
    targetPlatform DynFlags
    dflags
        let fe_nm :: CLabelString
    fe_nm = String -> CLabelString
    mkFastString (String -> CLabelString) -> String -> CLabelString
    forall a b. (a -> b) -> a -> b
    $ String -> String
    zEncodeString
                (Module -> String
    moduleStableString Module
    mod String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "$" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ DynFlags -> Id -> String
    toCName DynFlags
    dflags Id
    id)
            -- Construct the label based on the passed id, don't use names
            -- depending on Unique. See #13807 and Note [Unique Determinism].
        Id
    cback <- Type -> Type -> DsM Id
    newSysLocalDs Type
    arg_mult Type
    arg_ty
        Id
    newStablePtrId <- Name -> DsM Id
    dsLookupGlobalId Name
    newStablePtrName
        TyCon
    stable_ptr_tycon <- Name -> DsM TyCon
    dsLookupTyCon Name
    stablePtrTyConName
        let
            stable_ptr_ty :: Type
    stable_ptr_ty = TyCon -> [Type] -> Type
    mkTyConApp TyCon
    stable_ptr_tycon [Type
    arg_ty]
            export_ty :: Type
    export_ty     = Type -> Type -> Type
    mkVisFunTyMany Type
    stable_ptr_ty Type
    arg_ty
        Id
    bindIOId <- Name -> DsM Id
    dsLookupGlobalId Name
    bindIOName
        Id
    stbl_value <- Type -> Type -> DsM Id
    newSysLocalDs Type
    Many Type
    stable_ptr_ty
        (CHeader
    h_code, CStub
    c_code, String
    typestring, Arity
    args_size) <- Id
    -> Coercion
    -> CLabelString
    -> CCallConv
    -> Bool
    -> DsM (CHeader, CStub, String, Arity)
    dsFExport Id
    id (Type -> Coercion
    mkRepReflCo Type
    export_ty) CLabelString
    fe_nm CCallConv
    cconv Bool
    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 :: [CoreExpr]
    adj_args      = [ Platform -> Integer -> CoreExpr
    forall b. Platform -> Integer -> Expr b
    mkIntLit Platform
    platform (Arity -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (CCallConv -> Arity
    ccallConvToInt CCallConv
    cconv))
                            , Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    stbl_value
                            , Literal -> CoreExpr
    forall b. Literal -> Expr b
    Lit (CLabelString -> Maybe Arity -> FunctionOrData -> Literal
    LitLabel CLabelString
    fe_nm Maybe Arity
    mb_sz_args FunctionOrData
    IsFunction)
                            , Literal -> CoreExpr
    forall b. Literal -> Expr b
    Lit (String -> Literal
    mkLitString String
    typestring)
                            ]
              -- name of external entry point providing these services.
              -- (probably in the RTS.)
            adjustor :: CLabelString
    adjustor   = String -> CLabelString
    fsLit String
    "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 :: Maybe Arity
    mb_sz_args = case CCallConv
    cconv of
                            CCallConv
    StdCallConv -> Arity -> Maybe Arity
    forall a. a -> Maybe a
    Just Arity
    args_size
                            CCallConv
    _           -> Maybe Arity
    forall a. Maybe a
    Nothing

        CoreExpr
    ccall_adj <- CLabelString -> [CoreExpr] -> Safety -> Type -> DsM CoreExpr
    dsCCall CLabelString
    adjustor [CoreExpr]
    adj_args Safety
    PlayRisky (TyCon -> [Type] -> Type
    mkTyConApp TyCon
    io_tc [Type
    res_ty])
            -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback

        let io_app :: CoreExpr
    io_app = [Id] -> CoreExpr -> CoreExpr
    forall b. [b] -> Expr b -> Expr b
    mkLams [Id]
    tvs                  (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                     Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    cback                   (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
    forall a b. (a -> b) -> a -> b
    $
                     CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    bindIOId)
                            [ Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    stable_ptr_ty
                            , Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    res_ty
                            , CoreExpr -> [CoreExpr] -> CoreExpr
    forall b. Expr b -> [Expr b] -> Expr b
    mkApps (Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    newStablePtrId) [ Type -> CoreExpr
    forall b. Type -> Expr b
    Type Type
    arg_ty, Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    cback ]
                            , Id -> CoreExpr -> CoreExpr
    forall b. b -> Expr b -> Expr b
    Lam Id
    stbl_value CoreExpr
    ccall_adj
                            ]

            fed :: Binding
    fed = (Id
    id Id -> Activation -> Id
    `setInlineActivation` Activation
    NeverActive, CoreExpr -> Coercion -> CoreExpr
    forall b. Expr b -> Coercion -> Expr b
    Cast CoreExpr
    io_app Coercion
    co0)
                   -- Never inline the f.e.d. function, because the litlit
                   -- might not be in scope in other modules.

        ([Binding], CHeader, CStub) -> DsM ([Binding], CHeader, CStub)
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Binding
    fed], CHeader
    h_code, CStub
    c_code)

     where
      ty :: Type
    ty                       = Coercion -> Type
    coercionLKind Coercion
    co0
      ([Id]
    tvs,Type
    sans_foralls)       = Type -> ([Id], Type)
    tcSplitForAllInvisTyVars Type
    ty
      ([Scaled Type
    arg_mult Type
    arg_ty], Type
    fn_res_ty)    = Type -> ([Scaled Type], Type)
    tcSplitFunTys Type
    sans_foralls
      Just (TyCon
    io_tc, Type
    res_ty)     = Type -> Maybe (TyCon, Type)
    tcSplitIOType_maybe Type
    fn_res_ty
            -- Must have an IO type; hence Just

    toCName :: DynFlags -> Id -> String
    toCName :: DynFlags -> Id -> String
    toCName DynFlags
    dflags Id
    i = DynFlags -> SDoc -> String
    showSDoc DynFlags
    dflags (LabelStyle -> SDoc -> SDoc
    pprCode LabelStyle
    CStyle (Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Id -> Name
    idName Id
    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 :: DynFlags
    -> CLabelString
    -> Maybe Id
    -> [Type]
    -> Type
    -> Bool
    -> CCallConv
    -> (CHeader, CStub, String, Arity)
    mkFExportCBits DynFlags
    dflags CLabelString
    c_nm Maybe Id
    maybe_target [Type]
    arg_htys Type
    res_hty Bool
    is_IO_res_ty CCallConv
    cc
     = (CHeader
    header_bits, CStub
    c_bits, String
    type_string,
        [Arity] -> Arity
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum [ Width -> Arity
    widthInBytes (CmmType -> Width
    typeWidth CmmType
    rep) | (SDoc
    _,SDoc
    _,Type
    _,CmmType
    rep) <- [(SDoc, SDoc, Type, CmmType)]
    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 :: Platform
    platform = DynFlags -> Platform
    targetPlatform DynFlags
    dflags

      -- list the arguments to the C function
      arg_info :: [(SDoc,           -- arg name
                    SDoc,           -- C type
                    Type,           -- Haskell type
                    CmmType)]       -- the CmmType
      arg_info :: [(SDoc, SDoc, Type, CmmType)]
    arg_info  = [ let stg_type :: SDoc
    stg_type = Type -> SDoc
    showStgType Type
    ty in
                    (Arity -> SDoc -> SDoc
    arg_cname Arity
    n SDoc
    stg_type,
                     SDoc
    stg_type,
                     Type
    ty,
                    Platform -> Type -> CmmType
    typeCmmType Platform
    platform (Type -> Type
    getPrimTyOf Type
    ty))
                  | (Type
    ty,Arity
    n) <- [Type] -> [Arity] -> [(Type, Arity)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Type]
    arg_htys [Arity
    1::Int ..] ]

      arg_cname :: Arity -> SDoc -> SDoc
    arg_cname Arity
    n SDoc
    stg_ty
            | Bool
    libffi    = Char -> SDoc
    char Char
    '*' SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    parens (SDoc
    stg_ty SDoc -> SDoc -> SDoc
    <> Char -> SDoc
    char Char
    '*') SDoc -> SDoc -> SDoc
    <>
                          String -> SDoc
    text String
    "args" SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    brackets (Arity -> SDoc
    int (Arity
    nArity -> Arity -> Arity
    forall a. Num a => a -> a -> a
    -Arity
    1))
            | Bool
    otherwise = String -> SDoc
    text (Char
    'a'Char -> String -> String
    forall a. a -> [a] -> [a]
    :Arity -> String
    forall a. Show a => a -> String
    show Arity
    n)

      -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
      libffi :: Bool
    libffi = PlatformMisc -> Bool
    platformMisc_libFFI (DynFlags -> PlatformMisc
    platformMisc DynFlags
    dflags) Bool -> Bool -> Bool
    && Maybe Id -> Bool
    forall a. Maybe a -> Bool
    isNothing Maybe Id
    maybe_target

      type_string :: String
    type_string
          -- libffi needs to know the result type too:
          | Bool
    libffi    = Platform -> Type -> Char
    primTyDescChar Platform
    platform Type
    res_hty Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    arg_type_string
          | Bool
    otherwise = String
    arg_type_string

      arg_type_string :: String
    arg_type_string = [Platform -> Type -> Char
    primTyDescChar Platform
    platform Type
    ty | (SDoc
    _,SDoc
    _,Type
    ty,CmmType
    _) <- [(SDoc, SDoc, Type, CmmType)]
    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 :: [(SDoc, SDoc, Type, CmmType)]
    aug_arg_info
        | Maybe Id -> Bool
    forall a. Maybe a -> Bool
    isNothing Maybe Id
    maybe_target = (SDoc, SDoc, Type, CmmType)
    stable_ptr_arg (SDoc, SDoc, Type, CmmType)
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    forall a. a -> [a] -> [a]
    : Platform
    -> CCallConv
    -> [(SDoc, SDoc, Type, CmmType)]
    -> [(SDoc, SDoc, Type, CmmType)]
    insertRetAddr Platform
    platform CCallConv
    cc [(SDoc, SDoc, Type, CmmType)]
    arg_info
        | Bool
    otherwise              = [(SDoc, SDoc, Type, CmmType)]
    arg_info

      stable_ptr_arg :: (SDoc, SDoc, Type, CmmType)
    stable_ptr_arg =
            (String -> SDoc
    text String
    "the_stableptr", String -> SDoc
    text String
    "StgStablePtr", Type
    forall a. HasCallStack => a
    undefined,
             Platform -> Type -> CmmType
    typeCmmType Platform
    platform (Type -> Type
    mkStablePtrPrimTy Type
    alphaTy))

      -- stuff to do with the return type of the C function
      res_hty_is_unit :: Bool
    res_hty_is_unit = Type
    res_hty Type -> Type -> Bool
    `eqType` Type
    unitTy     -- Look through any newtypes

      cResType :: SDoc
    cResType | Bool
    res_hty_is_unit = String -> SDoc
    text String
    "void"
               | Bool
    otherwise       = Type -> SDoc
    showStgType Type
    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 :: SDoc
    ffi_cResType
         | Bool
    is_ffi_arg_type = String -> SDoc
    text String
    "ffi_arg"
         | Bool
    otherwise       = SDoc
    cResType
         where
           res_ty_key :: Unique
    res_ty_key = Name -> Unique
    forall a. Uniquable a => a -> Unique
    getUnique (TyCon -> Name
    forall a. NamedThing a => a -> Name
    getName (Type -> TyCon
    typeTyCon Type
    res_hty))
           is_ffi_arg_type :: Bool
    is_ffi_arg_type = Unique
    res_ty_key Unique -> [Unique] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `notElem`
                  [Unique
    floatTyConKey, Unique
    doubleTyConKey,
                   Unique
    int64TyConKey, Unique
    word64TyConKey]

      -- Now we can cook up the prototype for the exported function.
      pprCconv :: SDoc
    pprCconv = CCallConv -> SDoc
    ccallConvAttribute CCallConv
    cc

      header_bits :: CHeader
    header_bits = SDoc -> CHeader
    CHeader (String -> SDoc
    text String
    "extern" SDoc -> SDoc -> SDoc
    <+> SDoc
    fun_proto SDoc -> SDoc -> SDoc
    <> SDoc
    semi)

      fun_args :: SDoc
    fun_args
        | [(SDoc, SDoc, Type, CmmType)] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [(SDoc, SDoc, Type, CmmType)]
    aug_arg_info = String -> SDoc
    text String
    "void"
        | Bool
    otherwise         = [SDoc] -> SDoc
    hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> [SDoc] -> [SDoc]
    punctuate SDoc
    comma
                                   ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
    forall a b. (a -> b) -> a -> b
    $ ((SDoc, SDoc, Type, CmmType) -> SDoc)
    -> [(SDoc, SDoc, Type, CmmType)] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(SDoc
    nm,SDoc
    ty,Type
    _,CmmType
    _) -> SDoc
    ty SDoc -> SDoc -> SDoc
    <+> SDoc
    nm) [(SDoc, SDoc, Type, CmmType)]
    aug_arg_info

      fun_proto :: SDoc
    fun_proto
        | Bool
    libffi
          = String -> SDoc
    text String
    "void" SDoc -> SDoc -> SDoc
    <+> CLabelString -> SDoc
    ftext CLabelString
    c_nm SDoc -> SDoc -> SDoc
    <>
              SDoc -> SDoc
    parens (String -> SDoc
    text String
    "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
        | Bool
    otherwise
          = SDoc
    cResType SDoc -> SDoc -> SDoc
    <+> SDoc
    pprCconv SDoc -> SDoc -> SDoc
    <+> CLabelString -> SDoc
    ftext CLabelString
    c_nm SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    parens SDoc
    fun_args

      -- the target which will form the root of what we ask rts_inCall to run
      the_cfun :: SDoc
    the_cfun
         = case Maybe Id
    maybe_target of
              Maybe Id
    Nothing    -> String -> SDoc
    text String
    "(StgClosure*)deRefStablePtr(the_stableptr)"
              Just Id
    hs_fn -> Char -> SDoc
    char Char
    '&' SDoc -> SDoc -> SDoc
    <> Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    hs_fn SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    "_closure"

      cap :: SDoc
    cap = String -> SDoc
    text String
    "cap" SDoc -> SDoc -> SDoc
    <> SDoc
    comma

      -- the expression we give to rts_inCall
      expr_to_run :: SDoc
    expr_to_run
         = (SDoc -> (SDoc, SDoc, Type, CmmType) -> SDoc)
    -> SDoc -> [(SDoc, SDoc, Type, CmmType)] -> SDoc
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' SDoc -> (SDoc, SDoc, Type, CmmType) -> SDoc
    forall {b} {d}. SDoc -> (SDoc, b, Type, d) -> SDoc
    appArg SDoc
    the_cfun [(SDoc, SDoc, Type, CmmType)]
    arg_info -- NOT aug_arg_info
           where
              appArg :: SDoc -> (SDoc, b, Type, d) -> SDoc
    appArg SDoc
    acc (SDoc
    arg_cname, b
    _, Type
    arg_hty, d
    _)
                 = String -> SDoc
    text String
    "rts_apply"
                   SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    parens (SDoc
    cap SDoc -> SDoc -> SDoc
    <> SDoc
    acc SDoc -> SDoc -> SDoc
    <> SDoc
    comma SDoc -> SDoc -> SDoc
    <> Type -> SDoc
    mkHObj Type
    arg_hty SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    parens (SDoc
    cap SDoc -> SDoc -> SDoc
    <> SDoc
    arg_cname))

      -- various other bits for inside the fn
      declareResult :: SDoc
    declareResult = String -> SDoc
    text String
    "HaskellObj ret;"
      declareCResult :: SDoc
    declareCResult | Bool
    res_hty_is_unit = SDoc
    empty
                     | Bool
    otherwise       = SDoc
    cResType SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "cret;"

      assignCResult :: SDoc
    assignCResult | Bool
    res_hty_is_unit = SDoc
    empty
                    | Bool
    otherwise       =
                            String -> SDoc
    text String
    "cret=" SDoc -> SDoc -> SDoc
    <> Type -> SDoc
    unpackHObj Type
    res_hty SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    parens (String -> SDoc
    text String
    "ret") SDoc -> SDoc -> SDoc
    <> SDoc
    semi

      -- an extern decl for the fn being called
      extern_decl :: SDoc
    extern_decl
         = case Maybe Id
    maybe_target of
              Maybe Id
    Nothing -> SDoc
    empty
              Just Id
    hs_fn -> String -> SDoc
    text String
    "extern StgClosure " SDoc -> SDoc -> SDoc
    <> Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    hs_fn SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    "_closure" SDoc -> SDoc -> SDoc
    <> SDoc
    semi

      -- finally, the whole darn thing
      c_bits :: CStub
    c_bits = SDoc -> CStub
    CStub (SDoc -> CStub) -> SDoc -> CStub
    forall a b. (a -> b) -> a -> b
    $
        SDoc
    space SDoc -> SDoc -> SDoc
    $$
        SDoc
    extern_decl SDoc -> SDoc -> SDoc
    $$
        SDoc
    fun_proto  SDoc -> SDoc -> SDoc
    $$
        [SDoc] -> SDoc
    vcat
         [ SDoc
    lbrace
         ,   String -> SDoc
    text String
    "Capability *cap;"
         ,   SDoc
    declareResult
         ,   SDoc
    declareCResult
         ,   String -> SDoc
    text String
    "cap = rts_lock();"
              -- create the application + perform it.
         ,   String -> SDoc
    text String
    "rts_inCall" SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    parens (
                    Char -> SDoc
    char Char
    '&' SDoc -> SDoc -> SDoc
    <> SDoc
    cap SDoc -> SDoc -> SDoc
    <>
                    String -> SDoc
    text String
    "rts_apply" SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    parens (
                        SDoc
    cap SDoc -> SDoc -> SDoc
    <>
                        String -> SDoc
    text String
    "(HaskellObj)"
                     SDoc -> SDoc -> SDoc
    <> PtrString -> SDoc
    ptext (if Bool
    is_IO_res_ty
                                    then (String -> PtrString
    sLit String
    "runIO_closure")
                                    else (String -> PtrString
    sLit String
    "runNonIO_closure"))
                     SDoc -> SDoc -> SDoc
    <> SDoc
    comma
                     SDoc -> SDoc -> SDoc
    <> SDoc
    expr_to_run
                    ) SDoc -> SDoc -> SDoc
    <+> SDoc
    comma
                   SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    "&ret"
                 ) SDoc -> SDoc -> SDoc
    <> SDoc
    semi
         ,   String -> SDoc
    text String
    "rts_checkSchedStatus" SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    parens (SDoc -> SDoc
    doubleQuotes (CLabelString -> SDoc
    ftext CLabelString
    c_nm)
                                                    SDoc -> SDoc -> SDoc
    <> SDoc
    comma SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    "cap") SDoc -> SDoc -> SDoc
    <> SDoc
    semi
         ,   SDoc
    assignCResult
         ,   String -> SDoc
    text String
    "rts_unlock(cap);"
         ,   Bool -> SDoc -> SDoc
    ppUnless Bool
    res_hty_is_unit (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $
             if Bool
    libffi
                      then Char -> SDoc
    char Char
    '*' SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    parens (SDoc
    ffi_cResType SDoc -> SDoc -> SDoc
    <> Char -> SDoc
    char Char
    '*') SDoc -> SDoc -> SDoc
    <>
                           String -> SDoc
    text String
    "resp = cret;"
                      else String -> SDoc
    text String
    "return cret;"
         , SDoc
    rbrace
         ]

    foreignExportsInitialiser :: Module -> [Id] -> CStub
    foreignExportsInitialiser :: Module -> [Id] -> CStub
    foreignExportsInitialiser Module
    mod [Id]
    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
       SDoc -> CStub
    CStub (SDoc -> CStub) -> SDoc -> CStub
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    vcat
        [ String -> SDoc
    text String
    "static struct ForeignExportsList" SDoc -> SDoc -> SDoc
    <+> SDoc
    list_symbol SDoc -> SDoc -> SDoc
    <+> SDoc
    equals
             SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    braces (
               String -> SDoc
    text String
    ".exports = " SDoc -> SDoc -> SDoc
    <+> SDoc
    export_list SDoc -> SDoc -> SDoc
    <> SDoc
    comma SDoc -> SDoc -> SDoc
    <+>
               String -> SDoc
    text String
    ".n_entries = " SDoc -> SDoc -> SDoc
    <+> Arity -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ([Id] -> Arity
    forall (t :: * -> *) a. Foldable t => t a -> Arity
    length [Id]
    hs_fns))
             SDoc -> SDoc -> SDoc
    <> SDoc
    semi
        , String -> SDoc
    text String
    "static void " SDoc -> SDoc -> SDoc
    <> SDoc
    ctor_symbol SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    "(void)"
             SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    " __attribute__((constructor));"
        , String -> SDoc
    text String
    "static void " SDoc -> SDoc -> SDoc
    <> SDoc
    ctor_symbol SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    "()"
        , SDoc -> SDoc
    braces (String -> SDoc
    text String
    "registerForeignExports" SDoc -> SDoc -> SDoc
    <> SDoc -> SDoc
    parens (Char -> SDoc
    char Char
    '&' SDoc -> SDoc -> SDoc
    <> SDoc
    list_symbol) SDoc -> SDoc -> SDoc
    <> SDoc
    semi)
        ]
      where
        mod_str :: SDoc
    mod_str = ModuleName -> SDoc
    pprModuleName (Module -> ModuleName
    forall unit. GenModule unit -> ModuleName
    moduleName Module
    mod)
        ctor_symbol :: SDoc
    ctor_symbol = String -> SDoc
    text String
    "stginit_export_" SDoc -> SDoc -> SDoc
    <> SDoc
    mod_str
        list_symbol :: SDoc
    list_symbol = String -> SDoc
    text String
    "stg_exports_" SDoc -> SDoc -> SDoc
    <> SDoc
    mod_str
        export_list :: SDoc
    export_list = SDoc -> SDoc
    braces (SDoc -> SDoc) -> SDoc -> SDoc
    forall a b. (a -> b) -> a -> b
    $ (Id -> SDoc) -> [Id] -> SDoc
    forall a. (a -> SDoc) -> [a] -> SDoc
    pprWithCommas Id -> SDoc
    closure_ptr [Id]
    hs_fns

        closure_ptr :: Id -> SDoc
        closure_ptr :: Id -> SDoc
    closure_ptr Id
    fn = String -> SDoc
    text String
    "(StgPtr) &" SDoc -> SDoc -> SDoc
    <> Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    fn SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text String
    "_closure"

    mkHObj :: Type -> SDoc
    mkHObj :: Type -> SDoc
    mkHObj Type
    t = String -> SDoc
    text String
    "rts_mk" SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text (Type -> String
    showFFIType Type
    t)

    unpackHObj :: Type -> SDoc
    unpackHObj :: Type -> SDoc
    unpackHObj Type
    t = String -> SDoc
    text String
    "rts_get" SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text (Type -> String
    showFFIType Type
    t)

    showStgType :: Type -> SDoc
    showStgType :: Type -> SDoc
    showStgType Type
    t = String -> SDoc
    text String
    "Hs" SDoc -> SDoc -> SDoc
    <> String -> SDoc
    text (Type -> String
    showFFIType Type
    t)

    showFFIType :: Type -> String
    showFFIType :: Type -> String
    showFFIType Type
    t = Name -> String
    forall a. NamedThing a => a -> String
    getOccString (TyCon -> Name
    forall a. NamedThing a => a -> Name
    getName (Type -> TyCon
    typeTyCon Type
    t))

    toCType :: Type -> (Maybe Header, SDoc)
    toCType :: Type -> (Maybe Header, SDoc)
    toCType = Bool -> Type -> (Maybe Header, SDoc)
    f Bool
    False
        where f :: Bool -> Type -> (Maybe Header, SDoc)
    f Bool
    voidOK Type
    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 (TyCon
    ptr, [Type
    t']) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    splitTyConApp_maybe Type
    t
               , TyCon -> Name
    tyConName TyCon
    ptr Name -> [Name] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Name
    ptrTyConName, Name
    funPtrTyConName]
                  = case Bool -> Type -> (Maybe Header, SDoc)
    f Bool
    True Type
    t' of
                    (Maybe Header
    mh, SDoc
    cType') ->
                        (Maybe Header
    mh, SDoc
    cType' SDoc -> SDoc -> SDoc
    <> Char -> SDoc
    char 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
    tycon <- Type -> Maybe TyCon
    tyConAppTyConPicky_maybe Type
    t
               , Just (CType SourceText
    _ Maybe Header
    mHeader (SourceText
    _,CLabelString
    cType)) <- TyCon -> Maybe CType
    tyConCType_maybe TyCon
    tycon
                  = (Maybe Header
    mHeader, CLabelString -> SDoc
    ftext CLabelString
    cType)
               -- If we don't know a C type for this type, then try looking
               -- through one layer of type synonym etc.
               | Just Type
    t' <- Type -> Maybe Type
    coreView Type
    t
                  = Bool -> Type -> (Maybe Header, SDoc)
    f Bool
    voidOK Type
    t'
               -- This may be an 'UnliftedFFITypes'-style ByteArray# argument
               -- (which is marshalled like a Ptr)
               | TyCon -> Maybe TyCon
    forall a. a -> Maybe a
    Just TyCon
    byteArrayPrimTyCon        Maybe TyCon -> Maybe TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == Type -> Maybe TyCon
    tyConAppTyConPicky_maybe Type
    t
                  = (Maybe Header
    forall a. Maybe a
    Nothing, String -> SDoc
    text String
    "const void*")
               | TyCon -> Maybe TyCon
    forall a. a -> Maybe a
    Just TyCon
    mutableByteArrayPrimTyCon Maybe TyCon -> Maybe TyCon -> Bool
    forall a. Eq a => a -> a -> Bool
    == Type -> Maybe TyCon
    tyConAppTyConPicky_maybe Type
    t
                  = (Maybe Header
    forall a. Maybe a
    Nothing, String -> SDoc
    text String
    "void*")
               -- Otherwise we don't know the C type. If we are allowing
               -- void then return that; otherwise something has gone wrong.
               | Bool
    voidOK = (Maybe Header
    forall a. Maybe a
    Nothing, String -> SDoc
    text String
    "void")
               | Bool
    otherwise
                  = String -> SDoc -> (Maybe Header, SDoc)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "toCType" (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    t)

    typeTyCon :: Type -> TyCon
    typeTyCon :: Type -> TyCon
    typeTyCon Type
    ty
      | Just (TyCon
    tc, [Type]
    _) <- HasCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    tcSplitTyConApp_maybe (Type -> Type
    unwrapType Type
    ty)
      = TyCon
    tc
      | Bool
    otherwise
      = String -> SDoc -> TyCon
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "GHC.HsToCore.Foreign.Decl.typeTyCon" (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty)

    insertRetAddr :: Platform -> CCallConv
                  -> [(SDoc, SDoc, Type, CmmType)]
                  -> [(SDoc, SDoc, Type, CmmType)]
    insertRetAddr :: Platform
    -> CCallConv
    -> [(SDoc, SDoc, Type, CmmType)]
    -> [(SDoc, SDoc, Type, CmmType)]
    insertRetAddr Platform
    platform CCallConv
    CCallConv [(SDoc, SDoc, Type, CmmType)]
    args
        = case Platform -> Arch
    platformArch Platform
    platform of
          Arch
    ArchX86_64
           | Platform -> OS
    platformOS Platform
    platform OS -> OS -> Bool
    forall a. Eq a => a -> a -> Bool
    == OS
    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 :: Arity
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    go Arity
    4 [(SDoc, SDoc, Type, CmmType)]
    args = Platform -> (SDoc, SDoc, Type, CmmType)
    ret_addr_arg Platform
    platform (SDoc, SDoc, Type, CmmType)
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    forall a. a -> [a] -> [a]
    : [(SDoc, SDoc, Type, CmmType)]
    args
                  go Arity
    n ((SDoc, SDoc, Type, CmmType)
    arg:[(SDoc, SDoc, Type, CmmType)]
    args) = (SDoc, SDoc, Type, CmmType)
    arg (SDoc, SDoc, Type, CmmType)
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    forall a. a -> [a] -> [a]
    : Arity
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    go (Arity
    nArity -> Arity -> Arity
    forall a. Num a => a -> a -> a
    +Arity
    1) [(SDoc, SDoc, Type, CmmType)]
    args
                  go Arity
    _ [] = []
              in Arity
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    go Arity
    0 [(SDoc, SDoc, Type, CmmType)]
    args
           | Bool
    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 :: Arity
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    go Arity
    6 [(SDoc, SDoc, Type, CmmType)]
    args = Platform -> (SDoc, SDoc, Type, CmmType)
    ret_addr_arg Platform
    platform (SDoc, SDoc, Type, CmmType)
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    forall a. a -> [a] -> [a]
    : [(SDoc, SDoc, Type, CmmType)]
    args
                  go Arity
    n (arg :: (SDoc, SDoc, Type, CmmType)
    arg@(SDoc
    _,SDoc
    _,Type
    _,CmmType
    rep):[(SDoc, SDoc, Type, CmmType)]
    args)
                   | CmmType -> CmmType -> Bool
    cmmEqType_ignoring_ptrhood CmmType
    rep CmmType
    b64 = (SDoc, SDoc, Type, CmmType)
    arg (SDoc, SDoc, Type, CmmType)
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    forall a. a -> [a] -> [a]
    : Arity
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    go (Arity
    nArity -> Arity -> Arity
    forall a. Num a => a -> a -> a
    +Arity
    1) [(SDoc, SDoc, Type, CmmType)]
    args
                   | Bool
    otherwise  = (SDoc, SDoc, Type, CmmType)
    arg (SDoc, SDoc, Type, CmmType)
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    forall a. a -> [a] -> [a]
    : Arity
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    go Arity
    n     [(SDoc, SDoc, Type, CmmType)]
    args
                  go Arity
    _ [] = []
              in Arity
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    go Arity
    0 [(SDoc, SDoc, Type, CmmType)]
    args
          Arch
    _ ->
              Platform -> (SDoc, SDoc, Type, CmmType)
    ret_addr_arg Platform
    platform (SDoc, SDoc, Type, CmmType)
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    forall a. a -> [a] -> [a]
    : [(SDoc, SDoc, Type, CmmType)]
    args
    insertRetAddr Platform
    _ CCallConv
    _ [(SDoc, SDoc, Type, CmmType)]
    args = [(SDoc, SDoc, Type, CmmType)]
    args

    ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType)
    ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType)
    ret_addr_arg Platform
    platform = (String -> SDoc
    text String
    "original_return_addr", String -> SDoc
    text String
    "void*", Type
    forall a. HasCallStack => a
    undefined,
                             Platform -> Type -> CmmType
    typeCmmType Platform
    platform Type
    addrPrimTy)

    -- This function returns the primitive type associated with the boxed
    -- type argument to a foreign export (eg. Int ==> Int#).
    getPrimTyOf :: Type -> UnaryType
    getPrimTyOf :: Type -> Type
    getPrimTyOf Type
    ty
      | Type -> Bool
    isBoolTy Type
    rep_ty = Type
    intPrimTy
      -- Except for Bool, the types we are interested in have a single constructor
      -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
      | Bool
    otherwise =
      case Type -> Maybe (TyCon, [Type], DataCon, [Scaled Type])
    splitDataProductType_maybe Type
    rep_ty of
         Just (TyCon
    _, [Type]
    _, DataCon
    data_con, [Scaled Type
    _ Type
    prim_ty]) ->
            ASSERT(dataConSourceArity data_con == 1)
            ASSERT2(isUnliftedType prim_ty, ppr prim_ty)
            Type
    prim_ty
         Maybe (TyCon, [Type], DataCon, [Scaled Type])
    _other -> String -> SDoc -> Type
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty)
      where
            rep_ty :: Type
    rep_ty = Type -> Type
    unwrapType Type
    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 -> Type -> Char
    primTyDescChar Platform
    platform Type
    ty
     | Type
    ty Type -> Type -> Bool
    `eqType` Type
    unitTy = Char
    'v'
     | Bool
    otherwise
     = case HasDebugCallStack => Type -> PrimRep
    Type -> PrimRep
    typePrimRep1 (Type -> Type
    getPrimTyOf Type
    ty) of
         PrimRep
    IntRep      -> Char
    signed_word
         PrimRep
    WordRep     -> Char
    unsigned_word
         PrimRep
    Int8Rep     -> Char
    'B'
         PrimRep
    Word8Rep    -> Char
    'b'
         PrimRep
    Int16Rep    -> Char
    'S'
         PrimRep
    Word16Rep   -> Char
    's'
         PrimRep
    Int32Rep    -> Char
    'W'
         PrimRep
    Word32Rep   -> Char
    'w'
         PrimRep
    Int64Rep    -> Char
    'L'
         PrimRep
    Word64Rep   -> Char
    'l'
         PrimRep
    AddrRep     -> Char
    'p'
         PrimRep
    FloatRep    -> Char
    'f'
         PrimRep
    DoubleRep   -> Char
    'd'
         PrimRep
    _           -> String -> SDoc -> Char
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "primTyDescChar" (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    ty)
      where
        (Char
    signed_word, Char
    unsigned_word) = case Platform -> PlatformWordSize
    platformWordSize Platform
    platform of
          PlatformWordSize
    PW4 -> (Char
    'W',Char
    'w')
          PlatformWordSize
    PW8 -> (Char
    'L',Char
    'l')