{-# 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
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}.
HasLoc a =>
GenLocated 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 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
      ([Binding]
bs, CHeader
h, CStub
c, [Id]
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
      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, [Id]
ids, [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 EpaLocation
_ (CExportStatic SourceText
_ CLabelString
ext_nm CCallConv
cconv)) }) = do
      (CHeader
h, CStub
c, String
_, Int
_, [Id]
ids, [Binding]
bs) <- Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String, Int, [Id], [Binding])
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]
ids, [Binding]
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
platform <- IOEnv (Env DsGblEnv DsLclEnv) Platform
forall a b. TcRnIf a b Platform
getPlatform
  let cconv' :: CCallConv
cconv' = GenLocated EpaLocation CCallConv -> CCallConv
forall l e. GenLocated l e -> e
unLoc XRec (GhcPass p) CCallConv
GenLocated EpaLocation CCallConv
cconv
      safety' :: Safety
safety' = GenLocated EpaLocation Safety -> Safety
forall l e. GenLocated l e -> e
unLoc XRec (GhcPass p) Safety
GenLocated EpaLocation Safety
safety
  case (Platform -> Arch
platformArch Platform
platform, CCallConv
cconv') of
    (Arch
ArchJavaScript, CCallConv
_) -> do
      ([Binding]
bs, CHeader
h, CStub
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
      ([Binding], CHeader, CStub, [Id])
-> DsM ([Binding], CHeader, CStub, [Id])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Binding]
bs, CHeader
h, CStub
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
      ([Binding]
bs, CHeader
h, CStub
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
      ([Binding], CHeader, CStub, [Id])
-> DsM ([Binding], CHeader, CStub, [Id])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Binding]
bs, CHeader
h, CStub
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.
                 , Int          -- size of args to stub function
                 , [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, Int, [Id], [Binding])
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, CCallConv
cconv) of
    (Arch
ArchJavaScript, CCallConv
_) -> do
      (CHeader
h, CStub
c, String
ts, Int
args) <- Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String, Int)
dsJsFExport Id
fn_id Coercion
co CLabelString
ext_name CCallConv
cconv Bool
is_dyn
      (CHeader, CStub, String, Int, [Id], [Binding])
-> DsM (CHeader, CStub, String, Int, [Id], [Binding])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CHeader
h, CStub
c, String
ts, Int
args, [Id
fn_id], [])
    (Arch
ArchWasm32, CCallConv
JavaScriptCallConv) ->
      Id
-> Coercion
-> CLabelString
-> DsM (CHeader, CStub, String, Int, [Id], [Binding])
dsWasmJSExport Id
fn_id Coercion
co CLabelString
ext_name
    (Arch, CCallConv)
_ -> do
      (CHeader
h, CStub
c, String
ts, Int
args) <- Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String, Int)
dsCFExport Id
fn_id Coercion
co CLabelString
ext_name CCallConv
cconv Bool
is_dyn
      (CHeader, CStub, String, Int, [Id], [Binding])
-> DsM (CHeader, CStub, String, Int, [Id], [Binding])
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CHeader
h, CStub
c, String
ts, Int
args, [Id
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"