module DsCCall
( dsCCall
, mkFCall
, unboxArg
, boxResult
, resultWrapper
) where
#include "HsVersions.h"
import CoreSyn
import DsMonad
import CoreUtils
import MkCore
import Var
import MkId
import ForeignCall
import DataCon
import TcType
import Type
import Coercion
import PrimOp
import TysPrim
import TyCon
import TysWiredIn
import BasicTypes
import Literal
import PrelNames
import VarSet
import DynFlags
import Outputable
import Util
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 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
= mkApps (mkVarApps (Var the_fcall_id) tyvars) val_args
where
arg_tys = map exprType val_args
body_ty = (mkFunTys arg_tys res_ty)
tyvars = varSetElems (tyVarsOfType body_ty)
ty = mkForAllTys 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 (mkCast arg co)
| Just tc <- tyConAppTyCon_maybe arg_ty,
tc `hasKey` boolTyConKey
= do dflags <- getDynFlags
prim_arg <- newSysLocalDs intPrimTy
return (Var prim_arg,
\ body -> Case (mkWildCase arg arg_ty intPrimTy
[(DataAlt falseDataCon,[],mkIntLit dflags 0),
(DataAlt trueDataCon, [],mkIntLit dflags 1)])
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 arg_ty
prim_arg <- newSysLocalDs 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 arg_ty
vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs 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, data_con_arg_tys) = maybe_product_type
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
= mkCoreConApps (tupleCon UnboxedTuple (2 + length extra_result_tys))
(map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
++ (state : anss))
; (ccall_res_ty, the_alt) <- mk_alt return_result res
; state_id <- newSysLocalDs 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))
ccall_res_ty
(coreAltType the_alt)
[the_alt]
]
; return (realWorldStatePrimTy `mkFunTy` 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))
ccall_res_ty
(coreAltType the_alt)
[the_alt]
return (realWorldStatePrimTy `mkFunTy` 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 realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
[wrap_result (panic "boxResult")]
ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
return (ccall_res_ty, the_alt)
mk_alt return_result (Just prim_res_ty, wrap_result)
| isUnboxedTupleType prim_res_ty= do
let
Just ls = tyConAppArgs_maybe prim_res_ty
arity = 1 + length ls
args_ids@(result_id:as) <- mapM newSysLocalDs ls
state_id <- newSysLocalDs realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
(wrap_result (Var result_id) : map Var as)
ccall_res_ty = mkTyConApp (tupleTyCon UnboxedTuple arity)
(realWorldStatePrimTy : ls)
the_alt = ( DataAlt (tupleCon UnboxedTuple arity)
, (state_id : args_ids)
, the_rhs
)
return (ccall_res_ty, the_alt)
| otherwise = do
result_id <- newSysLocalDs prim_res_ty
state_id <- newSysLocalDs realWorldStatePrimTy
let
the_rhs = return_result (Var state_id)
[wrap_result (Var result_id)]
ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
the_alt = (DataAlt unboxedPairDataCon, [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, \_ -> Var unitDataConId)
| Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
= do
dflags <- getDynFlags
return
(Just intPrimTy, \e -> mkWildCase e intPrimTy
boolTy
[(DEFAULT ,[],Var trueDataConId ),
(LitAlt (mkMachInt dflags 0),[],Var falseDataConId)])
| Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
= do (maybe_ty, wrapper) <- resultWrapper rep_ty
return (maybe_ty, \e -> mkCast (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, data_con, data_con_arg_tys) <- splitDataProductType_maybe result_ty,
dataConSourceArity data_con == 1
= do dflags <- getDynFlags
let
(unwrapped_res_ty : _) = data_con_arg_tys
narrow_wrapper = maybeNarrow dflags tycon
(maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty
return
(maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
(map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
| otherwise
= pprPanic "resultWrapper" (ppr result_ty)
where
maybe_tc_app = splitTyConApp_maybe result_ty
maybeNarrow :: DynFlags -> TyCon -> (CoreExpr -> CoreExpr)
maybeNarrow dflags tycon
| tycon `hasKey` int8TyConKey = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e
| tycon `hasKey` int16TyConKey = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e
| tycon `hasKey` int32TyConKey
&& wORD_SIZE dflags > 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
&& wORD_SIZE dflags > 4 = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e
| otherwise = id