never executed always true always false
1
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE TypeFamilies #-}
4
5 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
6
7 {-
8 (c) The University of Glasgow 2006
9 (c) The AQUA Project, Glasgow University, 1998
10
11
12 Desugaring foreign declarations (see also GHC.HsToCore.Foreign.Call).
13 -}
14
15 module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where
16
17 import GHC.Prelude
18
19 import GHC.Tc.Utils.Monad -- temp
20
21 import GHC.Core
22
23 import GHC.HsToCore.Foreign.Call
24 import GHC.HsToCore.Monad
25 import GHC.HsToCore.Types (ds_next_wrapper_num)
26
27 import GHC.Hs
28 import GHC.Core.DataCon
29 import GHC.Core.Unfold.Make
30 import GHC.Types.Id
31 import GHC.Types.Literal
32 import GHC.Types.ForeignStubs
33 import GHC.Types.SourceText
34 import GHC.Unit.Module
35 import GHC.Types.Name
36 import GHC.Core.Type
37 import GHC.Types.RepType
38 import GHC.Core.TyCon
39 import GHC.Core.Coercion
40 import GHC.Core.Multiplicity
41 import GHC.Tc.Utils.Env
42 import GHC.Tc.Utils.TcType
43
44 import GHC.Cmm.Expr
45 import GHC.Cmm.Utils
46 import GHC.Driver.Ppr
47 import GHC.Types.ForeignCall
48 import GHC.Builtin.Types
49 import GHC.Builtin.Types.Prim
50 import GHC.Builtin.Names
51 import GHC.Types.Basic
52 import GHC.Types.SrcLoc
53 import GHC.Utils.Outputable
54 import GHC.Data.FastString
55 import GHC.Driver.Session
56 import GHC.Driver.Config
57 import GHC.Platform
58 import GHC.Data.OrdList
59 import GHC.Utils.Panic
60 import GHC.Utils.Panic.Plain
61 import GHC.Driver.Hooks
62 import GHC.Utils.Encoding
63
64 import Data.Maybe
65 import Data.List (unzip4, nub)
66
67 {-
68 Desugaring of @foreign@ declarations is naturally split up into
69 parts, an @import@ and an @export@ part. A @foreign import@
70 declaration
71 \begin{verbatim}
72 foreign import cc nm f :: prim_args -> IO prim_res
73 \end{verbatim}
74 is the same as
75 \begin{verbatim}
76 f :: prim_args -> IO prim_res
77 f a1 ... an = _ccall_ nm cc a1 ... an
78 \end{verbatim}
79 so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with these.
80 -}
81
82 type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
83 -- the occurrence analyser will sort it all out
84
85 dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)
86 dsForeigns fos = do
87 hooks <- getHooks
88 case dsForeignsHook hooks of
89 Nothing -> dsForeigns' fos
90 Just h -> h fos
91
92 dsForeigns' :: [LForeignDecl GhcTc]
93 -> DsM (ForeignStubs, OrdList Binding)
94 dsForeigns' []
95 = return (NoStubs, nilOL)
96 dsForeigns' fos = do
97 mod <- getModule
98 fives <- mapM do_ldecl fos
99 let
100 (hs, cs, idss, bindss) = unzip4 fives
101 fe_ids = concat idss
102 fe_init_code = foreignExportsInitialiser mod fe_ids
103 --
104 return (ForeignStubs
105 (mconcat hs)
106 (mconcat cs `mappend` fe_init_code),
107 foldr (appOL . toOL) nilOL bindss)
108 where
109 do_ldecl (L loc decl) = putSrcSpanDs (locA loc) (do_decl decl)
110
111 do_decl :: ForeignDecl GhcTc -> DsM (CHeader, CStub, [Id], [Binding])
112 do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do
113 traceIf (text "fi start" <+> ppr id)
114 let id' = unLoc id
115 (bs, h, c) <- dsFImport id' co spec
116 traceIf (text "fi end" <+> ppr id)
117 return (h, c, [], bs)
118
119 do_decl (ForeignExport { fd_name = L _ id
120 , fd_e_ext = co
121 , fd_fe = CExport
122 (L _ (CExportStatic _ ext_nm cconv)) _ }) = do
123 (h, c, _, _) <- dsFExport id co ext_nm cconv False
124 return (h, c, [id], [])
125
126 {-
127 ************************************************************************
128 * *
129 \subsection{Foreign import}
130 * *
131 ************************************************************************
132
133 Desugaring foreign imports is just the matter of creating a binding
134 that on its RHS unboxes its arguments, performs the external call
135 (using the @CCallOp@ primop), before boxing the result up and returning it.
136
137 However, we create a worker/wrapper pair, thus:
138
139 foreign import f :: Int -> IO Int
140 ==>
141 f x = IO ( \s -> case x of { I# x# ->
142 case fw s x# of { (# s1, y# #) ->
143 (# s1, I# y# #)}})
144
145 fw s x# = ccall f s x#
146
147 The strictness/CPR analyser won't do this automatically because it doesn't look
148 inside returned tuples; but inlining this wrapper is a Really Good Idea
149 because it exposes the boxing to the call site.
150 -}
151
152 dsFImport :: Id
153 -> Coercion
154 -> ForeignImport
155 -> DsM ([Binding], CHeader, CStub)
156 dsFImport id co (CImport cconv safety mHeader spec _) =
157 dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader
158
159 dsCImport :: Id
160 -> Coercion
161 -> CImportSpec
162 -> CCallConv
163 -> Safety
164 -> Maybe Header
165 -> DsM ([Binding], CHeader, CStub)
166 dsCImport id co (CLabel cid) cconv _ _ = do
167 dflags <- getDynFlags
168 let ty = coercionLKind co
169 platform = targetPlatform dflags
170 fod = case tyConAppTyCon_maybe (dropForAlls ty) of
171 Just tycon
172 | tyConUnique tycon == funPtrTyConKey ->
173 IsFunction
174 _ -> IsData
175 (resTy, foRhs) <- resultWrapper ty
176 assert (fromJust resTy `eqType` addrPrimTy) $ -- typechecker ensures this
177 let
178 rhs = foRhs (Lit (LitLabel cid stdcall_info fod))
179 rhs' = Cast rhs co
180 stdcall_info = fun_type_arg_stdcall_info platform cconv ty
181 in
182 return ([(id, rhs')], mempty, mempty)
183
184 dsCImport id co (CFunction target) cconv@PrimCallConv safety _
185 = dsPrimCall id co (CCall (CCallSpec target cconv safety))
186 dsCImport id co (CFunction target) cconv safety mHeader
187 = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader
188 dsCImport id co CWrapper cconv _ _
189 = dsFExportDynamic id co cconv
190
191 -- For stdcall labels, if the type was a FunPtr or newtype thereof,
192 -- then we need to calculate the size of the arguments in order to add
193 -- the @n suffix to the label.
194 fun_type_arg_stdcall_info :: Platform -> CCallConv -> Type -> Maybe Int
195 fun_type_arg_stdcall_info platform StdCallConv ty
196 | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,
197 tyConUnique tc == funPtrTyConKey
198 = let
199 (bndrs, _) = tcSplitPiTys arg_ty
200 fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs
201 in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys)
202 fun_type_arg_stdcall_info _ _other_conv _
203 = Nothing
204
205 {-
206 ************************************************************************
207 * *
208 \subsection{Foreign calls}
209 * *
210 ************************************************************************
211 -}
212
213 dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header
214 -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
215 dsFCall fn_id co fcall mDeclHeader = do
216 let
217 ty = coercionLKind co
218 (tv_bndrs, rho) = tcSplitForAllTyVarBinders ty
219 (arg_tys, io_res_ty) = tcSplitFunTys rho
220
221 args <- newSysLocalsDs arg_tys -- no FFI representation polymorphism
222 (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)
223
224 let
225 work_arg_ids = [v | Var v <- val_args] -- All guaranteed to be vars
226
227 (ccall_result_ty, res_wrapper) <- boxResult io_res_ty
228
229 ccall_uniq <- newUnique
230 work_uniq <- newUnique
231
232 (fcall', cDoc) <-
233 case fcall of
234 CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)
235 CApiConv safety) ->
236 do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv
237 wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName)
238 let fcall' = CCall (CCallSpec
239 (StaticTarget NoSourceText
240 wrapperName mUnitId
241 True)
242 CApiConv safety)
243 c = includes
244 $$ fun_proto <+> braces (cRet <> semi)
245 includes = vcat [ text "#include \"" <> ftext h
246 <> text "\""
247 | Header _ h <- nub headers ]
248 fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes
249 cRet
250 | isVoidRes = cCall
251 | otherwise = text "return" <+> cCall
252 cCall = if isFun
253 then ppr cName <> parens argVals
254 else if null arg_tys
255 then ppr cName
256 else panic "dsFCall: Unexpected arguments to FFI value import"
257 raw_res_ty = case tcSplitIOType_maybe io_res_ty of
258 Just (_ioTyCon, res_ty) -> res_ty
259 Nothing -> io_res_ty
260 isVoidRes = raw_res_ty `eqType` unitTy
261 (mHeader, cResType)
262 | isVoidRes = (Nothing, text "void")
263 | otherwise = toCType raw_res_ty
264 pprCconv = ccallConvAttribute CApiConv
265 mHeadersArgTypeList
266 = [ (header, cType <+> char 'a' <> int n)
267 | (t, n) <- zip arg_tys [1..]
268 , let (header, cType) = toCType (scaledThing t) ]
269 (mHeaders, argTypeList) = unzip mHeadersArgTypeList
270 argTypes = if null argTypeList
271 then text "void"
272 else hsep $ punctuate comma argTypeList
273 mHeaders' = mDeclHeader : mHeader : mHeaders
274 headers = catMaybes mHeaders'
275 argVals = hsep $ punctuate comma
276 [ char 'a' <> int n
277 | (_, n) <- zip arg_tys [1..] ]
278 return (fcall', c)
279 _ ->
280 return (fcall, empty)
281 dflags <- getDynFlags
282 let
283 -- Build the worker
284 worker_ty = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty)
285 tvs = map binderVar tv_bndrs
286 the_ccall_app = mkFCall dflags ccall_uniq fcall' val_args ccall_result_ty
287 work_rhs = mkLams tvs (mkLams work_arg_ids the_ccall_app)
288 work_id = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty
289
290 -- Build the wrapper
291 work_app = mkApps (mkVarApps (Var work_id) tvs) val_args
292 wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers
293 wrap_rhs = mkLams (tvs ++ args) wrapper_body
294 wrap_rhs' = Cast wrap_rhs co
295 simpl_opts = initSimpleOpts dflags
296 fn_id_w_inl = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity
297 (length args)
298 simpl_opts
299 wrap_rhs'
300
301 return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc)
302
303 {-
304 ************************************************************************
305 * *
306 \subsection{Primitive calls}
307 * *
308 ************************************************************************
309
310 This is for `@foreign import prim@' declarations.
311
312 Currently, at the core level we pretend that these primitive calls are
313 foreign calls. It may make more sense in future to have them as a distinct
314 kind of Id, or perhaps to bundle them with PrimOps since semantically and
315 for calling convention they are really prim ops.
316 -}
317
318 dsPrimCall :: Id -> Coercion -> ForeignCall
319 -> DsM ([(Id, Expr TyVar)], CHeader, CStub)
320 dsPrimCall fn_id co fcall = do
321 let
322 ty = coercionLKind co
323 (tvs, fun_ty) = tcSplitForAllInvisTyVars ty
324 (arg_tys, io_res_ty) = tcSplitFunTys fun_ty
325
326 args <- newSysLocalsDs arg_tys -- no FFI representation polymorphism
327
328 ccall_uniq <- newUnique
329 dflags <- getDynFlags
330 let
331 call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty
332 rhs = mkLams tvs (mkLams args call_app)
333 rhs' = Cast rhs co
334 return ([(fn_id, rhs')], mempty, mempty)
335
336 {-
337 ************************************************************************
338 * *
339 \subsection{Foreign export}
340 * *
341 ************************************************************************
342
343 The function that does most of the work for `@foreign export@' declarations.
344 (see below for the boilerplate code a `@foreign export@' declaration expands
345 into.)
346
347 For each `@foreign export foo@' in a module M we generate:
348 \begin{itemize}
349 \item a C function `@foo@', which calls
350 \item a Haskell stub `@M.\$ffoo@', which calls
351 \end{itemize}
352 the user-written Haskell function `@M.foo@'.
353 -}
354
355 dsFExport :: Id -- Either the exported Id,
356 -- or the foreign-export-dynamic constructor
357 -> Coercion -- Coercion between the Haskell type callable
358 -- from C, and its representation type
359 -> CLabelString -- The name to export to C land
360 -> CCallConv
361 -> Bool -- True => foreign export dynamic
362 -- so invoke IO action that's hanging off
363 -- the first argument's stable pointer
364 -> DsM ( CHeader -- contents of Module_stub.h
365 , CStub -- contents of Module_stub.c
366 , String -- string describing type to pass to createAdj.
367 , Int -- size of args to stub function
368 )
369
370 dsFExport fn_id co ext_name cconv isDyn = do
371 let
372 ty = coercionRKind co
373 (bndrs, orig_res_ty) = tcSplitPiTys ty
374 fe_arg_tys' = mapMaybe binderRelevantType_maybe bndrs
375 -- We must use tcSplits here, because we want to see
376 -- the (IO t) in the corner of the type!
377 fe_arg_tys | isDyn = tail fe_arg_tys'
378 | otherwise = fe_arg_tys'
379
380 -- Look at the result type of the exported function, orig_res_ty
381 -- If it's IO t, return (t, True)
382 -- If it's plain t, return (t, False)
383 (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of
384 -- The function already returns IO t
385 Just (_ioTyCon, res_ty) -> (res_ty, True)
386 -- The function returns t
387 Nothing -> (orig_res_ty, False)
388
389 dflags <- getDynFlags
390 return $
391 mkFExportCBits dflags ext_name
392 (if isDyn then Nothing else Just fn_id)
393 fe_arg_tys res_ty is_IO_res_ty cconv
394
395 {-
396 @foreign import "wrapper"@ (previously "foreign export dynamic") lets
397 you dress up Haskell IO actions of some fixed type behind an
398 externally callable interface (i.e., as a C function pointer). Useful
399 for callbacks and stuff.
400
401 \begin{verbatim}
402 type Fun = Bool -> Int -> IO Int
403 foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)
404
405 -- Haskell-visible constructor, which is generated from the above:
406 -- SUP: No check for NULL from createAdjustor anymore???
407
408 f :: Fun -> IO (FunPtr Fun)
409 f cback =
410 bindIO (newStablePtr cback)
411 (\StablePtr sp# -> IO (\s1# ->
412 case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of
413 (# s2#, a# #) -> (# s2#, A# a# #)))
414
415 foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)
416
417 -- and the helper in C: (approximately; see `mkFExportCBits` below)
418
419 f_helper(StablePtr s, HsBool b, HsInt i)
420 {
421 Capability *cap;
422 cap = rts_lock();
423 rts_inCall(&cap,
424 rts_apply(rts_apply(deRefStablePtr(s),
425 rts_mkBool(b)), rts_mkInt(i)));
426 rts_unlock(cap);
427 }
428 \end{verbatim}
429 -}
430
431 dsFExportDynamic :: Id
432 -> Coercion
433 -> CCallConv
434 -> DsM ([Binding], CHeader, CStub)
435 dsFExportDynamic id co0 cconv = do
436 mod <- getModule
437 dflags <- getDynFlags
438 let platform = targetPlatform dflags
439 let fe_nm = mkFastString $ zEncodeString
440 (moduleStableString mod ++ "$" ++ toCName dflags id)
441 -- Construct the label based on the passed id, don't use names
442 -- depending on Unique. See #13807 and Note [Unique Determinism].
443 cback <- newSysLocalDs arg_mult arg_ty
444 newStablePtrId <- dsLookupGlobalId newStablePtrName
445 stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName
446 let
447 stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]
448 export_ty = mkVisFunTyMany stable_ptr_ty arg_ty
449 bindIOId <- dsLookupGlobalId bindIOName
450 stbl_value <- newSysLocalDs Many stable_ptr_ty
451 (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True
452 let
453 {-
454 The arguments to the external function which will
455 create a little bit of (template) code on the fly
456 for allowing the (stable pointed) Haskell closure
457 to be entered using an external calling convention
458 (stdcall, ccall).
459 -}
460 adj_args = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv))
461 , Var stbl_value
462 , Lit (LitLabel fe_nm mb_sz_args IsFunction)
463 , Lit (mkLitString typestring)
464 ]
465 -- name of external entry point providing these services.
466 -- (probably in the RTS.)
467 adjustor = fsLit "createAdjustor"
468
469 -- Determine the number of bytes of arguments to the stub function,
470 -- so that we can attach the '@N' suffix to its label if it is a
471 -- stdcall on Windows.
472 mb_sz_args = case cconv of
473 StdCallConv -> Just args_size
474 _ -> Nothing
475
476 ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
477 -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
478
479 let io_app = mkLams tvs $
480 Lam cback $
481 mkApps (Var bindIOId)
482 [ Type stable_ptr_ty
483 , Type res_ty
484 , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]
485 , Lam stbl_value ccall_adj
486 ]
487
488 fed = (id `setInlineActivation` NeverActive, Cast io_app co0)
489 -- Never inline the f.e.d. function, because the litlit
490 -- might not be in scope in other modules.
491
492 return ([fed], h_code, c_code)
493
494 where
495 ty = coercionLKind co0
496 (tvs,sans_foralls) = tcSplitForAllInvisTyVars ty
497 ([Scaled arg_mult arg_ty], fn_res_ty) = tcSplitFunTys sans_foralls
498 Just (io_tc, res_ty) = tcSplitIOType_maybe fn_res_ty
499 -- Must have an IO type; hence Just
500
501
502 toCName :: DynFlags -> Id -> String
503 toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))
504
505 {-
506 *
507
508 \subsection{Generating @foreign export@ stubs}
509
510 *
511
512 For each @foreign export@ function, a C stub function is generated.
513 The C stub constructs the application of the exported Haskell function
514 using the hugs/ghc rts invocation API.
515 -}
516
517 mkFExportCBits :: DynFlags
518 -> FastString
519 -> Maybe Id -- Just==static, Nothing==dynamic
520 -> [Type]
521 -> Type
522 -> Bool -- True <=> returns an IO type
523 -> CCallConv
524 -> (CHeader,
525 CStub,
526 String, -- the argument reps
527 Int -- total size of arguments
528 )
529 mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
530 = (header_bits, c_bits, type_string,
531 sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args
532 -- NB. the calculation here isn't strictly speaking correct.
533 -- We have a primitive Haskell type (eg. Int#, Double#), and
534 -- we want to know the size, when passed on the C stack, of
535 -- the associated C type (eg. HsInt, HsDouble). We don't have
536 -- this information to hand, but we know what GHC's conventions
537 -- are for passing around the primitive Haskell types, so we
538 -- use that instead. I hope the two coincide --SDM
539 )
540 where
541 platform = targetPlatform dflags
542
543 -- list the arguments to the C function
544 arg_info :: [(SDoc, -- arg name
545 SDoc, -- C type
546 Type, -- Haskell type
547 CmmType)] -- the CmmType
548 arg_info = [ let stg_type = showStgType ty in
549 (arg_cname n stg_type,
550 stg_type,
551 ty,
552 typeCmmType platform (getPrimTyOf ty))
553 | (ty,n) <- zip arg_htys [1::Int ..] ]
554
555 arg_cname n stg_ty
556 | libffi = char '*' <> parens (stg_ty <> char '*') <>
557 text "args" <> brackets (int (n-1))
558 | otherwise = text ('a':show n)
559
560 -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled
561 libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target
562
563 type_string
564 -- libffi needs to know the result type too:
565 | libffi = primTyDescChar platform res_hty : arg_type_string
566 | otherwise = arg_type_string
567
568 arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info]
569 -- just the real args
570
571 -- add some auxiliary args; the stable ptr in the wrapper case, and
572 -- a slot for the dummy return address in the wrapper + ccall case
573 aug_arg_info
574 | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info
575 | otherwise = arg_info
576
577 stable_ptr_arg =
578 (text "the_stableptr", text "StgStablePtr", undefined,
579 typeCmmType platform (mkStablePtrPrimTy alphaTy))
580
581 -- stuff to do with the return type of the C function
582 res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes
583
584 cResType | res_hty_is_unit = text "void"
585 | otherwise = showStgType res_hty
586
587 -- when the return type is integral and word-sized or smaller, it
588 -- must be assigned as type ffi_arg (#3516). To see what type
589 -- libffi is expecting here, take a look in its own testsuite, e.g.
590 -- libffi/testsuite/libffi.call/cls_align_ulonglong.c
591 ffi_cResType
592 | is_ffi_arg_type = text "ffi_arg"
593 | otherwise = cResType
594 where
595 res_ty_key = getUnique (getName (typeTyCon res_hty))
596 is_ffi_arg_type = res_ty_key `notElem`
597 [floatTyConKey, doubleTyConKey,
598 int64TyConKey, word64TyConKey]
599
600 -- Now we can cook up the prototype for the exported function.
601 pprCconv = ccallConvAttribute cc
602
603 header_bits = CHeader (text "extern" <+> fun_proto <> semi)
604
605 fun_args
606 | null aug_arg_info = text "void"
607 | otherwise = hsep $ punctuate comma
608 $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info
609
610 fun_proto
611 | libffi
612 = text "void" <+> ftext c_nm <>
613 parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")
614 | otherwise
615 = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args
616
617 -- the target which will form the root of what we ask rts_inCall to run
618 the_cfun
619 = case maybe_target of
620 Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)"
621 Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"
622
623 cap = text "cap" <> comma
624
625 -- the expression we give to rts_inCall
626 expr_to_run
627 = foldl' appArg the_cfun arg_info -- NOT aug_arg_info
628 where
629 appArg acc (arg_cname, _, arg_hty, _)
630 = text "rts_apply"
631 <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))
632
633 -- various other bits for inside the fn
634 declareResult = text "HaskellObj ret;"
635 declareCResult | res_hty_is_unit = empty
636 | otherwise = cResType <+> text "cret;"
637
638 assignCResult | res_hty_is_unit = empty
639 | otherwise =
640 text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi
641
642 -- an extern decl for the fn being called
643 extern_decl
644 = case maybe_target of
645 Nothing -> empty
646 Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi
647
648
649 -- finally, the whole darn thing
650 c_bits = CStub $
651 space $$
652 extern_decl $$
653 fun_proto $$
654 vcat
655 [ lbrace
656 , text "Capability *cap;"
657 , declareResult
658 , declareCResult
659 , text "cap = rts_lock();"
660 -- create the application + perform it.
661 , text "rts_inCall" <> parens (
662 char '&' <> cap <>
663 text "rts_apply" <> parens (
664 cap <>
665 text "(HaskellObj)"
666 <> (if is_IO_res_ty
667 then text "runIO_closure"
668 else text "runNonIO_closure")
669 <> comma
670 <> expr_to_run
671 ) <+> comma
672 <> text "&ret"
673 ) <> semi
674 , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)
675 <> comma <> text "cap") <> semi
676 , assignCResult
677 , text "rts_unlock(cap);"
678 , ppUnless res_hty_is_unit $
679 if libffi
680 then char '*' <> parens (ffi_cResType <> char '*') <>
681 text "resp = cret;"
682 else text "return cret;"
683 , rbrace
684 ]
685
686
687 foreignExportsInitialiser :: Module -> [Id] -> CStub
688 foreignExportsInitialiser mod hs_fns =
689 -- Initialise foreign exports by registering a stable pointer from an
690 -- __attribute__((constructor)) function.
691 -- The alternative is to do this from stginit functions generated in
692 -- codeGen/CodeGen.hs; however, stginit functions have a negative impact
693 -- on binary sizes and link times because the static linker will think that
694 -- all modules that are imported directly or indirectly are actually used by
695 -- the program.
696 -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)
697 --
698 -- See Note [Tracking foreign exports] in rts/ForeignExports.c
699 CStub $ vcat
700 [ text "static struct ForeignExportsList" <+> list_symbol <+> equals
701 <+> braces (
702 text ".exports = " <+> export_list <> comma <+>
703 text ".n_entries = " <+> ppr (length hs_fns))
704 <> semi
705 , text "static void " <> ctor_symbol <> text "(void)"
706 <+> text " __attribute__((constructor));"
707 , text "static void " <> ctor_symbol <> text "()"
708 , braces (text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi)
709 ]
710 where
711 mod_str = pprModuleName (moduleName mod)
712 ctor_symbol = text "stginit_export_" <> mod_str
713 list_symbol = text "stg_exports_" <> mod_str
714 export_list = braces $ pprWithCommas closure_ptr hs_fns
715
716 closure_ptr :: Id -> SDoc
717 closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure"
718
719
720 mkHObj :: Type -> SDoc
721 mkHObj t = text "rts_mk" <> text (showFFIType t)
722
723 unpackHObj :: Type -> SDoc
724 unpackHObj t = text "rts_get" <> text (showFFIType t)
725
726 showStgType :: Type -> SDoc
727 showStgType t = text "Hs" <> text (showFFIType t)
728
729 showFFIType :: Type -> String
730 showFFIType t = getOccString (getName (typeTyCon t))
731
732 toCType :: Type -> (Maybe Header, SDoc)
733 toCType = f False
734 where f voidOK t
735 -- First, if we have (Ptr t) of (FunPtr t), then we need to
736 -- convert t to a C type and put a * after it. If we don't
737 -- know a type for t, then "void" is fine, though.
738 | Just (ptr, [t']) <- splitTyConApp_maybe t
739 , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]
740 = case f True t' of
741 (mh, cType') ->
742 (mh, cType' <> char '*')
743 -- Otherwise, if we have a type constructor application, then
744 -- see if there is a C type associated with that constructor.
745 -- Note that we aren't looking through type synonyms or
746 -- anything, as it may be the synonym that is annotated.
747 | Just tycon <- tyConAppTyConPicky_maybe t
748 , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon
749 = (mHeader, ftext cType)
750 -- If we don't know a C type for this type, then try looking
751 -- through one layer of type synonym etc.
752 | Just t' <- coreView t
753 = f voidOK t'
754 -- This may be an 'UnliftedFFITypes'-style ByteArray# argument
755 -- (which is marshalled like a Ptr)
756 | Just byteArrayPrimTyCon == tyConAppTyConPicky_maybe t
757 = (Nothing, text "const void*")
758 | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t
759 = (Nothing, text "void*")
760 -- Otherwise we don't know the C type. If we are allowing
761 -- void then return that; otherwise something has gone wrong.
762 | voidOK = (Nothing, text "void")
763 | otherwise
764 = pprPanic "toCType" (ppr t)
765
766 typeTyCon :: Type -> TyCon
767 typeTyCon ty
768 | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)
769 = tc
770 | otherwise
771 = pprPanic "GHC.HsToCore.Foreign.Decl.typeTyCon" (ppr ty)
772
773 insertRetAddr :: Platform -> CCallConv
774 -> [(SDoc, SDoc, Type, CmmType)]
775 -> [(SDoc, SDoc, Type, CmmType)]
776 insertRetAddr platform CCallConv args
777 = case platformArch platform of
778 ArchX86_64
779 | platformOS platform == OSMinGW32 ->
780 -- On other Windows x86_64 we insert the return address
781 -- after the 4th argument, because this is the point
782 -- at which we need to flush a register argument to the stack
783 -- (See rts/Adjustor.c for details).
784 let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
785 -> [(SDoc, SDoc, Type, CmmType)]
786 go 4 args = ret_addr_arg platform : args
787 go n (arg:args) = arg : go (n+1) args
788 go _ [] = []
789 in go 0 args
790 | otherwise ->
791 -- On other x86_64 platforms we insert the return address
792 -- after the 6th integer argument, because this is the point
793 -- at which we need to flush a register argument to the stack
794 -- (See rts/Adjustor.c for details).
795 let go :: Int -> [(SDoc, SDoc, Type, CmmType)]
796 -> [(SDoc, SDoc, Type, CmmType)]
797 go 6 args = ret_addr_arg platform : args
798 go n (arg@(_,_,_,rep):args)
799 | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args
800 | otherwise = arg : go n args
801 go _ [] = []
802 in go 0 args
803 _ ->
804 ret_addr_arg platform : args
805 insertRetAddr _ _ args = args
806
807 ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType)
808 ret_addr_arg platform = (text "original_return_addr", text "void*", undefined,
809 typeCmmType platform addrPrimTy)
810
811 -- This function returns the primitive type associated with the boxed
812 -- type argument to a foreign export (eg. Int ==> Int#).
813 getPrimTyOf :: Type -> UnaryType
814 getPrimTyOf ty
815 | isBoolTy rep_ty = intPrimTy
816 -- Except for Bool, the types we are interested in have a single constructor
817 -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).
818 | otherwise =
819 case splitDataProductType_maybe rep_ty of
820 Just (_, _, data_con, [Scaled _ prim_ty]) ->
821 assert (dataConSourceArity data_con == 1) $
822 assertPpr (isUnliftedType prim_ty) (ppr prim_ty)
823 prim_ty
824 _other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty)
825 where
826 rep_ty = unwrapType ty
827
828 -- represent a primitive type as a Char, for building a string that
829 -- described the foreign function type. The types are size-dependent,
830 -- e.g. 'W' is a signed 32-bit integer.
831 primTyDescChar :: Platform -> Type -> Char
832 primTyDescChar platform ty
833 | ty `eqType` unitTy = 'v'
834 | otherwise
835 = case typePrimRep1 (getPrimTyOf ty) of
836 IntRep -> signed_word
837 WordRep -> unsigned_word
838 Int8Rep -> 'B'
839 Word8Rep -> 'b'
840 Int16Rep -> 'S'
841 Word16Rep -> 's'
842 Int32Rep -> 'W'
843 Word32Rep -> 'w'
844 Int64Rep -> 'L'
845 Word64Rep -> 'l'
846 AddrRep -> 'p'
847 FloatRep -> 'f'
848 DoubleRep -> 'd'
849 _ -> pprPanic "primTyDescChar" (ppr ty)
850 where
851 (signed_word, unsigned_word) = case platformWordSize platform of
852 PW4 -> ('W','w')
853 PW8 -> ('L','l')