{-# 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.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)
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], [])
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
dsFExport :: Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM ( CHeader
, CStub
, String
, Int
)
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 =
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"