- = -- The result is IO t, so wrap the result in an IO constructor
-
- 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
- _ -> []
-
- return_result state anss
- = mkConApp (tupleCon Unboxed (2 + length extra_result_tys))
- (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
- ++ (state : anss))
- in
- mk_alt return_result 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)
- (coreAltType the_alt)
- [the_alt]
- ]
- in
- returnDs (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)
+ -- The result is IO t, so wrap the result in an IO constructor
+ = do { res <- resultWrapper io_res_ty
+ ; let extra_result_tys
+ = case res of
+ (Just ty,_)
+ | isUnboxedTupleType ty
+ -> let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
+ _ -> []
+
+ return_result state anss
+ = mkConApp (tupleCon Unboxed (2 + length extra_result_tys))
+ (map Type (realWorldStatePrimTy : io_res_ty : extra_result_tys)
+ ++ (state : anss))
+
+ ; (ccall_res_ty, the_alt) <- mk_alt return_result res
+
+ ; state_id <- newSysLocalDs realWorldStatePrimTy
+ ; let io_data_con = head (tyConDataCons io_tycon)
+ toIOCon = dataConWrapId io_data_con
+
+ wrap the_call = mkCoerce (mkSymCo co) $
+ mkApps (Var toIOCon)
+ [ Type io_res_ty,
+ Lam state_id $
+ mkWildCase (App the_call (Var state_id))
+ ccall_res_ty
+ (coreAltType the_alt)
+ [the_alt]
+ ]
+
+ ; return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap) }
+
+boxResult result_ty
+ = 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 res
+ let
+ wrap = \ the_call -> mkWildCase (App the_call (Var realWorldPrimId))
+ ccall_res_ty
+ (coreAltType the_alt)
+ [the_alt]
+ return (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)