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,
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 )
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,
60 Desugaring of @foreign@ declarations is naturally split up into
61 parts, an @import@ and an @export@ part. A @foreign import@
64 foreign import cc nm f :: prim_args -> IO prim_res
68 f :: prim_args -> IO prim_res
69 f a1 ... an = _ccall_ nm cc a1 ... an
71 so we reuse the desugaring code in @DsCCall@ to deal with these.
74 dsForeigns :: [TypecheckedForeignDecl]
75 -> DsM ( [CoreBinding] -- desugared foreign imports
76 , [CoreBinding] -- helper functions for foreign exports
77 , SDoc -- auxilliary code to emit into .hc file
78 , SDoc -- Header file prototypes for "foreign exported" functions.
79 , SDoc -- C stubs to use when calling "foreign exported" funs.
81 dsForeigns fos = foldlDs combine ([],[],empty,empty,empty) fos
83 combine (acc_fi, acc_fe, acc_hc, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _)
85 dsFImport i (idType i) uns ext_nm cconv `thenDs` \ b ->
86 returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c)
88 dsFLabel i ext_nm `thenDs` \ b ->
89 returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c)
91 dsFExportDynamic i (idType i) ext_nm cconv `thenDs` \ (fi,fe,hc,h,c) ->
92 returnDs (fi:acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c)
94 dsFExport i (idType i) ext_nm cconv False `thenDs` \ (fe,hc,h,c) ->
95 returnDs (acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c)
108 (FoImport uns) = imp_exp
112 Desugaring foreign imports is just the matter of creating a binding
113 that on its RHS unboxes its arguments, performs the external call
114 (using the CCallOp primop), before boxing the result up and returning it.
118 -> Type -- Type of foreign import.
119 -> Bool -- True <=> might cause Haskell GC
123 dsFImport nm ty may_not_gc ext_name cconv =
124 newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s ->
125 mkArgs ty `thenDs` \ (tvs, args, io_res_ty) ->
126 mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
128 final_args = Var old_s : unboxed_args
129 (ioOkDataCon, ioDataCon, result_ty) = getIoOkDataCon io_res_ty
131 boxResult ioOkDataCon result_ty `thenDs` \ (final_result_ty, res_wrapper) ->
133 Dynamic -> getUniqueDs `thenDs` \ u -> returnDs (Right u)
134 ExtName fs _ -> returnDs (Left fs)) `thenDs` \ label ->
136 the_ccall_op = CCallOp label False (not may_not_gc) cconv
137 (map coreExprType final_args)
140 mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app ->
142 the_body = mkValLam [old_s]
143 (foldr ($) (res_wrapper the_prim_app) arg_wrappers)
145 newSysLocalDs (coreExprType the_body) `thenDs` \ ds ->
147 io_app = mkValApp (mkTyApp (Var ioDataCon) [result_ty]) [VarArg ds]
148 fo_rhs = mkTyLam tvs $
149 mkValLam (map (\ (Var x) -> x) args)
150 (mkCoLetAny (NonRec ds the_body) io_app)
152 returnDs (NonRec nm fo_rhs)
154 mkArgs :: Type -> DsM ([TyVar], [CoreExpr], Type)
156 case splitFunTys sans_foralls of
158 newSysLocalsDs arg_tys `thenDs` \ ds_args ->
159 returnDs (tvs, map Var ds_args, res_ty)
161 (tvs, sans_foralls) = splitForAllTys ty
167 dsFLabel :: Id -> ExtName -> DsM CoreBinding
168 dsFLabel nm ext_name =
169 returnDs (NonRec nm fo_rhs)
171 fo_rhs = mkCon addrDataCon [] [LitArg (MachLitLit enm AddrRep)]
182 -> Type -- Type of foreign export.
185 -> Bool -- True => invoke IO action that's hanging off
186 -- the first argument's stable pointer
187 -> DsM (CoreBinding, SDoc, SDoc, SDoc)
188 dsFExport i ty ext_name cconv isDyn =
189 newSysLocalDs realWorldStatePrimTy `thenDs` \ s1 ->
190 newSysLocalDs realWorldStatePrimTy `thenDs` \ s3 ->
191 newSysLocalDs helper_ty `thenDs` \ f_helper ->
192 newSysLocalsDs helper_arg_tys `thenDs` \ helper_args ->
193 newSysLocalDs res_ty `thenDs` \ v1 ->
194 unboxResult the_prim_result_ty res_ty s3 v1 `thenDs` \ (state_and_prim_ty, unpack_result) ->
195 zipWithDs boxArg fe_arg_tys helper_args `thenDs` \ stuff ->
197 newSysLocalDs realWorldStatePrimTy `thenDs` \ s11 ->
198 newSysLocalDs stbl_ptr_ty `thenDs` \ stbl_ptr ->
199 newSysLocalDs stbl_ptr_to_ty `thenDs` \ f ->
200 mkPrimDs DeRefStablePtrOp
201 [TyArg stbl_ptr_to_ty,
202 VarArg (Var stbl_ptr),
203 VarArg (Var s1)] `thenDs` \ the_deref_app ->
207 (AlgAlts [(stateAndPtrPrimDataCon, [s11, f], cont)]
210 returnDs (f, stbl_app, s11, stbl_ptr)
215 panic "stbl_ptr" -- should never be touched.
216 )) `thenDs` \ (i, getFun_wrapper, s2, stbl_ptr) ->
218 (boxed_args, arg_wrappers) = unzip stuff
221 | isDyn = stbl_ptr:helper_args
222 | otherwise = helper_args
225 | isDyn = stbl_ptr_ty:helper_arg_tys
226 | otherwise = helper_arg_tys
228 fe_app = mkGenApp (Var i) (map (TyArg . mkTyVarTy) tvs ++ map VarArg boxed_args)
231 mkValApp (Note (Coerce io_result_ty io_res) fe_app)
234 newFailLocalDs (coreExprType the_app) `thenDs` \ wild ->
235 getModuleAndGroupDs `thenDs` \ (mod,_) ->
236 getUniqueDs `thenDs` \ uniq ->
241 mkValLam wrapper_args $
243 foldr ($) (perform_and_unpack) arg_wrappers
246 Case the_app (AlgAlts [(ioOkDataCon, [s3, v1], unpack_result)]
247 (BindDefault wild err))
253 full_msg = "Exception caught: " ++ _UNPK_ (nameString (idName i))
254 msg = NoRepStr (_PK_ full_msg)
255 err = mkApp (Var eRROR_ID) [state_and_prim_ty] [LitArg msg]
257 f_helper_glob = (mkIdVisible mod uniq f_helper)
258 (hc_stub, h_stub, c_stub) = fexportEntry c_nm f_helper_glob wrapper_arg_tys the_prim_result_ty cconv
260 returnDs (NonRec f_helper_glob the_body, hc_stub, h_stub, c_stub)
262 (tvs,sans_foralls) = splitForAllTys ty
263 (fe_arg_tys', io_res) = splitFunTys sans_foralls
264 (ioOkDataCon, ioDataCon, res_ty) = getIoOkDataCon io_res
266 maybe_data_type = splitAlgTyConApp_maybe res_ty
267 Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
268 (the_data_con : other_data_cons) = data_cons
270 data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
271 (prim_result_ty : other_args_tys) = data_con_arg_tys
273 ioDataConTy = idType ioDataCon
274 (io_tvs, ioDataConTy') = splitForAllTys ioDataConTy
275 ([arg_ty], _) = splitFunTys ioDataConTy'
276 io_result_ty = applyTy (mkForAllTys io_tvs arg_ty) res_ty
278 (_, stbl_ptr_ty') = splitForAllTys stbl_ptr_ty
279 (_, stbl_ptr_to_ty) = splitAppTy stbl_ptr_ty'
282 | isDyn = tail fe_arg_tys'
283 | otherwise = fe_arg_tys'
285 (stbl_ptr_ty, helper_arg_tys) =
286 case (map unboxTy fe_arg_tys') of
287 (x:xs) | isDyn -> (x,xs)
288 ls -> (error "stbl_ptr_ty", ls)
292 mkFunTys (arg_tys ++ [realWorldStatePrimTy])
296 | isDyn = stbl_ptr_ty : helper_arg_tys
297 | otherwise = helper_arg_tys
300 | null data_con_arg_tys = Nothing
301 | otherwise = Just prim_result_ty
304 | (null other_data_cons) &&
305 (null data_con_arg_tys) = realWorldStateTy
306 | otherwise = snd (getStatePairingConInfo (unboxTy res_ty))
309 "foreign export dynamic" lets you dress up Haskell IO actions
310 of some fixed type behind an externally callable interface (i.e.,
311 as a C function pointer). Useful for callbacks and stuff.
314 foreign export stdcall f :: (Addr -> Int -> IO Int) -> IO Addr
316 -- Haskell-visible constructor, which is generated from the
319 f :: (Addr -> Int -> IO Int) -> IO Addr
320 f cback = IO ( \ s1# ->
321 case makeStablePtr# cback s1# of { StateAndStablePtr# s2# sp# ->
322 case _ccall_ "mkAdjustor" sp# ``f_helper'' s2# of
323 StateAndAddr# s3# a# ->
333 foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr -> Int -> IO Int
334 -- `special' foreign export that invokes the closure pointed to by the
339 dsFExportDynamic :: Id
340 -> Type -- Type of foreign export.
343 -> DsM (CoreBinding, CoreBinding, SDoc, SDoc, SDoc)
344 dsFExportDynamic i ty ext_name cconv =
345 newSysLocalDs ty `thenDs` \ fe_id ->
347 -- hack: need to get at the name of the C stub we're about to generate.
348 fe_nm = toCName fe_id
349 fe_ext_name = ExtName (_PK_ fe_nm) Nothing
351 dsFExport i export_ty fe_ext_name cconv True `thenDs` \ (fe@(NonRec fe_helper fe_expr), hc_code, h_code, c_code) ->
352 newSysLocalDs realWorldStatePrimTy `thenDs` \ s1 ->
353 newSysLocalDs realWorldStatePrimTy `thenDs` \ s2 ->
354 newSysLocalDs realWorldStatePrimTy `thenDs` \ s3 ->
355 newSysLocalDs arg_ty `thenDs` \ cback_arg ->
356 newSysLocalDs arg_ty `thenDs` \ cback ->
357 newSysLocalDs (mkStablePtrPrimTy arg_ty) `thenDs` \ stbl ->
358 newSysLocalDs addrPrimTy `thenDs` \ addrPrim ->
359 newSysLocalDs addrTy `thenDs` \ addr ->
360 mkPrimDs MakeStablePtrOp [TyArg arg_ty,
362 VarArg (Var s1)] `thenDs` \ mkStablePtr_app ->
363 mkPrimDs Addr2IntOp [VarArg (Var addrPrim)] `thenDs` \ the_addr2Int_app ->
364 boxArg addrTy addrPrim `thenDs` \ (addr_result, addrPrim_wrapper) ->
366 (stateAndStablePtrPrimDataCon, _) = getStatePairingConInfo (mkStablePtrPrimTy arg_ty)
367 (stateAndAddrPrimDataCon, stateAndAddrPrimTy) = getStatePairingConInfo addrPrimTy
370 | cconv == stdCallConv = 1
373 ccall_args = [Var s2, Lit (mkMachInt cc),
375 Lit (MachLitLit (_PK_ fe_nm) AddrRep)]
377 label = Left SLIT("createAdjustor")
378 the_ccall_op = CCallOp label False False{-won't GC-} cCallConv
379 (map coreExprType ccall_args)
382 mkPrimDs the_ccall_op (map VarArg ccall_args) `thenDs` \ the_ccall_app ->
384 [TyArg res_ty, VarArg (Var s3), VarArg (Var addr_result)]
385 `thenDs` \ ioOkApp ->
386 newSysLocalDs intPrimTy `thenDs` \ default_val ->
388 the_mkStablePtr = \ cont ->
390 (AlgAlts [(stateAndStablePtrPrimDataCon, [s2, stbl], cont)]
393 the_ccall = \ cont ->
395 (AlgAlts [(stateAndAddrPrimDataCon, [s3, addrPrim], cont)]
397 the_addr2Int = \ cont ->
398 Case the_addr2Int_app
399 (PrimAlts [(mkMachInt 0, io_fail)]
400 (BindDefault default_val cont))
402 io_fail = mkApp (Var eRROR_ID) [coreExprType wrap_res] [LitArg msg]
403 full_msg = "Exception caught: " ++ _UNPK_ (nameString (idName i))
404 msg = NoRepStr (_PK_ full_msg)
406 wrap_res = addrPrim_wrapper ioOkApp
409 mkValLam [cback,s1] $
412 the_addr2Int wrap_res
415 newSysLocalDs (coreExprType the_body) `thenDs` \ ds ->
416 newSysLocalDs (mkFunTy realWorldStatePrimTy
417 (coreExprType ioOkApp)) `thenDs` \ ap ->
419 io_app = mkValApp (mkTyApp (Var ioDataCon) [res_ty]) [VarArg ap]
422 mkValLam [cback_arg] $
423 mkCoLetAny (NonRec ds the_body) $
424 mkCoLetAny (NonRec ap (mkValApp (mkTyApp (Var ds) (map mkTyVarTy tvs)) [VarArg cback_arg])) $
427 returnDs (NonRec i io_action, fe, hc_code, h_code, c_code)
429 (tvs,sans_foralls) = splitForAllTys ty
430 ([arg_ty], io_res) = splitFunTys sans_foralls
431 (ioOkDataCon, ioDataCon, res_ty) = getIoOkDataCon io_res
433 ioDataConTy = idType ioDataCon
434 (io_tvs, ioDataConTy') = splitForAllTys ioDataConTy
435 -- ([arg_ty], _) = splitFunTys ioDataConTy'
436 io_result_ty = applyTy (mkForAllTys io_tvs arg_ty) res_ty
438 export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty
440 toCName :: Id -> String
441 toCName i = showSDoc (pprCode CStyle (ppr (idName i)))
447 \subsection{Helper functions}
451 @boxArg@ boxes up an argument in preparation for calling
452 a function that maybe expects a boxed version of it, i.e.,
455 boxArg Addr a# ==> let ds_foo :: Addr ; ds_foo = A# a# in f ...ds_foo..
459 boxArg :: Type -- Expected type after possible boxing of arg.
460 -> Id -- The (unboxed) argument
461 -> DsM (Id, -- To pass as the actual, boxed argument
462 CoreExpr -> CoreExpr -- Wrapper to box the arg
464 boxArg box_ty prim_arg
465 | isUnpointedType box_ty = returnDs (prim_arg, \body -> body)
466 -- Data types with a single constructor,
467 -- which has a single, primitive-typed arg
469 = newSysLocalDs box_ty `thenDs` \ box_arg ->
471 , Let (NonRec box_arg (mkCon box_data_con tys_applied [VarArg prim_arg]))
474 maybe_boxed_prim_arg_ty = maybeBoxedPrimType box_ty
475 (Just (_,tys_applied,_)) = splitAlgTyConApp_maybe box_ty
476 (Just (box_data_con, _)) = maybe_boxed_prim_arg_ty
479 @foreign export@ed functions may return a value back to the outside world.
480 @unboxResult@ takes care of converting from the (boxed) value that the
481 exported action returns to the (unboxed) value that is returned across
485 unboxResult :: Maybe Type -- the (unboxed) type we want to return (along with the state token)
486 -- Nothing => no result, just the state token.
487 -> Type -- the (boxed) type we have in our hand.
488 -> Id -- the state token
490 -> DsM (Type, -- type of returned expression.
491 CoreExpr) -- expr that unboxes result and returns state+unboxed result.
493 unboxResult mb_res_uboxed_ty res_ty new_s v_boxed
494 | not (maybeToBool mb_res_uboxed_ty)
495 = -- no result, just return state token
496 mkConDs stateDataCon [ TyArg realWorldTy
497 , VarArg (Var new_s)] `thenDs` \ the_st ->
498 returnDs (realWorldStateTy, the_st)
501 -- oops! can't see the data constructors
502 = can'tSeeDataConsPanic "result" res_ty
504 | (maybeToBool maybe_data_type) && -- Data type
505 (null other_data_cons) && -- - with one constructor,
506 isUnpointedType res_uboxed_ty -- - and of primitive type.
507 -- (Glasgow extension)
509 newSysLocalDs res_uboxed_ty `thenDs` \ v_unboxed ->
510 mkConDs state_and_prim_datacon
511 ((TyArg realWorldTy):map (TyArg ) tycon_arg_tys ++
513 , VarArg (Var v_unboxed)]) `thenDs` \ the_result ->
515 the_alt = (the_data_con, [v_unboxed], the_result)
517 returnDs (state_and_prim_ty,
518 Case (Var v_boxed) (AlgAlts [the_alt] NoDefault))
521 = pprPanic "unboxResult: " (ppr res_ty)
523 (Just res_uboxed_ty) = mb_res_uboxed_ty
525 maybe_data_type = splitAlgTyConApp_maybe res_ty
526 Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type
527 (the_data_con : other_data_cons) = data_cons
529 (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo res_uboxed_ty
533 Returned the unboxed type of a (primitive) type:
536 unboxTy :: Type -> Type
538 | isUnpointedType ty || (ty == unitTy) = ty
540 ASSERT( isFFIArgumentTy ty ) -- legal arg types subsume result types.
541 case splitTyConApp_maybe ty of
543 case (tyConDataCons tyc) of
544 [dc] -> case (dataConArgTys dc ts) of
546 -- HACK: for the array types, the prim type is
547 -- the second tycon arg.
549 _ -> pprPanic "unboxTy: " (ppr ty)
550 _ -> pprPanic "unboxTy: " (ppr ty)
551 _ -> pprPanic "unboxTy: " (ppr ty)
557 \subsection{Generating @foreign export@ stubs}
561 [Severe hack to get @foreign export@ off the ground:]
563 For each @foreign export@ function, a C stub together with a @.hc@ stub
564 is generated. The C stub enters the .hc stub, setting up the passing of
565 parameters from C land to STG land through the use of global variables
566 (don't worry, this just a temporary solution!). Ditto for the result.
569 The generation of .hc code will go once the transition is
570 made over to the new rts. Hence the hack, instead of extending
571 AbsCSyn to cope with the .hc code generated.
575 fexportEntry :: FAST_STRING -> Id -> [Type] -> Maybe Type -> CallConv -> (SDoc, SDoc, SDoc)
576 fexportEntry c_nm helper args res cc =
577 ( paramArea $$ stopTemplate $$ startTemplate $$ vtblTemplate, h_code, c_code )
579 (h_code, c_code) = mkCStub c_nm h_stub_nm args res cc
582 vcat (zipWith declVar ( res_ty : param_tys ) ( res_name : param_names ) )
584 -- name of the (Haskell) helper function generated by the desugarer.
586 h_stub_nm = text foreign_export_prefix <> h_nm
587 closure = h_nm <> text "_closure"
589 param_names = zipWith (\ i _ -> h_stub_nm <> text ('_':show i)) [1..] args
590 param_tys = map (ppr.typePrimRep) args
594 Nothing -> (empty, empty)
595 Just t -> (h_stub_nm <> text "_res", ppr (typePrimRep t))
599 [ text "extern realWorldZh_closure;"
600 , ptext SLIT("STGFUN") <> parens (h_stub_nm)
602 , ptext SLIT("FUNBEGIN;")
603 , text "RestoreAllStgRegs();"
604 , stackCheck param_names
608 , vcat (map pushArg (reverse param_names))
609 , text "Node=" <> closure <> semi
610 , text "ENT_VIA_NODE();" -- ticky count
611 , text "InfoPtr=(D_)(INFO_PTR(Node));"
612 , text "JMP_(ENTRY_CODE(InfoPtr));"
619 [ ptext SLIT("STGFUN") <> parens (text "stop" <> h_stub_nm <> text "DirectReturn")
621 , ptext SLIT("FUNBEGIN;")
624 , text "#if defined(__STG_GCC_REGS__)"
625 , text "SaveAllStgRegs();"
627 , text "SAVE_Hp = Hp;"
628 , text "SAVE_HpLim = HpLim;"
630 , text "JMP_(miniInterpretEnd);"
637 [ text "const W_ vtbl_" <> h_stub_nm <> text "[] = {"
638 , vcat (punctuate comma (replicate 8 dir_ret))
642 dir_ret = text "(W_)stop" <> h_stub_nm <> text "DirectReturn"
647 Just _ -> res_name <> equals <> text "R3.i;" -- wrong
650 text "SpB -= BREL(1);" $$
651 text "*SpB = (W_)RetReg;"
654 text "RetReg=(StgRetAddr)*SpB;" $$
655 text "SpB += BREL(1);"
658 text "RetReg=(StgRetAddr)UNVEC(stop" <> h_stub_nm <>
659 text "DirectReturn,vtbl_" <> h_stub_nm <> text ");"
662 text "SpB -= BREL(1);" $$
663 text "*SpB = (W_)realWorldZh_closure;"
667 text "SpB -= BREL(1);" $$
668 text "*SpB = (W_)" <> nm <> semi
671 text "STK_CHK(LivenessReg,0," <> sz <> text ",0,0,0,0);"
674 hsep $ punctuate (text " + ") (text "1":(map sizer args))
676 sizer x = text "BYTES_TO_STGWORDS" <> parens (text "sizeof" <> parens x)
678 foreign_export_prefix :: String
679 foreign_export_prefix = "__fexp_"
681 mkCStub :: FAST_STRING -> SDoc -> [Type] -> Maybe Type -> CallConv -> (SDoc, SDoc)
682 mkCStub c_nm h_stub_nm args res cc =
683 ( hsep [ ptext SLIT("extern")
687 , parens (hsep (punctuate comma (zipWith (<+>) stubParamTypes stubArgs)))
694 , ptext c_nm <> parens (hsep (punctuate comma stubArgs))
695 , vcat (zipWith declVar stubParamTypes stubArgs)
697 , vcat (zipWith assignArgs param_names c_args)
698 , text "miniInterpret" <> parens (parens (text "StgFunPtr") <> h_stub_nm) <> semi
704 -- tedious hack to let us deal with caller-cleans-up-stack
705 -- discipline that the C calling convention uses.
707 | cc == cCallConv = ptext SLIT("void*") : cParamTypes
708 | otherwise = cParamTypes
710 | cc == cCallConv = ptext SLIT("_a0") : c_args
713 param_names = zipWith (\ i _ -> h_stub_nm <> text ('_':show i)) [1..] args
714 cParamTypes = map (text.showPrimRepToUser.typePrimRep) args
715 (cResType, cResDecl) =
717 Nothing -> (text "void", empty)
718 Just t -> (text (showPrimRepToUser (typePrimRep t)),
719 text "extern" <+> cResType <+> res_name <> semi)
722 | cc == cCallConv = empty
723 | otherwise = pprCallConv cc
726 vcat (zipWith mkExtern cParamTypes param_names) $$
728 text "extern void" <+> h_stub_nm <> text "();"
730 mkExtern ty nm = text "extern" <+> ty <+> nm <> semi
732 c_args = zipWith (\ _ n -> text ('a':show n)) args [0..]
734 assignArgs p_nm c_arg = p_nm <+> equals <+> c_arg <> semi
739 Just _ -> text "return" <+> res_name <> semi
743 Nothing -> (empty, empty)
744 Just t -> (h_stub_nm <> text "_res", ppr (typePrimRep t))
746 declVar :: SDoc -> SDoc -> SDoc
747 declVar ty var = ty <+> var <> semi
753 f :: Int -> Int -> Int -> IO Int
755 we'll emit the following stuff into the .hc file
767 STK_CHK(LivenessReg,0/*A*/,(SIZE_IN_WORDS(StgInt) +
768 SIZE_IN_WORDS(StgInt) +
769 SIZE_IN_WORDS(StgInt) + 1)/*B*/, 0, 0, 0/*prim*/, 0/*re-enter*/);
770 RetReg = (StgRetAddr) UNVEC(stopds_fDirectReturn,vtbl_stopds_f);
772 *SpB = (W_)__f_param_3;
774 *SpB = (W_)__f_param_2;
776 *SpB = (W_)__f_param_1;
779 *SpB = (W_) realWorldZh_closure;
781 Node = ds_f_helper_closure;
783 InfoPtr=(D_)(INFO_PTR(Node));
784 JMP_(ENTRY_CODE(InfoPtr));
788 STGFUN(stop_ds_fDirectReturn)
793 RESUME(miniInterpretEnd);
797 const W_ vtbl_stopds_f[] = {
798 (W_) stopds_fDirectReturn,
799 (W_) stopds_fDirectReturn,
800 (W_) stopds_fDirectReturn,
801 (W_) stopds_fDirectReturn,
802 (W_) stopds_fDirectReturn,
803 (W_) stopds_fDirectReturn,
804 (W_) stopds_fDirectReturn,
805 (W_) stopds_fDirectReturn
813 extern StgInt __f_param_1;
814 extern StgInt __f_param_2;
815 extern StgInt __f_param_3;
816 extern StgInt __f_res;
819 extern void miniInterpret(StgAddr);
830 miniInterpret((StgAddr)ds_f);