-tuple_con_2 = mkTupleCon 2 -- out here to avoid CAF (sigh)
-covar_tuple_con_0 = Var (mkTupleCon 0) -- ditto
-
-boxResult :: 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 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 stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state ->
- mkConDs the_data_con tycon_arg_tys [Var prim_result_id] `thenDs` \ the_result ->
-
- mkConDs tuple_con_2
- [result_ty, realWorldStateTy]
- [the_result, new_state] `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 stateDataCon [realWorldTy] [Var prim_state_id] `thenDs` \ new_state ->
-
- mkConDs tuple_con_2
- [result_ty, realWorldStateTy]
- [covar_tuple_con_0, new_state] `thenDs` \ the_pair ->
-
- let
- the_alt = (stateDataCon, [prim_state_id], the_pair)
+boxResult :: [Id]
+ -> ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr))
+ -> Maybe 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 #)
+
+boxResult arg_ids augment mbTopCon result_ty
+ = case tcSplitTyConApp_maybe result_ty of
+ -- This split absolutely has to be a tcSplit, because we must
+ -- see the IO type; and it's a newtype which is transparent to splitTyConApp.
+
+ -- The result is IO t, so wrap the result in an IO constructor
+ Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey
+ -> resultWrapper io_res_ty `thenDs` \ res ->
+ let aug_res = augment res
+ extra_result_tys =
+ case aug_res of
+ (Just ty,_)
+ | isUnboxedTupleType ty ->
+ let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
+ _ -> []
+ in
+ mk_alt (return_result extra_result_tys) aug_res
+ `thenDs` \ (ccall_res_ty, the_alt) ->
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ let
+ io_data_con = head (tyConDataCons io_tycon)
+ toIOCon =
+ case mbTopCon of
+ Nothing -> dataConWrapId io_data_con
+ Just x -> x
+ wrap = \ the_call ->
+ mkApps (Var toIOCon)
+ [ 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 ts state anss
+ = mkConApp (tupleCon Unboxed (2 + length ts))
+ (Type realWorldStatePrimTy : Type io_res_ty : map Type ts ++
+ state : anss)
+ -- It isn't, so do unsafePerformIO
+ -- It's not conveniently available, so we inline it
+ other -> 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)
+ [the_alt]
+ in
+ returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
+ where
+ return_result state [ans] = ans
+ return_result _ _ = panic "return_result: expected single result"
+ where
+ 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")]
+
+ 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
+ | 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 ->
+ 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 ->
+ 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)
+
+
+resultWrapper :: Type
+ -> DsM (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
+ = returnDs (Just result_ty, \e -> e)
+
+ -- Base case 2: the unit type ()
+ | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
+ = returnDs (Nothing, \e -> Var unitDataConId)
+
+ -- Base case 3: the boolean type
+ | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
+ = returnDs
+ (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
+ [(DEFAULT ,[],Var trueDataConId ),
+ (LitAlt (mkMachInt 0),[],Var falseDataConId)])
+
+ -- Recursive newtypes
+ | Just rep_ty <- splitRecNewType_maybe result_ty
+ = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
+ returnDs (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (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))
+
+ -- 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