DsForeign.lhs 16 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, boxResult, unboxArg, wrapUnboxedValue	)
sof's avatar
sof committed
16
17
18
import DsMonad
import DsUtils

sof's avatar
sof committed
19
import HsSyn		( ExtName(..), ForeignDecl(..), isDynamic, ForKind(..) )
sof's avatar
sof committed
20
import CallConv
21
import TcHsSyn		( TypecheckedForeignDecl )
sof's avatar
sof committed
22
import CoreUtils	( coreExprType )
23
24
25
26
import Const		( Con(..), mkMachInt )
import DataCon		( DataCon, dataConId )
import Id		( Id, idType, idName, 
			  mkIdVisible, mkWildId
sof's avatar
sof committed
27
			)
28
29
30
31
32
import Const		( Literal(..) )
import Name		( getOccString, NamedThing(..) )
import PrelVals		( realWorldPrimId )
import PrelInfo		( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME )
import Type		( splitAlgTyConApp_maybe, 
sof's avatar
sof committed
33
			  splitTyConApp_maybe, splitFunTys, splitForAllTys,
34
35
			  Type, mkFunTys, mkForAllTys, mkTyConApp,
			  mkTyVarTy, mkFunTy, splitAppTy
sof's avatar
sof committed
36
			)
37
38
39
40
41
import PrimOp		( PrimOp(..) )
import Var		( TyVar )
import TysPrim		( realWorldStatePrimTy, addrPrimTy )
import TysWiredIn	( unitTyCon, addrTy, stablePtrTyCon,
			  unboxedTupleCon, addrDataCon
sof's avatar
sof committed
42
			)
sof's avatar
sof committed
43
import Unique
sof's avatar
sof committed
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
import Outputable
\end{code}

Desugaring of @foreign@ declarations is naturally split up into
parts, an @import@ and an @export@  part. A @foreign import@ 
declaration 

  foreign import cc nm f :: prim_args -> IO prim_res

is the same as

  f :: prim_args -> IO prim_res
  f a1 ... an = _ccall_ nm cc a1 ... an

so we reuse the desugaring code in @DsCCall@ to deal with these.

\begin{code}
dsForeigns :: [TypecheckedForeignDecl] 
62
63
64
65
	   -> DsM ( [CoreBind]        -- desugared foreign imports
                  , [CoreBind]        -- helper functions for foreign exports
		  , SDoc	      -- Header file prototypes for "foreign exported" functions.
		  , SDoc 	      -- C stubs to use when calling "foreign exported" funs.
sof's avatar
sof committed
66
		  )
67
dsForeigns fos = foldlDs combine ([],[],empty,empty) fos
sof's avatar
sof committed
68
 where
69
70
  combine (acc_fi, acc_fe, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _) 
    | isForeignImport =   -- foreign import (dynamic)?
sof's avatar
sof committed
71
        dsFImport i (idType i) uns ext_nm cconv  `thenDs` \ b -> 
72
	returnDs (b:acc_fi, acc_fe, acc_h, acc_c)
sof's avatar
sof committed
73
74
    | isForeignLabel = 
        dsFLabel i ext_nm `thenDs` \ b -> 
75
	returnDs (b:acc_fi, acc_fe, acc_h, acc_c)
sof's avatar
sof committed
76
    | isDynamic ext_nm =
77
78
        dsFExportDynamic i (idType i) ext_nm cconv  `thenDs` \ (fi,fe,h,c) -> 
	returnDs (fi:acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c)
sof's avatar
sof committed
79

80
81
82
    | otherwise	       =  -- foreign export
        dsFExport i (idType i) ext_nm cconv False   `thenDs` \ (fe,h,c) ->
	returnDs (acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c)
sof's avatar
sof committed
83
   where
sof's avatar
sof committed
84
85
86
87
88
89
90
91
92
93
94
    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
95
96
97
98
99
100
101
102
103
104
105
106
107

\end{code}

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

\begin{code}
dsFImport :: Id
	  -> Type		-- Type of foreign import.
	  -> Bool		-- True <=> might cause Haskell GC
	  -> ExtName
	  -> CallConv
108
	  -> DsM CoreBind
sof's avatar
sof committed
109
110
dsFImport nm ty may_not_gc ext_name cconv =
    newSysLocalDs realWorldStatePrimTy	`thenDs` \ old_s ->
111
    splitForeignTyDs ty			`thenDs` \ (tvs, args, mbIoDataCon, io_res_ty)  ->
sof's avatar
sof committed
112
    let
sof's avatar
sof committed
113
114
115
116
	 the_state_arg
	   | is_io_action = old_s
	   | otherwise    = realWorldPrimId

117
         arg_exprs = map (Var) args
sof's avatar
sof committed
118
119

	 is_io_action =
120
121
122
	    case mbIoDataCon of
	      Nothing -> False
	      _	      -> True
sof's avatar
sof committed
123
    in
124
    mapAndUnzipDs unboxArg arg_exprs    `thenDs` \ (unboxed_args, arg_wrappers) ->
sof's avatar
sof committed
125
    (if not is_io_action then
126
127
128
129
130
       newSysLocalDs realWorldStatePrimTy `thenDs` \ state_tok ->
       wrapUnboxedValue io_res_ty         `thenDs` \ (ccall_result_ty, v, res_v) ->
       returnDs ( ccall_result_ty
                , \ prim_app -> Case prim_app  (mkWildId ccall_result_ty)
				    [(DataCon (unboxedTupleCon 2), [state_tok, v], res_v)])
sof's avatar
sof committed
131
     else
132
       boxResult io_res_ty)			`thenDs` \ (final_result_ty, res_wrapper) ->
sof's avatar
sof committed
133
    (case ext_name of
sof's avatar
sof committed
134
135
       Dynamic       -> getUniqueDs `thenDs` \ u -> 
			returnDs (Right u)
136
       ExtName fs _  -> returnDs (Left fs))	`thenDs` \ label ->
sof's avatar
sof committed
137
    let
138
139
140
141
142
143
144
	val_args   = Var the_state_arg : unboxed_args
	final_args = Type inst_ty : val_args

	-- A CCallOp has type (forall a. a), so we must instantiate
	-- it at the full type, including the state argument
	inst_ty = mkFunTys (map coreExprType val_args) final_result_ty

sof's avatar
sof committed
145
	the_ccall_op = CCallOp label False (not may_not_gc) cconv
sof's avatar
sof committed
146

147
148
149
150
151
 	the_prim_app = mkPrimApp the_ccall_op (final_args :: [CoreArg])

	body     = foldr ($) (res_wrapper the_prim_app) arg_wrappers

	the_body 
sof's avatar
sof committed
152
	  | not is_io_action = body
153
	  | otherwise	     = Lam old_s body
sof's avatar
sof committed
154
155
156
    in
    newSysLocalDs (coreExprType the_body) `thenDs` \ ds ->
    let
157
158
159
160
161
162
163
164
165
      io_app = 
        case mbIoDataCon of
	  Nothing -> Var ds
	  Just ioDataCon ->
	       mkApps (Var (dataConId ioDataCon)) 
      		      [Type io_res_ty, Var ds]

      fo_rhs = mkLams (tvs ++ args)
		      (Let (NonRec ds (the_body::CoreExpr)) io_app)
sof's avatar
sof committed
166
167
    in
    returnDs (NonRec nm fo_rhs)
168
169
170
171
\end{code}

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

173
174
175
176
177
178
179
180
181
\begin{code}
splitForeignTyDs :: Type -> DsM ([TyVar], [Id], Maybe DataCon, Type)
splitForeignTyDs ty = 
    newSysLocalsDs arg_tys  `thenDs` \ ds_args ->
    case splitAlgTyConApp_maybe res_ty of
       Just (_,(io_res_ty:_),(ioCon:_)) ->   -- .... -> IO t
	     returnDs (tvs, ds_args, Just ioCon, io_res_ty)
       _   ->				     -- .... -> t
	     returnDs (tvs, ds_args, Nothing, res_ty)
sof's avatar
sof committed
182
  where
183
   (arg_tys, res_ty)   = splitFunTys sans_foralls
sof's avatar
sof committed
184
   (tvs, sans_foralls) = splitForAllTys ty
185

sof's avatar
sof committed
186
187
\end{code}

188
foreign labels 
sof's avatar
sof committed
189
190

\begin{code}
191
192
dsFLabel :: Id -> ExtName -> DsM CoreBind
dsFLabel nm ext_name = returnDs (NonRec nm fo_rhs)
sof's avatar
sof committed
193
  where
194
   fo_rhs = mkConApp addrDataCon [mkLit (MachLitLit enm addrPrimTy)]
sof's avatar
sof committed
195
196
197
   enm    =
    case ext_name of
      ExtName f _ -> f
198
      Dynamic	  -> panic "dsFLabel: Dynamic - shouldn't ever happen."
sof's avatar
sof committed
199
200
201

\end{code}

202
203
204
The function that does most of the work for 'foreign export' declarations.
(see below for the boilerplate code a 'foreign export' declaration expands
 into.)
sof's avatar
sof committed
205

sof's avatar
sof committed
206
207
208
209
210
211
212
\begin{code}
dsFExport :: Id
	  -> Type		-- Type of foreign export.
	  -> ExtName
	  -> CallConv
	  -> Bool		-- True => invoke IO action that's hanging off 
				-- the first argument's stable pointer
213
214
215
216
	  -> DsM ( CoreBind
		 , SDoc
		 , SDoc
		 )
sof's avatar
sof committed
217
218
dsFExport i ty ext_name cconv isDyn =
     newSysLocalDs  helper_ty			        `thenDs` \ f_helper ->
219
     newSysLocalsDs fe_arg_tys				`thenDs` \ fe_args ->
sof's avatar
sof committed
220
221
     (if isDyn then 
        newSysLocalDs stbl_ptr_ty			`thenDs` \ stbl_ptr ->
222
223
	newSysLocalDs stbl_ptr_to_ty			`thenDs` \ stbl_value ->
	dsLookupGlobalValue deRefStablePtr_NAME		`thenDs` \ deRefStablePtrId ->
sof's avatar
sof committed
224
	let
225
226
	 the_deref_app = mkApps (Var deRefStablePtrId)
				[ Type stbl_ptr_to_ty, Var stbl_ptr ]
sof's avatar
sof committed
227
        in
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
	newSysLocalDs (coreExprType the_deref_app)	 `thenDs` \ x_deref_app ->
        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
243
244
245
246
      else
        returnDs (i, 
	          \ body -> body,
		  panic "stbl_ptr"  -- should never be touched.
247
		  ))					`thenDs` \ (i, getFun_wrapper, stbl_ptr) ->
sof's avatar
sof committed
248
249
     let
      wrapper_args
250
251
       | isDyn      = stbl_ptr:fe_args
       | otherwise  = fe_args
sof's avatar
sof committed
252
253
254
255
256
257

      wrapper_arg_tys
       | isDyn      = stbl_ptr_ty:helper_arg_tys
       | otherwise  = helper_arg_tys

      the_app  = 
258
259
         getFun_wrapper $
 	 mkApps (Var i) (map (Type . mkTyVarTy) tvs ++ map Var fe_args)
sof's avatar
sof committed
260
     in
261
262
     getModuleAndGroupDs		`thenDs` \ (mod,_) -> 
     getUniqueDs			`thenDs` \ uniq ->
sof's avatar
sof committed
263
     let
264
      the_body = mkLams (tvs ++ wrapper_args) the_app
sof's avatar
sof committed
265
266
267
268

      c_nm =
        case ext_name of
	  ExtName fs _ -> fs
269
	  Dynamic      -> panic "dsFExport: Dynamic - shouldn't ever happen."
sof's avatar
sof committed
270

sof's avatar
sof committed
271
      f_helper_glob    = mkIdVisible mod f_helper
sof's avatar
sof committed
272
      (h_stub, c_stub) = fexportEntry c_nm f_helper_glob wrapper_arg_tys the_result_ty cconv isDyn
sof's avatar
sof committed
273
     in
274
275
     returnDs (NonRec f_helper_glob the_body, h_stub, c_stub)

sof's avatar
sof committed
276
277
  where

278
279
   (tvs,sans_foralls)			= splitForAllTys ty
   (fe_arg_tys', io_res)	        = splitFunTys sans_foralls
sof's avatar
sof committed
280
281


282
   Just (ioTyCon, [res_ty])	        = splitTyConApp_maybe io_res
sof's avatar
sof committed
283
284
285
286
287
288
289
290
291

   (_, 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) = 
292
     case fe_arg_tys' of
sof's avatar
sof committed
293
294
295
296
297
       (x:xs) | isDyn -> (x,xs)
       ls	      -> (error "stbl_ptr_ty", ls)

   helper_ty      =  
	mkForAllTys tvs $
298
	mkFunTys arg_tys io_res
sof's avatar
sof committed
299
300
301
302
303
        where
	  arg_tys
	   | isDyn	= stbl_ptr_ty : helper_arg_tys
	   | otherwise  = helper_arg_tys

304
305
306
307
308
309
310
311
   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
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
\end{code}

"foreign export dynamic" lets you dress up Haskell IO actions
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.
		 -> ExtName
		 -> CallConv
348
		 -> DsM (CoreBind, CoreBind, SDoc, SDoc)
sof's avatar
sof committed
349
350
351
352
dsFExportDynamic i ty ext_name cconv =
     newSysLocalDs ty					 `thenDs` \ fe_id ->
     let 
        -- hack: need to get at the name of the C stub we're about to generate.
353
       fe_nm	   = toCName fe_id
sof's avatar
sof committed
354
355
       fe_ext_name = ExtName (_PK_ fe_nm) Nothing
     in
356
357
358
     dsFExport  i export_ty fe_ext_name cconv True `thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) ->
     newSysLocalDs arg_ty			   `thenDs` \ cback ->
     dsLookupGlobalValue makeStablePtr_NAME	   `thenDs` \ makeStablePtrId ->
sof's avatar
sof committed
359
     let
360
361
	mk_stbl_ptr_app    = mkApps (Var makeStablePtrId) [ Type arg_ty, Var cback ]
	mk_stbl_ptr_app_ty = coreExprType mk_stbl_ptr_app
sof's avatar
sof committed
362
     in
363
364
365
     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
366
     let
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
      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).
       -}
      adj_args      = [ mkLit (mkMachInt (fromInt (callConvToInt cconv)))
		      , 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 ->
     let ccall_adj_ty = coreExprType ccall_adj
     in
     newSysLocalDs ccall_adj_ty			  `thenDs` \ x_ccall_adj ->
     let ccall_io_adj = 
	    mkLams [stbl_value]		     $
	    bindNonRec x_ccall_adj ccall_adj $
	    Note (Coerce (mkTyConApp ioTyCon [res_ty]) ccall_adj_ty)
		 (Var x_ccall_adj)
     in
     newSysLocalDs (coreExprType ccall_io_adj)	  `thenDs` \ x_ccall_io_adj ->
     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
409
410
411
412
 where
  (tvs,sans_foralls)		   = splitForAllTys ty
  ([arg_ty], io_res)		   = splitFunTys sans_foralls

413
  Just (ioTyCon, [res_ty])	   = splitTyConApp_maybe io_res
sof's avatar
sof committed
414
415
416
417
418
419
420
421
422
423
424
425
426
427

  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}
%
%*

428
429
430
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
431
432

\begin{code}
sof's avatar
sof committed
433
434
435
436
437
438
439
440
fexportEntry :: FAST_STRING 
	     -> Id 
	     -> [Type] 
	     -> Maybe Type 
	     -> CallConv 
	     -> Bool
	     -> (SDoc, SDoc)
fexportEntry c_nm helper args res cc isDyn = (header_bits, c_bits)
sof's avatar
sof committed
441
442
 where
   -- name of the (Haskell) helper function generated by the desugarer.
443
444
445
  h_nm	    = ppr helper <> text "_closure"
   -- prototype for the exported function.
  header_bits = ptext SLIT("extern") <+> fun_proto <> semi
sof's avatar
sof committed
446

447
  fun_proto = cResType <+> pprCconv <+> ptext c_nm <>
sof's avatar
sof committed
448
	      parens (hsep (punctuate comma (zipWith (<+>) cParamTypes proto_args)))
sof's avatar
sof committed
449

450
451
452
  c_bits =
    externDecl $$
    fun_proto  $$
sof's avatar
sof committed
453
    vcat 
454
455
456
457
458
459
460
461
462
     [ 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
463

464
465
  appArg acc (a,c_a) =
     text "rts_apply" <> parens (acc <> comma <> mkHObj a <> parens c_a)
sof's avatar
sof committed
466

sof's avatar
sof committed
467
  cParamTypes  = map showStgType real_args
sof's avatar
sof committed
468

469
  cResType = 
sof's avatar
sof committed
470
   case res of
471
472
     Nothing -> text "void"
     Just t  -> showStgType t
sof's avatar
sof committed
473
474
475
476
477

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

480
  externDecl     = mkExtern (text "HaskellObj") h_nm
sof's avatar
sof committed
481

482
  mkExtern ty nm = text "extern" <+> ty <+> nm <> semi
sof's avatar
sof committed
483
484

  returnResult = 
485
486
487
488
489
490
491
    text "rts_checkSchedStatus" <> 
    parens (doubleQuotes (ptext c_nm) <> comma <> text "rc") <> semi $$
    (case res of
      Nothing -> text "return"
      Just _  -> text "return" <> parens (res_name)) <> semi

  res_name = 
sof's avatar
sof committed
492
493
    case res of
      Nothing -> empty
494
      Just t  -> unpackHObj t <> parens (text "ret")
sof's avatar
sof committed
495

sof's avatar
sof committed
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
  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)

  mkCArgNames n as = zipWith (\ _ n -> text ('a':show n)) as [n..] 
sof's avatar
sof committed
511

512
513
mkHObj :: Type -> SDoc
mkHObj t = text "rts_mk" <> showFFIType t
sof's avatar
sof committed
514

515
516
517
518
519
unpackHObj :: Type -> SDoc
unpackHObj t = text "rts_get" <> showFFIType t

showStgType :: Type -> SDoc
showStgType t = text "Stg" <> showFFIType t
sof's avatar
sof committed
520

521
522
523
524
525
526
527
showFFIType :: Type -> SDoc
showFFIType t = text (getOccString (getName tc))
 where
  tc = case splitTyConApp_maybe t of
	    Just (tc,_) -> tc
	    Nothing	-> pprPanic "showFFIType" (ppr t)
\end{code}