{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.HsToCore.Foreign.Decl
( dsForeigns
)
where
import GHC.Prelude
import GHC.Tc.Utils.Monad
import GHC.HsToCore.Foreign.C
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.Utils.Panic
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 (String -> SDoc
text String
"fi start" SDoc -> SDoc -> SDoc
<+> 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 (String -> SDoc
text String
"fi end" SDoc -> SDoc -> SDoc
<+> 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) =
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 = case CCallConv
cconv of
CCallConv
JavaScriptCallConv -> forall a. String -> a
panic String
"dsFExport: JavaScript foreign exports not supported yet"
CCallConv
_ -> 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 -> String -> CLabel
mkInitializerStubLabel Module
mod String
"fexports"
mod_str :: SDoc
mod_str = ModuleName -> SDoc
pprModuleName (forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
fn_body :: SDoc
fn_body = String -> SDoc
text String
"registerForeignExports" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (Char -> SDoc
char Char
'&' SDoc -> SDoc -> SDoc
<> SDoc
list_symbol) SDoc -> SDoc -> SDoc
<> SDoc
semi
list_symbol :: SDoc
list_symbol = String -> SDoc
text String
"stg_exports_" SDoc -> SDoc -> SDoc
<> SDoc
mod_str
list_decl :: SDoc
list_decl = String -> SDoc
text String
"static struct ForeignExportsList" SDoc -> SDoc -> SDoc
<+> SDoc
list_symbol SDoc -> SDoc -> SDoc
<+> SDoc
equals
SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces (
String -> SDoc
text String
".exports = " SDoc -> SDoc -> SDoc
<+> SDoc
export_list SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
".n_entries = " SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
hs_fns))
SDoc -> SDoc -> SDoc
<> SDoc
semi
export_list :: SDoc
export_list = SDoc -> SDoc
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 = String -> SDoc
text String
"(StgPtr) &" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Id
fn SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"_closure"