-dsFExport i ty mod_name ext_name cconv isDyn =
- getUniqueDs `thenDs` \ uniq ->
- getSrcLocDs `thenDs` \ src_loc ->
- let
- f_helper_glob = mkVanillaId helper_name helper_ty
- where
- name = idName i
- mod
- | isLocalName name = mod_name
- | otherwise = nameModule name
-
- occ = mkForeignExportOcc (nameOccName name)
- prov = LocalDef src_loc Exported
- helper_name = mkGlobalName uniq mod occ prov
- in
- newSysLocalsDs fe_arg_tys `thenDs` \ fe_args ->
+dsFExport fn_id ty mod_name ext_name cconv isDyn
+ = -- BUILD THE returnIO WRAPPER, if necessary
+ -- Look at the result type of the exported function, orig_res_ty
+ -- If it's IO t, return (\x.x, IO t, t)
+ -- If it's plain t, return (\x.returnIO x, IO t, t)
+ (case splitTyConApp_maybe orig_res_ty of
+ Just (ioTyCon, [res_ty])
+ -> ASSERT( ioTyCon `hasKey` ioTyConKey )
+ -- The function already returns IO t
+ returnDs (\body -> body, orig_res_ty, res_ty)
+
+ other -> -- The function returns t, so wrap the call in returnIO
+ dsLookupGlobalValue returnIOIdKey `thenDs` \ retIOId ->
+ returnDs (\body -> mkApps (Var retIOId) [Type orig_res_ty, body],
+ funResultTy (applyTy (idType retIOId) orig_res_ty),
+ -- We don't have ioTyCon conveniently to hand
+ orig_res_ty)
+
+ ) `thenDs` \ (return_io_wrapper, -- Either identity or returnIO
+ io_res_ty, -- IO t
+ res_ty) -> -- t
+
+
+ -- BUILD THE deRefStablePtr WRAPPER, if necessary