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, 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, mkId, mkSysLocal,
24
			  setInlinePragma )
25
26
import IdInfo		( neverInlinePrag, vanillaIdInfo, IdFlavour(..),
			  setFlavourInfo )
27
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
			  NamedThing(..),
32
			)
33
34
import Type		( repType, splitTyConApp_maybe,
			  tyConAppTyCon, splitFunTys, splitForAllTys,
35
			  Type, mkFunTys, mkForAllTys, mkTyConApp,
36
			  mkFunTy, splitAppTy, applyTy, funResultTy
sof's avatar
sof committed
37
			)
38
39
import PrimOp		( CCall(..), CCallTarget(..), dynamicTarget )
import TysWiredIn	( unitTy, addrTy, stablePtrTyCon )
40
import TysPrim		( addrPrimTy )
41
42
import PrelNames	( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName,
			  bindIOName, returnIOName
43
			)
sof's avatar
sof committed
44
import Outputable
45
46

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

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

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

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

89
    | otherwise	       =  -- foreign export
90
91
        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
92
   where
sof's avatar
sof committed
93
94
95
96
97
98
99
100
101
102
103
    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
104
105
106
107
108

\end{code}

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

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

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

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

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

165
Foreign labels 
sof's avatar
sof committed
166
167

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

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

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

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

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


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

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

263
264
	f_helper_glob = mkId helper_name helper_ty
				(vanillaIdInfo `setFlavourInfo` ExportedId)
265
		      where
266
			name	            = idName fn_id
267
268
269
270
271
			mod	
			 | isLocalName name = mod_name
			 | otherwise        = nameModule name

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

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

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

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

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

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

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

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

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

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

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

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

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

  export_ty			   = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty

390
391
392
  ioAddrTy :: Type	-- IO Addr
  ioAddrTy = mkTyConApp ioTyCon [addrTy]

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

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

403
404
405
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
406
407

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

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

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

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

sof's avatar
sof committed
445
  cParamTypes  = map showStgType real_args
sof's avatar
sof committed
446

447
448
449
450
  res_ty_is_unit = res_ty == unitTy

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

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

458
  externDecl     = mkExtern (text "HaskellObj") h_nm
sof's avatar
sof committed
459

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

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

sof's avatar
sof committed
465
466
467
468
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)
    | 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
479
480
mkCArgNames :: Int -> [a] -> [SDoc]
mkCArgNames n as = zipWith (\ _ n -> text ('a':show n)) as [n..] 
sof's avatar
sof committed
481

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

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

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

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