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

18
19
import HsSyn		( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) )
import HsDecls		( extNameStatic )
20
import TcHsSyn		( TypecheckedForeignDecl )
21
import CoreUtils	( exprType, mkInlineMe )
22
import Id		( Id, idType, idName, mkVanillaGlobal, mkSysLocal,
23
			  setInlinePragma )
24
import IdInfo		( neverInlinePrag, vanillaIdInfo )
25
import Literal		( Literal(..) )
sof's avatar
sof committed
26
import Module		( Module, moduleUserString )
27
import Name		( mkGlobalName, nameModule, nameOccName, getOccString, 
sof's avatar
sof committed
28
			  mkForeignExportOcc, isLocalName,
29
			  NamedThing(..),
30
			)
31
import Type		( repType, splitTyConApp_maybe,
32
			  splitFunTys, splitForAllTys,
33
			  Type, mkFunTys, mkForAllTys, mkTyConApp,
34
			  mkFunTy, splitAppTy, applyTy, funResultTy
sof's avatar
sof committed
35
			)
36
37
38
39
40
import ForeignCall	( ForeignCall(..), CCallSpec(..), 
			  Safety(..), playSafe,
			  CCallTarget(..), dynamicTarget,
			  CCallConv(..), ccallConvToInt
			)
41
import TysWiredIn	( unitTy, addrTy, stablePtrTyCon )
42
import TysPrim		( addrPrimTy )
43
44
import PrelNames	( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName,
			  bindIOName, returnIOName
45
			)
sof's avatar
sof committed
46
import Outputable
47
48

import Maybe 		( fromJust )
sof's avatar
sof committed
49
50
51
52
\end{code}

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

\begin{code}
65
66
67
type Binding = (Id, CoreExpr)	-- No rec/nonrec structure;
				-- the occurrence analyser will sort it all out

sof's avatar
sof committed
68
69
dsForeigns :: Module
           -> [TypecheckedForeignDecl] 
70
71
72
	   -> DsM ( [Id]		-- Foreign-exported binders; 
					-- we have to generate code to register these
		  , [Binding]
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
		  )
78
dsForeigns mod_name fos = foldlDs combine ([], [], empty, empty) fos
sof's avatar
sof committed
79
 where
80
  combine (acc_feb, acc_f, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _) 
81
    | isForeignImport =   -- foreign import (dynamic)?
82
        dsFImport i (idType i) uns ext_nm cconv  `thenDs` \ bs -> 
83
	returnDs (acc_feb, bs ++ acc_f, acc_h, acc_c)
sof's avatar
sof committed
84
    | isForeignLabel = 
85
        dsFLabel i (idType i) ext_nm `thenDs` \ b -> 
86
	returnDs (acc_feb, b:acc_f, acc_h, acc_c)
87
    | isDynamicExtName ext_nm =
88
89
        dsFExportDynamic i (idType i) mod_name ext_nm cconv  `thenDs` \ (feb,bs,h,c) -> 
	returnDs (feb:acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c)
sof's avatar
sof committed
90

91
    | otherwise	       =  -- foreign export
92
93
        dsFExport i (idType i) mod_name ext_nm cconv False   `thenDs` \ (feb,fe,h,c) ->
	returnDs (feb:acc_feb, fe:acc_f, 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
    isForeignImport = 
	case imp_exp of
	  FoImport _ -> True
	  _          -> False

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

105
    FoImport uns = imp_exp
sof's avatar
sof committed
106
107
108
109
\end{code}

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

112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
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
127
128
129
\begin{code}
dsFImport :: Id
	  -> Type		-- Type of foreign import.
130
	  -> Safety		-- Whether can re-enter the Haskell RTS, do GC etc
sof's avatar
sof committed
131
	  -> ExtName
132
	  -> CCallConv
133
	  -> DsM [Binding]
134
dsFImport fn_id ty safety ext_name cconv 
135
  = let
136
137
	(tvs, fun_ty)        = splitForAllTys ty
	(arg_tys, io_res_ty) = splitFunTys fun_ty
sof's avatar
sof committed
138
    in
139
    newSysLocalsDs arg_tys  			`thenDs` \ args ->
140
    mapAndUnzipDs unboxArg (map Var args)	`thenDs` \ (val_args, arg_wrappers) ->
141

142
143
144
    let
	work_arg_ids  = [v | Var v <- val_args]	-- All guaranteed to be vars

145
	-- These are the ids we pass to boxResult, which are used to decide
146
147
	-- whether to touch# an argument after the call (used to keep
	-- ForeignObj#s live across a 'safe' foreign import).
148
149
	maybe_arg_ids | playSafe safety = work_arg_ids
		      | otherwise	= []
150
    in
151
    boxResult maybe_arg_ids io_res_ty  		`thenDs` \ (ccall_result_ty, res_wrapper) ->
152
153
154

    getUniqueDs					`thenDs` \ ccall_uniq ->
    getUniqueDs					`thenDs` \ work_uniq ->
sof's avatar
sof committed
155
    let
156
157
158
159
	lbl = case ext_name of
		Dynamic	     -> dynamicTarget
	        ExtName fs _ -> StaticTarget fs

160
161
	-- Build the worker
	worker_ty     = mkForAllTys tvs (mkFunTys (map idType work_arg_ids) ccall_result_ty)
162
163
	the_ccall     = CCall (CCallSpec lbl cconv safety False)
 	the_ccall_app = mkFCall ccall_uniq the_ccall val_args ccall_result_ty
164
	work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)
165
	work_id       = mkSysLocal SLIT("$wccall") work_uniq worker_ty
166
167
168
169

	-- Build the wrapper
	work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args
	wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
170
        wrap_rhs     = mkInlineMe (mkLams (tvs ++ args) wrapper_body)
sof's avatar
sof committed
171
    in
172
    returnDs [(work_id, work_rhs), (fn_id, wrap_rhs)]
173
174
\end{code}

175
Foreign labels 
sof's avatar
sof committed
176
177

\begin{code}
178
dsFLabel :: Id -> Type -> ExtName -> DsM Binding
179
180
dsFLabel nm ty ext_name = 
   ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this
181
   returnDs (nm, fo_rhs (mkLit (MachLabel enm)))
sof's avatar
sof committed
182
  where
183
   (res_ty, fo_rhs) = resultWrapper ty
184
   enm    = extNameStatic ext_name
sof's avatar
sof committed
185
186
\end{code}

187
188
The function that does most of the work for `@foreign export@' declarations.
(see below for the boilerplate code a `@foreign export@' declaration expands
189
 into.)
sof's avatar
sof committed
190

191
192
193
194
195
196
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@'.
197

sof's avatar
sof committed
198
199
200
\begin{code}
dsFExport :: Id
	  -> Type		-- Type of foreign export.
sof's avatar
sof committed
201
	  -> Module
sof's avatar
sof committed
202
	  -> ExtName
203
	  -> CCallConv
sof's avatar
sof committed
204
205
	  -> Bool		-- True => invoke IO action that's hanging off 
				-- the first argument's stable pointer
206
207
	  -> DsM ( Id		-- The foreign-exported Id
		 , Binding
208
209
210
		 , SDoc
		 , SDoc
		 )
211
dsFExport fn_id ty mod_name ext_name cconv isDyn
212
213
214
215
216
217
  = 	-- BUILD THE returnIO WRAPPER, if necessary
	-- Look at the result type of the exported function, orig_res_ty
	-- If it's IO t, return		(\x.x,	        IO t, t)
	-- If it's plain t, return	(\x.returnIO x, IO t, t)
     (case splitTyConApp_maybe orig_res_ty of
	Just (ioTyCon, [res_ty])
218
	      -> ASSERT( ioTyCon `hasKey` ioTyConKey )
219
220
221
222
			-- 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
223
		 dsLookupGlobalValue returnIOName	`thenDs` \ retIOId ->
224
225
226
227
228
229
230
231
232
233
234
	         returnDs (\body -> mkApps (Var retIOId) [Type orig_res_ty, body],
		           funResultTy (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
sof's avatar
sof committed
235
236
     (if isDyn then 
        newSysLocalDs stbl_ptr_ty			`thenDs` \ stbl_ptr ->
237
	newSysLocalDs stbl_ptr_to_ty			`thenDs` \ stbl_value ->
238
239
	dsLookupGlobalValue deRefStablePtrName		`thenDs` \ deRefStablePtrId ->
        dsLookupGlobalValue bindIOName			`thenDs` \ bindIOId ->
sof's avatar
sof committed
240
	let
241
242
	 the_deref_app = mkApps (Var deRefStablePtrId)
				[ Type stbl_ptr_to_ty, Var stbl_ptr ]
243

244
245
246
247
248
	 stbl_app cont = mkApps (Var bindIOId)
				[ Type stbl_ptr_to_ty
				, Type res_ty
				, the_deref_app
				, mkLams [stbl_value] cont]
249
250
        in
	returnDs (stbl_value, stbl_app, stbl_ptr)
sof's avatar
sof committed
251
      else
252
        returnDs (fn_id, 
sof's avatar
sof committed
253
254
	          \ body -> body,
		  panic "stbl_ptr"  -- should never be touched.
255
		  ))			`thenDs` \ (i, getFun_wrapper, stbl_ptr) ->
sof's avatar
sof committed
256
257


258
	-- BUILD THE HELPER
259
     getModuleDs			`thenDs` \ mod -> 
260
     getUniqueDs			`thenDs` \ uniq ->
261
262
     getSrcLocDs			`thenDs` \ src_loc ->
     newSysLocalsDs fe_arg_tys		`thenDs` \ fe_args ->
sof's avatar
sof committed
263
     let
264
265
        wrapper_args | isDyn      = stbl_ptr:fe_args
		     | otherwise  = fe_args
sof's avatar
sof committed
266

267
268
269
270
271
272
        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

273
	f_helper_glob = mkVanillaGlobal helper_name helper_ty vanillaIdInfo
274
		      where
275
			name	            = idName fn_id
276
277
278
279
280
			mod	
			 | isLocalName name = mod_name
			 | otherwise        = nameModule name

			occ	            = mkForeignExportOcc (nameOccName name)
281
			helper_name         = mkGlobalName uniq mod occ src_loc
282
283
284
285
286
287

      	the_app = getFun_wrapper (return_io_wrapper (mkVarApps (Var i) (tvs ++ fe_args)))
      	the_body = mkLams (tvs ++ wrapper_args) the_app
      	c_nm     = extNameStatic ext_name
  
      	(h_stub, c_stub) = fexportEntry (moduleUserString mod)
sof's avatar
sof committed
288
      				      c_nm f_helper_glob
289
                                      wrapper_arg_tys res_ty cconv isDyn
sof's avatar
sof committed
290
     in
291
     returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub)
292

sof's avatar
sof committed
293
  where
294
   (tvs,sans_foralls)			= splitForAllTys ty
295
   (fe_arg_tys', orig_res_ty)	        = splitFunTys sans_foralls
sof's avatar
sof committed
296
297
298
299

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

300
301
302
303
304
   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"
sof's avatar
sof committed
305
306
\end{code}

307
@foreign export dynamic@ lets you dress up Haskell IO actions
sof's avatar
sof committed
308
309
310
311
of some fixed type behind an externally callable interface (i.e.,
as a C function pointer). Useful for callbacks and stuff.

\begin{verbatim}
312
foreign export dynamic f :: (Addr -> Int -> IO Int) -> IO Addr
sof's avatar
sof committed
313

314
315
-- Haskell-visible constructor, which is generated from the above:
-- SUP: No check for NULL from createAdjustor anymore???
sof's avatar
sof committed
316
317

f :: (Addr -> Int -> IO Int) -> IO Addr
318
f cback =
319
   bindIO (newStablePtr cback)
320
321
322
          (\StablePtr sp# -> IO (\s1# ->
              case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of
                 (# s2#, a# #) -> (# s2#, A# a# #)))
sof's avatar
sof committed
323
324
325
326
327
328
329
330
331

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
332
		 -> Module
sof's avatar
sof committed
333
		 -> ExtName
334
		 -> CCallConv
335
		 -> DsM (Id, [Binding], SDoc, SDoc)
sof's avatar
sof committed
336
dsFExportDynamic i ty mod_name ext_name cconv =
sof's avatar
sof committed
337
338
339
     newSysLocalDs ty					 `thenDs` \ fe_id ->
     let 
        -- hack: need to get at the name of the C stub we're about to generate.
340
       fe_nm	   = moduleUserString mod_name ++ "_" ++ toCName fe_id
sof's avatar
sof committed
341
342
       fe_ext_name = ExtName (_PK_ fe_nm) Nothing
     in
343
     dsFExport  i export_ty mod_name fe_ext_name cconv True
344
     	`thenDs` \ (feb, fe, h_code, c_code) ->
345
     newSysLocalDs arg_ty			`thenDs` \ cback ->
346
     dsLookupGlobalValue newStablePtrName	`thenDs` \ newStablePtrId ->
sof's avatar
sof committed
347
     let
348
	mk_stbl_ptr_app    = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
sof's avatar
sof committed
349
     in
350
     dsLookupGlobalValue bindIOName		        `thenDs` \ bindIOId ->
351
     newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value ->
sof's avatar
sof committed
352
     let
353
354
355
356
357
358
359
      stbl_app cont ret_ty 
	= mkApps (Var bindIOId)
		 [ Type (mkTyConApp stablePtrTyCon [arg_ty])
		 , Type ret_ty
		 , mk_stbl_ptr_app
		 , cont
		 ]
360
361
362
363
364
365
366
367

       {-
        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).
       -}
368
      adj_args      = [ mkIntLitInt (ccallConvToInt cconv)
369
		      , Var stbl_value
370
		      , mkLit (MachLabel (_PK_ fe_nm))
371
372
373
374
375
		      ]
        -- name of external entry point providing these services.
	-- (probably in the RTS.) 
      adjustor	    = SLIT("createAdjustor")
     in
376
377
     dsCCall adjustor adj_args PlayRisky False io_res_ty	`thenDs` \ ccall_adj ->
	-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
378
     let ccall_adj_ty = exprType ccall_adj
379
         ccall_io_adj = mkLams [stbl_value]		     $
380
			Note (Coerce io_res_ty ccall_adj_ty)
381
			     ccall_adj
382
         io_app = mkLams tvs	 $
383
		  mkLams [cback] $
384
		  stbl_app ccall_io_adj res_ty
385
386
387
	 fed = (i `setInlinePragma` neverInlinePrag, io_app)
		-- Never inline the f.e.d. function, because the litlit
		-- might not be in scope in other modules.
388
     in
389
     returnDs (feb, [fed, fe], h_code, c_code)
390

sof's avatar
sof committed
391
392
 where
  (tvs,sans_foralls)		   = splitForAllTys ty
393
394
  ([arg_ty], io_res_ty)		   = splitFunTys sans_foralls
  Just (ioTyCon, [res_ty])	   = splitTyConApp_maybe io_res_ty
sof's avatar
sof committed
395
396
397
398
399
400
401
402
403
404
405
406
  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}
%
%*

407
408
409
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
410
411

\begin{code}
sof's avatar
sof committed
412
413
fexportEntry :: String
	     -> FAST_STRING
sof's avatar
sof committed
414
415
	     -> Id 
	     -> [Type] 
416
	     -> Type 
417
	     -> CCallConv 
sof's avatar
sof committed
418
419
	     -> Bool
	     -> (SDoc, SDoc)
420
fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits)
sof's avatar
sof committed
421
422
 where
   -- name of the (Haskell) helper function generated by the desugarer.
423
424
425
  h_nm	    = ppr helper <> text "_closure"
   -- prototype for the exported function.
  header_bits = ptext SLIT("extern") <+> fun_proto <> semi
sof's avatar
sof committed
426

427
  fun_proto = cResType <+> pprCconv <+> ptext c_nm <>
sof's avatar
sof committed
428
	      parens (hsep (punctuate comma (zipWith (<+>) cParamTypes proto_args)))
sof's avatar
sof committed
429

430
431
432
  c_bits =
    externDecl $$
    fun_proto  $$
sof's avatar
sof committed
433
    vcat 
434
435
436
437
438
439
     [ 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
440
     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ptext c_nm)
441
442
						<> comma <> text "rc") <> semi
     ,   text "return" <> return_what <> semi
443
444
     , rbrace
     ]
sof's avatar
sof committed
445

446
447
  appArg acc (a,c_a) =
     text "rts_apply" <> parens (acc <> comma <> mkHObj a <> parens c_a)
sof's avatar
sof committed
448

sof's avatar
sof committed
449
  cParamTypes  = map showStgType real_args
sof's avatar
sof committed
450

451
452
453
454
  res_ty_is_unit = res_ty == unitTy

  cResType | res_ty_is_unit = text "void"
	   | otherwise	    = showStgType res_ty
sof's avatar
sof committed
455

456
457
458
  pprCconv = case cc of
		CCallConv   -> empty
		StdCallConv -> ppr cc
sof's avatar
sof committed
459
     
460
  declareResult  = text "HaskellObj ret;"
sof's avatar
sof committed
461

462
  externDecl     = mkExtern (text "HaskellObj") h_nm
sof's avatar
sof committed
463

464
  mkExtern ty nm = text "extern" <+> ty <+> nm <> semi
sof's avatar
sof committed
465

466
467
  return_what | res_ty_is_unit = empty
	      | otherwise      = parens (unpackHObj res_ty <> parens (text "ret"))
sof's avatar
sof committed
468

sof's avatar
sof committed
469
470
471
472
473
474
475
476
477
478
  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)
479
480
481
482
    = case cc of
	CCallConv | isDyn -> ( text "a0" : text "a_" : mkCArgNames 1 (tail args)
			     , head args : addrTy : tail args)
        other		  -> (mkCArgNames 0 args, args)
sof's avatar
sof committed
483

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

487
mkHObj :: Type -> SDoc
sof's avatar
sof committed
488
mkHObj t = text "rts_mk" <> text (showFFIType t)
sof's avatar
sof committed
489

490
unpackHObj :: Type -> SDoc
sof's avatar
sof committed
491
unpackHObj t = text "rts_get" <> text (showFFIType t)
492
493

showStgType :: Type -> SDoc
494
showStgType t = text "Hs" <> text (showFFIType t)
sof's avatar
sof committed
495

sof's avatar
sof committed
496
showFFIType :: Type -> String
497
498
499
500
501
showFFIType t = getOccString (getName tc)
 where
  tc = case splitTyConApp_maybe (repType t) of
	    Just (tc,_) -> tc
	    Nothing	-> pprPanic "showFFIType" (ppr t)
502
\end{code}