DsForeign.lhs 15.9 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
128
129
130
\begin{code}
dsFImport :: Id
	  -> Type		-- Type of foreign import.
	  -> Bool		-- True <=> might cause Haskell GC
	  -> ExtName
	  -> CallConv
131
	  -> DsM [Binding]
132
133
dsFImport fn_id ty may_not_gc ext_name cconv 
  = 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
139
    mapAndUnzipDs unboxArg (map Var args)	`thenDs` \ (val_args, arg_wrappers) ->
    boxResult io_res_ty				`thenDs` \ (ccall_result_ty, res_wrapper) ->
140
141
142

    getUniqueDs						`thenDs` \ ccall_uniq ->
    getUniqueDs						`thenDs` \ work_uniq ->
sof's avatar
sof committed
143
    let
144
145
146
147
	lbl = case ext_name of
		Dynamic	     -> dynamicTarget
	        ExtName fs _ -> StaticTarget fs

148
149
150
151
152
153
	-- Build the worker
	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)
154
	work_id       = mkSysLocal SLIT("$wccall") work_uniq worker_ty
155
156
157
158

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

164
Foreign labels 
sof's avatar
sof committed
165
166

\begin{code}
167
dsFLabel :: Id -> Type -> ExtName -> DsM Binding
168
169
dsFLabel nm ty ext_name = 
   ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this
170
   returnDs (nm, fo_rhs (mkLit (MachLabel enm)))
sof's avatar
sof committed
171
  where
172
   (res_ty, fo_rhs) = resultWrapper ty
173
   enm    = extNameStatic ext_name
sof's avatar
sof committed
174
175
\end{code}

176
177
The function that does most of the work for `@foreign export@' declarations.
(see below for the boilerplate code a `@foreign export@' declaration expands
178
 into.)
sof's avatar
sof committed
179

180
181
182
183
184
185
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@'.
186

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

233
234
235
236
237
	 stbl_app cont = mkApps (Var bindIOId)
				[ Type stbl_ptr_to_ty
				, Type res_ty
				, the_deref_app
				, mkLams [stbl_value] cont]
238
239
        in
	returnDs (stbl_value, stbl_app, stbl_ptr)
sof's avatar
sof committed
240
      else
241
        returnDs (fn_id, 
sof's avatar
sof committed
242
243
	          \ body -> body,
		  panic "stbl_ptr"  -- should never be touched.
244
		  ))			`thenDs` \ (i, getFun_wrapper, stbl_ptr) ->
sof's avatar
sof committed
245
246


247
	-- BUILD THE HELPER
248
     getModuleDs			`thenDs` \ mod -> 
249
     getUniqueDs			`thenDs` \ uniq ->
250
251
     getSrcLocDs			`thenDs` \ src_loc ->
     newSysLocalsDs fe_arg_tys		`thenDs` \ fe_args ->
sof's avatar
sof committed
252
     let
253
254
        wrapper_args | isDyn      = stbl_ptr:fe_args
		     | otherwise  = fe_args
sof's avatar
sof committed
255

256
257
258
259
260
261
        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

262
	f_helper_glob = mkVanillaGlobal helper_name helper_ty vanillaIdInfo
263
		      where
264
			name	            = idName fn_id
265
266
267
268
269
			mod	
			 | isLocalName name = mod_name
			 | otherwise        = nameModule name

			occ	            = mkForeignExportOcc (nameOccName name)
270
			helper_name         = mkGlobalName uniq mod occ src_loc
271
272
273
274
275
276

      	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
277
      				      c_nm f_helper_glob
278
                                      wrapper_arg_tys res_ty cconv isDyn
sof's avatar
sof committed
279
     in
280
     returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub)
281

sof's avatar
sof committed
282
  where
283
   (tvs,sans_foralls)			= splitForAllTys ty
284
   (fe_arg_tys', orig_res_ty)	        = splitFunTys sans_foralls
sof's avatar
sof committed
285
286
287
288

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

289
290
291
292
293
   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
294
295
\end{code}

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

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

303
304
-- Haskell-visible constructor, which is generated from the above:
-- SUP: No check for NULL from createAdjustor anymore???
sof's avatar
sof committed
305
306

f :: (Addr -> Int -> IO Int) -> IO Addr
307
f cback =
308
   bindIO (newStablePtr cback)
309
310
311
          (\StablePtr sp# -> IO (\s1# ->
              case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of
                 (# s2#, a# #) -> (# s2#, A# a# #)))
sof's avatar
sof committed
312
313
314
315
316
317
318
319
320

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

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

sof's avatar
sof committed
380
381
 where
  (tvs,sans_foralls)		   = splitForAllTys ty
382
  ([arg_ty], io_res_ty)		   = splitFunTys sans_foralls
sof's avatar
sof committed
383

384
  Just (ioTyCon, [res_ty])	   = splitTyConApp_maybe io_res_ty
sof's avatar
sof committed
385
386
387

  export_ty			   = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty

388
389
390
  ioAddrTy :: Type	-- IO Addr
  ioAddrTy = mkTyConApp ioTyCon [addrTy]

sof's avatar
sof committed
391
392
393
394
395
396
397
398
399
400
toCName :: Id -> String
toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
\end{code}

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

401
402
403
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
404
405

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

421
  fun_proto = cResType <+> pprCconv <+> ptext c_nm <>
sof's avatar
sof committed
422
	      parens (hsep (punctuate comma (zipWith (<+>) cParamTypes proto_args)))
sof's avatar
sof committed
423

424
425
426
  c_bits =
    externDecl $$
    fun_proto  $$
sof's avatar
sof committed
427
    vcat 
428
429
430
431
432
433
     [ 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
434
     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ptext c_nm)
435
436
						<> comma <> text "rc") <> semi
     ,   text "return" <> return_what <> semi
437
438
     , rbrace
     ]
sof's avatar
sof committed
439

440
441
  appArg acc (a,c_a) =
     text "rts_apply" <> parens (acc <> comma <> mkHObj a <> parens c_a)
sof's avatar
sof committed
442

sof's avatar
sof committed
443
  cParamTypes  = map showStgType real_args
sof's avatar
sof committed
444

445
446
447
448
  res_ty_is_unit = res_ty == unitTy

  cResType | res_ty_is_unit = text "void"
	   | otherwise	    = showStgType res_ty
sof's avatar
sof committed
449
450
451
452
453

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

456
  externDecl     = mkExtern (text "HaskellObj") h_nm
sof's avatar
sof committed
457

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

460
461
  return_what | res_ty_is_unit = empty
	      | otherwise      = parens (unpackHObj res_ty <> parens (text "ret"))
sof's avatar
sof committed
462

sof's avatar
sof committed
463
464
465
466
467
468
469
470
471
472
473
474
475
476
  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
477
478
mkCArgNames :: Int -> [a] -> [SDoc]
mkCArgNames n as = zipWith (\ _ n -> text ('a':show n)) as [n..] 
sof's avatar
sof committed
479

480
mkHObj :: Type -> SDoc
sof's avatar
sof committed
481
mkHObj t = text "rts_mk" <> text (showFFIType t)
sof's avatar
sof committed
482

483
unpackHObj :: Type -> SDoc
sof's avatar
sof committed
484
unpackHObj t = text "rts_get" <> text (showFFIType t)
485
486

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

sof's avatar
sof committed
489
showFFIType :: Type -> String
490
491
492
493
494
showFFIType t = getOccString (getName tc)
 where
  tc = case splitTyConApp_maybe (repType t) of
	    Just (tc,_) -> tc
	    Nothing	-> pprPanic "showFFIType" (ppr t)
495
\end{code}