{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.HsToCore.Foreign.Decl
( dsForeigns
)
where
import GHC.Prelude
import GHC.Data.FastString
import GHC.Tc.Utils.Monad
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)
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)
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, [])
dsFExport :: Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM ( CHeader
, CStub
, String
, [Id]
, [Binding]
)
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 =
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"