- -- 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 returnIOName `thenDs` \ retIOId ->
- returnDs (\body -> mkApps (Var retIOId) [Type orig_res_ty, body],
- tcFunResultTy (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
- (if isDyn then
- newSysLocalDs stbl_ptr_ty `thenDs` \ stbl_ptr ->
- newSysLocalDs stbl_ptr_to_ty `thenDs` \ stbl_value ->
- dsLookupGlobalValue deRefStablePtrName `thenDs` \ deRefStablePtrId ->
- dsLookupGlobalValue bindIOName `thenDs` \ bindIOId ->
- let
- the_deref_app = mkApps (Var deRefStablePtrId)
- [ Type stbl_ptr_to_ty, Var stbl_ptr ]
-
- stbl_app cont = mkApps (Var bindIOId)
- [ Type stbl_ptr_to_ty
- , Type res_ty
- , the_deref_app
- , mkLams [stbl_value] cont]
- in
- returnDs (stbl_value, stbl_app, stbl_ptr)
- else
- returnDs (fn_id,
- \ body -> body,
- panic "stbl_ptr" -- should never be touched.
- )) `thenDs` \ (i, getFun_wrapper, stbl_ptr) ->
-
-
- -- BUILD THE HELPER
- getModuleDs `thenDs` \ mod ->
- getUniqueDs `thenDs` \ uniq ->
- getSrcLocDs `thenDs` \ src_loc ->
- newSysLocalsDs fe_arg_tys `thenDs` \ fe_args ->
- let
- wrapper_args | isDyn = stbl_ptr:fe_args
- | otherwise = fe_args
-
- wrapper_arg_tys | isDyn = stbl_ptr_ty:fe_arg_tys
- | otherwise = fe_arg_tys
-
- helper_ty = mkForAllTys tvs $
- mkFunTys wrapper_arg_tys io_res_ty
-
- f_helper_glob = mkVanillaGlobal helper_name helper_ty vanillaIdInfo
- where
- name = idName fn_id
- mod
- | isLocalName name = mod_name
- | otherwise = nameModule name
-
- occ = mkForeignExportOcc (nameOccName name)
- helper_name = mkGlobalName uniq mod occ src_loc
-
- the_app = getFun_wrapper (return_io_wrapper (mkVarApps (Var i) (tvs ++ fe_args)))
- the_body = mkLams (tvs ++ wrapper_args) the_app
-
- (h_stub, c_stub) = fexportEntry (moduleUserString mod)
- ext_name f_helper_glob
- wrapper_arg_tys res_ty cconv isDyn
- in
- returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub)
-
- where
- (tvs,sans_foralls) = tcSplitForAllTys ty
- (fe_arg_tys', orig_res_ty) = tcSplitFunTys sans_foralls
- -- We must use tcSplits here, because we want to see
- -- the (IO t) in the corner of the type!
-
- fe_arg_tys | isDyn = tail fe_arg_tys'
- | otherwise = fe_arg_tys'
-
- stbl_ptr_ty | isDyn = head fe_arg_tys'
- | otherwise = error "stbl_ptr_ty"
-
- (_, stbl_ptr_ty') = tcSplitForAllTys stbl_ptr_ty
- (_, stbl_ptr_to_ty) = tcSplitAppTy stbl_ptr_ty'
- -- Again, stable pointers are just newtypes,
- -- so we must see them! Hence tcSplit*