    {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

    -- | Handling of C foreign imports/exports
    module GHC.HsToCore.Foreign.C
      ( dsCImport
      , dsCFExport
      , dsCFExportDynamic
      )
    where

    import GHC.Prelude

    import GHC.Platform

    import GHC.Tc.Utils.Monad        -- temp
    import GHC.Tc.Utils.Env
    import GHC.Tc.Utils.TcType

    import GHC.Core
    import GHC.Core.Unfold.Make
    import GHC.Core.Type
    import GHC.Core.TyCon
    import GHC.Core.Coercion
    import GHC.Core.Multiplicity

    import GHC.HsToCore.Foreign.Call
    import GHC.HsToCore.Foreign.Prim
    import GHC.HsToCore.Foreign.Utils
    import GHC.HsToCore.Monad
    import GHC.HsToCore.Types (ds_next_wrapper_num)

    import GHC.Hs

    import GHC.Types.Id
    import GHC.Types.Literal
    import GHC.Types.ForeignStubs
    import GHC.Types.SourceText
    import GHC.Types.Name
    import GHC.Types.RepType
    import GHC.Types.ForeignCall
    import GHC.Types.Basic

    import GHC.Unit.Module

    import GHC.Driver.DynFlags
    import GHC.Driver.Config

    import GHC.Cmm.Expr
    import GHC.Cmm.Utils

    import GHC.Builtin.Types
    import GHC.Builtin.Types.Prim
    import GHC.Builtin.Names

    import GHC.Data.FastString

    import GHC.Utils.Outputable
    import GHC.Utils.Panic
    import GHC.Utils.Encoding

    import Data.Maybe
    import Data.List (nub)

    dsCFExport:: 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
                     )

    dsCFExport :: Id
    -> Coercion
    -> CLabelString
    -> CCallConv
    -> Bool
    -> DsM (CHeader, CStub, String, Int)
    dsCFExport Id
    fn_id Coercion
    co CLabelString
    ext_name CCallConv
    cconv Bool
    isDyn = do
        let
           ty :: Type
    ty                     = Coercion -> Type
    coercionRKind Coercion
    co
           ([PiTyVarBinder]
    bndrs, Type
    orig_res_ty)   = Type -> ([PiTyVarBinder], Type)
    tcSplitPiTys Type
    ty
           fe_arg_tys' :: [Type]
    fe_arg_tys'            = (PiTyVarBinder -> Maybe Type) -> [PiTyVarBinder] -> [Type]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe PiTyVarBinder -> Maybe Type
    anonPiTyBinderType_maybe [PiTyVarBinder]
    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. HasCallStack => [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)

        dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        return $
          mkFExportCBits dflags ext_name
                         (if isDyn then Nothing else Just fn_id)
                         fe_arg_tys res_ty is_IO_res_ty cconv

    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
       dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
       let ty  = Coercion -> Type
    coercionLKind Coercion
    co
           platform = DynFlags -> Platform
    targetPlatform DynFlags
    dflags
           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
       (resTy, foRhs) <- resultWrapper ty
       assert (fromJust resTy `eqType` addrPrimTy) $    -- typechecker ensures this
        let
            rhs = CoreExpr -> CoreExpr
    foRhs (Literal -> CoreExpr
    forall b. Literal -> Expr b
    Lit (CLabelString -> Maybe Int -> FunctionOrData -> Literal
    LitLabel CLabelString
    cid Maybe Int
    stdcall_info FunctionOrData
    fod))
            rhs' = CoreExpr -> Coercion -> CoreExpr
    forall b. Expr b -> Coercion -> Expr b
    Cast CoreExpr
    rhs Coercion
    co
            stdcall_info = Platform -> CCallConv -> Type -> Maybe Int
    fun_type_arg_stdcall_info Platform
    platform CCallConv
    cconv Type
    ty
        in
        return ([(id, rhs')], mempty, 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)
    dsCFExportDynamic Id
    id Coercion
    co 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}
    -}
    dsCFExportDynamic :: Id
                     -> Coercion
                     -> CCallConv
                     -> DsM ([Binding], CHeader, CStub)
    dsCFExportDynamic :: Id -> Coercion -> CCallConv -> DsM ([Binding], CHeader, CStub)
    dsCFExportDynamic Id
    id Coercion
    co0 CCallConv
    cconv = do
        mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
    forall (m :: * -> *). HasModule m => m Module
    getModule
        dflags <- getDynFlags
        let platform = DynFlags -> Platform
    targetPlatform DynFlags
    dflags
        let 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]
    ++ Id -> String
    toCName Id
    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 = TyCon -> [Type] -> Type
    mkTyConApp TyCon
    stable_ptr_tycon [Type
    arg_ty]
            export_ty     = HasDebugCallStack => Type -> Type -> Type
    Type -> Type -> Type
    mkVisFunTyMany Type
    stable_ptr_ty Type
    arg_ty
        bindIOId <- dsLookupGlobalId bindIOName
        stbl_value <- newSysLocalDs ManyTy stable_ptr_ty
        (h_code, c_code, typestring, args_size) <- dsCFExport 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      = [ Platform -> Integer -> CoreExpr
    forall b. Platform -> Integer -> Expr b
    mkIntLit Platform
    platform (Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (CCallConv -> Int
    ccallConvToInt CCallConv
    cconv))
                            , Id -> CoreExpr
    forall b. Id -> Expr b
    Var Id
    stbl_value
                            , Literal -> CoreExpr
    forall b. Literal -> Expr b
    Lit (CLabelString -> Maybe Int -> FunctionOrData -> Literal
    LitLabel CLabelString
    fe_nm Maybe Int
    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   = 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 = case CCallConv
    cconv of
                            CCallConv
    StdCallConv -> Int -> Maybe Int
    forall a. a -> Maybe a
    Just Int
    args_size
                            CCallConv
    _           -> Maybe Int
    forall a. Maybe a
    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 = [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 = (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.

        return ([fed], h_code, 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

    -- | 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
            (Type
    ty,Type
    ty1)             = (Coercion -> Type
    coercionLKind Coercion
    co, Coercion -> Type
    coercionRKind 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

        let constQual :: SDoc
    constQual -- provide 'const' qualifier (#22043)
              | ([Scaled Type]
    _, Type
    res_ty1) <- Type -> ([Scaled Type], Type)
    tcSplitFunTys Type
    ty1
              , Type
    newty <- Type -> ((TyCon, Type) -> Type) -> Maybe (TyCon, Type) -> Type
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Type
    res_ty1 (TyCon, Type) -> Type
    forall a b. (a, b) -> b
    snd (Type -> Maybe (TyCon, Type)
    tcSplitIOType_maybe Type
    res_ty1)
              , Just (TyCon
    ptr, [Type]
    _) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
    Type -> Maybe (TyCon, [Type])
    splitTyConApp_maybe Type
    newty
              , TyCon -> Name
    tyConName TyCon
    ptr Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    constPtrConName
              = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "const"
              | Bool
    otherwise = SDoc
    forall doc. IsOutput doc => doc
    empty

        args <- [Scaled Type] -> DsM [Id]
    newSysLocalsDs [Scaled Type]
    arg_tys  -- no FFI representation polymorphism
        (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)

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

        (ccall_result_ty, res_wrapper) <- boxResult io_res_ty

        ccall_uniq <- newUnique
        work_uniq  <- newUnique

        (fcall', cDoc) <-
                  case fcall of
                  CCall (CCallSpec (StaticTarget SourceText
    _ CLabelString
    cName Maybe Unit
    mUnitId Bool
    isFun)
                                   CCallConv
    CApiConv Safety
    safety) ->
                   do nextWrapperNum <- DsGblEnv -> IORef (ModuleEnv Int)
    ds_next_wrapper_num (DsGblEnv -> IORef (ModuleEnv Int))
    -> IOEnv (Env DsGblEnv DsLclEnv) DsGblEnv
    -> IOEnv (Env DsGblEnv DsLclEnv) (IORef (ModuleEnv Int))
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IOEnv (Env DsGblEnv DsLclEnv) DsGblEnv
    forall gbl lcl. TcRnIf gbl lcl gbl
    getGblEnv
                      wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName)
                      let 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
    includes
                           SDoc -> SDoc -> SDoc
    forall doc. IsDoc doc => doc -> doc -> doc
    $$ SDoc
    fun_proto SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    braces (SDoc
    cRet SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    semi)
                          includes = [SDoc] -> SDoc
    forall doc. IsDoc doc => [doc] -> doc
    vcat [ String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "#include \"" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> CLabelString -> SDoc
    forall doc. IsLine doc => CLabelString -> doc
    ftext CLabelString
    h
                                            SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "\""
                                          | Header SourceText
    _ CLabelString
    h <- [Header] -> [Header]
    forall a. Eq a => [a] -> [a]
    nub [Header]
    headers ]
                          fun_proto = SDoc
    constQual SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    cResType SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    pprCconv SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CLabelString -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CLabelString
    wrapperName SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens SDoc
    argTypes
                          cRet
                           | Bool
    isVoidRes =                   SDoc
    cCall
                           | Bool
    otherwise = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "return" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    cCall
                          cCall
                            | Bool
    isFun = CLabelString -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CLabelString
    cName SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens SDoc
    argVals
                            | [Scaled Type] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Scaled Type]
    arg_tys = CLabelString -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr CLabelString
    cName
                            | Bool
    otherwise = String -> SDoc
    forall a. HasCallStack => String -> a
    panic String
    "dsFCall: Unexpected arguments to FFI value import"
                          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 = Type
    raw_res_ty Type -> Type -> Bool
    `eqType` Type
    unitTy
                          (mHeader, cResType)
                           | isVoidRes = (Nothing, text "void")
                           | otherwise = toCType raw_res_ty
                          pprCconv = CCallConv -> SDoc
    ccallConvAttribute CCallConv
    CApiConv
                          mHeadersArgTypeList
                              = [ (Maybe Header
    header, SDoc
    cType SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    'a' SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Int -> SDoc
    forall doc. IsLine doc => Int -> doc
    int Int
    n)
                                | (Scaled Type
    t, Int
    n) <- [Scaled Type] -> [Int] -> [(Scaled Type, Int)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Scaled Type]
    arg_tys [Int
    1..]
                                , let (Maybe Header
    header, SDoc
    cType) = Type -> (Maybe Header, SDoc)
    toCType (Scaled Type -> Type
    forall a. Scaled a -> a
    scaledThing Scaled Type
    t) ]
                          (mHeaders, argTypeList) = unzip mHeadersArgTypeList
                          argTypes = if [SDoc] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [SDoc]
    argTypeList
                                     then String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "void"
                                     else [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> [SDoc] -> [SDoc]
    forall doc. IsLine doc => doc -> [doc] -> [doc]
    punctuate SDoc
    forall doc. IsLine doc => doc
    comma [SDoc]
    argTypeList
                          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 = [Maybe Header] -> [Header]
    forall a. [Maybe a] -> [a]
    catMaybes [Maybe Header]
    mHeaders'
                          argVals = [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> [SDoc] -> [SDoc]
    forall doc. IsLine doc => doc -> [doc] -> [doc]
    punctuate SDoc
    forall doc. IsLine doc => doc
    comma
                                        [ Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    'a' SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Int -> SDoc
    forall doc. IsLine doc => Int -> doc
    int Int
    n
                                        | (Scaled Type
    _, Int
    n) <- [Scaled Type] -> [Int] -> [(Scaled Type, Int)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Scaled Type]
    arg_tys [Int
    1..] ]
                      return (fcall', c)
                  ForeignCall
    _ ->
                      (ForeignCall, SDoc)
    -> IOEnv (Env DsGblEnv DsLclEnv) (ForeignCall, SDoc)
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ForeignCall
    fcall, SDoc
    forall doc. IsOutput doc => doc
    empty)
        dflags <- getDynFlags
        let
            -- Build the worker
            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           = (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 = Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
    mkFCall Unique
    ccall_uniq ForeignCall
    fcall' [CoreExpr]
    val_args Type
    ccall_result_ty
            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       = CLabelString -> Unique -> Type -> Type -> Id
    mkSysLocal (String -> CLabelString
    fsLit String
    "$wccall") Unique
    work_uniq Type
    ManyTy Type
    worker_ty

            -- Build the wrapper
            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 -> CoreExpr) -> CoreExpr -> CoreExpr)
    -> CoreExpr -> [CoreExpr -> CoreExpr] -> CoreExpr
    forall a b. (a -> b -> b) -> b -> [a] -> b
    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     = [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 -> Coercion -> CoreExpr
    forall b. Expr b -> Coercion -> Expr b
    Cast CoreExpr
    wrap_rhs Coercion
    co
            simpl_opts   = DynFlags -> SimpleOpts
    initSimpleOpts DynFlags
    dflags
            fn_id_w_inl  = Id
    fn_id Id -> Unfolding -> Id
    `setIdUnfolding` SimpleOpts -> UnfoldingSource -> Int -> CoreExpr -> Unfolding
    mkInlineUnfoldingWithArity SimpleOpts
    simpl_opts
                                                    UnfoldingSource
    StableSystemSrc ([Id] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Id]
    args)
                                                    CoreExpr
    wrap_rhs'

        return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc [] [])

    toCName :: Id -> String
    toCName :: Id -> String
    toCName Id
    i = SDocContext -> SDoc -> String
    showSDocOneLine SDocContext
    defaultSDocContext (SDoc -> SDoc
    pprCode (Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Id -> Name
    idName Id
    i)))

    toCType :: Type -> (Maybe Header, SDoc)
    toCType :: Type -> (Maybe Header, SDoc)
    toCType = Bool -> Type -> (Maybe Header, SDoc)
    forall {b}. IsLine b => Bool -> Type -> (Maybe Header, b)
    f Bool
    False
        where f :: Bool -> Type -> (Maybe Header, b)
    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 a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Name
    ptrTyConName, Name
    funPtrTyConName]
                  = case Bool -> Type -> (Maybe Header, b)
    f Bool
    True Type
    t' of
                    (Maybe Header
    mh, b
    cType') ->
                        (Maybe Header
    mh, b
    cType' b -> b -> b
    forall doc. IsLine doc => doc -> doc -> doc
    <> Char -> b
    forall doc. IsLine doc => Char -> doc
    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 -> b
    forall doc. IsLine doc => CLabelString -> doc
    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, b)
    f Bool
    voidOK Type
    t'
              -- Handle 'UnliftedFFITypes' argument
               | Just TyCon
    tyCon <- Type -> Maybe TyCon
    tyConAppTyConPicky_maybe Type
    t
               , TyCon -> Bool
    isPrimTyCon TyCon
    tyCon
               , Just String
    cType <- TyCon -> Maybe String
    ppPrimTyConStgType TyCon
    tyCon
               = (Maybe Header
    forall a. Maybe a
    Nothing, String -> b
    forall doc. IsLine doc => String -> doc
    text String
    cType)

               -- 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 -> b
    forall doc. IsLine doc => String -> doc
    text String
    "void")
               | Bool
    otherwise
                  = String -> SDoc -> (Maybe Header, b)
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "toCType" (Type -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Type
    t)

    {-
    *

    \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, Int)
    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
       , SDoc -> [CLabel] -> [CLabel] -> CStub
    CStub SDoc
    body [] []
       , String
    type_string,
        Int
    aug_arg_size
        )
     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
                    (Int -> SDoc -> SDoc
    arg_cname Int
    n SDoc
    stg_type,
                     SDoc
    stg_type,
                     Type
    ty,
                    Platform -> Type -> CmmType
    typeCmmType Platform
    platform (Type -> Type
    getPrimTyOf Type
    ty))
                  | (Type
    ty,Int
    n) <- [Type] -> [Int] -> [(Type, Int)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Type]
    arg_htys [Int
    1::Int ..] ]

      arg_cname :: Int -> SDoc -> SDoc
    arg_cname Int
    n SDoc
    stg_ty
            | Bool
    libffi    = Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    '*' SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens (SDoc
    stg_ty SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    '*') SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <>
                          String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "args" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    brackets (Int -> SDoc
    forall doc. IsLine doc => Int -> doc
    int (Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1))
            | Bool
    otherwise = Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    'a' SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Int -> SDoc
    forall doc. IsLine doc => Int -> doc
    int Int
    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

      aug_arg_size :: Int
    aug_arg_size = [Int] -> Int
    forall a. Num a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum [ Width -> Int
    widthInBytes (CmmType -> Width
    typeWidth CmmType
    rep) | (SDoc
    _,SDoc
    _,Type
    _,CmmType
    rep) <- [(SDoc, SDoc, Type, CmmType)]
    aug_arg_info]
             -- 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
             -- AK: This seems just wrong, the code here uses widthInBytes, but when
             -- we pass args on the haskell stack we always extend to multiples of 8
             -- to my knowledge. Not sure if it matters though so I won't touch this
             -- for now.

      stable_ptr_arg :: (SDoc, SDoc, Type, CmmType)
    stable_ptr_arg =
            (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "the_stableptr", String -> SDoc
    forall doc. IsLine doc => String -> doc
    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
    forall doc. IsLine doc => String -> doc
    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
    forall doc. IsLine doc => String -> doc
    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
    forall doc. IsLine doc => String -> doc
    text String
    "extern" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    fun_proto SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    semi)

      fun_args :: SDoc
    fun_args
        | [(SDoc, SDoc, Type, CmmType)] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [(SDoc, SDoc, Type, CmmType)]
    aug_arg_info = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "void"
        | Bool
    otherwise         = [SDoc] -> SDoc
    forall doc. IsLine doc => [doc] -> doc
    hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
    forall a b. (a -> b) -> a -> b
    $ SDoc -> [SDoc] -> [SDoc]
    forall doc. IsLine doc => doc -> [doc] -> [doc]
    punctuate SDoc
    forall doc. IsLine doc => doc
    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
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    nm) [(SDoc, SDoc, Type, CmmType)]
    aug_arg_info

      fun_proto :: SDoc
    fun_proto
        | Bool
    libffi
          = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "void" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CLabelString -> SDoc
    forall doc. IsLine doc => CLabelString -> doc
    ftext CLabelString
    c_nm SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <>
              SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
        | Bool
    otherwise
          = SDoc
    cResType SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    pprCconv SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> CLabelString -> SDoc
    forall doc. IsLine doc => CLabelString -> doc
    ftext CLabelString
    c_nm SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    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
    forall doc. IsLine doc => String -> doc
    text String
    "(StgClosure*)deRefStablePtr(the_stableptr)"
              Just Id
    hs_fn -> Char -> SDoc
    forall doc. IsLine doc => Char -> doc
    char Char
    '&' SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    hs_fn SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "_closure"

      cap :: SDoc
    cap = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "cap" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    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 b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' SDoc -> (SDoc, SDoc, Type, CmmType) -> SDoc
    appArg SDoc
    the_cfun [(SDoc, SDoc, Type, CmmType)]
    arg_info -- NOT aug_arg_info
           where
              appArg :: SDoc -> (SDoc, SDoc, Type, CmmType) -> SDoc
    appArg SDoc
    acc (SDoc
    arg_cname, SDoc
    _, Type
    arg_hty, CmmType
    _)
                 = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "rts_apply"
                   SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens (SDoc
    cap SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    acc SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    comma SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Type -> SDoc
    mkHObj Type
    arg_hty SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    parens (SDoc
    cap SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    arg_cname))

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

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

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

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

    mkHObj :: Type -> SDoc
    mkHObj :: Type -> SDoc
    mkHObj Type
    t = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "rts_mk" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Type -> SDoc
    showFFIType Type
    t

    unpackHObj :: Type -> SDoc
    unpackHObj :: Type -> SDoc
    unpackHObj Type
    t = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "rts_get" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Type -> SDoc
    showFFIType Type
    t

    showStgType :: Type -> SDoc
    showStgType :: Type -> SDoc
    showStgType Type
    t = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "Hs" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Type -> SDoc
    showFFIType Type
    t

    showFFIType :: Type -> SDoc
    showFFIType :: Type -> SDoc
    showFFIType Type
    t = CLabelString -> SDoc
    forall doc. IsLine doc => CLabelString -> doc
    ftext (OccName -> CLabelString
    occNameFS (TyCon -> OccName
    forall a. NamedThing a => a -> OccName
    getOccName (Type -> TyCon
    typeTyCon 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.C.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 :: Int
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    go Int
    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 Int
    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]
    : Int
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    go (Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) [(SDoc, SDoc, Type, CmmType)]
    args
                  go Int
    _ [] = []
              in Int
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    go Int
    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 :: Int
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    go Int
    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 Int
    n (arg :: (SDoc, SDoc, Type, CmmType)
    arg@(SDoc
    _,SDoc
    _,Type
    _,CmmType
    rep):[(SDoc, SDoc, Type, CmmType)]
    args)
                    -- Int type fitting into int register
                    | (CmmType -> Bool
    isBitsType CmmType
    rep Bool -> Bool -> Bool
    && CmmType -> Width
    typeWidth CmmType
    rep Width -> Width -> Bool
    forall a. Ord a => a -> a -> Bool
    <= Width
    W64 Bool -> Bool -> Bool
    || CmmType -> Bool
    isGcPtrType CmmType
    rep)
                    = (SDoc, SDoc, Type, CmmType)
    arg (SDoc, SDoc, Type, CmmType)
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    forall a. a -> [a] -> [a]
    : Int
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    go (Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    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]
    : Int
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    go Int
    n [(SDoc, SDoc, Type, CmmType)]
    args
                  go Int
    _ [] = []
              in Int
    -> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
    go Int
    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
    forall doc. IsLine doc => String -> doc
    text String
    "original_return_addr", String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "void*", Type
    forall a. HasCallStack => a
    undefined,
                             Platform -> Type -> CmmType
    typeCmmType Platform
    platform Type
    addrPrimTy)

    -- 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 Int
    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
           ([PiTyVarBinder]
    bndrs, Type
    _) = Type -> ([PiTyVarBinder], Type)
    tcSplitPiTys Type
    arg_ty
           fe_arg_tys :: [Type]
    fe_arg_tys = (PiTyVarBinder -> Maybe Type) -> [PiTyVarBinder] -> [Type]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe PiTyVarBinder -> Maybe Type
    anonPiTyBinderType_maybe [PiTyVarBinder]
    bndrs
        in Int -> Maybe Int
    forall a. a -> Maybe a
    Just (Int -> Maybe Int) -> Int -> Maybe Int
    forall a b. (a -> b) -> a -> b
    $ [Int] -> Int
    forall a. Num a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum ((Type -> Int) -> [Type] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map (Width -> Int
    widthInBytes (Width -> Int) -> (Type -> Width) -> Type -> Int
    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 Int
    forall a. Maybe a
    Nothing