{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.HsToCore.Foreign.Call
( dsCCall
, mkFCall
, unboxArg
, boxResult
, resultWrapper
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Core
import GHC.HsToCore.Monad
import GHC.Core.Utils
import GHC.Core.Make
import GHC.Types.SourceText
import GHC.Types.Id.Make
import GHC.Types.ForeignCall
import GHC.Core.DataCon
import GHC.HsToCore.Utils
import GHC.Tc.Utils.TcType
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.Coercion
import GHC.Builtin.Types.Prim
import GHC.Core.TyCon
import GHC.Builtin.Types
import GHC.Types.Basic
import GHC.Types.Literal
import GHC.Builtin.Names
import GHC.Driver.Session
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Panic
import Data.Maybe
dsCCall :: CLabelString
-> [CoreExpr]
-> Safety
-> Type
-> DsM CoreExpr
dsCCall :: CLabelString -> [CoreExpr] -> Safety -> Type -> DsM CoreExpr
dsCCall CLabelString
lbl [CoreExpr]
args Safety
may_gc Type
result_ty
= do ([CoreExpr]
unboxed_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 [CoreExpr]
args
(Type
ccall_result_ty, CoreExpr -> CoreExpr
res_wrapper) <- Type -> DsM (Type, CoreExpr -> CoreExpr)
boxResult Type
result_ty
Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let
target :: CCallTarget
target = SourceText -> CLabelString -> Maybe Unit -> Bool -> CCallTarget
StaticTarget SourceText
NoSourceText CLabelString
lbl forall a. Maybe a
Nothing Bool
True
the_fcall :: ForeignCall
the_fcall = CCallSpec -> ForeignCall
CCall (CCallTarget -> CCallConv -> Safety -> CCallSpec
CCallSpec CCallTarget
target CCallConv
CCallConv Safety
may_gc)
the_prim_app :: CoreExpr
the_prim_app = DynFlags -> Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall DynFlags
dflags Unique
uniq ForeignCall
the_fcall [CoreExpr]
unboxed_args Type
ccall_result_ty
forall (m :: * -> *) a. Monad m => a -> m a
return (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
the_prim_app) [CoreExpr -> CoreExpr]
arg_wrappers)
mkFCall :: DynFlags -> Unique -> ForeignCall
-> [CoreExpr]
-> Type
-> CoreExpr
mkFCall :: DynFlags -> Unique -> ForeignCall -> [CoreExpr] -> Type -> CoreExpr
mkFCall DynFlags
dflags Unique
uniq ForeignCall
the_fcall [CoreExpr]
val_args Type
res_ty
= ASSERT( all isTyVar tyvars )
forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Expr b -> [Var] -> Expr b
mkVarApps (forall b. Var -> Expr b
Var Var
the_fcall_id) [Var]
tyvars) [CoreExpr]
val_args
where
arg_tys :: [Type]
arg_tys = forall a b. (a -> b) -> [a] -> [b]
map CoreExpr -> Type
exprType [CoreExpr]
val_args
body_ty :: Type
body_ty = ([Type] -> Type -> Type
mkVisFunTysMany [Type]
arg_tys Type
res_ty)
tyvars :: [Var]
tyvars = Type -> [Var]
tyCoVarsOfTypeWellScoped Type
body_ty
ty :: Type
ty = [Var] -> Type -> Type
mkInfForAllTys [Var]
tyvars Type
body_ty
the_fcall_id :: Var
the_fcall_id = DynFlags -> Unique -> ForeignCall -> Type -> Var
mkFCallId DynFlags
dflags Unique
uniq ForeignCall
the_fcall Type
ty
unboxArg :: CoreExpr
-> DsM (CoreExpr,
CoreExpr -> CoreExpr
)
unboxArg :: CoreExpr -> DsM (CoreExpr, CoreExpr -> CoreExpr)
unboxArg CoreExpr
arg
| Type -> Bool
isPrimitiveType Type
arg_ty
= forall (m :: * -> *) a. Monad m => a -> m a
return (CoreExpr
arg, \CoreExpr
body -> CoreExpr
body)
| Just(Coercion
co, Type
_rep_ty) <- Type -> Maybe (Coercion, Type)
topNormaliseNewType_maybe Type
arg_ty
= CoreExpr -> DsM (CoreExpr, CoreExpr -> CoreExpr)
unboxArg (CoreExpr -> Coercion -> CoreExpr
mkCastDs CoreExpr
arg Coercion
co)
| Just TyCon
tc <- Type -> Maybe TyCon
tyConAppTyCon_maybe Type
arg_ty,
TyCon
tc forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boolTyConKey
= do DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
Var
prim_arg <- Type -> Type -> DsM Var
newSysLocalDs Type
Many Type
intPrimTy
forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Var -> Expr b
Var Var
prim_arg,
\ CoreExpr
body -> forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case (CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
mkIfThenElse CoreExpr
arg (forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform Integer
1) (forall b. Platform -> Integer -> Expr b
mkIntLit Platform
platform Integer
0))
Var
prim_arg
(CoreExpr -> Type
exprType CoreExpr
body)
[forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] CoreExpr
body])
| Bool
is_product_type Bool -> Bool -> Bool
&& Arity
data_con_arity forall a. Eq a => a -> a -> Bool
== Arity
1
= ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty)
do Var
case_bndr <- Type -> Type -> DsM Var
newSysLocalDs Type
Many Type
arg_ty
Var
prim_arg <- Type -> Type -> DsM Var
newSysLocalDs Type
Many Type
data_con_arg_ty1
forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Var -> Expr b
Var Var
prim_arg,
\ CoreExpr
body -> forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg Var
case_bndr (CoreExpr -> Type
exprType CoreExpr
body) [forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
data_con) [Var
prim_arg] CoreExpr
body]
)
| Bool
is_product_type Bool -> Bool -> Bool
&&
Arity
data_con_arity forall a. Eq a => a -> a -> Bool
== Arity
3 Bool -> Bool -> Bool
&&
forall a. Maybe a -> Bool
isJust Maybe TyCon
maybe_arg3_tycon Bool -> Bool -> Bool
&&
(TyCon
arg3_tycon forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon Bool -> Bool -> Bool
||
TyCon
arg3_tycon forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon)
= do Var
case_bndr <- Type -> Type -> DsM Var
newSysLocalDs Type
Many Type
arg_ty
vars :: [Var]
vars@[Var
_l_var, Var
_r_var, Var
arr_cts_var] <- [Scaled Type] -> DsM [Var]
newSysLocalsDs (forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Scaled a
unrestricted [Type]
data_con_arg_tys)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall b. Var -> Expr b
Var Var
arr_cts_var,
\ CoreExpr
body -> forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case CoreExpr
arg Var
case_bndr (CoreExpr -> Type
exprType CoreExpr
body) [forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt DataCon
data_con) [Var]
vars CoreExpr
body]
)
| Bool
otherwise
= do SrcSpan
l <- DsM SrcSpan
getSrcSpanDs
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unboxArg: " (forall a. Outputable a => a -> SDoc
ppr SrcSpan
l SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
arg_ty)
where
arg_ty :: Type
arg_ty = CoreExpr -> Type
exprType CoreExpr
arg
maybe_product_type :: Maybe (TyCon, [Type], DataCon, [Scaled Type])
maybe_product_type = Type -> Maybe (TyCon, [Type], DataCon, [Scaled Type])
splitDataProductType_maybe Type
arg_ty
is_product_type :: Bool
is_product_type = forall a. Maybe a -> Bool
isJust Maybe (TyCon, [Type], DataCon, [Scaled Type])
maybe_product_type
Just (TyCon
_, [Type]
_, DataCon
data_con, [Scaled Type]
scaled_data_con_arg_tys) = Maybe (TyCon, [Type], DataCon, [Scaled Type])
maybe_product_type
data_con_arg_tys :: [Type]
data_con_arg_tys = forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled Type]
scaled_data_con_arg_tys
data_con_arity :: Arity
data_con_arity = DataCon -> Arity
dataConSourceArity DataCon
data_con
(Type
data_con_arg_ty1 : [Type]
_) = [Type]
data_con_arg_tys
(Type
_ : Type
_ : Type
data_con_arg_ty3 : [Type]
_) = [Type]
data_con_arg_tys
maybe_arg3_tycon :: Maybe TyCon
maybe_arg3_tycon = Type -> Maybe TyCon
tyConAppTyCon_maybe Type
data_con_arg_ty3
Just TyCon
arg3_tycon = Maybe TyCon
maybe_arg3_tycon
boxResult :: Type
-> DsM (Type, CoreExpr -> CoreExpr)
boxResult :: Type -> DsM (Type, CoreExpr -> CoreExpr)
boxResult Type
result_ty
| Just (TyCon
io_tycon, Type
io_res_ty) <- Type -> Maybe (TyCon, Type)
tcSplitIOType_maybe Type
result_ty
= do { (Maybe Type, CoreExpr -> CoreExpr)
res <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
io_res_ty
; let extra_result_tys :: [Type]
extra_result_tys
= case (Maybe Type, CoreExpr -> CoreExpr)
res of
(Just Type
ty,CoreExpr -> CoreExpr
_)
| Type -> Bool
isUnboxedTupleType Type
ty
-> let Just [Type]
ls = Type -> Maybe [Type]
tyConAppArgs_maybe Type
ty in forall a. [a] -> [a]
tail [Type]
ls
(Maybe Type, CoreExpr -> CoreExpr)
_ -> []
return_result :: CoreExpr -> [CoreExpr] -> CoreExpr
return_result CoreExpr
state [CoreExpr]
anss
= [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup
(Type
realWorldStatePrimTy forall a. a -> [a] -> [a]
: Type
io_res_ty forall a. a -> [a] -> [a]
: [Type]
extra_result_tys)
(CoreExpr
state forall a. a -> [a] -> [a]
: [CoreExpr]
anss)
; (Type
ccall_res_ty, Alt Var
the_alt) <- (CoreExpr -> [CoreExpr] -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr) -> DsM (Type, Alt Var)
mk_alt CoreExpr -> [CoreExpr] -> CoreExpr
return_result (Maybe Type, CoreExpr -> CoreExpr)
res
; Var
state_id <- Type -> Type -> DsM Var
newSysLocalDs Type
Many Type
realWorldStatePrimTy
; let io_data_con :: DataCon
io_data_con = forall a. [a] -> a
head (TyCon -> [DataCon]
tyConDataCons TyCon
io_tycon)
toIOCon :: Var
toIOCon = DataCon -> Var
dataConWrapId DataCon
io_data_con
wrap :: CoreExpr -> CoreExpr
wrap CoreExpr
the_call =
forall b. Expr b -> [Expr b] -> Expr b
mkApps (forall b. Var -> Expr b
Var Var
toIOCon)
[ forall b. Type -> Expr b
Type Type
io_res_ty,
forall b. b -> Expr b -> Expr b
Lam Var
state_id forall a b. (a -> b) -> a -> b
$
CoreExpr -> Scaled Type -> Type -> [Alt Var] -> CoreExpr
mkWildCase (forall b. Expr b -> Expr b -> Expr b
App CoreExpr
the_call (forall b. Var -> Expr b
Var Var
state_id))
(forall a. a -> Scaled a
unrestricted Type
ccall_res_ty)
(Alt Var -> Type
coreAltType Alt Var
the_alt)
[Alt Var
the_alt]
]
; forall (m :: * -> *) a. Monad m => a -> m a
return (Type
realWorldStatePrimTy Type -> Type -> Type
`mkVisFunTyMany` Type
ccall_res_ty, CoreExpr -> CoreExpr
wrap) }
boxResult Type
result_ty
= do
(Maybe Type, CoreExpr -> CoreExpr)
res <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
result_ty
(Type
ccall_res_ty, Alt Var
the_alt) <- (CoreExpr -> [CoreExpr] -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr) -> DsM (Type, Alt Var)
mk_alt forall {p} {a}. p -> [a] -> a
return_result (Maybe Type, CoreExpr -> CoreExpr)
res
let
wrap :: CoreExpr -> CoreExpr
wrap = \ CoreExpr
the_call -> CoreExpr -> Scaled Type -> Type -> [Alt Var] -> CoreExpr
mkWildCase (forall b. Expr b -> Expr b -> Expr b
App CoreExpr
the_call (forall b. Var -> Expr b
Var Var
realWorldPrimId))
(forall a. a -> Scaled a
unrestricted Type
ccall_res_ty)
(Alt Var -> Type
coreAltType Alt Var
the_alt)
[Alt Var
the_alt]
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
realWorldStatePrimTy Type -> Type -> Type
`mkVisFunTyMany` Type
ccall_res_ty, CoreExpr -> CoreExpr
wrap)
where
return_result :: p -> [a] -> a
return_result p
_ [a
ans] = a
ans
return_result p
_ [a]
_ = forall a. String -> a
panic String
"return_result: expected single result"
mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)
-> (Maybe Type, Expr Var -> Expr Var)
-> DsM (Type, CoreAlt)
mk_alt :: (CoreExpr -> [CoreExpr] -> CoreExpr)
-> (Maybe Type, CoreExpr -> CoreExpr) -> DsM (Type, Alt Var)
mk_alt CoreExpr -> [CoreExpr] -> CoreExpr
return_result (Maybe Type
Nothing, CoreExpr -> CoreExpr
wrap_result)
= do
Var
state_id <- Type -> Type -> DsM Var
newSysLocalDs Type
Many Type
realWorldStatePrimTy
let
the_rhs :: CoreExpr
the_rhs = CoreExpr -> [CoreExpr] -> CoreExpr
return_result (forall b. Var -> Expr b
Var Var
state_id)
[CoreExpr -> CoreExpr
wrap_result (forall a. String -> a
panic String
"boxResult")]
ccall_res_ty :: Type
ccall_res_ty = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy]
the_alt :: Alt Var
the_alt = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
1)) [Var
state_id] CoreExpr
the_rhs
forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ccall_res_ty, Alt Var
the_alt)
mk_alt CoreExpr -> [CoreExpr] -> CoreExpr
return_result (Just Type
prim_res_ty, CoreExpr -> CoreExpr
wrap_result)
=
ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty )
do { Var
result_id <- Type -> Type -> DsM Var
newSysLocalDs Type
Many Type
prim_res_ty
; Var
state_id <- Type -> Type -> DsM Var
newSysLocalDs Type
Many Type
realWorldStatePrimTy
; let the_rhs :: CoreExpr
the_rhs = CoreExpr -> [CoreExpr] -> CoreExpr
return_result (forall b. Var -> Expr b
Var Var
state_id)
[CoreExpr -> CoreExpr
wrap_result (forall b. Var -> Expr b
Var Var
result_id)]
ccall_res_ty :: Type
ccall_res_ty = Boxity -> [Type] -> Type
mkTupleTy Boxity
Unboxed [Type
realWorldStatePrimTy, Type
prim_res_ty]
the_alt :: Alt Var
the_alt = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (DataCon -> AltCon
DataAlt (Boxity -> Arity -> DataCon
tupleDataCon Boxity
Unboxed Arity
2)) [Var
state_id, Var
result_id] CoreExpr
the_rhs
; forall (m :: * -> *) a. Monad m => a -> m a
return (Type
ccall_res_ty, Alt Var
the_alt) }
resultWrapper :: Type
-> DsM (Maybe Type,
CoreExpr -> CoreExpr)
resultWrapper :: Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
result_ty
| Type -> Bool
isPrimitiveType Type
result_ty
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Type
result_ty, \CoreExpr
e -> CoreExpr
e)
| Just (TyCon
tc,[Type]
_) <- Maybe (TyCon, [Type])
maybe_tc_app
, TyCon
tc forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
unitTyConKey
= forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, \CoreExpr
_ -> CoreExpr
unitExpr)
| Just (TyCon
tc,[Type]
_) <- Maybe (TyCon, [Type])
maybe_tc_app
, TyCon
tc forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
boolTyConKey
= do { DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
; let marshal_bool :: CoreExpr -> CoreExpr
marshal_bool CoreExpr
e
= CoreExpr -> Scaled Type -> Type -> [Alt Var] -> CoreExpr
mkWildCase CoreExpr
e (forall a. a -> Scaled a
unrestricted Type
intPrimTy) Type
boolTy
[ forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
DEFAULT [] (forall b. Var -> Expr b
Var Var
trueDataConId )
, forall b. AltCon -> [b] -> Expr b -> Alt b
Alt (Literal -> AltCon
LitAlt (Platform -> Integer -> Literal
mkLitInt Platform
platform Integer
0)) [] (forall b. Var -> Expr b
Var Var
falseDataConId)]
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Type
intPrimTy, CoreExpr -> CoreExpr
marshal_bool) }
| Just (Coercion
co, Type
rep_ty) <- Type -> Maybe (Coercion, Type)
topNormaliseNewType_maybe Type
result_ty
= do { (Maybe Type
maybe_ty, CoreExpr -> CoreExpr
wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
rep_ty
; forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
maybe_ty, \CoreExpr
e -> CoreExpr -> Coercion -> CoreExpr
mkCastDs (CoreExpr -> CoreExpr
wrapper CoreExpr
e) (Coercion -> Coercion
mkSymCo Coercion
co)) }
| Just (Var
tyvar, Type
rest) <- Type -> Maybe (Var, Type)
splitForAllTyCoVar_maybe Type
result_ty
= do { (Maybe Type
maybe_ty, CoreExpr -> CoreExpr
wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
rest
; forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
maybe_ty, \CoreExpr
e -> forall b. b -> Expr b -> Expr b
Lam Var
tyvar (CoreExpr -> CoreExpr
wrapper CoreExpr
e)) }
| Just (TyCon
tycon, [Type]
tycon_arg_tys) <- Maybe (TyCon, [Type])
maybe_tc_app
, Just DataCon
data_con <- TyCon -> Maybe DataCon
tyConSingleAlgDataCon_maybe TyCon
tycon
, forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DataCon -> [Var]
dataConExTyCoVars DataCon
data_con)
, [Scaled Type
_ Type
unwrapped_res_ty] <- DataCon -> [Type] -> [Scaled Type]
dataConInstOrigArgTys DataCon
data_con [Type]
tycon_arg_tys
= do { (Maybe Type
maybe_ty, CoreExpr -> CoreExpr
wrapper) <- Type -> DsM (Maybe Type, CoreExpr -> CoreExpr)
resultWrapper Type
unwrapped_res_ty
; let marshal_con :: CoreExpr -> CoreExpr
marshal_con CoreExpr
e = forall b. Var -> Expr b
Var (DataCon -> Var
dataConWrapId DataCon
data_con)
forall b. Expr b -> [Type] -> Expr b
`mkTyApps` [Type]
tycon_arg_tys
forall b. Expr b -> Expr b -> Expr b
`App` CoreExpr -> CoreExpr
wrapper CoreExpr
e
; forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Type
maybe_ty, CoreExpr -> CoreExpr
marshal_con) }
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"resultWrapper" (forall a. Outputable a => a -> SDoc
ppr Type
result_ty)
where
maybe_tc_app :: Maybe (TyCon, [Type])
maybe_tc_app = HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
result_ty