-> DsM CoreExpr -- Result, of type ???
dsCCall lbl args may_gc result_ty
- = mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
- boxResult id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
- newUnique `thenDs` \ uniq ->
- let
- target = StaticTarget lbl
- the_fcall = CCall (CCallSpec target CCallConv may_gc)
- the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
- in
- returnDs (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
+ = do (unboxed_args, arg_wrappers) <- mapAndUnzipM unboxArg args
+ (ccall_result_ty, res_wrapper) <- boxResult id Nothing result_ty
+ uniq <- newUnique
+ let
+ target = StaticTarget lbl
+ the_fcall = CCall (CCallSpec target CCallConv may_gc)
+ the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
+ return (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
mkFCall :: Unique -> ForeignCall
-> [CoreExpr] -- Args
unboxArg arg
-- Primtive types: nothing to unbox
| isPrimitiveType arg_ty
- = returnDs (arg, \body -> body)
+ = return (arg, \body -> body)
-- Recursive newtypes
| Just(rep_ty, co) <- splitNewTypeRepCo_maybe arg_ty
-- Booleans
| Just (tc,_) <- splitTyConApp_maybe arg_ty,
tc `hasKey` boolTyConKey
- = newSysLocalDs intPrimTy `thenDs` \ prim_arg ->
- returnDs (Var prim_arg,
- \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
- [(DataAlt falseDataCon,[],mkIntLit 0),
- (DataAlt trueDataCon, [],mkIntLit 1)])
- -- In increasing tag order!
+ = do prim_arg <- newSysLocalDs intPrimTy
+ return (Var prim_arg,
+ \ body -> Case (Case arg (mkWildId arg_ty) intPrimTy
+ [(DataAlt falseDataCon,[],mkIntLit 0),
+ (DataAlt trueDataCon, [],mkIntLit 1)])
+ -- In increasing tag order!
prim_arg
(exprType body)
- [(DEFAULT,[],body)])
+ [(DEFAULT,[],body)])
-- Data types with a single constructor, which has a single, primitive-typed arg
-- This deals with Int, Float etc; also Ptr, ForeignPtr
| is_product_type && data_con_arity == 1
= ASSERT2(isUnLiftedType data_con_arg_ty1, pprType arg_ty)
- -- Typechecker ensures this
- newSysLocalDs arg_ty `thenDs` \ case_bndr ->
- newSysLocalDs data_con_arg_ty1 `thenDs` \ prim_arg ->
- returnDs (Var prim_arg,
- \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]
- )
+ -- Typechecker ensures this
+ 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)]
+ )
-- Byte-arrays, both mutable and otherwise; hack warning
-- We're looking for values of type ByteArray, MutableByteArray
maybeToBool maybe_arg3_tycon &&
(arg3_tycon == byteArrayPrimTyCon ||
arg3_tycon == mutableByteArrayPrimTyCon)
- = newSysLocalDs arg_ty `thenDs` \ case_bndr ->
- newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[l_var, r_var, arr_cts_var] ->
- returnDs (Var arr_cts_var,
- \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]
-
- )
+ = 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)]
+ )
----- Cases for .NET; almost certainly bit-rotted ---------
| Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
Just (cc,[]) <- splitTyConApp_maybe arg_ty,
cc == charTyCon
-- String; dotnet only
- = dsLookupGlobalId marshalStringName `thenDs` \ unpack_id ->
- newSysLocalDs addrPrimTy `thenDs` \ prim_string ->
- returnDs (Var prim_string,
- \ body ->
- let
- io_ty = exprType body
- Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
- in
- mkApps (Var unpack_id)
- [ Type io_arg
- , arg
- , Lam prim_string body
- ])
+ = do unpack_id <- dsLookupGlobalId marshalStringName
+ prim_string <- newSysLocalDs addrPrimTy
+ return (Var prim_string,
+ \ body ->
+ let
+ io_ty = exprType body
+ Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
+ in
+ mkApps (Var unpack_id)
+ [ Type io_arg
+ , arg
+ , Lam prim_string body
+ ])
| Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
tyConName tc == objectTyConName
-- Object; dotnet only
- = dsLookupGlobalId marshalObjectName `thenDs` \ unpack_id ->
- newSysLocalDs addrPrimTy `thenDs` \ prim_obj ->
- returnDs (Var prim_obj,
- \ body ->
- let
- io_ty = exprType body
- Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
- in
- mkApps (Var unpack_id)
- [ Type io_arg
- , arg
- , Lam prim_obj body
- ])
+ = do unpack_id <- dsLookupGlobalId marshalObjectName
+ prim_obj <- newSysLocalDs addrPrimTy
+ return (Var prim_obj,
+ \ body ->
+ let
+ io_ty = exprType body
+ Just (_,io_arg,_) = tcSplitIOType_maybe io_ty
+ in
+ mkApps (Var unpack_id)
+ [ Type io_arg
+ , arg
+ , Lam prim_obj body
+ ])
--------------- End of cases for .NET --------------------
| otherwise
- = getSrcSpanDs `thenDs` \ l ->
- pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
+ = do l <- getSrcSpanDs
+ pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
arg_ty = exprType arg
maybe_product_type = splitProductType_maybe arg_ty
; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
boxResult augment mbTopCon result_ty
- = -- It isn't IO, so do unsafePerformIO
- -- It's not conveniently available, so we inline it
- resultWrapper result_ty `thenDs` \ res ->
- mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
- let
- wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
- (mkWildId ccall_res_ty)
- (coreAltType the_alt)
- [the_alt]
- in
- returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+ = do -- It isn't IO, so do unsafePerformIO
+ -- It's not conveniently available, so we inline it
+ res <- resultWrapper result_ty
+ (ccall_res_ty, the_alt) <- mk_alt return_result (augment res)
+ let
+ wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
+ (mkWildId ccall_res_ty)
+ (coreAltType the_alt)
+ [the_alt]
+ return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
where
return_result state [ans] = ans
return_result _ _ = panic "return_result: expected single result"
mk_alt return_result (Nothing, wrap_result)
- = -- The ccall returns ()
- newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
- let
- the_rhs = return_result (Var state_id)
- [wrap_result (panic "boxResult")]
+ = do -- The ccall returns ()
+ 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)
- in
- returnDs (ccall_res_ty, the_alt)
+ 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)
-- The ccall returns a non-() value
- | isUnboxedTupleType prim_res_ty
- = let
- Just (_, ls) = splitTyConApp_maybe prim_res_ty
- arity = 1 + length ls
- in
- mappM newSysLocalDs ls `thenDs` \ args_ids@(result_id:as) ->
- newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ | isUnboxedTupleType prim_res_ty= do
let
- the_rhs = return_result (Var state_id)
- (wrap_result (Var result_id) : map Var as)
- ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
- (realWorldStatePrimTy : ls)
- the_alt = ( DataAlt (tupleCon Unboxed arity)
- , (state_id : args_ids)
- , the_rhs
- )
- in
- returnDs (ccall_res_ty, the_alt)
-
- | otherwise
- = newSysLocalDs prim_res_ty `thenDs` \ result_id ->
- newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ Just (_, ls) = splitTyConApp_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 Unboxed arity)
+ (realWorldStatePrimTy : ls)
+ the_alt = ( DataAlt (tupleCon Unboxed 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)
- in
- returnDs (ccall_res_ty, the_alt)
+ 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, -- Type of the expected result, if any
- CoreExpr -> CoreExpr) -- Wrapper for the result
+ -> DsM (Maybe Type, -- Type of the expected result, if any
+ CoreExpr -> CoreExpr) -- Wrapper for the result
-- resultWrapper deals with the result *value*
-- E.g. foreign import foo :: Int -> IO T
-- Then resultWrapper deals with marshalling the 'T' part
resultWrapper result_ty
-- Base case 1: primitive types
| isPrimitiveType result_ty
- = returnDs (Just result_ty, \e -> e)
+ = return (Just result_ty, \e -> e)
-- Base case 2: the unit type ()
| Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
- = returnDs (Nothing, \e -> Var unitDataConId)
+ = return (Nothing, \e -> Var unitDataConId)
-- Base case 3: the boolean type
| Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
- = returnDs
+ = return
(Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
boolTy
- [(DEFAULT ,[],Var trueDataConId ),
- (LitAlt (mkMachInt 0),[],Var falseDataConId)])
+ [(DEFAULT ,[],Var trueDataConId ),
+ (LitAlt (mkMachInt 0),[],Var falseDataConId)])
-- Recursive newtypes
| Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
- = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
- returnDs (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
+ = do (maybe_ty, wrapper) <- resultWrapper rep_ty
+ return (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
-- The type might contain foralls (eg. for dummy type arguments,
-- referring to 'Ptr a' is legal).
| Just (tyvar, rest) <- splitForAllTy_maybe result_ty
- = resultWrapper rest `thenDs` \ (maybe_ty, wrapper) ->
- returnDs (maybe_ty, \e -> Lam tyvar (wrapper e))
+ = do (maybe_ty, wrapper) <- resultWrapper rest
+ return (maybe_ty, \e -> Lam tyvar (wrapper e))
-- Data types with a single constructor, which has a single arg
-- This includes types like Ptr and ForeignPtr
| Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
dataConSourceArity data_con == 1
- = let
- (unwrapped_res_ty : _) = data_con_arg_tys
- narrow_wrapper = maybeNarrow tycon
- in
- resultWrapper unwrapped_res_ty `thenDs` \ (maybe_ty, wrapper) ->
- returnDs
- (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
- (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
+ = do let
+ (unwrapped_res_ty : _) = data_con_arg_tys
+ narrow_wrapper = maybeNarrow 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)]))
-- Strings; 'dotnet' only.
| Just (tc, [arg_ty]) <- maybe_tc_app, tc == listTyCon,
Just (cc,[]) <- splitTyConApp_maybe arg_ty, cc == charTyCon
- = dsLookupGlobalId unmarshalStringName `thenDs` \ pack_id ->
- returnDs (Just addrPrimTy,
- \ e -> App (Var pack_id) e)
+ = do pack_id <- dsLookupGlobalId unmarshalStringName
+ return (Just addrPrimTy,
+ \ e -> App (Var pack_id) e)
-- Objects; 'dotnet' only.
| Just (tc, [arg_ty]) <- maybe_tc_app,
tyConName tc == objectTyConName
- = dsLookupGlobalId unmarshalObjectName `thenDs` \ pack_id ->
- returnDs (Just addrPrimTy,
- \ e -> App (Var pack_id) e)
+ = do pack_id <- dsLookupGlobalId unmarshalObjectName
+ return (Just addrPrimTy,
+ \ e -> App (Var pack_id) e)
| otherwise
= pprPanic "resultWrapper" (ppr result_ty)
projects / ghc-hetmet.git / commitdiff