-boxResult :: Id -- IOok constructor
- -> Type -- Type of desired result
- -> DsM (Type, -- Type of the result of the ccall itself
- CoreExpr -> CoreExpr) -- Wrapper for the ccall
- -- to box the result
-boxResult ioOkDataCon result_ty
- | null data_cons
- -- oops! can't see the data constructors
- = can't_see_datacons_error "result" result_ty
-
- -- Data types with a single constructor,
- -- which has a single, primitive-typed arg.
- | (maybeToBool maybe_data_type) && -- Data type
- (null other_data_cons) && -- Just one constr
- not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
- isPrimType the_prim_result_ty -- of primitive type
- =
- newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
- newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
-
- mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
-
- mkConDs ioOkDataCon
- [TyArg result_ty, VarArg (Var prim_state_id), VarArg the_result]
- `thenDs` \ the_pair ->
- let
- the_alt = (state_and_prim_datacon, [prim_state_id, prim_result_id], the_pair)
- in
- returnDs (state_and_prim_ty,
- \prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault)
- )
-
- -- Data types with a single nullary constructor
- | (maybeToBool maybe_data_type) && -- Data type
- (null other_data_cons) && -- Just one constr
- (null data_con_arg_tys)
- =
- newSysLocalDs realWorldStatePrimTy `thenDs` \ prim_state_id ->
-
- mkConDs ioOkDataCon
- [TyArg result_ty, VarArg (Var prim_state_id), VarArg (Var unitDataCon)]
- `thenDs` \ the_pair ->
-
- let
- the_alt = (stateDataCon, [prim_state_id], the_pair)
+boxResult :: [Id] -> Type -> DsM (Type, CoreExpr -> CoreExpr)
+
+-- Takes the result of the user-level ccall:
+-- either (IO t),
+-- or maybe just t for an side-effect-free call
+-- Returns a wrapper for the primitive ccall itself, along with the
+-- type of the result of the primitive ccall. This result type
+-- will be of the form
+-- State# RealWorld -> (# State# RealWorld, t' #)
+-- where t' is the unwrapped form of t. If t is simply (), then
+-- the result type will be
+-- State# RealWorld -> (# State# RealWorld #)
+
+-- Here is where we arrange that ForeignPtrs which are passed to a 'safe'
+-- foreign import don't get finalized until the call returns. For each
+-- argument of type ForeignObj# we arrange to touch# the argument after
+-- the call. The arg_ids passed in are the Ids passed to the actual ccall.
+
+boxResult arg_ids result_ty
+ = case tcSplitTyConApp_maybe result_ty of
+
+ -- The result is IO t, so wrap the result in an IO constructor
+ Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey
+ -> mk_alt return_result
+ (resultWrapper io_res_ty) `thenDs` \ (ccall_res_ty, the_alt) ->
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ let
+ io_data_con = head (tyConDataCons io_tycon)
+ wrap = \ the_call ->
+ mkApps (Var (dataConWrapId io_data_con))
+ [ Type io_res_ty,
+ Lam state_id $
+ Case (App the_call (Var state_id))
+ (mkWildId ccall_res_ty)
+ [the_alt]
+ ]
+ in
+ returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+ where
+ return_result state ans = mkConApp unboxedPairDataCon
+ [Type realWorldStatePrimTy, Type io_res_ty,
+ state, ans]
+
+ -- It isn't, so do unsafePerformIO
+ -- It's not conveniently available, so we inline it
+ other -> mk_alt return_result
+ (resultWrapper result_ty) `thenDs` \ (ccall_res_ty, the_alt) ->
+ let
+ wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
+ (mkWildId ccall_res_ty)
+ [the_alt]
+ in
+ returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+ where
+ return_result state ans = ans
+ where
+ mk_alt return_result (Nothing, wrap_result)
+ = -- The ccall returns ()
+ let
+ rhs_fun state_id = return_result (Var state_id)
+ (wrap_result (panic "boxResult"))
+ in
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ mkTouches arg_ids state_id rhs_fun `thenDs` \ the_rhs ->
+ let
+ ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
+ the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
+ in
+ returnDs (ccall_res_ty, the_alt)
+
+ mk_alt return_result (Just prim_res_ty, wrap_result)
+ = -- The ccall returns a non-() value
+ newSysLocalDs prim_res_ty `thenDs` \ result_id ->
+ let
+ rhs_fun state_id = return_result (Var state_id)
+ (wrap_result (Var result_id))
+ in
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ mkTouches arg_ids state_id rhs_fun `thenDs` \ the_rhs ->
+ let
+ 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)
+
+touchzh = mkPrimOpId TouchOp
+
+mkTouches [] s cont = returnDs (cont s)
+mkTouches (v:vs) s cont
+ | not (idType v `eqType` foreignObjPrimTy) = mkTouches vs s cont
+ | otherwise = newSysLocalDs realWorldStatePrimTy `thenDs` \s' ->
+ mkTouches vs s' cont `thenDs` \ rest ->
+ returnDs (Case (mkApps (Var touchzh) [Type foreignObjPrimTy,
+ Var v, Var s]) s'
+ [(DEFAULT, [], rest)])
+
+resultWrapper :: Type
+ -> (Maybe Type, -- Type of the expected result, if any
+ CoreExpr -> CoreExpr) -- Wrapper for the result
+resultWrapper result_ty
+ -- Base case 1: primitive types
+ | isPrimitiveType result_ty_rep
+ = (Just result_ty, \e -> e)
+
+ -- Base case 2: the unit type ()
+ | isUnitTy result_ty_rep
+ = (Nothing, \e -> Var unitDataConId)
+
+ -- Base case 3: the boolean type ()
+ | isBoolTy result_ty_rep
+ = (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
+ [(DEFAULT ,[],Var trueDataConId ),
+ (LitAlt (mkMachInt 0),[],Var falseDataConId)])
+
+ -- Data types with a single constructor, which has a single arg
+ | Just (_, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty_rep,
+ dataConSourceArity data_con == 1
+ = let
+ (maybe_ty, wrapper) = resultWrapper unwrapped_res_ty
+ (unwrapped_res_ty : _) = data_con_arg_tys