content: 
  {-# 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 fos = do
      hooks <- getHooks
      case dsForeignsHook hooks of
          Nothing -> dsForeigns' fos
          Just h  -> h fos
  
  dsForeigns' :: [LForeignDecl GhcTc]
              -> DsM (ForeignStubs, OrdList Binding)
  dsForeigns' []
    = return (NoStubs, nilOL)
  dsForeigns' fos = do
      mod <- getModule
      platform <- targetPlatform <$> getDynFlags
      fives <- mapM do_ldecl fos
      let
          (hs, cs, idss, bindss) = unzip4 fives
          fe_ids = concat idss
          fe_init_code = foreignExportsInitialiser platform mod fe_ids
      --
      return (ForeignStubs
               (mconcat hs)
               (mconcat cs `mappend` fe_init_code),
              foldr (appOL . toOL) nilOL bindss)
    where
     do_ldecl (L loc decl) = putSrcSpanDs (locA loc) (do_decl decl)
  
     do_decl :: ForeignDecl GhcTc -> DsM (CHeader, CStub, [Id], [Binding])
     do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
        traceIf (text "fi start" <+> ppr id)
        let id' = unLoc id
        (bs, h, c, ids) <- dsFImport id' co spec
        traceIf (text "fi end" <+> ppr id)
        return (h, c, ids, bs)
  
     do_decl (ForeignExport { fd_name = L _ id
                            , fd_e_ext = co
                            , fd_fe = CExport _
                                (L _ (CExportStatic _ ext_nm cconv)) }) = do
        (h, c, _, ids, bs) <- dsFExport id co ext_nm cconv 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 id co (CImport _ cconv safety mHeader spec) = do
    platform <- getPlatform
    let cconv' = unLoc cconv
        safety' = unLoc safety
    case (platformArch platform, cconv') of
      (ArchJavaScript, _) -> do
        (bs, h, c) <- dsJsImport id co spec cconv' safety' mHeader
        pure (bs, h, c, [])
      (ArchWasm32, JavaScriptCallConv) ->
        dsWasmJSImport id co spec safety'
      _ -> do
        (bs, h, c) <- dsCImport id co spec cconv' safety' 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 fn_id co ext_name cconv is_dyn = do
    platform <- getPlatform
    case (platformArch platform, cconv) of
      (ArchJavaScript, _) -> do
        (h, c, ts) <- dsJsFExport fn_id co ext_name cconv is_dyn
        pure (h, c, ts, [fn_id], [])
      (ArchWasm32, JavaScriptCallConv) ->
        dsWasmJSExport fn_id co ext_name
      _ -> do
        (h, c, ts) <- dsCFExport fn_id co ext_name cconv is_dyn
        pure (h, c, ts, [fn_id], [])
  
  
  foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub
  foreignExportsInitialiser _        _   []     = mempty
  foreignExportsInitialiser platform mod hs_fns =
     -- Initialise foreign exports by registering a stable pointer from an
     -- __attribute__((constructor)) function.
     -- The alternative is to do this from stginit functions generated in
     -- codeGen/CodeGen.hs; however, stginit functions have a negative impact
     -- on binary sizes and link times because the static linker will think that
     -- all modules that are imported directly or indirectly are actually used by
     -- the program.
     -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
     --
     -- See Note [Tracking foreign exports] in rts/ForeignExports.c
     initializerCStub platform fn_nm list_decl fn_body
    where
      fn_nm       = mkInitializerStubLabel mod (fsLit "fexports")
      mod_str     = pprModuleName (moduleName mod)
      fn_body     = text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi
      list_symbol = text "stg_exports_" <> mod_str
      list_decl   = text "static struct ForeignExportsList" <+> list_symbol <+> equals
           <+> braces (
             text ".exports = " <+> export_list <> comma <+>
             text ".n_entries = " <+> ppr (length hs_fns))
           <> semi
  
      export_list = braces $ pprWithCommas closure_ptr hs_fns
  
      closure_ptr :: Id -> SDoc
      closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure"
  