    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE TypeFamilies #-}

    {-
    (c) The University of Glasgow 2006
    (c) The AQUA Project, Glasgow University, 1998
    -}

    -- | Desugaring foreign declarations
    module GHC.HsToCore.Foreign.Decl
      ( dsForeigns
      )
    where

    import GHC.Prelude
    import GHC.Data.FastString

    import GHC.Tc.Utils.Monad        -- temp

    import GHC.HsToCore.Foreign.C
    import GHC.HsToCore.Foreign.JavaScript
    import GHC.HsToCore.Foreign.Wasm
    import GHC.HsToCore.Foreign.Utils
    import GHC.HsToCore.Monad

    import GHC.Hs
    import GHC.Types.Id
    import GHC.Types.ForeignStubs
    import GHC.Unit.Module
    import GHC.Core.Coercion

    import GHC.Cmm.CLabel
    import GHC.Types.ForeignCall
    import GHC.Types.SrcLoc
    import GHC.Utils.Outputable
    import GHC.Driver.DynFlags
    import GHC.Platform
    import GHC.Data.OrdList
    import GHC.Driver.Hooks

    import Data.List (unzip4)

    {-
    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.
    -}

    dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
    dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
    dsForeigns [LForeignDecl GhcTc]
    fos = do
        hooks <- IOEnv (Env DsGblEnv DsLclEnv) Hooks
    forall (m :: * -> *). HasHooks m => m Hooks
    getHooks
        case dsForeignsHook 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 [LForeignDecl GhcTc]
    [GenLocated SrcSpanAnnA (ForeignDecl 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 a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ForeignStubs
    NoStubs, OrdList Binding
    forall a. OrdList a
    nilOL)
    dsForeigns' [LForeignDecl GhcTc]
    fos = do
        mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
    forall (m :: * -> *). HasModule m => m Module
    getModule
        platform <- targetPlatform <$> getDynFlags
        fives <- mapM do_ldecl fos
        let
            (hs, cs, idss, bindss) = unzip4 fives
            fe_ids = [[Id]] -> [Id]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Id]]
    idss
            fe_init_code = Platform -> Module -> [Id] -> CStub
    foreignExportsInitialiser Platform
    platform Module
    mod [Id]
    fe_ids
        --
        return (ForeignStubs
                 (mconcat hs)
                 (mconcat cs `mappend` fe_init_code),
                foldr (appOL . toOL) nilOL bindss)
      where
       do_ldecl :: GenLocated a (ForeignDecl GhcTc)
    -> IOEnv (Env DsGblEnv DsLclEnv) (CHeader, CStub, [Id], [Binding])
    do_ldecl (L 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 (a -> SrcSpan
    forall a. HasLoc a => a -> SrcSpan
    locA 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 pass
    fd_fi = ForeignImport GhcTc
    spec }) = do
          SDoc -> TcRnIf DsGblEnv DsLclEnv ()
    forall m n. SDoc -> TcRnIf m n ()
    traceIf (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "fi start" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> GenLocated SrcSpanAnnN Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr LIdP GhcTc
    GenLocated SrcSpanAnnN Id
    id)
          let id' :: Id
    id' = GenLocated SrcSpanAnnN Id -> Id
    forall l e. GenLocated l e -> e
    unLoc LIdP GhcTc
    GenLocated SrcSpanAnnN Id
    id
          (bs, h, c, ids) <- Id
    -> Coercion
    -> ForeignImport GhcTc
    -> DsM ([Binding], CHeader, CStub, [Id])
    forall (p :: Pass).
    Id
    -> Coercion
    -> ForeignImport (GhcPass p)
    -> DsM ([Binding], CHeader, CStub, [Id])
    dsFImport Id
    id' XForeignImport GhcTc
    Coercion
    co ForeignImport GhcTc
    spec
          traceIf (text "fi end" <+> ppr id)
          return (h, c, ids, 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 pass
    fd_fe = CExport XCExport GhcTc
    _
                                  (L EpaLocation
    _ (CExportStatic SourceText
    _ CLabelString
    ext_nm CCallConv
    cconv)) }) = do
          (h, c, _, ids, bs) <- Id
    -> Coercion
    -> CLabelString
    -> CCallConv
    -> Bool
    -> DsM (CHeader, CStub, String, [Id], [Binding])
    dsFExport Id
    id XForeignExport GhcTc
    Coercion
    co CLabelString
    ext_nm CCallConv
    cconv Bool
    False
          return (h, c, ids, bs)

    {-
    ************************************************************************
    *                                                                      *
    \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 (GhcPass p)
              -> DsM ([Binding], CHeader, CStub, [Id])
    dsFImport :: forall (p :: Pass).
    Id
    -> Coercion
    -> ForeignImport (GhcPass p)
    -> DsM ([Binding], CHeader, CStub, [Id])
    dsFImport Id
    id Coercion
    co (CImport XCImport (GhcPass p)
    _ XRec (GhcPass p) CCallConv
    cconv XRec (GhcPass p) Safety
    safety Maybe Header
    mHeader CImportSpec
    spec) = do
      platform <- IOEnv (Env DsGblEnv DsLclEnv) Platform
    forall a b. TcRnIf a b Platform
    getPlatform
      let cconv' = GenLocated EpaLocation CCallConv -> CCallConv
    forall l e. GenLocated l e -> e
    unLoc XRec (GhcPass p) CCallConv
    GenLocated EpaLocation CCallConv
    cconv
          safety' = GenLocated EpaLocation Safety -> Safety
    forall l e. GenLocated l e -> e
    unLoc XRec (GhcPass p) Safety
    GenLocated EpaLocation Safety
    safety
      case (platformArch platform, cconv') of
        (Arch
    ArchJavaScript, CCallConv
    _) -> do
          (bs, h, c) <- Id
    -> Coercion
    -> CImportSpec
    -> CCallConv
    -> Safety
    -> Maybe Header
    -> DsM ([Binding], CHeader, CStub)
    dsJsImport Id
    id Coercion
    co CImportSpec
    spec CCallConv
    cconv' Safety
    safety' Maybe Header
    mHeader
          pure (bs, h, c, [])
        (Arch
    ArchWasm32, CCallConv
    JavaScriptCallConv) ->
          Id
    -> Coercion
    -> CImportSpec
    -> Safety
    -> DsM ([Binding], CHeader, CStub, [Id])
    dsWasmJSImport Id
    id Coercion
    co CImportSpec
    spec Safety
    safety'
        (Arch, CCallConv)
    _ -> do
          (bs, h, c) <- Id
    -> Coercion
    -> CImportSpec
    -> CCallConv
    -> Safety
    -> Maybe Header
    -> DsM ([Binding], CHeader, CStub)
    dsCImport Id
    id Coercion
    co CImportSpec
    spec CCallConv
    cconv' Safety
    safety' Maybe Header
    mHeader
          pure (bs, h, c, [])

    {-
    ************************************************************************
    *                                                                      *
    \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.
                     , [Id]         -- function closures to be registered as GC roots
                     , [Binding]    -- additional bindings used by desugared foreign export
                     )
    dsFExport :: Id
    -> Coercion
    -> CLabelString
    -> CCallConv
    -> Bool
    -> DsM (CHeader, CStub, String, [Id], [Binding])
    dsFExport Id
    fn_id Coercion
    co CLabelString
    ext_name CCallConv
    cconv Bool
    is_dyn = do
      platform <- IOEnv (Env DsGblEnv DsLclEnv) Platform
    forall a b. TcRnIf a b Platform
    getPlatform
      case (platformArch platform, cconv) of
        (Arch
    ArchJavaScript, CCallConv
    _) -> do
          (h, c, ts) <- Id
    -> Coercion
    -> CLabelString
    -> CCallConv
    -> Bool
    -> DsM (CHeader, CStub, String)
    dsJsFExport Id
    fn_id Coercion
    co CLabelString
    ext_name CCallConv
    cconv Bool
    is_dyn
          pure (h, c, ts, [fn_id], [])
        (Arch
    ArchWasm32, CCallConv
    JavaScriptCallConv) ->
          Id
    -> Coercion
    -> CLabelString
    -> DsM (CHeader, CStub, String, [Id], [Binding])
    dsWasmJSExport Id
    fn_id Coercion
    co CLabelString
    ext_name
        (Arch, CCallConv)
    _ -> do
          (h, c, ts) <- Id
    -> Coercion
    -> CLabelString
    -> CCallConv
    -> Bool
    -> DsM (CHeader, CStub, String)
    dsCFExport Id
    fn_id Coercion
    co CLabelString
    ext_name CCallConv
    cconv Bool
    is_dyn
          pure (h, c, ts, [fn_id], [])

    foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub
    foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub
    foreignExportsInitialiser Platform
    _        Module
    _   []     = CStub
    forall a. Monoid a => a
    mempty
    foreignExportsInitialiser Platform
    platform 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
       Platform -> CLabel -> SDoc -> SDoc -> CStub
    initializerCStub Platform
    platform CLabel
    fn_nm SDoc
    list_decl SDoc
    fn_body
      where
        fn_nm :: CLabel
    fn_nm       = Module -> CLabelString -> CLabel
    mkInitializerStubLabel Module
    mod (String -> CLabelString
    fsLit String
    "fexports")
        mod_str :: SDoc
    mod_str     = ModuleName -> SDoc
    forall doc. IsLine doc => ModuleName -> doc
    pprModuleName (Module -> ModuleName
    forall unit. GenModule unit -> ModuleName
    moduleName Module
    mod)
        fn_body :: SDoc
    fn_body     = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "registerForeignExports" 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
    list_symbol) SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    semi
        list_symbol :: SDoc
    list_symbol = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "stg_exports_" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    mod_str
        list_decl :: SDoc
    list_decl   = String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "static struct ForeignExportsList" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    list_symbol SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    forall doc. IsLine doc => doc
    equals
             SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    braces (
               String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    ".exports = " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> SDoc
    export_list 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
    ".n_entries = " SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <+> Int -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr ([Id] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Id]
    hs_fns))
             SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> SDoc
    forall doc. IsLine doc => doc
    semi

        export_list :: SDoc
    export_list = SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc
    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
    forall doc. IsLine doc => String -> doc
    text String
    "(StgPtr) &" SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    fn SDoc -> SDoc -> SDoc
    forall doc. IsLine doc => doc -> doc -> doc
    <> String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "_closure"