- fe_nm = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName fe_id)
- in
- newSysLocalDs arg_ty `thenDs` \ cback ->
- dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId ->
- dsLookupTyCon stablePtrTyConName `thenDs` \ stable_ptr_tycon ->
- let
- stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
- export_ty = mkFunTy stable_ptr_ty arg_ty
- in
- dsLookupGlobalId bindIOName `thenDs` \ bindIOId ->
- newSysLocalDs stable_ptr_ty `thenDs` \ stbl_value ->
- dsFExport id export_ty fe_nm cconv True
- `thenDs` \ (h_code, c_code, arg_reps, args_size) ->
- 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
- , mkLit (MachLabel fe_nm mb_sz_args)
- , mkLit (mkStringLit arg_type_info)
- ]
- -- name of external entry point providing these services.
- -- (probably in the RTS.)
- adjustor = FSLIT("createAdjustor")
-
- arg_type_info = map repCharCode arg_reps
- repCharCode F32 = 'f'
- repCharCode F64 = 'd'
- repCharCode I64 = 'l'
- repCharCode _ = 'i'
-
- -- 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
-
- in
- 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 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.
- in
- returnDs ([fed], h_code, c_code)
+ fe_nm = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName fe_id)
+
+ 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 IsFunction)
+ , 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 $
+ mkCoerce (mkSymCo 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 `setInlineActivation` 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)