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

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

import Maybe 		( fromJust )
sof's avatar
sof committed
46
47
48
49
\end{code}

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

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

sof's avatar
sof committed
65
66
dsForeigns :: Module
           -> [TypecheckedForeignDecl] 
67
68
69
	   -> DsM ( [Id]		-- Foreign-exported binders; 
					-- we have to generate code to register these
		  , [Binding]
70
71
72
73
		  , SDoc	      -- Header file prototypes for
                                      -- "foreign exported" functions.
		  , SDoc 	      -- C stubs to use when calling
                                      -- "foreign exported" functions.
sof's avatar
sof committed
74
		  )
75
dsForeigns mod_name fos = foldlDs combine ([], [], empty, empty) fos
sof's avatar
sof committed
76
 where
77
  combine (acc_feb, acc_f, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _) 
78
    | isForeignImport =   -- foreign import (dynamic)?
79
        dsFImport i (idType i) uns ext_nm cconv  `thenDs` \ bs -> 
80
	returnDs (acc_feb, bs ++ acc_f, acc_h, acc_c)
sof's avatar
sof committed
81
    | isForeignLabel = 
82
        dsFLabel i (idType i) ext_nm `thenDs` \ b -> 
83
	returnDs (acc_feb, b:acc_f, acc_h, acc_c)
84
    | isDynamicExtName ext_nm =
85
86
        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
87

88
    | otherwise	       =  -- foreign export
89
90
        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
91
   where
sof's avatar
sof committed
92
93
94
95
96
97
98
99
100
101
102
    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
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
108
(using the @CCallOp@ primop), before boxing the result up and returning it.
sof's avatar
sof committed
109

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

140
141
142
143
144
145
146
147
148
149
150
151
152
    let
	work_arg_ids  = [v | Var v <- val_args]	-- All guaranteed to be vars

	-- these are the ids we pass to boxResult, which are used to decide
	-- whether to touch# an argument after the call (used to keep
	-- ForeignObj#s live across a 'safe' foreign import).
	maybe_arg_ids | unsafe    = []
		      | otherwise = work_arg_ids
    in
    boxResult work_arg_ids io_res_ty   		`thenDs` \ (ccall_result_ty, res_wrapper) ->

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

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

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

173
Foreign labels 
sof's avatar
sof committed
174
175

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

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

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

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

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


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

265
266
267
268
269
270
        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

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

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

      	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
286
      				      c_nm f_helper_glob
287
                                      wrapper_arg_tys res_ty cconv isDyn
sof's avatar
sof committed
288
     in
289
     returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub)
290

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

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

298
299
300
301
302
   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
303
304
\end{code}

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

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

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

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

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

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

sof's avatar
sof committed
389
390
 where
  (tvs,sans_foralls)		   = splitForAllTys ty
391
  ([arg_ty], io_res_ty)		   = splitFunTys sans_foralls
sof's avatar
sof committed
392

393
  Just (ioTyCon, [res_ty])	   = splitTyConApp_maybe io_res_ty
sof's avatar
sof committed
394
395
396

  export_ty			   = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty

397
398
399
  ioAddrTy :: Type	-- IO Addr
  ioAddrTy = mkTyConApp ioTyCon [addrTy]

sof's avatar
sof committed
400
401
402
403
404
405
406
407
408
409
toCName :: Id -> String
toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
\end{code}

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

410
411
412
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
413
414

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

430
  fun_proto = cResType <+> pprCconv <+> ptext c_nm <>
sof's avatar
sof committed
431
	      parens (hsep (punctuate comma (zipWith (<+>) cParamTypes proto_args)))
sof's avatar
sof committed
432

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

449
450
  appArg acc (a,c_a) =
     text "rts_apply" <> parens (acc <> comma <> mkHObj a <> parens c_a)
sof's avatar
sof committed
451

sof's avatar
sof committed
452
  cParamTypes  = map showStgType real_args
sof's avatar
sof committed
453

454
455
456
457
  res_ty_is_unit = res_ty == unitTy

  cResType | res_ty_is_unit = text "void"
	   | otherwise	    = showStgType res_ty
sof's avatar
sof committed
458
459
460
461
462

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

465
  externDecl     = mkExtern (text "HaskellObj") h_nm
sof's avatar
sof committed
466

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

469
470
  return_what | res_ty_is_unit = empty
	      | otherwise      = parens (unpackHObj res_ty <> parens (text "ret"))
sof's avatar
sof committed
471

sof's avatar
sof committed
472
473
474
475
476
477
478
479
480
481
482
483
484
485
  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
486
487
mkCArgNames :: Int -> [a] -> [SDoc]
mkCArgNames n as = zipWith (\ _ n -> text ('a':show n)) as [n..] 
sof's avatar
sof committed
488

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

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

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

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