- maybe_product_type = splitProductType_maybe result_ty
- Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) = maybe_product_type
- (the_prim_result_ty : other_args_tys) = data_con_arg_tys
-
- ccall_res_type = mkUnboxedTupleTy 2 [realWorldStatePrimTy, the_prim_result_ty]
-
--- wrap up an unboxed value.
-wrapUnboxedValue :: Type -> DsM (Type, Id, CoreExpr)
-wrapUnboxedValue ty
- | (maybeToBool maybe_product_type) && -- Data type
- not (null data_con_arg_tys) && null other_args_tys && -- Just one arg
- isUnLiftedType the_prim_result_ty -- of primitive type
- =
- newSysLocalDs the_prim_result_ty `thenDs` \ prim_result_id ->
- let
- the_result = mkConApp data_con (map Type tycon_arg_tys ++ [Var prim_result_id])
+ 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