{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.HsToCore.Foreign.C
( dsCImport
, dsCFExport
, dsCFExportDynamic
)
where
import GHC.Prelude
import GHC.Platform
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcType
import GHC.Core
import GHC.Core.Unfold.Make
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Core.Coercion
import GHC.Core.Multiplicity
import GHC.HsToCore.Foreign.Call
import GHC.HsToCore.Foreign.Prim
import GHC.HsToCore.Foreign.Utils
import GHC.HsToCore.Monad
import GHC.HsToCore.Types (ds_next_wrapper_num)
import GHC.Hs
import GHC.Types.Id
import GHC.Types.Literal
import GHC.Types.ForeignStubs
import GHC.Types.SourceText
import GHC.Types.Name
import GHC.Types.RepType
import GHC.Types.ForeignCall
import GHC.Types.Basic
import GHC.Unit.Module
import GHC.Driver.DynFlags
import GHC.Driver.Config
import GHC.Cmm.Expr
import GHC.Cmm.Utils
import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Builtin.Names
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Encoding
import Data.Maybe
import Data.List (nub)
dsCFExport:: Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM ( CHeader
, CStub
, String
)
dsCFExport :: Id
-> Coercion
-> CLabelString
-> CCallConv
-> Bool
-> DsM (CHeader, CStub, String)
dsCFExport Id
fn_id Coercion
co CLabelString
ext_name CCallConv
cconv Bool
isDyn = do
let
ty :: Type
ty = HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionRKind Coercion
co
([PiTyVarBinder]
bndrs, Type
orig_res_ty) = Type -> ([PiTyVarBinder], Type)
tcSplitPiTys Type
ty
fe_arg_tys' :: [Type]
fe_arg_tys' = (PiTyVarBinder -> Maybe Type) -> [PiTyVarBinder] -> [Type]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PiTyVarBinder -> Maybe Type
anonPiTyBinderType_maybe [PiTyVarBinder]
bndrs
fe_arg_tys :: [Type]
fe_arg_tys | Bool
isDyn = [Type] -> [Type]
forall a. HasCallStack => [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)
dflags <- IOEnv (Env DsGblEnv DsLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
return $
mkFExportCBits dflags ext_name
(if isDyn then Nothing else Just fn_id)
fe_arg_tys res_ty is_IO_res_ty cconv
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
_ Safety
_ Maybe Header
_ = do
let ty :: Type
ty = HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionLKind Coercion
co
fod :: FunctionOrData
fod = case Type -> Maybe TyCon
tyConAppTyCon_maybe (Type -> Type
dropForAlls Type
ty) of
Just TyCon
tycon
| TyCon -> Unique
tyConUnique TyCon
tycon Unique -> Unique -> Bool
forall a. Eq a => a -> a -> Bool
== Unique
funPtrTyConKey ->
FunctionOrData
IsFunction
Maybe TyCon
_ -> FunctionOrData
IsData
(resTy, foRhs) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
ty
assert (fromJust resTy `eqType` addrPrimTy) $
let
rhs = CoreExpr -> CoreExpr
foRhs (Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (CLabelString -> FunctionOrData -> Literal
LitLabel CLabelString
cid FunctionOrData
fod))
rhs' = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
rhs Coercion
co
in
return ([(id, rhs')], mempty, 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)
dsCFExportDynamic Id
id Coercion
co CCallConv
cconv
dsCFExportDynamic :: Id
-> Coercion
-> CCallConv
-> DsM ([Binding], CHeader, CStub)
dsCFExportDynamic :: Id -> Coercion -> CCallConv -> DsM ([Binding], CHeader, CStub)
dsCFExportDynamic Id
id Coercion
co0 CCallConv
cconv = do
mod <- IOEnv (Env DsGblEnv DsLclEnv) Module
forall (m :: * -> *). HasModule m => m Module
getModule
let fe_nm = String -> CLabelString
mkFastString (String -> CLabelString) -> String -> CLabelString
forall a b. (a -> b) -> a -> b
$ String -> String
zEncodeString
(Module -> String
moduleStableString Module
mod String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"$" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Id -> String
toCName Id
id)
cback <- newSysLocalDs scaled_arg_ty
newStablePtrId <- dsLookupGlobalId newStablePtrName
stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
let
stable_ptr_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
stable_ptr_tycon [Type
arg_ty]
export_ty = HasDebugCallStack => Type -> Type -> Type
Type -> Type -> Type
mkVisFunTyMany Type
stable_ptr_ty Type
arg_ty
bindIOId <- dsLookupGlobalId bindIOName
stbl_value <- newSysLocalMDs stable_ptr_ty
(h_code, c_code, typestring) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv True
let
adj_args = [ Id -> CoreExpr
forall b. Id -> Expr b
Var Id
stbl_value
, Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (CLabelString -> FunctionOrData -> Literal
LitLabel CLabelString
fe_nm FunctionOrData
IsFunction)
, Literal -> CoreExpr
forall b. Literal -> Expr b
Lit (String -> Literal
mkLitString String
typestring)
]
adjustor = String -> CLabelString
fsLit String
"createAdjustor"
ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
let io_app = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
cback (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
$
CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
bindIOId)
[ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
stable_ptr_ty
, Type -> CoreExpr
forall b. Type -> Expr b
Type Type
res_ty
, CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
newStablePtrId) [ Type -> CoreExpr
forall b. Type -> Expr b
Type Type
arg_ty, Id -> CoreExpr
forall b. Id -> Expr b
Var Id
cback ]
, Id -> CoreExpr -> CoreExpr
forall b. b -> Expr b -> Expr b
Lam Id
stbl_value CoreExpr
ccall_adj
]
fed = (Id
id Id -> Activation -> Id
`setInlineActivation` Activation
NeverActive, CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
io_app Coercion
co0)
return ([fed], h_code, c_code)
where
ty :: Type
ty = HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionLKind Coercion
co0
([Id]
tvs,Type
sans_foralls) = Type -> ([Id], Type)
tcSplitForAllInvisTyVars Type
ty
([Scaled Type
scaled_arg_ty], Type
fn_res_ty) = Type -> ([Scaled Type], Type)
tcSplitFunTys Type
sans_foralls
arg_ty :: Type
arg_ty = Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
scaled_arg_ty
Just (TyCon
io_tc, Type
res_ty) = Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
fn_res_ty
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
(Type
ty,Type
ty1) = (HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionLKind Coercion
co, HasDebugCallStack => Coercion -> Type
Coercion -> Type
coercionRKind 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
let constQual :: SDoc
constQual
| ([Scaled Type]
_, Type
res_ty1) <- Type -> ([Scaled Type], Type)
tcSplitFunTys Type
ty1
, Type
newty <- Type -> ((TyCon, Type) -> Type) -> Maybe (TyCon, Type) -> Type
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Type
res_ty1 (TyCon, Type) -> Type
forall a b. (a, b) -> b
snd (Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
res_ty1)
, Just (TyCon
ptr, [Type]
_) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
newty
, TyCon -> Name
tyConName TyCon
ptr Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
constPtrConName
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"const"
| Bool
otherwise = SDoc
forall doc. IsOutput doc => doc
empty
args <- [Scaled Type] -> DsM [Id]
newSysLocalsDs [Scaled Type]
arg_tys
(val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
let
work_arg_ids = [Id
v | Var Id
v <- [CoreExpr]
val_args]
(ccall_result_ty, res_wrapper) <- boxResult io_res_ty
ccall_uniq <- newUnique
work_uniq <- newUnique
(fcall', cDoc) <-
case fcall of
CCall (CCallSpec (StaticTarget SourceText
_ CLabelString
cName Maybe Unit
mUnitId Bool
isFun)
CCallConv
CApiConv Safety
safety) ->
do nextWrapperNum <- DsGblEnv -> IORef (ModuleEnv Int)
ds_next_wrapper_num (DsGblEnv -> IORef (ModuleEnv Int))
-> IOEnv (Env DsGblEnv DsLclEnv) DsGblEnv
-> IOEnv (Env DsGblEnv DsLclEnv) (IORef (ModuleEnv Int))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env DsGblEnv DsLclEnv) DsGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName)
let 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
includes
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ SDoc
fun_proto SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (SDoc
cRet SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi)
includes = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"#include \"" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
h
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"\""
| Header SourceText
_ CLabelString
h <- [Header] -> [Header]
forall a. Eq a => [a] -> [a]
nub [Header]
headers ]
fun_proto = SDoc
constQual SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
cResType SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pprCconv SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabelString
wrapperName SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
argTypes
cRet
| Bool
isVoidRes = SDoc
cCall
| Bool
otherwise = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"return" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
cCall
cCall
| Bool
isFun = CLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabelString
cName SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
argVals
| [Scaled Type] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Scaled Type]
arg_tys = CLabelString -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabelString
cName
| Bool
otherwise = String -> SDoc
forall a. HasCallStack => String -> a
panic String
"dsFCall: Unexpected arguments to FFI value import"
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 = Type
raw_res_ty HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
unitTy
(mHeader, cResType)
| isVoidRes = (Nothing, text "void")
| otherwise = toCType raw_res_ty
pprCconv = CCallConv -> SDoc
ccallConvAttribute CCallConv
CApiConv
mHeadersArgTypeList
= [ (Maybe Header
header, SDoc
cType SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'a' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n)
| (Scaled Type
t, Int
n) <- [Scaled Type] -> [Int] -> [(Scaled Type, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Scaled Type]
arg_tys [Int
1..]
, let (Maybe Header
header, SDoc
cType) = Type -> (Maybe Header, SDoc)
toCType (Scaled Type -> Type
forall a. Scaled a -> a
scaledThing Scaled Type
t) ]
(mHeaders, argTypeList) = unzip mHeadersArgTypeList
argTypes = if [SDoc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SDoc]
argTypeList
then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"void"
else [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [SDoc]
argTypeList
mHeaders' = Maybe Header
mDeclHeader Maybe Header -> [Maybe Header] -> [Maybe Header]
forall a. a -> [a] -> [a]
: Maybe Header
mHeader Maybe Header -> [Maybe Header] -> [Maybe Header]
forall a. a -> [a] -> [a]
: [Maybe Header]
mHeaders
headers = [Maybe Header] -> [Header]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Header]
mHeaders'
argVals = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma
[ Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'a' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n
| (Scaled Type
_, Int
n) <- [Scaled Type] -> [Int] -> [(Scaled Type, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Scaled Type]
arg_tys [Int
1..] ]
return (fcall', c)
ForeignCall
_ ->
(ForeignCall, SDoc)
-> IOEnv (Env DsGblEnv DsLclEnv) (ForeignCall, SDoc)
forall a. a -> IOEnv (Env DsGblEnv DsLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignCall
fcall, SDoc
forall doc. IsOutput doc => doc
empty)
dflags <- getDynFlags
let
worker_ty = [TyVarBinder] -> Type -> Type
mkForAllTys [TyVarBinder]
tv_bndrs ([Type] -> Type -> Type
mkVisFunTysMany ((Id -> Type) -> [Id] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Type
idType [Id]
work_arg_ids) Type
ccall_result_ty)
tvs = (TyVarBinder -> Id) -> [TyVarBinder] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar [TyVarBinder]
tv_bndrs
the_ccall_app = Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall Unique
ccall_uniq ForeignCall
fcall' [CoreExpr]
val_args Type
ccall_result_ty
work_rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
tvs ([Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams [Id]
work_arg_ids CoreExpr
the_ccall_app)
work_id = CLabelString -> Unique -> Type -> Type -> Id
mkSysLocal (String -> CLabelString
fsLit String
"$wccall") Unique
work_uniq Type
ManyTy Type
worker_ty
work_app = CoreExpr -> [CoreExpr] -> CoreExpr
forall b. Expr b -> [Expr b] -> Expr b
mkApps (CoreExpr -> [Id] -> CoreExpr
forall b. Expr b -> [Id] -> Expr b
mkVarApps (Id -> CoreExpr
forall b. Id -> Expr b
Var Id
work_id) [Id]
tvs) [CoreExpr]
val_args
wrapper_body = ((CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr)
-> CoreExpr -> [CoreExpr -> CoreExpr] -> CoreExpr
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (CoreExpr -> CoreExpr) -> CoreExpr -> CoreExpr
forall a b. (a -> b) -> a -> b
($) (CoreExpr -> CoreExpr
res_wrapper CoreExpr
work_app) [CoreExpr -> CoreExpr]
arg_wrappers
wrap_rhs = [Id] -> CoreExpr -> CoreExpr
forall b. [b] -> Expr b -> Expr b
mkLams ([Id]
tvs [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
args) CoreExpr
wrapper_body
wrap_rhs' = CoreExpr -> Coercion -> CoreExpr
forall b. Expr b -> Coercion -> Expr b
Cast CoreExpr
wrap_rhs Coercion
co
simpl_opts = DynFlags -> SimpleOpts
initSimpleOpts DynFlags
dflags
fn_id_w_inl = Id
fn_id Id -> Unfolding -> Id
`setIdUnfolding` SimpleOpts -> UnfoldingSource -> Int -> CoreExpr -> Unfolding
mkInlineUnfoldingWithArity SimpleOpts
simpl_opts
UnfoldingSource
StableSystemSrc ([Id] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Id]
args)
CoreExpr
wrap_rhs'
return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc [] [])
toCName :: Id -> String
toCName :: Id -> String
toCName Id
i = SDocContext -> SDoc -> String
showSDocOneLine SDocContext
defaultSDocContext (SDoc -> SDoc
pprCode (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Name
idName Id
i)))
toCType :: Type -> (Maybe Header, SDoc)
toCType :: Type -> (Maybe Header, SDoc)
toCType = Bool -> Type -> (Maybe Header, SDoc)
forall {b}. IsLine b => Bool -> Type -> (Maybe Header, b)
f Bool
False
where f :: Bool -> Type -> (Maybe Header, b)
f Bool
voidOK Type
t
| Just (TyCon
ptr, [Type
t']) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t
, TyCon -> Name
tyConName TyCon
ptr Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name
ptrTyConName, Name
funPtrTyConName]
= case Bool -> Type -> (Maybe Header, b)
f Bool
True Type
t' of
(Maybe Header
mh, b
cType') ->
(Maybe Header
mh, b
cType' b -> b -> b
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> b
forall doc. IsLine doc => Char -> doc
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 -> b
forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
cType)
| Just Type
t' <- Type -> Maybe Type
coreView Type
t
= Bool -> Type -> (Maybe Header, b)
f Bool
voidOK Type
t'
| Just TyCon
tyCon <- Type -> Maybe TyCon
tyConAppTyConPicky_maybe Type
t
, TyCon -> Bool
isPrimTyCon TyCon
tyCon
, Just String
cType <- TyCon -> Maybe String
ppPrimTyConStgType TyCon
tyCon
= (Maybe Header
forall a. Maybe a
Nothing, String -> b
forall doc. IsLine doc => String -> doc
text String
cType)
| Bool
voidOK = (Maybe Header
forall a. Maybe a
Nothing, String -> b
forall doc. IsLine doc => String -> doc
text String
"void")
| Bool
otherwise
= String -> SDoc -> (Maybe Header, b)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"toCType" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
t)
mkFExportCBits :: DynFlags
-> FastString
-> Maybe Id
-> [Type]
-> Type
-> Bool
-> CCallConv
-> (CHeader,
CStub,
String
)
mkFExportCBits :: DynFlags
-> CLabelString
-> Maybe Id
-> [Type]
-> Type
-> Bool
-> CCallConv
-> (CHeader, CStub, String)
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
, SDoc -> [CLabel] -> [CLabel] -> CStub
CStub SDoc
body [] []
, String
type_string
)
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
(Int -> SDoc -> SDoc
arg_cname Int
n SDoc
stg_type,
SDoc
stg_type,
Type
ty,
Platform -> Type -> CmmType
typeCmmType Platform
platform (Type -> Type
getPrimTyOf Type
ty))
| (Type
ty,Int
n) <- [Type] -> [Int] -> [(Type, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Type]
arg_htys [Int
1::Int ..] ]
arg_cname :: Int -> SDoc -> SDoc
arg_cname Int
n SDoc
stg_ty
| Bool
libffi = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'*' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc
stg_ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'*') SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"args" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Int -> SDoc
forall doc. IsLine doc => Int -> doc
int (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1))
| Bool
otherwise = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'a' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n
libffi :: Bool
libffi = PlatformMisc -> Bool
platformMisc_libFFI (DynFlags -> PlatformMisc
platformMisc DynFlags
dflags) Bool -> Bool -> Bool
&& Maybe Id -> 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 Char -> String -> String
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
| Maybe Id -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Id
maybe_target = (SDoc, SDoc, Type, CmmType)
stable_ptr_arg (SDoc, SDoc, Type, CmmType)
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
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
forall doc. IsLine doc => String -> doc
text String
"the_stableptr", String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StgStablePtr", Type
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 HasCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`eqType` Type
unitTy
cResType :: SDoc
cResType | Bool
res_hty_is_unit = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"void"
| Bool
otherwise = Type -> SDoc
showStgType Type
res_hty
ffi_cResType :: SDoc
ffi_cResType
| Bool
is_ffi_arg_type = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ffi_arg"
| Bool
otherwise = SDoc
cResType
where
res_ty_key :: Unique
res_ty_key = Name -> Unique
forall a. Uniquable a => a -> Unique
getUnique (TyCon -> Name
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 Unique -> [Unique] -> Bool
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
forall doc. IsLine doc => String -> doc
text String
"extern" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
fun_proto SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi)
fun_args :: SDoc
fun_args
| [(SDoc, SDoc, Type, CmmType)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(SDoc, SDoc, Type, CmmType)]
aug_arg_info = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"void"
| Bool
otherwise = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma
([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ((SDoc, SDoc, Type, CmmType) -> SDoc)
-> [(SDoc, SDoc, Type, CmmType)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (\(SDoc
nm,SDoc
ty,Type
_,CmmType
_) -> SDoc
ty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
nm) [(SDoc, SDoc, Type, CmmType)]
aug_arg_info
fun_proto :: SDoc
fun_proto
| Bool
libffi
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"void" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
c_nm SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
| Bool
otherwise
= SDoc
cResType SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
pprCconv SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
c_nm SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
fun_args
the_cfun :: SDoc
the_cfun
= case Maybe Id
maybe_target of
Maybe Id
Nothing -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(StgClosure*)deRefStablePtr(the_stableptr)"
Just Id
hs_fn -> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'&' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
hs_fn SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"_closure"
cap :: SDoc
cap = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cap" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma
expr_to_run :: SDoc
expr_to_run
= (SDoc -> (SDoc, SDoc, Type, CmmType) -> SDoc)
-> SDoc -> [(SDoc, SDoc, Type, CmmType)] -> SDoc
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SDoc -> (SDoc, SDoc, Type, CmmType) -> SDoc
appArg SDoc
the_cfun [(SDoc, SDoc, Type, CmmType)]
arg_info
where
appArg :: SDoc -> (SDoc, SDoc, Type, CmmType) -> SDoc
appArg SDoc
acc (SDoc
arg_cname, SDoc
_, Type
arg_hty, CmmType
_)
= String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rts_apply"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc
cap SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
acc 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
<> Type -> SDoc
mkHObj Type
arg_hty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc
cap SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
arg_cname))
declareResult :: SDoc
declareResult = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"HaskellObj ret;"
declareCResult :: SDoc
declareCResult | Bool
res_hty_is_unit = SDoc
forall doc. IsOutput doc => doc
empty
| Bool
otherwise = SDoc
cResType SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cret;"
assignCResult :: SDoc
assignCResult | Bool
res_hty_is_unit = SDoc
forall doc. IsOutput doc => doc
empty
| Bool
otherwise =
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cret=" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
unpackHObj Type
res_hty SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ret") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
extern_decl :: SDoc
extern_decl
= case Maybe Id
maybe_target of
Maybe Id
Nothing -> SDoc
forall doc. IsOutput doc => doc
empty
Just Id
hs_fn -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"extern StgClosure " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
hs_fn SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"_closure" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
body :: SDoc
body =
SDoc
forall doc. IsLine doc => doc
space SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
SDoc
extern_decl SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
SDoc
fun_proto SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
[ SDoc
forall doc. IsLine doc => doc
lbrace
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Capability *cap;"
, SDoc
declareResult
, SDoc
declareCResult
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cap = rts_lock();"
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rts_inCall" 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
cap SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rts_apply" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (
SDoc
cap SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(HaskellObj)"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> (if Bool
is_IO_res_ty
then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"runIO_closure"
else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"runNonIO_closure")
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
<> SDoc
expr_to_run
) 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
"&ret"
) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rts_checkSchedStatus" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
doubleQuotes (CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
ftext CLabelString
c_nm)
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
"cap") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
semi
, SDoc
assignCResult
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rts_unlock(cap);"
, Bool -> SDoc -> SDoc
forall doc. IsOutput doc => Bool -> doc -> doc
ppUnless Bool
res_hty_is_unit (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
if Bool
libffi
then Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'*' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (SDoc
ffi_cResType SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'*') SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"resp = " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens SDoc
ffi_cResType SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cret;"
else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"return cret;"
, SDoc
forall doc. IsLine doc => doc
rbrace
]
mkHObj :: Type -> SDoc
mkHObj :: Type -> SDoc
mkHObj Type
t = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rts_mk" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
showFFIType Type
t
unpackHObj :: Type -> SDoc
unpackHObj :: Type -> SDoc
unpackHObj Type
t = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"rts_get" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
showFFIType Type
t
showStgType :: Type -> SDoc
showStgType :: Type -> SDoc
showStgType Type
t = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Hs" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Type -> SDoc
showFFIType Type
t
showFFIType :: Type -> SDoc
showFFIType :: Type -> SDoc
showFFIType Type
t = CLabelString -> SDoc
forall doc. IsLine doc => CLabelString -> doc
ftext (OccName -> CLabelString
occNameFS (TyCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName (Type -> TyCon
typeTyCon Type
t)))
typeTyCon :: Type -> TyCon
typeTyCon :: Type -> TyCon
typeTyCon Type
ty
| Just (TyCon
tc, [Type]
_) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe (Type -> Type
unwrapType Type
ty)
= TyCon
tc
| Bool
otherwise
= String -> SDoc -> TyCon
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"GHC.HsToCore.Foreign.C.typeTyCon" (Type -> SDoc
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 OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSMinGW32 ->
let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
-> [(SDoc, SDoc, Type, CmmType)]
go :: Int
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go Int
4 [(SDoc, SDoc, Type, CmmType)]
args = Platform -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg Platform
platform (SDoc, SDoc, Type, CmmType)
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
forall a. a -> [a] -> [a]
: [(SDoc, SDoc, Type, CmmType)]
args
go Int
n ((SDoc, SDoc, Type, CmmType)
arg:[(SDoc, SDoc, Type, CmmType)]
args) = (SDoc, SDoc, Type, CmmType)
arg (SDoc, SDoc, Type, CmmType)
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
forall a. a -> [a] -> [a]
: Int
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [(SDoc, SDoc, Type, CmmType)]
args
go Int
_ [] = []
in Int
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go Int
0 [(SDoc, SDoc, Type, CmmType)]
args
| Bool
otherwise ->
let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
-> [(SDoc, SDoc, Type, CmmType)]
go :: Int
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go Int
6 [(SDoc, SDoc, Type, CmmType)]
args = Platform -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg Platform
platform (SDoc, SDoc, Type, CmmType)
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
forall a. a -> [a] -> [a]
: [(SDoc, SDoc, Type, CmmType)]
args
go Int
n (arg :: (SDoc, SDoc, Type, CmmType)
arg@(SDoc
_,SDoc
_,Type
_,CmmType
rep):[(SDoc, SDoc, Type, CmmType)]
args)
| (CmmType -> Bool
isBitsType CmmType
rep Bool -> Bool -> Bool
&& CmmType -> Width
typeWidth CmmType
rep Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
<= Width
W64 Bool -> Bool -> Bool
|| CmmType -> Bool
isGcPtrType CmmType
rep)
= (SDoc, SDoc, Type, CmmType)
arg (SDoc, SDoc, Type, CmmType)
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
forall a. a -> [a] -> [a]
: Int
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [(SDoc, SDoc, Type, CmmType)]
args
| Bool
otherwise
= (SDoc, SDoc, Type, CmmType)
arg (SDoc, SDoc, Type, CmmType)
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
forall a. a -> [a] -> [a]
: Int
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go Int
n [(SDoc, SDoc, Type, CmmType)]
args
go Int
_ [] = []
in Int
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
go Int
0 [(SDoc, SDoc, Type, CmmType)]
args
Arch
_ ->
Platform -> (SDoc, SDoc, Type, CmmType)
ret_addr_arg Platform
platform (SDoc, SDoc, Type, CmmType)
-> [(SDoc, SDoc, Type, CmmType)] -> [(SDoc, SDoc, Type, CmmType)]
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
forall doc. IsLine doc => String -> doc
text String
"original_return_addr", String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"void*", Type
forall a. HasCallStack => a
undefined,
Platform -> Type -> CmmType
typeCmmType Platform
platform Type
addrPrimTy)