DsForeign.lhs 17.6 KB
Newer Older
sof's avatar
sof committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
%
% (c) The AQUA Project, Glasgow University, 1998
%
\section[DsCCall]{Desugaring \tr{foreign} declarations}

Expanding out @foreign import@ and @foreign export@ declarations.

\begin{code}
module DsForeign ( dsForeigns ) where

#include "HsVersions.h"

import CoreSyn

15
import DsCCall		( dsCCall, mkCCall, boxResult, unboxArg, wrapUnboxedValue )
sof's avatar
sof committed
16
17
18
import DsMonad
import DsUtils

19
20
import HsSyn		( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) )
import HsDecls		( extNameStatic )
sof's avatar
sof committed
21
import CallConv
22
import TcHsSyn		( TypecheckedForeignDecl )
23
import CoreUtils	( exprType, mkInlineMe, bindNonRec )
24
import DataCon		( DataCon, dataConWrapId )
25
import Id		( Id, idType, idName, mkWildId, mkVanillaId )
26
27
import MkId		( mkCCallOpId, mkWorkerId )
import Literal		( Literal(..) )
sof's avatar
sof committed
28
import Module		( Module, moduleUserString )
29
import Name		( mkGlobalName, nameModule, nameOccName, getOccString, 
sof's avatar
sof committed
30
			  mkForeignExportOcc, isLocalName,
31
32
			  NamedThing(..), Provenance(..), ExportFlag(..)
			)
33
import PrelInfo		( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME, realWorldPrimId )
34
import Type		( splitAlgTyConApp_maybe,  unUsgTy,
sof's avatar
sof committed
35
			  splitTyConApp_maybe, splitFunTys, splitForAllTys,
36
37
			  Type, mkFunTys, mkForAllTys, mkTyConApp,
			  mkTyVarTy, mkFunTy, splitAppTy
sof's avatar
sof committed
38
			)
39
import PprType          ( {- instance Outputable Type -} )
40
import PrimOp		( PrimOp(..), CCall(..), CCallTarget(..) )
41
42
43
44
import Var		( TyVar )
import TysPrim		( realWorldStatePrimTy, addrPrimTy )
import TysWiredIn	( unitTyCon, addrTy, stablePtrTyCon,
			  unboxedTupleCon, addrDataCon
sof's avatar
sof committed
45
			)
sof's avatar
sof committed
46
import Unique
47
import Maybes		( maybeToBool )
sof's avatar
sof committed
48
import Outputable
49
50
51
52

#if __GLASGOW_HASKELL__ >= 404
import GlaExts		( fromInt )
#endif
sof's avatar
sof committed
53
54
55
56
\end{code}

Desugaring of @foreign@ declarations is naturally split up into
parts, an @import@ and an @export@  part. A @foreign import@ 
57
58
declaration
\begin{verbatim}
sof's avatar
sof committed
59
  foreign import cc nm f :: prim_args -> IO prim_res
60
\end{verbatim}
sof's avatar
sof committed
61
is the same as
62
\begin{verbatim}
sof's avatar
sof committed
63
64
  f :: prim_args -> IO prim_res
  f a1 ... an = _ccall_ nm cc a1 ... an
65
\end{verbatim}
sof's avatar
sof committed
66
67
68
so we reuse the desugaring code in @DsCCall@ to deal with these.

\begin{code}
sof's avatar
sof committed
69
70
dsForeigns :: Module
           -> [TypecheckedForeignDecl] 
71
72
	   -> DsM ( [CoreBind]        -- desugared foreign imports
                  , [CoreBind]        -- helper functions for foreign exports
73
74
75
76
		  , SDoc	      -- Header file prototypes for
                                      -- "foreign exported" functions.
		  , SDoc 	      -- C stubs to use when calling
                                      -- "foreign exported" functions.
sof's avatar
sof committed
77
		  )
sof's avatar
sof committed
78
dsForeigns mod_name fos = foldlDs combine ([],[],empty,empty) fos
sof's avatar
sof committed
79
 where
80
81
  combine (acc_fi, acc_fe, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _) 
    | isForeignImport =   -- foreign import (dynamic)?
82
83
        dsFImport i (idType i) uns ext_nm cconv  `thenDs` \ bs -> 
	returnDs (bs ++ acc_fi, acc_fe, acc_h, acc_c)
sof's avatar
sof committed
84
85
    | isForeignLabel = 
        dsFLabel i ext_nm `thenDs` \ b -> 
86
	returnDs (b:acc_fi, acc_fe, acc_h, acc_c)
87
    | isDynamicExtName ext_nm =
sof's avatar
sof committed
88
        dsFExportDynamic i (idType i) mod_name ext_nm cconv  `thenDs` \ (fi,fe,h,c) -> 
89
	returnDs (fi:acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c)
sof's avatar
sof committed
90

91
    | otherwise	       =  -- foreign export
sof's avatar
sof committed
92
        dsFExport i (idType i) mod_name ext_nm cconv False   `thenDs` \ (fe,h,c) ->
93
	returnDs (acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c)
sof's avatar
sof committed
94
   where
sof's avatar
sof committed
95
96
97
98
99
100
101
102
103
104
105
    isForeignImport = 
	case imp_exp of
	  FoImport _ -> True
	  _          -> False

    isForeignLabel = 
	case imp_exp of
	  FoLabel -> True
	  _       -> False

    (FoImport uns)   = imp_exp
sof's avatar
sof committed
106
107
108
109
110

\end{code}

Desugaring foreign imports is just the matter of creating a binding
that on its RHS unboxes its arguments, performs the external call
111
(using the @CCallOp@ primop), before boxing the result up and returning it.
sof's avatar
sof committed
112

113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
However, we create a worker/wrapper pair, thus:

	foreign import f :: Int -> IO Int
==>
	f x = IO ( \s -> case x of { I# x# ->
			 case fw s x# of { (# s1, y# #) ->
			 (# s1, I# y# #)}})

	fw s x# = ccall f s x#

The strictness/CPR analyser won't do this automatically because it doesn't look
inside returned tuples; but inlining this wrapper is a Really Good Idea 
because it exposes the boxing to the call site.
			

sof's avatar
sof committed
128
129
130
131
132
133
\begin{code}
dsFImport :: Id
	  -> Type		-- Type of foreign import.
	  -> Bool		-- True <=> might cause Haskell GC
	  -> ExtName
	  -> CallConv
134
135
136
137
138
	  -> DsM [CoreBind]
dsFImport fn_id ty may_not_gc ext_name cconv 
  = let
	(tvs, arg_tys, mbIoDataCon, io_res_ty) = splitForeignTyDs ty
	is_io_action 			       = maybeToBool mbIoDataCon
sof's avatar
sof committed
139
    in
140
141
142
143
    newSysLocalsDs arg_tys  			`thenDs` \ args ->
    newSysLocalDs realWorldStatePrimTy		`thenDs` \ old_s ->
    mapAndUnzipDs unboxArg (map Var args)	`thenDs` \ (unboxed_args, arg_wrappers) ->

sof's avatar
sof committed
144
    (if not is_io_action then
145
146
       newSysLocalDs realWorldStatePrimTy	`thenDs` \ state_tok ->
       wrapUnboxedValue io_res_ty		`thenDs` \ (ccall_result_ty, v, res_v) ->
147
148
       returnDs ( ccall_result_ty
                , \ prim_app -> Case prim_app  (mkWildId ccall_result_ty)
149
				    [(DataAlt (unboxedTupleCon 2), [state_tok, v], res_v)])
sof's avatar
sof committed
150
     else
151
152
       boxResult io_res_ty)			`thenDs` \ (ccall_result_ty, res_wrapper) ->

sof's avatar
sof committed
153
    (case ext_name of
sof's avatar
sof committed
154
       Dynamic       -> getUniqueDs `thenDs` \ u -> 
155
156
			returnDs (DynamicTarget u)
       ExtName fs _  -> returnDs (StaticTarget fs))	`thenDs` \ lbl ->
157

158
159
    getUniqueDs						`thenDs` \ ccall_uniq ->
    getUniqueDs						`thenDs` \ work_uniq ->
sof's avatar
sof committed
160
    let
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
	the_state_arg | is_io_action = old_s
		      | otherwise    = realWorldPrimId

	-- Build the worker
	val_args      = Var the_state_arg : unboxed_args
	work_arg_ids  = [v | Var v <- val_args]		-- All guaranteed to be vars
	worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
	the_ccall     = CCall lbl False (not may_not_gc) cconv
 	the_ccall_app = mkCCall ccall_uniq the_ccall val_args ccall_result_ty
	work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
	work_id       = mkWorkerId work_uniq fn_id worker_ty

	-- Build the wrapper
	work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
	wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
        io_app 	     = case mbIoDataCon of
			   Nothing        -> wrapper_body
			   Just ioDataCon -> mkApps (Var (dataConWrapId ioDataCon)) 
						    [Type io_res_ty, Lam old_s wrapper_body]
        wrap_rhs = mkInlineMe (mkLams (tvs ++ args) io_app)
sof's avatar
sof committed
181
    in
182
    returnDs [NonRec fn_id wrap_rhs, NonRec work_id work_rhs]
183
184
185
186
\end{code}

Given the type of a foreign import declaration, split it up into
its constituent parts.
sof's avatar
sof committed
187

188
\begin{code}
189
190
191
splitForeignTyDs :: Type -> ([TyVar], [Type], Maybe DataCon, Type)
splitForeignTyDs ty
  = case splitAlgTyConApp_maybe res_ty of
192
       Just (_,(io_res_ty:_),(ioCon:_)) ->   -- .... -> IO t
193
	     (tvs, arg_tys, Just ioCon, io_res_ty)
194
       _   ->				     -- .... -> t
195
	     (tvs, arg_tys, Nothing, res_ty)
sof's avatar
sof committed
196
  where
197
   (arg_tys, res_ty)   = splitFunTys sans_foralls
sof's avatar
sof committed
198
199
200
   (tvs, sans_foralls) = splitForAllTys ty
\end{code}

201
foreign labels 
sof's avatar
sof committed
202
203

\begin{code}
204
205
dsFLabel :: Id -> ExtName -> DsM CoreBind
dsFLabel nm ext_name = returnDs (NonRec nm fo_rhs)
sof's avatar
sof committed
206
  where
207
   fo_rhs = mkConApp addrDataCon [mkLit (MachLitLit enm addrPrimTy)]
208
   enm    = extNameStatic ext_name
sof's avatar
sof committed
209
210
\end{code}

211
212
The function that does most of the work for `@foreign export@' declarations.
(see below for the boilerplate code a `@foreign export@' declaration expands
213
 into.)
sof's avatar
sof committed
214

215
216
217
218
219
220
For each `@foreign export foo@' in a module M we generate:
\begin{itemize}
\item a C function `@foo@', which calls
\item a Haskell stub `@M.$ffoo@', which calls
\end{itemize}
the user-written Haskell function `@M.foo@'.
221

sof's avatar
sof committed
222
223
224
\begin{code}
dsFExport :: Id
	  -> Type		-- Type of foreign export.
sof's avatar
sof committed
225
	  -> Module
sof's avatar
sof committed
226
227
228
229
	  -> ExtName
	  -> CallConv
	  -> Bool		-- True => invoke IO action that's hanging off 
				-- the first argument's stable pointer
230
231
232
233
	  -> DsM ( CoreBind
		 , SDoc
		 , SDoc
		 )
sof's avatar
sof committed
234
dsFExport i ty mod_name ext_name cconv isDyn =
235
236
237
     getUniqueDs					`thenDs` \ uniq ->
     getSrcLocDs					`thenDs` \ src_loc ->
     let
238
	f_helper_glob = mkVanillaId helper_name helper_ty
239
		      where
sof's avatar
sof committed
240
241
242
243
244
245
246
247
			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
248
     in
249
     newSysLocalsDs fe_arg_tys				`thenDs` \ fe_args ->
sof's avatar
sof committed
250
251
     (if isDyn then 
        newSysLocalDs stbl_ptr_ty			`thenDs` \ stbl_ptr ->
252
253
	newSysLocalDs stbl_ptr_to_ty			`thenDs` \ stbl_value ->
	dsLookupGlobalValue deRefStablePtr_NAME		`thenDs` \ deRefStablePtrId ->
sof's avatar
sof committed
254
	let
255
256
	 the_deref_app = mkApps (Var deRefStablePtrId)
				[ Type stbl_ptr_to_ty, Var stbl_ptr ]
sof's avatar
sof committed
257
        in
258
	newSysLocalDs (exprType the_deref_app)	 `thenDs` \ x_deref_app ->
259
260
261
262
263
264
265
266
267
268
269
270
271
272
        dsLookupGlobalValue bindIO_NAME			 `thenDs` \ bindIOId ->
	newSysLocalDs (mkFunTy stbl_ptr_to_ty 
			       (mkTyConApp ioTyCon [res_ty])) `thenDs` \ x_cont ->
	let
	 stbl_app      = \ cont -> 
		bindNonRec x_cont   (mkLams [stbl_value] cont) $
		bindNonRec x_deref_app the_deref_app  
			   (mkApps (Var bindIOId)
				     [ Type stbl_ptr_to_ty
				     , Type res_ty
				     , Var x_deref_app
				     , Var x_cont])
        in
	returnDs (stbl_value, stbl_app, stbl_ptr)
sof's avatar
sof committed
273
274
275
276
      else
        returnDs (i, 
	          \ body -> body,
		  panic "stbl_ptr"  -- should never be touched.
277
		  ))			`thenDs` \ (i, getFun_wrapper, stbl_ptr) ->
sof's avatar
sof committed
278
279
     let
      wrapper_args
280
281
       | isDyn      = stbl_ptr:fe_args
       | otherwise  = fe_args
sof's avatar
sof committed
282
283
284
285
286
287

      wrapper_arg_tys
       | isDyn      = stbl_ptr_ty:helper_arg_tys
       | otherwise  = helper_arg_tys

      the_app  = 
288
289
         getFun_wrapper $
 	 mkApps (Var i) (map (Type . mkTyVarTy) tvs ++ map Var fe_args)
sof's avatar
sof committed
290
     in
291
     getModuleDs			`thenDs` \ mod -> 
292
     getUniqueDs			`thenDs` \ uniq ->
sof's avatar
sof committed
293
     let
294
      the_body = mkLams (tvs ++ wrapper_args) the_app
295
      c_nm     = extNameStatic ext_name
sof's avatar
sof committed
296

sof's avatar
sof committed
297
298
      (h_stub, c_stub) = fexportEntry (moduleUserString mod)
      				      c_nm f_helper_glob
299
                                      wrapper_arg_tys the_result_ty cconv isDyn
sof's avatar
sof committed
300
     in
301
302
     returnDs (NonRec f_helper_glob the_body, h_stub, c_stub)

sof's avatar
sof committed
303
304
  where

305
306
   (tvs,sans_foralls)			= splitForAllTys ty
   (fe_arg_tys', io_res)	        = splitFunTys sans_foralls
sof's avatar
sof committed
307
308


309
   Just (ioTyCon, [res_ty])	        = splitTyConApp_maybe io_res
sof's avatar
sof committed
310
311
312
313
314
315
316
317
318

   (_, stbl_ptr_ty')			= splitForAllTys stbl_ptr_ty
   (_, stbl_ptr_to_ty)			= splitAppTy stbl_ptr_ty'

   fe_arg_tys
     | isDyn	    = tail fe_arg_tys'
     | otherwise    = fe_arg_tys'

   (stbl_ptr_ty, helper_arg_tys) = 
319
     case fe_arg_tys' of
sof's avatar
sof committed
320
321
322
323
324
       (x:xs) | isDyn -> (x,xs)
       ls	      -> (error "stbl_ptr_ty", ls)

   helper_ty      =  
	mkForAllTys tvs $
325
	mkFunTys arg_tys io_res
sof's avatar
sof committed
326
327
328
329
330
        where
	  arg_tys
	   | isDyn	= stbl_ptr_ty : helper_arg_tys
	   | otherwise  = helper_arg_tys

331
332
333
334
335
336
337
338
   the_result_ty =
     case splitTyConApp_maybe io_res of
       Just (_,[res_ty]) ->
         case splitTyConApp_maybe res_ty of
	   Just (tc,_) | getUnique tc /= getUnique unitTyCon -> Just res_ty
	   _						     -> Nothing
       _		 -> Nothing
   
sof's avatar
sof committed
339
340
\end{code}

341
@foreign export dynamic@ lets you dress up Haskell IO actions
sof's avatar
sof committed
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
of some fixed type behind an externally callable interface (i.e.,
as a C function pointer). Useful for callbacks and stuff.

\begin{verbatim}
foreign export stdcall f :: (Addr -> Int -> IO Int) -> IO Addr

-- Haskell-visible constructor, which is generated from the
-- above:

f :: (Addr -> Int -> IO Int) -> IO Addr
f cback = IO ( \ s1# ->
  case makeStablePtr# cback s1# of { StateAndStablePtr# s2# sp# ->
  case _ccall_ "mkAdjustor" sp# ``f_helper'' s2# of
    StateAndAddr# s3# a# ->
    case addr2Int# a# of
      0# -> IOfail s# err
      _  -> 
	 let
	  a :: Addr
	  a = A# a#
	 in
         IOok s3# a)

foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr -> Int -> IO Int
-- `special' foreign export that invokes the closure pointed to by the
-- first argument.
\end{verbatim}

\begin{code}
dsFExportDynamic :: Id
		 -> Type		-- Type of foreign export.
sof's avatar
sof committed
373
		 -> Module
sof's avatar
sof committed
374
375
		 -> ExtName
		 -> CallConv
376
		 -> DsM (CoreBind, CoreBind, SDoc, SDoc)
sof's avatar
sof committed
377
dsFExportDynamic i ty mod_name ext_name cconv =
sof's avatar
sof committed
378
379
380
     newSysLocalDs ty					 `thenDs` \ fe_id ->
     let 
        -- hack: need to get at the name of the C stub we're about to generate.
381
       fe_nm	   = toCName fe_id
sof's avatar
sof committed
382
383
       fe_ext_name = ExtName (_PK_ fe_nm) Nothing
     in
384
385
     dsFExport  i export_ty mod_name fe_ext_name cconv True
     `thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) ->
sof's avatar
sof committed
386
     newSysLocalDs arg_ty			            `thenDs` \ cback ->
387
     dsLookupGlobalValue makeStablePtr_NAME	   `thenDs` \ makeStablePtrId ->
sof's avatar
sof committed
388
     let
389
	mk_stbl_ptr_app    = mkApps (Var makeStablePtrId) [ Type arg_ty, Var cback ]
390
	mk_stbl_ptr_app_ty = exprType mk_stbl_ptr_app
sof's avatar
sof committed
391
     in
392
393
394
     newSysLocalDs mk_stbl_ptr_app_ty			`thenDs` \ x_mk_stbl_ptr_app ->
     dsLookupGlobalValue bindIO_NAME		        `thenDs` \ bindIOId ->
     newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value ->
sof's avatar
sof committed
395
     let
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
      stbl_app      = \ x_cont cont ret_ty -> 
	bindNonRec x_cont	     cont	     $
	bindNonRec x_mk_stbl_ptr_app mk_stbl_ptr_app $
		   (mkApps (Var bindIOId)
			   [ Type (mkTyConApp stablePtrTyCon [arg_ty])
			   , Type ret_ty
			   , Var x_mk_stbl_ptr_app
			   , Var x_cont
			   ])

       {-
        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).
       -}
413
      adj_args      = [ mkIntLitInt (callConvToInt cconv)
414
415
416
417
418
419
420
421
		      , Var stbl_value
		      , mkLit (MachLitLit (_PK_ fe_nm) addrPrimTy)
		      ]
        -- name of external entry point providing these services.
	-- (probably in the RTS.) 
      adjustor	    = SLIT("createAdjustor")
     in
     dsCCall adjustor adj_args False False addrTy `thenDs` \ ccall_adj ->
422
     let ccall_adj_ty = exprType ccall_adj
423
424
425
426
427
     in
     newSysLocalDs ccall_adj_ty			  `thenDs` \ x_ccall_adj ->
     let ccall_io_adj = 
	    mkLams [stbl_value]		     $
	    bindNonRec x_ccall_adj ccall_adj $
428
	    Note (Coerce (mkTyConApp ioTyCon [res_ty]) (unUsgTy ccall_adj_ty))
429
430
		 (Var x_ccall_adj)
     in
431
     newSysLocalDs (exprType ccall_io_adj)	  `thenDs` \ x_ccall_io_adj ->
432
433
434
435
436
437
     let io_app = mkLams tvs	 $
		  mkLams [cback] $
		  stbl_app x_ccall_io_adj ccall_io_adj addrTy
     in
     returnDs (NonRec i io_app, fe, h_code, c_code)

sof's avatar
sof committed
438
439
440
441
 where
  (tvs,sans_foralls)		   = splitForAllTys ty
  ([arg_ty], io_res)		   = splitFunTys sans_foralls

442
  Just (ioTyCon, [res_ty])	   = splitTyConApp_maybe io_res
sof's avatar
sof committed
443
444
445
446
447
448
449
450
451
452
453
454
455
456

  export_ty			   = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty

toCName :: Id -> String
toCName i = showSDoc (pprCode CStyle (ppr (idName i)))

\end{code}

%*
%
\subsection{Generating @foreign export@ stubs}
%
%*

457
458
459
For each @foreign export@ function, a C stub function is generated.
The C stub constructs the application of the exported Haskell function 
using the hugs/ghc rts invocation API.
sof's avatar
sof committed
460
461

\begin{code}
sof's avatar
sof committed
462
463
fexportEntry :: String
	     -> FAST_STRING
sof's avatar
sof committed
464
465
466
467
468
469
	     -> Id 
	     -> [Type] 
	     -> Maybe Type 
	     -> CallConv 
	     -> Bool
	     -> (SDoc, SDoc)
sof's avatar
sof committed
470
fexportEntry mod_nm c_nm helper args res cc isDyn = (header_bits, c_bits)
sof's avatar
sof committed
471
472
 where
   -- name of the (Haskell) helper function generated by the desugarer.
473
474
475
  h_nm	    = ppr helper <> text "_closure"
   -- prototype for the exported function.
  header_bits = ptext SLIT("extern") <+> fun_proto <> semi
sof's avatar
sof committed
476

477
  fun_proto = cResType <+> pprCconv <+> ptext c_nm <>
sof's avatar
sof committed
478
	      parens (hsep (punctuate comma (zipWith (<+>) cParamTypes proto_args)))
sof's avatar
sof committed
479

480
481
482
  c_bits =
    externDecl $$
    fun_proto  $$
sof's avatar
sof committed
483
    vcat 
484
485
486
487
488
489
490
491
492
     [ lbrace
     ,   text "SchedulerStatus rc;"
     ,   declareResult
	  -- create the application + perform it.
     ,   text "rc=rts_evalIO" <> 
                  parens (foldl appArg (text "(StgClosure*)&" <> h_nm) (zip args c_args) <> comma <> text "&ret") <> semi
     ,   returnResult
     , rbrace
     ]
sof's avatar
sof committed
493

494
495
  appArg acc (a,c_a) =
     text "rts_apply" <> parens (acc <> comma <> mkHObj a <> parens c_a)
sof's avatar
sof committed
496

sof's avatar
sof committed
497
  cParamTypes  = map showStgType real_args
sof's avatar
sof committed
498

499
  cResType = 
sof's avatar
sof committed
500
   case res of
501
502
     Nothing -> text "void"
     Just t  -> showStgType t
sof's avatar
sof committed
503
504
505
506
507

  pprCconv
   | cc == cCallConv = empty
   | otherwise	     = pprCallConv cc
     
508
  declareResult  = text "HaskellObj ret;"
sof's avatar
sof committed
509

510
  externDecl     = mkExtern (text "HaskellObj") h_nm
sof's avatar
sof committed
511

512
  mkExtern ty nm = text "extern" <+> ty <+> nm <> semi
sof's avatar
sof committed
513
514

  returnResult = 
515
    text "rts_checkSchedStatus" <> 
sof's avatar
sof committed
516
    parens (doubleQuotes (text mod_nm <> char '.' <> ptext c_nm) <> comma <> text "rc") <> semi $$
517
518
519
520
521
    (case res of
      Nothing -> text "return"
      Just _  -> text "return" <> parens (res_name)) <> semi

  res_name = 
sof's avatar
sof committed
522
523
    case res of
      Nothing -> empty
524
      Just t  -> unpackHObj t <> parens (text "ret")
sof's avatar
sof committed
525

sof's avatar
sof committed
526
527
528
529
530
531
532
533
534
535
536
537
538
539
  c_args = mkCArgNames 0 args

  {-
   If we're generating an entry point for a 'foreign export ccall dynamic',
   then we receive the return address of the C function that wants to
   invoke a Haskell function as any other C function, as second arg.
   This arg is unused within the body of the generated C stub, but
   needed by the Adjustor.c code to get the stack cleanup right.
  -}
  (proto_args, real_args)
    | cc == cCallConv && isDyn = ( text "a0" : text "a_" : mkCArgNames 1 (tail args)
				, head args : addrTy : tail args)
    | otherwise = (mkCArgNames 0 args, args)

sof's avatar
sof committed
540
541
mkCArgNames :: Int -> [a] -> [SDoc]
mkCArgNames n as = zipWith (\ _ n -> text ('a':show n)) as [n..] 
sof's avatar
sof committed
542

543
mkHObj :: Type -> SDoc
sof's avatar
sof committed
544
mkHObj t = text "rts_mk" <> text (showFFIType t)
sof's avatar
sof committed
545

546
unpackHObj :: Type -> SDoc
sof's avatar
sof committed
547
unpackHObj t = text "rts_get" <> text (showFFIType t)
548
549

showStgType :: Type -> SDoc
sof's avatar
sof committed
550
showStgType t = text "Stg" <> text (showFFIType t)
sof's avatar
sof committed
551

sof's avatar
sof committed
552
553
showFFIType :: Type -> String
showFFIType t = getOccString (getName tc)
554
555
556
557
558
 where
  tc = case splitTyConApp_maybe t of
	    Just (tc,_) -> tc
	    Nothing	-> pprPanic "showFFIType" (ppr t)
\end{code}