-- If it's IO t, return (t, True)
-- If it's plain t, return (t, False)
(case tcSplitIOType_maybe orig_res_ty of
- Just (ioTyCon, res_ty) -> returnDs (res_ty, True)
+ Just (ioTyCon, res_ty, co) -> returnDs (res_ty, True)
-- The function already returns IO t
+ -- ToDo: what about the coercion?
Nothing -> returnDs (orig_res_ty, False)
-- The function returns t
) `thenDs` \ (res_ty, -- t
dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId ->
dsLookupTyCon stablePtrTyConName `thenDs` \ stable_ptr_tycon ->
let
- mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
export_ty = mkFunTy stable_ptr_ty arg_ty
in
dsFExport id export_ty fe_nm cconv True
`thenDs` \ (h_code, c_code, arg_reps, args_size) ->
let
- stbl_app cont ret_ty = mkApps (Var bindIOId)
- [ Type stable_ptr_ty
- , Type ret_ty
- , mk_stbl_ptr_app
- , cont
- ]
{-
The arguments to the external function which will
create a little bit of (template) code on the fly
_ -> Nothing
in
- dsCCall adjustor adj_args PlayRisky io_res_ty `thenDs` \ ccall_adj ->
+ dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) `thenDs` \ ccall_adj ->
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
- let ccall_adj_ty = exprType ccall_adj
- ccall_io_adj = mkLams [stbl_value] $
-#ifdef DEBUG
- pprTrace "DsForeign: why is there an unsafeCoerce here?" (text "") $
-#endif
- (Cast ccall_adj (mkUnsafeCoercion ccall_adj_ty io_res_ty ))
- io_app = mkLams tvs $
- mkLams [cback] $
- stbl_app ccall_io_adj res_ty
+ let io_app = mkLams tvs $
+ Lam cback $
+ mkCoerceI (mkSymCoI co) $
+ mkApps (Var bindIOId)
+ [ Type stable_ptr_ty
+ , Type res_ty
+ , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
+ , Lam stbl_value ccall_adj
+ ]
+
fed = (id `setInlinePragma` NeverActive, io_app)
-- Never inline the f.e.d. function, because the litlit
-- might not be in scope in other modules.
returnDs ([fed], h_code, c_code)
where
- ty = idType id
- (tvs,sans_foralls) = tcSplitForAllTys ty
- ([arg_ty], io_res_ty) = tcSplitFunTys sans_foralls
- [res_ty] = tcTyConAppArgs io_res_ty
- -- Must use tcSplit* to see the (IO t), which is a newtype
+ ty = idType id
+ (tvs,sans_foralls) = tcSplitForAllTys ty
+ ([arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls
+ Just (io_tc, res_ty, co) = tcSplitIOType_maybe fn_res_ty
+ -- Must have an IO type; hence Just
+ -- co : fn_res_ty ~ IO res_ty
toCName :: Id -> String
toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
MachRep)] -- the MachRep
arg_info = [ (text ('a':show n), showStgType ty, ty,
typeMachRep (getPrimTyOf ty))
- | (ty,n) <- zip arg_htys [1..] ]
+ | (ty,n) <- zip arg_htys [1::Int ..] ]
-- add some auxiliary args; the stable ptr in the wrapper case, and
-- a slot for the dummy return address in the wrapper + ccall case