- io_app = mkLams tvs $
- mkLams [cback] $
- stbl_app ccall_io_adj res_ty
- fed = (id `setInlinePragma` NeverActive, io_app)
- -- Never inline the f.e.d. function, because the litlit
- -- might not be in scope in other modules.
- in
- returnDs ([fed], h_code, c_code)
+ cback <- newSysLocalDs arg_ty
+ newStablePtrId <- dsLookupGlobalId newStablePtrName
+ stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
+ let
+ stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
+ export_ty = mkFunTy stable_ptr_ty arg_ty
+ bindIOId <- dsLookupGlobalId bindIOName
+ stbl_value <- newSysLocalDs stable_ptr_ty
+ (h_code, c_code, typestring, args_size) <- dsFExport id export_ty fe_nm cconv True
+ let
+ {-
+ The arguments to the external function which will
+ create a little bit of (template) code on the fly
+ for allowing the (stable pointed) Haskell closure
+ to be entered using an external calling convention
+ (stdcall, ccall).
+ -}
+ adj_args = [ mkIntLitInt (ccallConvToInt cconv)
+ , Var stbl_value
+ , Lit (MachLabel fe_nm mb_sz_args)
+ , Lit (mkMachString typestring)
+ ]
+ -- name of external entry point providing these services.
+ -- (probably in the RTS.)
+ adjustor = fsLit "createAdjustor"
+
+ -- Determine the number of bytes of arguments to the stub function,
+ -- so that we can attach the '@N' suffix to its label if it is a
+ -- stdcall on Windows.
+ mb_sz_args = case cconv of
+ StdCallConv -> Just args_size
+ _ -> Nothing
+
+ ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
+ -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
+
+ 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.
+
+ return ([fed], h_code, c_code)