- 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 ()
+ 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
+ = (Just result_ty, \e -> e)
+
+ -- Base case 2: the unit type ()
+ | Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
+ = (Nothing, \e -> Var unitDataConId)
+
+ -- Base case 3: the boolean type
+ | Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
+ = (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
+ [(DEFAULT ,[],Var trueDataConId ),
+ (LitAlt (mkMachInt 0),[],Var falseDataConId)])
+
+ -- Recursive newtypes
+ | Just rep_ty <- splitNewType_maybe result_ty
+ = let
+ (maybe_ty, wrapper) = resultWrapper rep_ty