    {-# 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.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.Session
    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
    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 [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
        Module
    mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
    forall (m :: * -> *). HasModule m => m Module
    getModule
        Platform
    platform <- DynFlags -> Platform
    targetPlatform (DynFlags -> Platform)
    -> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    -> IOEnv (Env DsGblEnv DsLclEnv) Platform
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IOEnv (Env DsGblEnv DsLclEnv) DynFlags
    forall (m :: * -> *). HasDynFlags m => m DynFlags
    getDynFlags
        [(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)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 [LForeignDecl GhcTc]
    [GenLocated SrcSpanAnnA (ForeignDecl 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 = Platform -> Module -> [Id] -> CStub
    foreignExportsInitialiser Platform
    platform Module
    mod [Id]
    fe_ids
        --
        (ForeignStubs, OrdList Binding)
    -> DsM (ForeignStubs, OrdList Binding)
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    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 a b. (a -> b -> b) -> b -> [a] -> b
    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 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
          ([Binding]
    bs, CHeader
    h, CStub
    c) <- Id
    -> Coercion
    -> ForeignImport GhcTc
    -> DsM ([Binding], CHeader, CStub)
    forall (p :: Pass).
    Id
    -> Coercion
    -> ForeignImport (GhcPass p)
    -> DsM ([Binding], CHeader, CStub)
    dsFImport Id
    id' XForeignImport GhcTc
    Coercion
    co ForeignImport GhcTc
    spec
          SDoc -> TcRnIf DsGblEnv DsLclEnv ()
    forall m n. SDoc -> TcRnIf m n ()
    traceIf (String -> SDoc
    forall doc. IsLine doc => String -> doc
    text String
    "fi end" 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)
          (CHeader, CStub, [Id], [Binding])
    -> IOEnv (Env DsGblEnv DsLclEnv) (CHeader, CStub, [Id], [Binding])
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    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 pass
    fd_fe = CExport XCExport GhcTc
    _
                                  (L SrcSpan
    _ (CExportStatic SourceText
    _ CLabelString
    ext_nm CCallConv
    cconv)) }) = do
          (CHeader
    h, CStub
    c, String
    _, Int
    _) <- Id
    -> Coercion
    -> CLabelString
    -> CCallConv
    -> Bool
    -> DsM (CHeader, CStub, String, Int)
    dsFExport Id
    id XForeignExport GhcTc
    Coercion
    co CLabelString
    ext_nm CCallConv
    cconv Bool
    False
          (CHeader, CStub, [Id], [Binding])
    -> IOEnv (Env DsGblEnv DsLclEnv) (CHeader, CStub, [Id], [Binding])
    forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
    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 (GhcPass p)
              -> DsM ([Binding], CHeader, CStub)
    dsFImport :: forall (p :: Pass).
    Id
    -> Coercion
    -> ForeignImport (GhcPass p)
    -> DsM ([Binding], CHeader, CStub)
    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
    platform <- IOEnv (Env DsGblEnv DsLclEnv) Platform
    forall a b. TcRnIf a b Platform
    getPlatform
      case Platform -> Arch
    platformArch Platform
    platform of
        Arch
    ArchJavaScript -> Id
    -> Coercion
    -> CImportSpec
    -> CCallConv
    -> Safety
    -> Maybe Header
    -> DsM ([Binding], CHeader, CStub)
    dsJsImport Id
    id Coercion
    co CImportSpec
    spec (GenLocated SrcSpan CCallConv -> CCallConv
    forall l e. GenLocated l e -> e
    unLoc XRec (GhcPass p) CCallConv
    GenLocated SrcSpan CCallConv
    cconv) (GenLocated SrcSpan Safety -> Safety
    forall l e. GenLocated l e -> e
    unLoc XRec (GhcPass p) Safety
    GenLocated SrcSpan Safety
    safety) Maybe Header
    mHeader
        Arch
    _              -> Id
    -> Coercion
    -> CImportSpec
    -> CCallConv
    -> Safety
    -> Maybe Header
    -> DsM ([Binding], CHeader, CStub)
    dsCImport  Id
    id Coercion
    co CImportSpec
    spec (GenLocated SrcSpan CCallConv -> CCallConv
    forall l e. GenLocated l e -> e
    unLoc XRec (GhcPass p) CCallConv
    GenLocated SrcSpan CCallConv
    cconv) (GenLocated SrcSpan Safety -> Safety
    forall l e. GenLocated l e -> e
    unLoc XRec (GhcPass p) Safety
    GenLocated SrcSpan Safety
    safety) Maybe Header
    mHeader

    {-
    ************************************************************************
    *                                                                      *
    \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, Int)
    dsFExport Id
    fn_id Coercion
    co CLabelString
    ext_name CCallConv
    cconv Bool
    is_dyn = do
      Platform
    platform <- IOEnv (Env DsGblEnv DsLclEnv) Platform
    forall a b. TcRnIf a b Platform
    getPlatform
      case Platform -> Arch
    platformArch Platform
    platform of
        Arch
    ArchJavaScript -> Id
    -> Coercion
    -> CLabelString
    -> CCallConv
    -> Bool
    -> DsM (CHeader, CStub, String, Int)
    dsJsFExport Id
    fn_id Coercion
    co CLabelString
    ext_name CCallConv
    cconv Bool
    is_dyn
        Arch
    _              -> Id
    -> Coercion
    -> CLabelString
    -> CCallConv
    -> Bool
    -> DsM (CHeader, CStub, String, Int)
    dsCFExport  Id
    fn_id Coercion
    co CLabelString
    ext_name CCallConv
    cconv Bool
    is_dyn

    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"