module GHC.HsToCore.Foreign.Call
( dsCCall
, mkFCall
, unboxArg
, boxResult
, resultWrapper
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.Core
import GHC.HsToCore.Monad
import GHC.Core.Utils
import GHC.Core.Make
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.Types.Id ( Id )
import GHC.Core.Coercion
import GHC.Builtin.PrimOps
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 Data.Maybe
dsCCall :: CLabelString
-> [CoreExpr]
-> Safety
-> Type
-> DsM CoreExpr
dsCCall lbl args may_gc result_ty
= do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
(ccall_result_ty, res_wrapper) <- boxResult result_ty
uniq <- newUnique
dflags <- getDynFlags
let
target = StaticTarget NoSourceText lbl Nothing True
the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall dflags uniq the_fcall unboxed_args ccall_result_ty
return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
mkFCall :: DynFlags -> Unique -> ForeignCall
-> [CoreExpr]
-> Type
-> CoreExpr
mkFCall dflags uniq the_fcall val_args res_ty
= ASSERT( all isTyVar tyvars )
mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
where
arg_tys = map exprType val_args
body_ty = (mkVisFunTysMany arg_tys res_ty)
tyvars = tyCoVarsOfTypeWellScoped body_ty
ty = mkInfForAllTys tyvars body_ty
the_fcall_id = mkFCallId dflags uniq the_fcall ty
unboxArg :: CoreExpr
-> DsM (CoreExpr,
CoreExpr -> CoreExpr
)
unboxArg arg
| isPrimitiveType arg_ty
= return (arg, \body -> body)
| Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
= unboxArg (mkCastDs arg co)
| Just tc <- tyConAppTyCon_maybe arg_ty,
tc `hasKey` boolTyConKey
= do dflags <- getDynFlags
let platform = targetPlatform dflags
prim_arg <- newSysLocalDs Many intPrimTy
return (Var prim_arg,
\ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0))
prim_arg
(exprType body)
[(DEFAULT,[],body)])
| is_product_type && data_con_arity == 1
= ASSERT2(isUnliftedType data_con_arg_ty1, pprType arg_ty)
do case_bndr <- newSysLocalDs Many arg_ty
prim_arg <- newSysLocalDs Many data_con_arg_ty1
return (Var prim_arg,
\ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
)
| is_product_type &&
data_con_arity == 3 &&
isJust maybe_arg3_tycon &&
(arg3_tycon == byteArrayPrimTyCon ||
arg3_tycon == mutableByteArrayPrimTyCon)
= do case_bndr <- newSysLocalDs Many arg_ty
vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs (map unrestricted data_con_arg_tys)
return (Var arr_cts_var,
\ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
)
| otherwise
= do l <- getSrcSpanDs
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
arg_ty = exprType arg
maybe_product_type = splitDataProductType_maybe arg_ty
is_product_type = isJust maybe_product_type
Just (_, _, data_con, scaled_data_con_arg_tys) = maybe_product_type
data_con_arg_tys = map scaledThing scaled_data_con_arg_tys
data_con_arity = dataConSourceArity data_con
(data_con_arg_ty1 : _) = data_con_arg_tys
(_ : _ : data_con_arg_ty3 : _) = data_con_arg_tys
maybe_arg3_tycon = tyConAppTyCon_maybe data_con_arg_ty3
Just arg3_tycon = maybe_arg3_tycon
boxResult :: Type
-> DsM (Type, CoreExpr -> CoreExpr)
boxResult result_ty
| Just (io_tycon, io_res_ty) <- tcSplitIOType_maybe result_ty
= do { res <- resultWrapper io_res_ty
; let extra_result_tys
= case res of
(Just ty,_)
| isUnboxedTupleType ty
-> let Just ls = tyConAppArgs_maybe ty in tail ls
_ -> []
return_result state anss
= mkCoreUbxTup
(realWorldStatePrimTy : io_res_ty : extra_result_tys)
(state : anss)
; (ccall_res_ty, the_alt) <- mk_alt return_result res
; state_id <- newSysLocalDs Many realWorldStatePrimTy
; let io_data_con = head (tyConDataCons io_tycon)
toIOCon = dataConWrapId io_data_con
wrap the_call =
mkApps (Var toIOCon)
[ Type io_res_ty,
Lam state_id $
mkWildCase (App the_call (Var state_id))
(unrestricted ccall_res_ty)
(coreAltType the_alt)
[the_alt]
]
; return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap) }
boxResult result_ty
= do
res <- resultWrapper result_ty
(ccall_res_ty, the_alt) <- mk_alt return_result res
let
wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
(unrestricted ccall_res_ty)
(coreAltType the_alt)
[the_alt]
return (realWorldStatePrimTy `mkVisFunTyMany` ccall_res_ty, wrap)
where
return_result _ [ans] = ans
return_result _ _ = panic "return_result: expected single result"
mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)
-> (Maybe Type, Expr Var -> Expr Var)
-> DsM (Type, (AltCon, [Id], Expr Var))
mk_alt return_result (Nothing, wrap_result)
= do
state_id <- newSysLocalDs Many realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
[wrap_result (panic "boxResult")]
ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]
the_alt = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs)
return (ccall_res_ty, the_alt)
mk_alt return_result (Just prim_res_ty, wrap_result)
=
ASSERT2( isPrimitiveType prim_res_ty, ppr prim_res_ty )
do { result_id <- newSysLocalDs Many prim_res_ty
; state_id <- newSysLocalDs Many realWorldStatePrimTy
; let the_rhs = return_result (Var state_id)
[wrap_result (Var result_id)]
ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]
the_alt = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs)
; return (ccall_res_ty, the_alt) }
resultWrapper :: Type
-> DsM (Maybe Type,
CoreExpr -> CoreExpr)
resultWrapper result_ty
| isPrimitiveType result_ty
= return (Just result_ty, \e -> e)
| Just (tc,_) <- maybe_tc_app
, tc `hasKey` unitTyConKey
= return (Nothing, \_ -> unitExpr)
| Just (tc,_) <- maybe_tc_app
, tc `hasKey` boolTyConKey
= do { dflags <- getDynFlags
; let platform = targetPlatform dflags
; let marshal_bool e
= mkWildCase e (unrestricted intPrimTy) boolTy
[ (DEFAULT ,[],Var trueDataConId )
, (LitAlt (mkLitInt platform 0),[],Var falseDataConId)]
; return (Just intPrimTy, marshal_bool) }
| Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
= do { (maybe_ty, wrapper) <- resultWrapper rep_ty
; return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co)) }
| Just (tyvar, rest) <- splitForAllTy_maybe result_ty
= do { (maybe_ty, wrapper) <- resultWrapper rest
; return (maybe_ty, \e -> Lam tyvar (wrapper e)) }
| Just (tycon, tycon_arg_tys) <- maybe_tc_app
, Just data_con <- isDataProductTyCon_maybe tycon
, [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys
= do { dflags <- getDynFlags
; let platform = targetPlatform dflags
; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
; let narrow_wrapper = maybeNarrow platform tycon
marshal_con e = Var (dataConWrapId data_con)
`mkTyApps` tycon_arg_tys
`App` wrapper (narrow_wrapper e)
; return (maybe_ty, marshal_con) }
| otherwise
= pprPanic "resultWrapper" (ppr result_ty)
where
maybe_tc_app = splitTyConApp_maybe result_ty
maybeNarrow :: Platform -> TyCon -> (CoreExpr -> CoreExpr)
maybeNarrow platform tycon
| tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
| tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
| tycon `hasKey` int32TyConKey
, platformWordSizeInBytes platform > 4
= \e -> App (Var (mkPrimOpId Narrow32IntOp)) e
| tycon `hasKey` word8TyConKey = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e
| tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e
| tycon `hasKey` word32TyConKey
, platformWordSizeInBytes platform > 4
= \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
| otherwise = id