{-# 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 <- 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
h [LForeignDecl GhcTc]
fos
dsForeigns' :: [LForeignDecl GhcTc]
-> DsM (ForeignStubs, OrdList Binding)
dsForeigns' :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
dsForeigns' []
= forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignStubs
NoStubs, forall a. OrdList a
nilOL)
dsForeigns' [LForeignDecl GhcTc]
fos = do
Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
Platform
platform <- DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
[(CHeader, CStub, [Id], [Binding])]
fives <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {a}.
GenLocated (SrcSpanAnn' a) (ForeignDecl GhcTc)
-> DsM (CHeader, CStub, [Id], [Binding])
do_ldecl [LForeignDecl GhcTc]
fos
let
([CHeader]
hs, [CStub]
cs, [[Id]]
idss, [[Binding]]
bindss) = forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [(CHeader, CStub, [Id], [Binding])]
fives
fe_ids :: [Id]
fe_ids = 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
forall (m :: * -> *) a. Monad m => a -> m a
return (CHeader -> CStub -> ForeignStubs
ForeignStubs
(forall a. Monoid a => [a] -> a
mconcat [CHeader]
hs)
(forall a. Monoid a => [a] -> a
mconcat [CStub]
cs forall a. Monoid a => a -> a -> a
`mappend` CStub
fe_init_code),
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a. OrdList a -> OrdList a -> OrdList a
appOL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> OrdList a
toOL) forall a. OrdList a
nilOL [[Binding]]
bindss)
where
do_ldecl :: GenLocated (SrcSpanAnn' a) (ForeignDecl GhcTc)
-> DsM (CHeader, CStub, [Id], [Binding])
do_ldecl (L SrcSpanAnn' a
loc ForeignDecl GhcTc
decl) = forall a. SrcSpan -> DsM a -> DsM a
putSrcSpanDs (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnn' a
loc) (ForeignDecl GhcTc -> DsM (CHeader, CStub, [Id], [Binding])
do_decl ForeignDecl GhcTc
decl)
do_decl :: ForeignDecl GhcTc -> DsM (CHeader, CStub, [Id], [Binding])
do_decl :: ForeignDecl GhcTc -> DsM (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
forall m n. SDoc -> TcRnIf m n ()
traceIf (forall doc. IsLine doc => String -> doc
text String
"fi start" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr LIdP GhcTc
id)
let id' :: Id
id' = forall l e. GenLocated l e -> e
unLoc LIdP GhcTc
id
([Binding]
bs, CHeader
h, CStub
c) <- forall (p :: Pass).
Id
-> Coercion
-> ForeignImport (GhcPass p)
-> DsM ([Binding], CHeader, CStub)
dsFImport Id
id' XForeignImport GhcTc
co ForeignImport GhcTc
spec
forall m n. SDoc -> TcRnIf m n ()
traceIf (forall doc. IsLine doc => String -> doc
text String
"fi end" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr LIdP GhcTc
id)
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
co CLabelString
ext_nm CCallConv
cconv Bool
False
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 <- 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 (forall l e. GenLocated l e -> e
unLoc XRec (GhcPass p) CCallConv
cconv) (forall l e. GenLocated l e -> e
unLoc XRec (GhcPass p) Safety
safety) Maybe Header
mHeader
Arch
_ -> Id
-> Coercion
-> CImportSpec
-> CCallConv
-> Safety
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
dsCImport Id
id Coercion
co CImportSpec
spec (forall l e. GenLocated l e -> e
unLoc XRec (GhcPass p) CCallConv
cconv) (forall l e. GenLocated l e -> e
unLoc XRec (GhcPass p) 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 <- 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
_ [] = 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 = forall doc. IsLine doc => ModuleName -> doc
pprModuleName (forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
fn_body :: SDoc
fn_body = forall doc. IsLine doc => String -> doc
text String
"registerForeignExports" forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc -> doc
parens (forall doc. IsLine doc => Char -> doc
char Char
'&' forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
list_symbol) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
semi
list_symbol :: SDoc
list_symbol = forall doc. IsLine doc => String -> doc
text String
"stg_exports_" forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
mod_str
list_decl :: SDoc
list_decl = forall doc. IsLine doc => String -> doc
text String
"static struct ForeignExportsList" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
list_symbol forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => doc
equals
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => doc -> doc
braces (
forall doc. IsLine doc => String -> doc
text String
".exports = " forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
export_list forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
comma forall doc. IsLine doc => doc -> doc -> doc
<+>
forall doc. IsLine doc => String -> doc
text String
".n_entries = " forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
hs_fns))
forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
semi
export_list :: SDoc
export_list = forall doc. IsLine doc => doc -> doc
braces forall a b. (a -> b) -> a -> b
$ 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 = forall doc. IsLine doc => String -> doc
text String
"(StgPtr) &" forall doc. IsLine doc => doc -> doc -> doc
<> forall a. Outputable a => a -> SDoc
ppr Id
fn forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => String -> doc
text String
"_closure"