2 % (c) The AQUA Project, Glasgow University, 1998
4 \section[DsCCall]{Desugaring \tr{foreign} declarations}
6 Expanding out @foreign import@ and @foreign export@ declarations.
9 module DsForeign ( dsForeigns ) where
12 #include "HsVersions.h"
16 import DsCCall ( getIoOkDataCon, boxResult, unboxArg,
17 can'tSeeDataConsPanic, wrapUnboxedValue
22 import HsSyn ( ExtName(..), ForeignDecl(..), isDynamic, ForKind(..) )
24 import TcHsSyn ( maybeBoxedPrimType, TypecheckedForeignDecl )
25 import CoreUtils ( coreExprType )
26 import Id ( Id, dataConArgTys, idType, idName,
27 mkVanillaId, dataConRawArgTys,
28 dataConTyCon, mkIdVisible
30 import IdInfo ( noIdInfo )
31 import Literal ( Literal(..), mkMachInt )
32 import Maybes ( maybeToBool )
33 import Name ( nameString, occNameString, nameOccName, nameUnique )
34 import PrelVals ( packStringForCId, eRROR_ID, realWorldPrimId )
35 import PrimOp ( PrimOp(..) )
36 import Type ( isUnpointedType, splitAlgTyConApp_maybe,
37 splitTyConApp_maybe, splitFunTys, splitForAllTys,
38 Type, mkFunTys, applyTy, mkForAllTys, mkTyConApp,
39 typePrimRep, mkTyVarTy, mkFunTy, splitAppTy
41 import PrimRep ( showPrimRepToUser, PrimRep(..) )
42 import TyVar ( TyVar )
43 import TyCon ( tyConDataCons )
44 import TysPrim ( byteArrayPrimTy, realWorldStatePrimTy,
45 byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
46 realWorldTy, addrPrimTy, mkStablePtrPrimTy,
49 import TysWiredIn ( getStatePairingConInfo,
50 unitDataCon, stringTy,
51 realWorldStateTy, stateDataCon,
52 isFFIArgumentTy, unitTy,
53 addrTy, stablePtrTyCon,
54 stateAndPtrPrimDataCon,
61 Desugaring of @foreign@ declarations is naturally split up into
62 parts, an @import@ and an @export@ part. A @foreign import@
65 foreign import cc nm f :: prim_args -> IO prim_res
69 f :: prim_args -> IO prim_res
70 f a1 ... an = _ccall_ nm cc a1 ... an
72 so we reuse the desugaring code in @DsCCall@ to deal with these.
75 dsForeigns :: [TypecheckedForeignDecl]
76 -> DsM ( [CoreBinding] -- desugared foreign imports
77 , [CoreBinding] -- helper functions for foreign exports
78 , SDoc -- auxilliary code to emit into .hc file
79 , SDoc -- Header file prototypes for "foreign exported" functions.
80 , SDoc -- C stubs to use when calling "foreign exported" funs.
82 dsForeigns fos = foldlDs combine ([],[],empty,empty,empty) fos
84 combine (acc_fi, acc_fe, acc_hc, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _)
86 dsFImport i (idType i) uns ext_nm cconv `thenDs` \ b ->
87 returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c)
89 dsFLabel i ext_nm `thenDs` \ b ->
90 returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c)
92 dsFExportDynamic i (idType i) ext_nm cconv `thenDs` \ (fi,fe,hc,h,c) ->
93 returnDs (fi:acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c)
95 dsFExport i (idType i) ext_nm cconv False `thenDs` \ (fe,hc,h,c) ->
96 returnDs (acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c)
109 (FoImport uns) = imp_exp
113 Desugaring foreign imports is just the matter of creating a binding
114 that on its RHS unboxes its arguments, performs the external call
115 (using the CCallOp primop), before boxing the result up and returning it.
119 -> Type -- Type of foreign import.
120 -> Bool -- True <=> might cause Haskell GC
124 dsFImport nm ty may_not_gc ext_name cconv =
125 newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s ->
126 mkArgs ty `thenDs` \ (tvs, args, io_res_ty) ->
127 mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
130 | is_io_action = old_s
131 | otherwise = realWorldPrimId
133 final_args = Var the_state_arg : unboxed_args
134 (ioOkDataCon, ioDataCon, result_ty) = getIoOkDataCon io_res_ty
137 case (splitTyConApp_maybe io_res_ty) of
138 Just (iot,[_]) -> (uniqueOf iot) == ioTyConKey
141 (if not is_io_action then
142 newSysLocalDs realWorldStatePrimTy `thenDs` \ state_tok ->
143 wrapUnboxedValue io_res_ty `thenDs` \ (state_and_foo, state_and_foo_ty, v, res_v) ->
144 let the_alt = (state_and_foo, [state_tok,v], res_v) in
145 returnDs (state_and_foo_ty, \ prim_app -> Case prim_app (AlgAlts [the_alt] NoDefault))
147 boxResult ioOkDataCon result_ty) `thenDs` \ (final_result_ty, res_wrapper) ->
149 Dynamic -> getUniqueDs `thenDs` \ u ->
151 ExtName fs _ -> returnDs (Left fs)) `thenDs` \ label ->
153 the_ccall_op = CCallOp label False (not may_not_gc) cconv
154 (map coreExprType final_args)
157 mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
159 body = foldr ($) (res_wrapper the_prim_app) arg_wrappers
162 | not is_io_action = body
163 | otherwise = mkValLam [old_s] body
165 newSysLocalDs (coreExprType the_body) `thenDs` \ ds ->
168 | is_io_action = mkValApp (mkTyApp (Var ioDataCon) [result_ty]) [VarArg ds]
171 fo_rhs = mkTyLam tvs $
172 mkValLam (map (\ (Var x) -> x) args)
173 (mkCoLetAny (NonRec ds the_body) io_app)
175 returnDs (NonRec nm fo_rhs)
177 mkArgs :: Type -> DsM ([TyVar], [CoreExpr], Type)
179 case splitFunTys sans_foralls of
181 newSysLocalsDs arg_tys `thenDs` \ ds_args ->
182 returnDs (tvs, map Var ds_args, res_ty)
184 (tvs, sans_foralls) = splitForAllTys ty
190 dsFLabel :: Id -> ExtName -> DsM CoreBinding
191 dsFLabel nm ext_name =
192 returnDs (NonRec nm fo_rhs)
194 fo_rhs = mkCon addrDataCon [] [LitArg (MachLitLit enm AddrRep)]
205 -> Type -- Type of foreign export.
208 -> Bool -- True => invoke IO action that's hanging off
209 -- the first argument's stable pointer
210 -> DsM (CoreBinding, SDoc, SDoc, SDoc)
211 dsFExport i ty ext_name cconv isDyn =
212 newSysLocalDs realWorldStatePrimTy `thenDs` \ s1 ->
213 newSysLocalDs realWorldStatePrimTy `thenDs` \ s3 ->
214 newSysLocalDs helper_ty `thenDs` \ f_helper ->
215 newSysLocalsDs helper_arg_tys `thenDs` \ helper_args ->
216 newSysLocalDs res_ty `thenDs` \ v1 ->
217 unboxResult the_prim_result_ty res_ty s3 v1 `thenDs` \ (state_and_prim_ty, unpack_result) ->
218 zipWithDs boxArg fe_arg_tys helper_args `thenDs` \ stuff ->
220 newSysLocalDs realWorldStatePrimTy `thenDs` \ s11 ->
221 newSysLocalDs stbl_ptr_ty `thenDs` \ stbl_ptr ->
222 newSysLocalDs stbl_ptr_to_ty `thenDs` \ f ->
223 mkPrimDs DeRefStablePtrOp
224 [TyArg stbl_ptr_to_ty,
225 VarArg (Var stbl_ptr),
226 VarArg (Var s1)] `thenDs` \ the_deref_app ->
230 (AlgAlts [(stateAndPtrPrimDataCon, [s11, f], cont)]
233 returnDs (f, stbl_app, s11, stbl_ptr)
238 panic "stbl_ptr" -- should never be touched.
239 )) `thenDs` \ (i, getFun_wrapper, s2, stbl_ptr) ->
241 (boxed_args, arg_wrappers) = unzip stuff
244 | isDyn = stbl_ptr:helper_args
245 | otherwise = helper_args
248 | isDyn = stbl_ptr_ty:helper_arg_tys
249 | otherwise = helper_arg_tys
251 fe_app = mkGenApp (Var i) (map (TyArg . mkTyVarTy) tvs ++ map VarArg boxed_args)
254 mkValApp (Note (Coerce io_result_ty io_res) fe_app)
257 newFailLocalDs (coreExprType the_app) `thenDs` \ wild ->
258 getModuleAndGroupDs `thenDs` \ (mod,_) ->
259 getUniqueDs `thenDs` \ uniq ->
264 mkValLam wrapper_args $
266 foldr ($) (perform_and_unpack) arg_wrappers
269 Case the_app (AlgAlts [(ioOkDataCon, [s3, v1], unpack_result)]
270 (BindDefault wild err))
276 full_msg = "Exception caught: " ++ _UNPK_ (nameString (idName i))
277 msg = NoRepStr (_PK_ full_msg)
278 err = mkApp (Var eRROR_ID) [state_and_prim_ty] [LitArg msg]
280 f_helper_glob = (mkIdVisible mod uniq f_helper)
281 (hc_stub, h_stub, c_stub) = fexportEntry c_nm f_helper_glob wrapper_arg_tys the_prim_result_ty cconv
283 returnDs (NonRec f_helper_glob the_body, hc_stub, h_stub, c_stub)
285 (tvs,sans_foralls) = splitForAllTys ty
286 (fe_arg_tys', io_res) = splitFunTys sans_foralls
287 (ioOkDataCon, ioDataCon, res_ty) = getIoOkDataCon io_res
289 maybe_data_type = splitAlgTyConApp_maybe res_ty
290 Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
291 (the_data_con : other_data_cons) = data_cons
293 data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
294 (prim_result_ty : other_args_tys) = data_con_arg_tys
296 ioDataConTy = idType ioDataCon
297 (io_tvs, ioDataConTy') = splitForAllTys ioDataConTy
298 ([arg_ty], _) = splitFunTys ioDataConTy'
299 io_result_ty = applyTy (mkForAllTys io_tvs arg_ty) res_ty
301 (_, stbl_ptr_ty') = splitForAllTys stbl_ptr_ty
302 (_, stbl_ptr_to_ty) = splitAppTy stbl_ptr_ty'
305 | isDyn = tail fe_arg_tys'
306 | otherwise = fe_arg_tys'
308 (stbl_ptr_ty, helper_arg_tys) =
309 case (map unboxTy fe_arg_tys') of
310 (x:xs) | isDyn -> (x,xs)
311 ls -> (error "stbl_ptr_ty", ls)
315 mkFunTys (arg_tys ++ [realWorldStatePrimTy])
319 | isDyn = stbl_ptr_ty : helper_arg_tys
320 | otherwise = helper_arg_tys
323 | null data_con_arg_tys = Nothing
324 | otherwise = Just prim_result_ty
327 | (null other_data_cons) &&
328 (null data_con_arg_tys) = realWorldStateTy
329 | otherwise = snd (getStatePairingConInfo (unboxTy res_ty))
332 "foreign export dynamic" lets you dress up Haskell IO actions
333 of some fixed type behind an externally callable interface (i.e.,
334 as a C function pointer). Useful for callbacks and stuff.
337 foreign export stdcall f :: (Addr -> Int -> IO Int) -> IO Addr
339 -- Haskell-visible constructor, which is generated from the
342 f :: (Addr -> Int -> IO Int) -> IO Addr
343 f cback = IO ( \ s1# ->
344 case makeStablePtr# cback s1# of { StateAndStablePtr# s2# sp# ->
345 case _ccall_ "mkAdjustor" sp# ``f_helper'' s2# of
346 StateAndAddr# s3# a# ->
356 foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr -> Int -> IO Int
357 -- `special' foreign export that invokes the closure pointed to by the
362 dsFExportDynamic :: Id
363 -> Type -- Type of foreign export.
366 -> DsM (CoreBinding, CoreBinding, SDoc, SDoc, SDoc)
367 dsFExportDynamic i ty ext_name cconv =
368 newSysLocalDs ty `thenDs` \ fe_id ->
370 -- hack: need to get at the name of the C stub we're about to generate.
371 fe_nm = toCName fe_id
372 fe_ext_name = ExtName (_PK_ fe_nm) Nothing
374 dsFExport i export_ty fe_ext_name cconv True `thenDs` \ (fe@(NonRec fe_helper fe_expr), hc_code, h_code, c_code) ->
375 newSysLocalDs realWorldStatePrimTy `thenDs` \ s1 ->
376 newSysLocalDs realWorldStatePrimTy `thenDs` \ s2 ->
377 newSysLocalDs realWorldStatePrimTy `thenDs` \ s3 ->
378 newSysLocalDs arg_ty `thenDs` \ cback_arg ->
379 newSysLocalDs arg_ty `thenDs` \ cback ->
380 newSysLocalDs (mkStablePtrPrimTy arg_ty) `thenDs` \ stbl ->
381 newSysLocalDs addrPrimTy `thenDs` \ addrPrim ->
382 newSysLocalDs addrTy `thenDs` \ addr ->
383 mkPrimDs MakeStablePtrOp [TyArg arg_ty,
385 VarArg (Var s1)] `thenDs` \ mkStablePtr_app ->
386 mkPrimDs Addr2IntOp [VarArg (Var addrPrim)] `thenDs` \ the_addr2Int_app ->
387 boxArg addrTy addrPrim `thenDs` \ (addr_result, addrPrim_wrapper) ->
389 (stateAndStablePtrPrimDataCon, _) = getStatePairingConInfo (mkStablePtrPrimTy arg_ty)
390 (stateAndAddrPrimDataCon, stateAndAddrPrimTy) = getStatePairingConInfo addrPrimTy
393 | cconv == stdCallConv = 1
396 ccall_args = [Var s2, Lit (mkMachInt cc),
398 Lit (MachLitLit (_PK_ fe_nm) AddrRep)]
400 label = Left SLIT("createAdjustor")
401 the_ccall_op = CCallOp label False False{-won't GC-} cCallConv
402 (map coreExprType ccall_args)
405 mkPrimDs the_ccall_op (map VarArg ccall_args) `thenDs` \ the_ccall_app ->
407 [TyArg res_ty, VarArg (Var s3), VarArg (Var addr_result)]
408 `thenDs` \ ioOkApp ->
409 newSysLocalDs intPrimTy `thenDs` \ default_val ->
411 the_mkStablePtr = \ cont ->
413 (AlgAlts [(stateAndStablePtrPrimDataCon, [s2, stbl], cont)]
416 the_ccall = \ cont ->
418 (AlgAlts [(stateAndAddrPrimDataCon, [s3, addrPrim], cont)]
420 the_addr2Int = \ cont ->
421 Case the_addr2Int_app
422 (PrimAlts [(mkMachInt 0, io_fail)]
423 (BindDefault default_val cont))
425 io_fail = mkApp (Var eRROR_ID) [coreExprType wrap_res] [LitArg msg]
426 full_msg = "Exception caught: " ++ _UNPK_ (nameString (idName i))
427 msg = NoRepStr (_PK_ full_msg)
429 wrap_res = addrPrim_wrapper ioOkApp
432 mkValLam [cback,s1] $
435 the_addr2Int wrap_res
438 newSysLocalDs (coreExprType the_body) `thenDs` \ ds ->
439 newSysLocalDs (mkFunTy realWorldStatePrimTy
440 (coreExprType ioOkApp)) `thenDs` \ ap ->
442 io_app = mkValApp (mkTyApp (Var ioDataCon) [res_ty]) [VarArg ap]
445 mkValLam [cback_arg] $
446 mkCoLetAny (NonRec ds the_body) $
447 mkCoLetAny (NonRec ap (mkValApp (mkTyApp (Var ds) (map mkTyVarTy tvs)) [VarArg cback_arg])) $
450 returnDs (NonRec i io_action, fe, hc_code, h_code, c_code)
452 (tvs,sans_foralls) = splitForAllTys ty
453 ([arg_ty], io_res) = splitFunTys sans_foralls
454 (ioOkDataCon, ioDataCon, res_ty) = getIoOkDataCon io_res
456 ioDataConTy = idType ioDataCon
457 (io_tvs, ioDataConTy') = splitForAllTys ioDataConTy
458 -- ([arg_ty], _) = splitFunTys ioDataConTy'
459 io_result_ty = applyTy (mkForAllTys io_tvs arg_ty) res_ty
461 export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty
463 toCName :: Id -> String
464 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
470 \subsection{Helper functions}
474 @boxArg@ boxes up an argument in preparation for calling
475 a function that maybe expects a boxed version of it, i.e.,
478 boxArg Addr a# ==> let ds_foo :: Addr ; ds_foo = A# a# in f ...ds_foo..
482 boxArg :: Type -- Expected type after possible boxing of arg.
483 -> Id -- The (unboxed) argument
484 -> DsM (Id, -- To pass as the actual, boxed argument
485 CoreExpr -> CoreExpr -- Wrapper to box the arg
487 boxArg box_ty prim_arg
488 | isUnpointedType box_ty = returnDs (prim_arg, \body -> body)
489 -- Data types with a single constructor,
490 -- which has a single, primitive-typed arg
492 = newSysLocalDs box_ty `thenDs` \ box_arg ->
494 , Let (NonRec box_arg (mkCon box_data_con tys_applied [VarArg prim_arg]))
497 maybe_boxed_prim_arg_ty = maybeBoxedPrimType box_ty
498 (Just (_,tys_applied,_)) = splitAlgTyConApp_maybe box_ty
499 (Just (box_data_con, _)) = maybe_boxed_prim_arg_ty
502 @foreign export@ed functions may return a value back to the outside world.
503 @unboxResult@ takes care of converting from the (boxed) value that the
504 exported action returns to the (unboxed) value that is returned across
508 unboxResult :: Maybe Type -- the (unboxed) type we want to return (along with the state token)
509 -- Nothing => no result, just the state token.
510 -> Type -- the (boxed) type we have in our hand.
511 -> Id -- the state token
513 -> DsM (Type, -- type of returned expression.
514 CoreExpr) -- expr that unboxes result and returns state+unboxed result.
516 unboxResult mb_res_uboxed_ty res_ty new_s v_boxed
517 | not (maybeToBool mb_res_uboxed_ty)
518 = -- no result, just return state token
519 mkConDs stateDataCon [ TyArg realWorldTy
520 , VarArg (Var new_s)] `thenDs` \ the_st ->
521 returnDs (realWorldStateTy, the_st)
524 -- oops! can't see the data constructors
525 = can'tSeeDataConsPanic "result" res_ty
527 | (maybeToBool maybe_data_type) && -- Data type
528 (null other_data_cons) && -- - with one constructor,
529 isUnpointedType res_uboxed_ty -- - and of primitive type.
530 -- (Glasgow extension)
532 newSysLocalDs res_uboxed_ty `thenDs` \ v_unboxed ->
533 mkConDs state_and_prim_datacon
534 ((TyArg realWorldTy):map (TyArg ) tycon_arg_tys ++
536 , VarArg (Var v_unboxed)]) `thenDs` \ the_result ->
538 the_alt = (the_data_con, [v_unboxed], the_result)
540 returnDs (state_and_prim_ty,
541 Case (Var v_boxed) (AlgAlts [the_alt] NoDefault))
544 = pprPanic "unboxResult: " (ppr res_ty)
546 (Just res_uboxed_ty) = mb_res_uboxed_ty
548 maybe_data_type = splitAlgTyConApp_maybe res_ty
549 Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
550 (the_data_con : other_data_cons) = data_cons
552 (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo res_uboxed_ty
556 Returned the unboxed type of a (primitive) type:
559 unboxTy :: Type -> Type
561 | isUnpointedType ty || (ty == unitTy) = ty
563 ASSERT( isFFIArgumentTy ty ) -- legal arg types subsume result types.
564 case splitTyConApp_maybe ty of
566 case (tyConDataCons tyc) of
567 [dc] -> case (dataConArgTys dc ts) of
569 -- HACK: for the array types, the prim type is
570 -- the second tycon arg.
572 _ -> pprPanic "unboxTy: " (ppr ty)
573 _ -> pprPanic "unboxTy: " (ppr ty)
574 _ -> pprPanic "unboxTy: " (ppr ty)
580 \subsection{Generating @foreign export@ stubs}
584 [Severe hack to get @foreign export@ off the ground:]
586 For each @foreign export@ function, a C stub together with a @.hc@ stub
587 is generated. The C stub enters the .hc stub, setting up the passing of
588 parameters from C land to STG land through the use of global variables
589 (don't worry, this just a temporary solution!). Ditto for the result.
592 The generation of .hc code will go once the transition is
593 made over to the new rts. Hence the hack, instead of extending
594 AbsCSyn to cope with the .hc code generated.
598 fexportEntry :: FAST_STRING -> Id -> [Type] -> Maybe Type -> CallConv -> (SDoc, SDoc, SDoc)
599 fexportEntry c_nm helper args res cc =
600 ( paramArea $$ stopTemplate $$ startTemplate $$ vtblTemplate, h_code, c_code )
602 (h_code, c_code) = mkCStub c_nm h_stub_nm args res cc
605 vcat (zipWith declVar ( res_ty : param_tys ) ( res_name : param_names ) )
607 -- name of the (Haskell) helper function generated by the desugarer.
609 h_stub_nm = text foreign_export_prefix <> h_nm
610 closure = h_nm <> text "_closure"
612 param_names = zipWith (\ i _ -> h_stub_nm <> text ('_':show i)) [1..] args
613 param_tys = map (ppr.typePrimRep) args
617 Nothing -> (empty, empty)
618 Just t -> (h_stub_nm <> text "_res", ppr (typePrimRep t))
622 [ text "extern void* realWorldZh_closure;"
623 , ptext SLIT("STGFUN") <> parens (h_stub_nm)
625 , ptext SLIT("FUNBEGIN;")
626 , text "RestoreAllStgRegs();"
627 , stackCheck param_names
631 , vcat (map pushArg (reverse param_names))
632 , text "Node=" <> closure <> semi
633 , text "ENT_VIA_NODE();" -- ticky count
634 , text "InfoPtr=(D_)(INFO_PTR(Node));"
635 , text "JMP_(ENTRY_CODE(InfoPtr));"
642 [ ptext SLIT("STGFUN") <> parens (text "stop" <> h_stub_nm <> text "DirectReturn")
644 , ptext SLIT("FUNBEGIN;")
647 , text "#if defined(__STG_GCC_REGS__)"
648 , text "SaveAllStgRegs();"
650 , text "SAVE_Hp = Hp;"
651 , text "SAVE_HpLim = HpLim;"
653 , text "JMP_(miniInterpretEnd);"
660 [ text "const W_ vtbl_" <> h_stub_nm <> text "[] = {"
661 , vcat (punctuate comma (replicate 8 dir_ret))
665 dir_ret = text "(W_)stop" <> h_stub_nm <> text "DirectReturn"
670 Just _ -> res_name <> equals <> text "R3.i;" -- wrong
673 text "SpB -= BREL(1);" $$
674 text "*SpB = (W_)RetReg;"
677 text "RetReg=(StgRetAddr)*SpB;" $$
678 text "SpB += BREL(1);"
681 text "RetReg=(StgRetAddr)UNVEC(stop" <> h_stub_nm <>
682 text "DirectReturn,vtbl_" <> h_stub_nm <> text ");"
685 text "SpB -= BREL(1);" $$
686 text "*SpB = (W_)realWorldZh_closure;"
690 text "SpB -= BREL(1);" $$
691 text "*SpB = (W_)" <> nm <> semi
694 text "STK_CHK(LivenessReg,0," <> sz <> text ",0,0,0,0);"
697 hsep $ punctuate (text " + ") (text "1":(map sizer args))
699 sizer x = text "BYTES_TO_STGWORDS" <> parens (text "sizeof" <> parens x)
701 foreign_export_prefix :: String
702 foreign_export_prefix = "__fexp_"
704 mkCStub :: FAST_STRING -> SDoc -> [Type] -> Maybe Type -> CallConv -> (SDoc, SDoc)
705 mkCStub c_nm h_stub_nm args res cc =
706 ( hsep [ ptext SLIT("extern")
710 , parens (hsep (punctuate comma (zipWith (<+>) stubParamTypes stubArgs)))
717 , ptext c_nm <> parens (hsep (punctuate comma stubArgs))
718 , vcat (zipWith declVar stubParamTypes stubArgs)
720 , vcat (zipWith assignArgs param_names c_args)
721 , text "miniInterpret" <> parens (parens (text "StgFunPtr") <> h_stub_nm) <> semi
727 -- tedious hack to let us deal with caller-cleans-up-stack
728 -- discipline that the C calling convention uses.
730 | cc == cCallConv = ptext SLIT("void*") : cParamTypes
731 | otherwise = cParamTypes
733 | cc == cCallConv = ptext SLIT("_a0") : c_args
736 param_names = zipWith (\ i _ -> h_stub_nm <> text ('_':show i)) [1..] args
737 cParamTypes = map (text.showPrimRepToUser.typePrimRep) args
738 (cResType, cResDecl) =
740 Nothing -> (text "void", empty)
741 Just t -> (text (showPrimRepToUser (typePrimRep t)),
742 text "extern" <+> cResType <+> res_name <> semi)
745 | cc == cCallConv = empty
746 | otherwise = pprCallConv cc
749 vcat (zipWith mkExtern cParamTypes param_names) $$
751 text "extern void" <+> h_stub_nm <> text "();"
753 mkExtern ty nm = text "extern" <+> ty <+> nm <> semi
755 c_args = zipWith (\ _ n -> text ('a':show n)) args [0..]
757 assignArgs p_nm c_arg = p_nm <+> equals <+> c_arg <> semi
762 Just _ -> text "return" <+> res_name <> semi
766 Nothing -> (empty, empty)
767 Just t -> (h_stub_nm <> text "_res", ppr (typePrimRep t))
769 declVar :: SDoc -> SDoc -> SDoc
770 declVar ty var = ty <+> var <> semi
776 f :: Int -> Int -> Int -> IO Int
778 we'll emit the following stuff into the .hc file
790 STK_CHK(LivenessReg,0/*A*/,(SIZE_IN_WORDS(StgInt) +
791 SIZE_IN_WORDS(StgInt) +
792 SIZE_IN_WORDS(StgInt) + 1)/*B*/, 0, 0, 0/*prim*/, 0/*re-enter*/);
793 RetReg = (StgRetAddr) UNVEC(stopds_fDirectReturn,vtbl_stopds_f);
795 *SpB = (W_)__f_param_3;
797 *SpB = (W_)__f_param_2;
799 *SpB = (W_)__f_param_1;
802 *SpB = (W_) realWorldZh_closure;
804 Node = ds_f_helper_closure;
806 InfoPtr=(D_)(INFO_PTR(Node));
807 JMP_(ENTRY_CODE(InfoPtr));
811 STGFUN(stop_ds_fDirectReturn)
816 RESUME(miniInterpretEnd);
820 const W_ vtbl_stopds_f[] = {
821 (W_) stopds_fDirectReturn,
822 (W_) stopds_fDirectReturn,
823 (W_) stopds_fDirectReturn,
824 (W_) stopds_fDirectReturn,
825 (W_) stopds_fDirectReturn,
826 (W_) stopds_fDirectReturn,
827 (W_) stopds_fDirectReturn,
828 (W_) stopds_fDirectReturn
836 extern StgInt __f_param_1;
837 extern StgInt __f_param_2;
838 extern StgInt __f_param_3;
839 extern StgInt __f_res;
842 extern void miniInterpret(StgAddr);
853 miniInterpret((StgAddr)ds_f);