{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Tc.Utils.Monad
import GHC.Core
import GHC.HsToCore.Foreign.Call
import GHC.HsToCore.Monad
import GHC.Hs
import GHC.Core.DataCon
import GHC.Core.Unfold.Make
import GHC.Types.Id
import GHC.Types.Literal
import GHC.Types.ForeignStubs
import GHC.Types.SourceText
import GHC.Unit.Module
import GHC.Types.Name
import GHC.Core.Type
import GHC.Types.RepType
import GHC.Core.TyCon
import GHC.Core.Coercion
import GHC.Core.Multiplicity
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcType
import GHC.Cmm.Expr
import GHC.Cmm.Utils
import GHC.Driver.Ppr
import GHC.Types.ForeignCall
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Builtin.Names
import GHC.Types.Basic
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Driver.Session
import GHC.Driver.Config
import GHC.Platform
import GHC.Data.OrdList
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Driver.Hooks
import GHC.Utils.Encoding
import Data.Maybe
import Data.List (unzip4, nub)
type Binding = (Id, CoreExpr)
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
[(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 = Module -> [Id] -> CStub
foreignExportsInitialiser 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
fd_fi = ForeignImport
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) <- Id -> Coercion -> ForeignImport -> DsM ([Binding], CHeader, CStub)
dsFImport Id
id' XForeignImport GhcTc
co ForeignImport
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
fd_fe = CExport
(L SrcSpan
_ (CExportStatic SourceText
_ CLabelString
ext_nm CCallConv
cconv)) Located SourceText
_ }) = do
(CHeader
h, CStub
c, String
_, Arity
_) <- Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String, Arity)
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
-> DsM ([Binding], CHeader, CStub)
dsFImport :: Id -> Coercion -> ForeignImport -> DsM ([Binding], CHeader, CStub)
dsFImport Id
id Coercion
co (CImport Located CCallConv
cconv Located Safety
safety Maybe Header
mHeader CImportSpec
spec Located SourceText
_) =
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 Located CCallConv
cconv) (forall l e. GenLocated l e -> e
unLoc Located Safety
safety) Maybe Header
mHeader
dsCImport :: Id
-> Coercion
-> CImportSpec
-> CCallConv
-> Safety
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
dsCImport :: Id
-> Coercion
-> CImportSpec
-> CCallConv
-> Safety
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
dsCImport Id
id Coercion
co (CLabel CLabelString
cid) CCallConv
cconv Safety
_ Maybe Header
_ = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let ty :: Type
ty = Coercion -> Type
coercionLKind Coercion
co
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
fod :: FunctionOrData
fod = case Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Type
dropForAlls Type
ty) of
Just TyCon
tycon
| TyCon -> Unique
tyConUnique TyCon
tycon forall a. Eq a => a -> a -> Bool
== Unique
funPtrTyConKey ->
FunctionOrData
IsFunction
Maybe TyCon
_ -> FunctionOrData
IsData
(Maybe Type
resTy, CoreExpr -> CoreExpr
foRhs) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
ty
ASSERT(fromJust resTy `eqType` addrPrimTy)
let
rhs :: CoreExpr
rhs = CoreExpr -> CoreExpr
foRhs (forall b. Literal -> Expr b
Lit (CLabelString -> Maybe Arity -> FunctionOrData -> Literal
LitLabel CLabelString
cid Maybe Arity
stdcall_info FunctionOrData
fod))
rhs' :: CoreExpr
rhs' = forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
rhs Coercion
co
stdcall_info :: Maybe Arity
stdcall_info = Platform -> CCallConv -> Type -> Maybe Arity
fun_type_arg_stdcall_info Platform
platform CCallConv
cconv Type
ty
in
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id
id, CoreExpr
rhs')], forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)
dsCImport Id
id Coercion
co (CFunction CCallTarget
target) cconv :: CCallConv
cconv@CCallConv
PrimCallConv Safety
safety Maybe Header
_
= Id -> Coercion -> ForeignCall -> DsM ([Binding], CHeader, CStub)
dsPrimCall Id
id Coercion
co (CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec CCallTarget
target CCallConv
cconv Safety
safety))
dsCImport Id
id Coercion
co (CFunction CCallTarget
target) CCallConv
cconv Safety
safety Maybe Header
mHeader
= Id
-> Coercion
-> ForeignCall
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
dsFCall Id
id Coercion
co (CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec CCallTarget
target CCallConv
cconv Safety
safety)) Maybe Header
mHeader
dsCImport Id
id Coercion
co CImportSpec
CWrapper CCallConv
cconv Safety
_ Maybe Header
_
= Id -> Coercion -> CCallConv -> DsM ([Binding], CHeader, CStub)
dsFExportDynamic Id
id Coercion
co CCallConv
cconv
fun_type_arg_stdcall_info :: Platform -> CCallConv -> Type -> Maybe Int
fun_type_arg_stdcall_info :: Platform -> CCallConv -> Type -> Maybe Arity
fun_type_arg_stdcall_info Platform
platform CCallConv
StdCallConv Type
ty
| Just (TyCon
tc,[Type
arg_ty]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty,
TyCon -> Unique
tyConUnique TyCon
tc forall a. Eq a => a -> a -> Bool
== Unique
funPtrTyConKey
= let
([TyBinder]
bndrs, Type
_) = Type -> ([TyBinder], Type)
tcSplitPiTys Type
arg_ty
fe_arg_tys :: [Type]
fe_arg_tys = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TyBinder -> Maybe Type
binderRelevantType_maybe [TyBinder]
bndrs
in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map (Width -> Arity
widthInBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmType -> Width
typeWidth forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> Type -> CmmType
typeCmmType Platform
platform forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type
getPrimTyOf) [Type]
fe_arg_tys)
fun_type_arg_stdcall_info Platform
_ CCallConv
_other_conv Type
_
= forall a. Maybe a
Nothing
dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
-> DsM ([(Id, Expr TyVar)], CHeader, CStub)
dsFCall :: Id
-> Coercion
-> ForeignCall
-> Maybe Header
-> DsM ([Binding], CHeader, CStub)
dsFCall Id
fn_id Coercion
co ForeignCall
fcall Maybe Header
mDeclHeader = do
let
ty :: Type
ty = Coercion -> Type
coercionLKind Coercion
co
([TyVarBinder]
tv_bndrs, Type
rho) = Type -> ([TyVarBinder], Type)
tcSplitForAllTyVarBinders Type
ty
([Scaled Type]
arg_tys, Type
io_res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
rho
[Id]
args <- [Scaled Type] -> DsM [Id]
newSysLocalsDs [Scaled Type]
arg_tys
([CoreExpr]
val_args, [CoreExpr -> CoreExpr]
arg_wrappers) <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM CoreExpr -> DsM (CoreExpr, CoreExpr -> CoreExpr)
unboxArg (forall a b. (a -> b) -> [a] -> [b]
map forall b. Id -> Expr b
Var [Id]
args)
let
work_arg_ids :: [Id]
work_arg_ids = [Id
v | Var Id
v <- [CoreExpr]
val_args]
(Type
ccall_result_ty, CoreExpr -> CoreExpr
res_wrapper) <- Type -> DsM (Type, CoreExpr -> CoreExpr)
boxResult Type
io_res_ty
Unique
ccall_uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
Unique
work_uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
(ForeignCall
fcall', SDoc
cDoc) <-
case ForeignCall
fcall of
CCall (CCallSpec (StaticTarget SourceText
_ CLabelString
cName Maybe Unit
mUnitId Bool
isFun)
CCallConv
CApiConv Safety
safety) ->
do CLabelString
wrapperName <- forall (m :: * -> *).
(MonadIO m, HasDynFlags m, HasModule m) =>
String -> String -> m CLabelString
mkWrapperName String
"ghc_wrapper" (CLabelString -> String
unpackFS CLabelString
cName)
let fcall' :: ForeignCall
fcall' = CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec
(SourceText -> CLabelString -> Maybe Unit -> Bool -> CCallTarget
StaticTarget SourceText
NoSourceText
CLabelString
wrapperName Maybe Unit
mUnitId
Bool
True)
CCallConv
CApiConv Safety
safety)
c :: SDoc
c = SDoc
includes
SDoc -> SDoc -> SDoc
$$ SDoc
fun_proto SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
braces (SDoc
cRet SDoc -> SDoc -> SDoc
<> SDoc
semi)
includes :: SDoc
includes = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"#include \"" SDoc -> SDoc -> SDoc
<> CLabelString -> SDoc
ftext CLabelString
h
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"\""
| Header SourceText
_ CLabelString
h <- forall a. Eq a => [a] -> [a]
nub [Header]
headers ]
fun_proto :: SDoc
fun_proto = SDoc
cResType SDoc -> SDoc -> SDoc
<+> SDoc
pprCconv SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr CLabelString
wrapperName SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens SDoc
argTypes
cRet :: SDoc
cRet
| Bool
isVoidRes = SDoc
cCall
| Bool
otherwise = String -> SDoc
text String
"return" SDoc -> SDoc -> SDoc
<+> SDoc
cCall
cCall :: SDoc
cCall = if Bool
isFun
then forall a. Outputable a => a -> SDoc
ppr CLabelString
cName SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens SDoc
argVals
else if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Scaled Type]
arg_tys
then forall a. Outputable a => a -> SDoc
ppr CLabelString
cName
else forall a. String -> a
panic String
"dsFCall: Unexpected arguments to FFI value import"
raw_res_ty :: Type
raw_res_ty = case Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
io_res_ty of
Just (TyCon
_ioTyCon, Type
res_ty) -> Type
res_ty
Maybe (TyCon, Type)
Nothing -> Type
io_res_ty
isVoidRes :: Bool
isVoidRes = Type
raw_res_ty Type -> Type -> Bool
`eqType` Type
unitTy
(Maybe Header
mHeader, SDoc
cResType)
| Bool
isVoidRes = (forall a. Maybe a
Nothing, String -> SDoc
text String
"void")
| Bool
otherwise = Type -> (Maybe Header, SDoc)
toCType Type
raw_res_ty
pprCconv :: SDoc
pprCconv = CCallConv -> SDoc
ccallConvAttribute CCallConv
CApiConv
mHeadersArgTypeList :: [(Maybe Header, SDoc)]
mHeadersArgTypeList
= [ (Maybe Header
header, SDoc
cType SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'a' SDoc -> SDoc -> SDoc
<> Arity -> SDoc
int Arity
n)
| (Scaled Type
t, Arity
n) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Scaled Type]
arg_tys [Arity
1..]
, let (Maybe Header
header, SDoc
cType) = Type -> (Maybe Header, SDoc)
toCType (forall a. Scaled a -> a
scaledThing Scaled Type
t) ]
([Maybe Header]
mHeaders, [SDoc]
argTypeList) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Maybe Header, SDoc)]
mHeadersArgTypeList
argTypes :: SDoc
argTypes = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SDoc]
argTypeList
then String -> SDoc
text String
"void"
else [SDoc] -> SDoc
hsep forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma [SDoc]
argTypeList
mHeaders' :: [Maybe Header]
mHeaders' = Maybe Header
mDeclHeader forall a. a -> [a] -> [a]
: Maybe Header
mHeader forall a. a -> [a] -> [a]
: [Maybe Header]
mHeaders
headers :: [Header]
headers = forall a. [Maybe a] -> [a]
catMaybes [Maybe Header]
mHeaders'
argVals :: SDoc
argVals = [SDoc] -> SDoc
hsep forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
[ Char -> SDoc
char Char
'a' SDoc -> SDoc -> SDoc
<> Arity -> SDoc
int Arity
n
| (Scaled Type
_, Arity
n) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Scaled Type]
arg_tys [Arity
1..] ]
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignCall
fcall', SDoc
c)
ForeignCall
_ ->
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignCall
fcall, SDoc
empty)
let
worker_ty :: Type
worker_ty = [TyVarBinder] -> Type -> Type
mkForAllTys [TyVarBinder]
tv_bndrs ([Type] -> Type -> Type
mkVisFunTysMany (forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
work_arg_ids) Type
ccall_result_ty)
tvs :: [Id]
tvs = forall a b. (a -> b) -> [a] -> [b]
map forall tv argf. VarBndr tv argf -> tv
binderVar [TyVarBinder]
tv_bndrs
the_ccall_app :: CoreExpr
the_ccall_app = DynFlags -> Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall DynFlags
dflags Unique
ccall_uniq ForeignCall
fcall' [CoreExpr]
val_args Type
ccall_result_ty
work_rhs :: CoreExpr
work_rhs = forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs (forall b. [b] -> Expr b -> Expr b
mkLams [Id]
work_arg_ids CoreExpr
the_ccall_app)
work_id :: Id
work_id = CLabelString -> Unique -> Type -> Type -> Id
mkSysLocal (String -> CLabelString
fsLit String
"$wccall") Unique
work_uniq Type
Many Type
worker_ty
work_app :: CoreExpr
work_app = forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Expr b -> [Id] -> Expr b
mkVarApps (forall b. Id -> Expr b
Var Id
work_id) [Id]
tvs) [CoreExpr]
val_args
wrapper_body :: CoreExpr
wrapper_body = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. (a -> b) -> a -> b
($) (CoreExpr -> CoreExpr
res_wrapper CoreExpr
work_app) [CoreExpr -> CoreExpr]
arg_wrappers
wrap_rhs :: CoreExpr
wrap_rhs = forall b. [b] -> Expr b -> Expr b
mkLams ([Id]
tvs forall a. [a] -> [a] -> [a]
++ [Id]
args) CoreExpr
wrapper_body
wrap_rhs' :: CoreExpr
wrap_rhs' = forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
wrap_rhs Coercion
co
simpl_opts :: SimpleOpts
simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
fn_id_w_inl :: Id
fn_id_w_inl = Id
fn_id Id -> Unfolding -> Id
`setIdUnfolding` Arity -> SimpleOpts -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity
(forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Id]
args)
SimpleOpts
simpl_opts
CoreExpr
wrap_rhs'
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id
work_id, CoreExpr
work_rhs), (Id
fn_id_w_inl, CoreExpr
wrap_rhs')], forall a. Monoid a => a
mempty, SDoc -> CStub
CStub SDoc
cDoc)
dsPrimCall :: Id -> Coercion -> ForeignCall
-> DsM ([(Id, Expr TyVar)], CHeader, CStub)
dsPrimCall :: Id -> Coercion -> ForeignCall -> DsM ([Binding], CHeader, CStub)
dsPrimCall Id
fn_id Coercion
co ForeignCall
fcall = do
let
ty :: Type
ty = Coercion -> Type
coercionLKind Coercion
co
([Id]
tvs, Type
fun_ty) = Type -> ([Id], Type)
tcSplitForAllInvisTyVars Type
ty
([Scaled Type]
arg_tys, Type
io_res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
fun_ty
[Id]
args <- [Scaled Type] -> DsM [Id]
newSysLocalsDs [Scaled Type]
arg_tys
Unique
ccall_uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let
call_app :: CoreExpr
call_app = DynFlags -> Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall DynFlags
dflags Unique
ccall_uniq ForeignCall
fcall (forall a b. (a -> b) -> [a] -> [b]
map forall b. Id -> Expr b
Var [Id]
args) Type
io_res_ty
rhs :: CoreExpr
rhs = forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs (forall b. [b] -> Expr b -> Expr b
mkLams [Id]
args CoreExpr
call_app)
rhs' :: CoreExpr
rhs' = forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
rhs Coercion
co
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Id
fn_id, CoreExpr
rhs')], forall a. Monoid a => a
mempty, forall a. Monoid a => a
mempty)
dsFExport :: Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM ( CHeader
, CStub
, String
, Int
)
dsFExport :: Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String, Arity)
dsFExport Id
fn_id Coercion
co CLabelString
ext_name CCallConv
cconv Bool
isDyn = do
let
ty :: Type
ty = Coercion -> Type
coercionRKind Coercion
co
([TyBinder]
bndrs, Type
orig_res_ty) = Type -> ([TyBinder], Type)
tcSplitPiTys Type
ty
fe_arg_tys' :: [Type]
fe_arg_tys' = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe TyBinder -> Maybe Type
binderRelevantType_maybe [TyBinder]
bndrs
fe_arg_tys :: [Type]
fe_arg_tys | Bool
isDyn = forall a. [a] -> [a]
tail [Type]
fe_arg_tys'
| Bool
otherwise = [Type]
fe_arg_tys'
(Type
res_ty, Bool
is_IO_res_ty) = case Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
orig_res_ty of
Just (TyCon
_ioTyCon, Type
res_ty) -> (Type
res_ty, Bool
True)
Maybe (TyCon, Type)
Nothing -> (Type
orig_res_ty, Bool
False)
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
DynFlags
-> CLabelString
-> Maybe Id
-> [Type]
-> Type
-> Bool
-> CCallConv
-> (CHeader, CStub, String, Arity)
mkFExportCBits DynFlags
dflags CLabelString
ext_name
(if Bool
isDyn then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Id
fn_id)
[Type]
fe_arg_tys Type
res_ty Bool
is_IO_res_ty CCallConv
cconv
dsFExportDynamic :: Id
-> Coercion
-> CCallConv
-> DsM ([Binding], CHeader, CStub)
dsFExportDynamic :: Id -> Coercion -> CCallConv -> DsM ([Binding], CHeader, CStub)
dsFExportDynamic Id
id Coercion
co0 CCallConv
cconv = do
Module
mod <- forall (m :: * -> *). HasModule m => m Module
getModule
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
let fe_nm :: CLabelString
fe_nm = String -> CLabelString
mkFastString forall a b. (a -> b) -> a -> b
$ String -> String
zEncodeString
(Module -> String
moduleStableString Module
mod forall a. [a] -> [a] -> [a]
++ String
"$" forall a. [a] -> [a] -> [a]
++ DynFlags -> Id -> String
toCName DynFlags
dflags Id
id)
Id
cback <- Type -> Type -> DsM Id
newSysLocalDs Type
arg_mult Type
arg_ty
Id
newStablePtrId <- Name -> DsM Id
dsLookupGlobalId Name
newStablePtrName
TyCon
stable_ptr_tycon <- Name -> DsM TyCon
dsLookupTyCon Name
stablePtrTyConName
let
stable_ptr_ty :: Type
stable_ptr_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
stable_ptr_tycon [Type
arg_ty]
export_ty :: Type
export_ty = Type -> Type -> Type
mkVisFunTyMany Type
stable_ptr_ty Type
arg_ty
Id
bindIOId <- Name -> DsM Id
dsLookupGlobalId Name
bindIOName
Id
stbl_value <- Type -> Type -> DsM Id
newSysLocalDs Type
Many Type
stable_ptr_ty
(CHeader
h_code, CStub
c_code, String
typestring, Arity
args_size) <- Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String, Arity)
dsFExport Id
id (Type -> Coercion
mkRepReflCo Type
export_ty) CLabelString
fe_nm CCallConv
cconv Bool
True
let
adj_args :: [CoreExpr]
adj_args = [ forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform (forall a b. (Integral a, Num b) => a -> b
fromIntegral (CCallConv -> Arity
ccallConvToInt CCallConv
cconv))
, forall b. Id -> Expr b
Var Id
stbl_value
, forall b. Literal -> Expr b
Lit (CLabelString -> Maybe Arity -> FunctionOrData -> Literal
LitLabel CLabelString
fe_nm Maybe Arity
mb_sz_args FunctionOrData
IsFunction)
, forall b. Literal -> Expr b
Lit (String -> Literal
mkLitString String
typestring)
]
adjustor :: CLabelString
adjustor = String -> CLabelString
fsLit String
"createAdjustor"
mb_sz_args :: Maybe Arity
mb_sz_args = case CCallConv
cconv of
CCallConv
StdCallConv -> forall a. a -> Maybe a
Just Arity
args_size
CCallConv
_ -> forall a. Maybe a
Nothing
CoreExpr
ccall_adj <- CLabelString -> [CoreExpr] -> Safety -> Type -> DsM CoreExpr
dsCCall CLabelString
adjustor [CoreExpr]
adj_args Safety
PlayRisky (TyCon -> [Type] -> Type
mkTyConApp TyCon
io_tc [Type
res_ty])
let io_app :: CoreExpr
io_app = forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs forall a b. (a -> b) -> a -> b
$
forall b. b -> Expr b -> Expr b
Lam Id
cback forall a b. (a -> b) -> a -> b
$
forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var Id
bindIOId)
[ forall b. Type -> Expr b
Type Type
stable_ptr_ty
, forall b. Type -> Expr b
Type Type
res_ty
, forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Id -> Expr b
Var Id
newStablePtrId) [ forall b. Type -> Expr b
Type Type
arg_ty, forall b. Id -> Expr b
Var Id
cback ]
, forall b. b -> Expr b -> Expr b
Lam Id
stbl_value CoreExpr
ccall_adj
]
fed :: Binding
fed = (Id
id Id -> Activation -> Id
`setInlineActivation` Activation
NeverActive, forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
io_app Coercion
co0)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Binding
fed], CHeader
h_code, CStub
c_code)
where
ty :: Type
ty = Coercion -> Type
coercionLKind Coercion
co0
([Id]
tvs,Type
sans_foralls) = Type -> ([Id], Type)
tcSplitForAllInvisTyVars Type
ty
([Scaled Type
arg_mult Type
arg_ty], Type
fn_res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
sans_foralls
Just (TyCon
io_tc, Type
res_ty) = Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
fn_res_ty
toCName :: DynFlags -> Id -> String
toCName :: DynFlags -> Id -> String
toCName DynFlags
dflags Id
i = DynFlags -> SDoc -> String
showSDoc DynFlags
dflags (LabelStyle -> SDoc -> SDoc
pprCode LabelStyle
CStyle (forall a. Outputable a => a -> SDoc
ppr (Id -> Name
idName Id
i)))
mkFExportCBits :: DynFlags
-> FastString
-> Maybe Id
-> [Type]
-> Type
-> Bool
-> CCallConv
-> (CHeader,
CStub,
String,
Int
)
mkFExportCBits :: DynFlags
-> CLabelString
-> Maybe Id
-> [Type]
-> Type
-> Bool
-> CCallConv
-> (CHeader, CStub, String, Arity)
mkFExportCBits DynFlags
dflags CLabelString
c_nm Maybe Id
maybe_target [Type]
arg_htys Type
res_hty Bool
is_IO_res_ty CCallConv
cc
= (CHeader
header_bits, CStub
c_bits, String
type_string,
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [ Width -> Arity
widthInBytes (CmmType -> Width
typeWidth CmmType
rep) | (SDoc
_,SDoc
_,Type
_,CmmType
rep) <- [(SDoc, SDoc, Type, CmmType)]
aug_arg_info]
)
where
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
arg_info :: [(SDoc,
SDoc,
Type,
CmmType)]
arg_info :: [(SDoc, SDoc, Type, CmmType)]
arg_info = [ let stg_type :: SDoc
stg_type = Type -> SDoc
showStgType Type
ty in
(Arity -> SDoc -> SDoc
arg_cname Arity
n SDoc
stg_type,
SDoc
stg_type,
Type
ty,
Platform -> Type -> CmmType
typeCmmType Platform
platform (Type -> Type
getPrimTyOf Type
ty))
| (Type
ty,Arity
n) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
arg_htys [Arity
1::Int ..] ]
arg_cname :: Arity -> SDoc -> SDoc
arg_cname Arity
n SDoc
stg_ty
| Bool
libffi = Char -> SDoc
char Char
'*' SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (SDoc
stg_ty SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'*') SDoc -> SDoc -> SDoc
<>
String -> SDoc
text String
"args" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets (Arity -> SDoc
int (Arity
nforall a. Num a => a -> a -> a
-Arity
1))
| Bool
otherwise = String -> SDoc
text (Char
'a'forall a. a -> [a] -> [a]
:forall a. Show a => a -> String
show Arity
n)
libffi :: Bool
libffi = PlatformMisc -> Bool
platformMisc_libFFI (DynFlags -> PlatformMisc
platformMisc DynFlags
dflags) Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing Maybe Id
maybe_target
type_string :: String
type_string
| Bool
libffi = Platform -> Type -> Char
primTyDescChar Platform
platform Type
res_hty forall a. a -> [a] -> [a]
: String
arg_type_string
| Bool
otherwise = String
arg_type_string
arg_type_string :: String
arg_type_string = [Platform -> Type -> Char
primTyDescChar Platform
platform Type
ty | (SDoc
_,SDoc
_,Type
ty,CmmType
_) <- [(SDoc, SDoc, Type, CmmType)]
arg_info]
aug_arg_info :: [(SDoc, SDoc, Type, CmmType)]
aug_arg_info
| forall a. Maybe a -> Bool
isNothing Maybe Id
maybe_target = (SDoc, SDoc, Type, CmmType)
stable_ptr_arg forall a. a -> [a] -> [a]
: Platform
-> CCallConv
-> [(SDoc, SDoc, Type, CmmType)]
-> [(SDoc, SDoc, Type, CmmType)]
insertRetAddr Platform
platform CCallConv
cc [(SDoc, SDoc, Type, CmmType)]
arg_info
| Bool
otherwise = [(SDoc, SDoc, Type, CmmType)]
arg_info
stable_ptr_arg :: (SDoc, SDoc, Type, CmmType)
stable_ptr_arg =
(String -> SDoc
text String
"the_stableptr", String -> SDoc
text String
"StgStablePtr", forall a. HasCallStack => a
undefined,
Platform -> Type -> CmmType
typeCmmType Platform
platform (Type -> Type
mkStablePtrPrimTy Type
alphaTy))
res_hty_is_unit :: Bool
res_hty_is_unit = Type
res_hty Type -> Type -> Bool
`eqType` Type
unitTy
cResType :: SDoc
cResType | Bool
res_hty_is_unit = String -> SDoc
text String
"void"
| Bool
otherwise = Type -> SDoc
showStgType Type
res_hty
ffi_cResType :: SDoc
ffi_cResType
| Bool
is_ffi_arg_type = String -> SDoc
text String
"ffi_arg"
| Bool
otherwise = SDoc
cResType
where
res_ty_key :: Unique
res_ty_key = forall a. Uniquable a => a -> Unique
getUnique (forall a. NamedThing a => a -> Name
getName (Type -> TyCon
typeTyCon Type
res_hty))
is_ffi_arg_type :: Bool
is_ffi_arg_type = Unique
res_ty_key forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem`
[Unique
floatTyConKey, Unique
doubleTyConKey,
Unique
int64TyConKey, Unique
word64TyConKey]
pprCconv :: SDoc
pprCconv = CCallConv -> SDoc
ccallConvAttribute CCallConv
cc
header_bits :: CHeader
header_bits = SDoc -> CHeader
CHeader (String -> SDoc
text String
"extern" SDoc -> SDoc -> SDoc
<+> SDoc
fun_proto SDoc -> SDoc -> SDoc
<> SDoc
semi)
fun_args :: SDoc
fun_args
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(SDoc, SDoc, Type, CmmType)]
aug_arg_info = String -> SDoc
text String
"void"
| Bool
otherwise = [SDoc] -> SDoc
hsep forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(SDoc
nm,SDoc
ty,Type
_,CmmType
_) -> SDoc
ty SDoc -> SDoc -> SDoc
<+> SDoc
nm) [(SDoc, SDoc, Type, CmmType)]
aug_arg_info
fun_proto :: SDoc
fun_proto
| Bool
libffi
= String -> SDoc
text String
"void" SDoc -> SDoc -> SDoc
<+> CLabelString -> SDoc
ftext CLabelString
c_nm SDoc -> SDoc -> SDoc
<>
SDoc -> SDoc
parens (String -> SDoc
text String
"void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
| Bool
otherwise
= SDoc
cResType SDoc -> SDoc -> SDoc
<+> SDoc
pprCconv SDoc -> SDoc -> SDoc
<+> CLabelString -> SDoc
ftext CLabelString
c_nm SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens SDoc
fun_args
the_cfun :: SDoc
the_cfun
= case Maybe Id
maybe_target of
Maybe Id
Nothing -> String -> SDoc
text String
"(StgClosure*)deRefStablePtr(the_stableptr)"
Just Id
hs_fn -> Char -> SDoc
char Char
'&' SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Id
hs_fn SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"_closure"
cap :: SDoc
cap = String -> SDoc
text String
"cap" SDoc -> SDoc -> SDoc
<> SDoc
comma
expr_to_run :: SDoc
expr_to_run
= forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {b} {d}. SDoc -> (SDoc, b, Type, d) -> SDoc
appArg SDoc
the_cfun [(SDoc, SDoc, Type, CmmType)]
arg_info
where
appArg :: SDoc -> (SDoc, b, Type, d) -> SDoc
appArg SDoc
acc (SDoc
arg_cname, b
_, Type
arg_hty, d
_)
= String -> SDoc
text String
"rts_apply"
SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (SDoc
cap SDoc -> SDoc -> SDoc
<> SDoc
acc SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<> Type -> SDoc
mkHObj Type
arg_hty SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (SDoc
cap SDoc -> SDoc -> SDoc
<> SDoc
arg_cname))
declareResult :: SDoc
declareResult = String -> SDoc
text String
"HaskellObj ret;"
declareCResult :: SDoc
declareCResult | Bool
res_hty_is_unit = SDoc
empty
| Bool
otherwise = SDoc
cResType SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"cret;"
assignCResult :: SDoc
assignCResult | Bool
res_hty_is_unit = SDoc
empty
| Bool
otherwise =
String -> SDoc
text String
"cret=" SDoc -> SDoc -> SDoc
<> Type -> SDoc
unpackHObj Type
res_hty SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (String -> SDoc
text String
"ret") SDoc -> SDoc -> SDoc
<> SDoc
semi
extern_decl :: SDoc
extern_decl
= case Maybe Id
maybe_target of
Maybe Id
Nothing -> SDoc
empty
Just Id
hs_fn -> String -> SDoc
text String
"extern StgClosure " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Id
hs_fn SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"_closure" SDoc -> SDoc -> SDoc
<> SDoc
semi
c_bits :: CStub
c_bits = SDoc -> CStub
CStub forall a b. (a -> b) -> a -> b
$
SDoc
space SDoc -> SDoc -> SDoc
$$
SDoc
extern_decl SDoc -> SDoc -> SDoc
$$
SDoc
fun_proto SDoc -> SDoc -> SDoc
$$
[SDoc] -> SDoc
vcat
[ SDoc
lbrace
, String -> SDoc
text String
"Capability *cap;"
, SDoc
declareResult
, SDoc
declareCResult
, String -> SDoc
text String
"cap = rts_lock();"
, String -> SDoc
text String
"rts_inCall" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (
Char -> SDoc
char Char
'&' SDoc -> SDoc -> SDoc
<> SDoc
cap SDoc -> SDoc -> SDoc
<>
String -> SDoc
text String
"rts_apply" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (
SDoc
cap SDoc -> SDoc -> SDoc
<>
String -> SDoc
text String
"(HaskellObj)"
SDoc -> SDoc -> SDoc
<> PtrString -> SDoc
ptext (if Bool
is_IO_res_ty
then (String -> PtrString
sLit String
"runIO_closure")
else (String -> PtrString
sLit String
"runNonIO_closure"))
SDoc -> SDoc -> SDoc
<> SDoc
comma
SDoc -> SDoc -> SDoc
<> SDoc
expr_to_run
) SDoc -> SDoc -> SDoc
<+> SDoc
comma
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"&ret"
) SDoc -> SDoc -> SDoc
<> SDoc
semi
, String -> SDoc
text String
"rts_checkSchedStatus" SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (SDoc -> SDoc
doubleQuotes (CLabelString -> SDoc
ftext CLabelString
c_nm)
SDoc -> SDoc -> SDoc
<> SDoc
comma SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"cap") SDoc -> SDoc -> SDoc
<> SDoc
semi
, SDoc
assignCResult
, String -> SDoc
text String
"rts_unlock(cap);"
, Bool -> SDoc -> SDoc
ppUnless Bool
res_hty_is_unit forall a b. (a -> b) -> a -> b
$
if Bool
libffi
then Char -> SDoc
char Char
'*' SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (SDoc
ffi_cResType SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'*') SDoc -> SDoc -> SDoc
<>
String -> SDoc
text String
"resp = cret;"
else String -> SDoc
text String
"return cret;"
, SDoc
rbrace
]
foreignExportsInitialiser :: Module -> [Id] -> CStub
foreignExportsInitialiser :: Module -> [Id] -> CStub
foreignExportsInitialiser Module
mod [Id]
hs_fns =
SDoc -> CStub
CStub forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ 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 -> Arity
length [Id]
hs_fns))
SDoc -> SDoc -> SDoc
<> SDoc
semi
, String -> SDoc
text String
"static void " SDoc -> SDoc -> SDoc
<> SDoc
ctor_symbol SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"(void)"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
" __attribute__((constructor));"
, String -> SDoc
text String
"static void " SDoc -> SDoc -> SDoc
<> SDoc
ctor_symbol SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
"()"
, SDoc -> SDoc
braces (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)
]
where
mod_str :: SDoc
mod_str = ModuleName -> SDoc
pprModuleName (forall unit. GenModule unit -> ModuleName
moduleName Module
mod)
ctor_symbol :: SDoc
ctor_symbol = String -> SDoc
text String
"stginit_export_" SDoc -> SDoc -> SDoc
<> SDoc
mod_str
list_symbol :: SDoc
list_symbol = String -> SDoc
text String
"stg_exports_" SDoc -> SDoc -> SDoc
<> SDoc
mod_str
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"
mkHObj :: Type -> SDoc
mkHObj :: Type -> SDoc
mkHObj Type
t = String -> SDoc
text String
"rts_mk" SDoc -> SDoc -> SDoc
<> String -> SDoc
text (Type -> String
showFFIType Type
t)
unpackHObj :: Type -> SDoc
unpackHObj :: Type -> SDoc
unpackHObj Type
t = String -> SDoc
text String
"rts_get" SDoc -> SDoc -> SDoc
<> String -> SDoc
text (Type -> String
showFFIType Type
t)
showStgType :: Type -> SDoc
showStgType :: Type -> SDoc
showStgType Type
t = String -> SDoc
text String
"Hs" SDoc -> SDoc -> SDoc
<> String -> SDoc
text (Type -> String
showFFIType Type
t)
showFFIType :: Type -> String
showFFIType :: Type -> String
showFFIType Type
t = forall a. NamedThing a => a -> String
getOccString (forall a. NamedThing a => a -> Name
getName (Type -> TyCon
typeTyCon Type
t))
toCType :: Type -> (Maybe Header, SDoc)
toCType :: Type -> (Maybe Header, SDoc)
toCType = Bool -> Type -> (Maybe Header, SDoc)
f Bool
False
where f :: Bool -> Type -> (Maybe Header, SDoc)
f Bool
voidOK Type
t
| Just (TyCon
ptr, [Type
t']) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t
, TyCon -> Name
tyConName TyCon
ptr forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name
ptrTyConName, Name
funPtrTyConName]
= case Bool -> Type -> (Maybe Header, SDoc)
f Bool
True Type
t' of
(Maybe Header
mh, SDoc
cType') ->
(Maybe Header
mh, SDoc
cType' SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'*')
| Just TyCon
tycon <- Type -> Maybe TyCon
tyConAppTyConPicky_maybe Type
t
, Just (CType SourceText
_ Maybe Header
mHeader (SourceText
_,CLabelString
cType)) <- TyCon -> Maybe CType
tyConCType_maybe TyCon
tycon
= (Maybe Header
mHeader, CLabelString -> SDoc
ftext CLabelString
cType)
| Just Type
t' <- Type -> Maybe Type
coreView Type
t
= Bool -> Type -> (Maybe Header, SDoc)
f Bool
voidOK Type
t'
| forall a. a -> Maybe a
Just TyCon
byteArrayPrimTyCon forall a. Eq a => a -> a -> Bool
== Type -> Maybe TyCon
tyConAppTyConPicky_maybe Type
t
= (forall a. Maybe a
Nothing, String -> SDoc
text String
"const void*")
| forall a. a -> Maybe a
Just TyCon
mutableByteArrayPrimTyCon forall a. Eq a => a -> a -> Bool
== Type -> Maybe TyCon
tyConAppTyConPicky_maybe Type
t
= (forall a. Maybe a
Nothing, String -> SDoc
text String
"void*")
| Bool
voidOK = (forall a. Maybe a
Nothing, String -> SDoc
text String
"void")
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"toCType" (forall a. Outputable a => a -> SDoc
ppr Type
t)
typeTyCon :: Type -> TyCon
typeTyCon :: Type -> TyCon
typeTyCon Type
ty
| Just (TyCon
tc, [Type]
_) <- HasCallStack => Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe (Type -> Type
unwrapType Type
ty)
= TyCon
tc
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.HsToCore.Foreign.Decl.typeTyCon" (forall a. Outputable a => a -> SDoc
ppr Type
ty)
insertRetAddr :: Platform -> CCallConv
-> [(SDoc, SDoc, Type, CmmType)]
-> [(SDoc, SDoc, Type, CmmType)]
insertRetAddr :: Platform
-> CCallConv
-> [(SDoc, SDoc, Type, CmmType)]
-> [(SDoc, SDoc, Type, CmmType)]
insertRetAddr Platform
platform CCallConv
CCallConv [(SDoc, SDoc, Type, CmmType)]
args
= case Platform -> Arch
platformArch Platform
platform of
Arch
ArchX86_64
| Platform -> OS
platformOS Platform
platform forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32 ->
let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
-> [(SDoc, SDoc, Type, CmmType)]
go :: Arity
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go Arity
4 [(SDoc, SDoc, Type, CmmType)]
args = Platform -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg Platform
platform forall a. a -> [a] -> [a]
: [(SDoc, SDoc, Type, CmmType)]
args
go Arity
n ((SDoc, SDoc, Type, CmmType)
arg:[(SDoc, SDoc, Type, CmmType)]
args) = (SDoc, SDoc, Type, CmmType)
arg forall a. a -> [a] -> [a]
: Arity
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go (Arity
nforall a. Num a => a -> a -> a
+Arity
1) [(SDoc, SDoc, Type, CmmType)]
args
go Arity
_ [] = []
in Arity
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go Arity
0 [(SDoc, SDoc, Type, CmmType)]
args
| Bool
otherwise ->
let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
-> [(SDoc, SDoc, Type, CmmType)]
go :: Arity
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go Arity
6 [(SDoc, SDoc, Type, CmmType)]
args = Platform -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg Platform
platform forall a. a -> [a] -> [a]
: [(SDoc, SDoc, Type, CmmType)]
args
go Arity
n (arg :: (SDoc, SDoc, Type, CmmType)
arg@(SDoc
_,SDoc
_,Type
_,CmmType
rep):[(SDoc, SDoc, Type, CmmType)]
args)
| CmmType -> CmmType -> Bool
cmmEqType_ignoring_ptrhood CmmType
rep CmmType
b64 = (SDoc, SDoc, Type, CmmType)
arg forall a. a -> [a] -> [a]
: Arity
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go (Arity
nforall a. Num a => a -> a -> a
+Arity
1) [(SDoc, SDoc, Type, CmmType)]
args
| Bool
otherwise = (SDoc, SDoc, Type, CmmType)
arg forall a. a -> [a] -> [a]
: Arity
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go Arity
n [(SDoc, SDoc, Type, CmmType)]
args
go Arity
_ [] = []
in Arity
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go Arity
0 [(SDoc, SDoc, Type, CmmType)]
args
Arch
_ ->
Platform -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg Platform
platform forall a. a -> [a] -> [a]
: [(SDoc, SDoc, Type, CmmType)]
args
insertRetAddr Platform
_ CCallConv
_ [(SDoc, SDoc, Type, CmmType)]
args = [(SDoc, SDoc, Type, CmmType)]
args
ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg Platform
platform = (String -> SDoc
text String
"original_return_addr", String -> SDoc
text String
"void*", forall a. HasCallStack => a
undefined,
Platform -> Type -> CmmType
typeCmmType Platform
platform Type
addrPrimTy)
getPrimTyOf :: Type -> UnaryType
getPrimTyOf :: Type -> Type
getPrimTyOf Type
ty
| Type -> Bool
isBoolTy Type
rep_ty = Type
intPrimTy
| Bool
otherwise =
case Type -> Maybe (TyCon, [Type], DataCon, [Scaled Type])
splitDataProductType_maybe Type
rep_ty of
Just (TyCon
_, [Type]
_, DataCon
data_con, [Scaled Type
_ Type
prim_ty]) ->
ASSERT(dataConSourceArity data_con == 1)
ASSERT2(isUnliftedType prim_ty, ppr prim_ty)
Type
prim_ty
Maybe (TyCon, [Type], DataCon, [Scaled Type])
_other -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.HsToCore.Foreign.Decl.getPrimTyOf" (forall a. Outputable a => a -> SDoc
ppr Type
ty)
where
rep_ty :: Type
rep_ty = Type -> Type
unwrapType Type
ty
primTyDescChar :: Platform -> Type -> Char
primTyDescChar :: Platform -> Type -> Char
primTyDescChar Platform
platform Type
ty
| Type
ty Type -> Type -> Bool
`eqType` Type
unitTy = Char
'v'
| Bool
otherwise
= case HasDebugCallStack => Type -> PrimRep
typePrimRep1 (Type -> Type
getPrimTyOf Type
ty) of
PrimRep
IntRep -> Char
signed_word
PrimRep
WordRep -> Char
unsigned_word
PrimRep
Int8Rep -> Char
'B'
PrimRep
Word8Rep -> Char
'b'
PrimRep
Int16Rep -> Char
'S'
PrimRep
Word16Rep -> Char
's'
PrimRep
Int32Rep -> Char
'W'
PrimRep
Word32Rep -> Char
'w'
PrimRep
Int64Rep -> Char
'L'
PrimRep
Word64Rep -> Char
'l'
PrimRep
AddrRep -> Char
'p'
PrimRep
FloatRep -> Char
'f'
PrimRep
DoubleRep -> Char
'd'
PrimRep
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"primTyDescChar" (forall a. Outputable a => a -> SDoc
ppr Type
ty)
where
(Char
signed_word, Char
unsigned_word) = case Platform -> PlatformWordSize
platformWordSize Platform
platform of
PlatformWordSize
PW4 -> (Char
'W',Char
'w')
PlatformWordSize
PW8 -> (Char
'L',Char
'l')