From 3c10dbebec3f19e7107c8eb7df1a902390cd5be6 Mon Sep 17 00:00:00 2001 From: sewardj Date: Thu, 21 Feb 2002 14:42:17 +0000 Subject: [PATCH] [project @ 2002-02-21 14:42:17 by sewardj] In DsForeign.fexportEntry, track recent changes to f-x-dynamic implementation. At the same time completely rewrite this fn, since I couldn't figure out how the previous incarnation worked. --- ghc/compiler/deSugar/DsForeign.lhs | 125 ++++++++++++++++++++---------------- 1 file changed, 71 insertions(+), 54 deletions(-) diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 8d83f56..4072ded 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -97,7 +97,7 @@ dsForeigns mod_name fos = dsFExport mod_name id (idType id) ext_nm cconv False `thenDs` \(feb, b, h, c) -> warnDepr depr loc `thenDs` \_ -> - returnDs (feb:acc_feb, b : acc_f, h $$ acc_h, c $$ acc_c, acc_header) + returnDs (feb:acc_feb, b:acc_f, h $$ acc_h, c $$ acc_c, acc_header) warnDepr False _ = returnDs () warnDepr True loc = dsWarn (addShortWarnLocLine loc msg) @@ -325,8 +325,9 @@ dsFExport mod_name fn_id ty ext_name cconv isDyn the_body = mkLams (tvs ++ wrapper_args) the_app (h_stub, c_stub) = fexportEntry (moduleUserString mod) - ext_name f_helper_glob - wrapper_arg_tys res_ty cconv isDyn + ext_name + (if isDyn then Nothing else Just f_helper_glob) + fe_arg_tys res_ty cconv in returnDs (f_helper_glob, (f_helper_glob, the_body), h_stub, c_stub) @@ -381,7 +382,7 @@ dsFExportDynamic mod_name id cconv -- hack: need to get at the name of the C stub we're about to generate. fe_nm = _PK_ (moduleUserString mod_name ++ "_" ++ toCName fe_id) in - dsFExport mod_name id export_ty fe_nm cconv True `thenDs` \ (feb, fe, h_code, c_code) -> + dsFExport mod_name id export_ty fe_nm cconv True `thenDs` \ ({-feb-}_, {-fe-}_, h_code, c_code) -> newSysLocalDs arg_ty `thenDs` \ cback -> dsLookupGlobalValue newStablePtrName `thenDs` \ newStablePtrId -> let @@ -426,7 +427,7 @@ dsFExportDynamic mod_name id cconv -- Never inline the f.e.d. function, because the litlit -- might not be in scope in other modules. in - returnDs ([fed, fe], h_code, c_code) + returnDs ([fed] {-[fed, fe]-}, h_code, c_code) where ty = idType id @@ -453,23 +454,79 @@ using the hugs/ghc rts invocation API. \begin{code} fexportEntry :: String -> FAST_STRING - -> Id + -> Maybe Id -- Just==static, Nothing==dynamic -> [Type] -> Type -> CCallConv - -> Bool -> (SDoc, SDoc) -fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits) +fexportEntry mod_nm c_nm maybe_target arg_htys res_hty cc = (header_bits, c_bits) where - -- name of the (Haskell) helper function generated by the desugarer. - h_nm = ppr helper <> text "_closure" - -- prototype for the exported function. + -- Create up types and names for the real args + arg_cnames, arg_ctys :: [SDoc] + arg_cnames = mkCArgNames 1 arg_htys + arg_ctys = map showStgType arg_htys + + -- and also for auxiliary ones; the stable ptr in the dynamic case, and + -- a slot for the dummy return address in the dynamic + ccall case + extra_cnames_and_ctys + = case maybe_target of + Nothing -> [(text "the_stableptr", text "StgStablePtr")] + other -> [] + ++ + case (maybe_target, cc) of + (Nothing, CCallConv) -> [(text "original_return_addr", text "void*")] + other -> [] + + all_cnames_and_ctys :: [(SDoc, SDoc)] + all_cnames_and_ctys + = extra_cnames_and_ctys ++ zip arg_cnames arg_ctys + + -- stuff to do with the return type of the C function + res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes + + cResType | res_hty_is_unit = text "void" + | otherwise = showStgType res_hty + + -- Now we can cook up the prototype for the exported function. + pprCconv = case cc of + CCallConv -> empty + StdCallConv -> text (ccallConvAttribute cc) + header_bits = ptext SLIT("extern") <+> fun_proto <> semi fun_proto = cResType <+> pprCconv <+> ptext c_nm <> - parens (hsep (punctuate comma (zipWith (<+>) cParamTypes proto_args))) - + parens (hsep (punctuate comma (map (\(nm,ty) -> ty <+> nm) + all_cnames_and_ctys))) + + -- the target which will form the root of what we ask rts_evalIO to run + the_cfun + = case maybe_target of + Nothing -> text "(StgClosure*)deRefStablePtr(the_stableptr)" + Just hs_fn -> ppr hs_fn <> text "_closure" + + -- the expression we give to rts_evalIO + expr_to_run + = foldl appArg the_cfun (zip arg_cnames arg_htys) + where + appArg acc (arg_cname, arg_hty) + = text "rts_apply" + <> parens (acc <> comma <> mkHObj arg_hty <> parens arg_cname) + + -- various other bits for inside the fn + declareResult = text "HaskellObj ret;" + + return_what | res_hty_is_unit = empty + | otherwise = parens (unpackHObj res_hty <> parens (text "ret")) + + -- an extern decl for the fn being called + extern_decl + = case maybe_target of + Nothing -> empty + Just hs_fn -> text "extern StgClosure* " <> ppr hs_fn <> text "_closure" <> semi + + -- finally, the whole darn thing c_bits = + extern_decl $$ fun_proto $$ vcat [ lbrace @@ -477,11 +534,7 @@ fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits) , declareResult -- create the application + perform it. , text "rc=rts_evalIO" - <> parens (foldl appArg (text "(StgClosure*)deRefStablePtr(a0)") - (tail (zip args c_args)) - <> comma - <> text "&ret" - ) + <> parens (expr_to_run <+> comma <> text "&ret") <> semi , text "rts_checkSchedStatus" <> parens (doubleQuotes (ptext c_nm) <> comma <> text "rc") <> semi @@ -489,42 +542,6 @@ fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits) , rbrace ] - appArg acc (a,c_a) = - text "rts_apply" <> parens (acc <> comma <> mkHObj a <> parens c_a) - - cParamTypes = map showStgType real_args - - res_ty_is_unit = res_ty `eqType` unitTy -- Look through any newtypes - - cResType | res_ty_is_unit = text "void" - | otherwise = showStgType res_ty - - pprCconv = case cc of - CCallConv -> empty - StdCallConv -> text (ccallConvAttribute cc) - - declareResult = text "HaskellObj ret;" - - mkExtern ty nm = text "extern" <+> ty <+> nm <> semi - - return_what | res_ty_is_unit = empty - | otherwise = parens (unpackHObj res_ty <> parens (text "ret")) - - 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) - = case cc of - CCallConv | isDyn -> ( text "a0" : text "original_return_addr" - : mkCArgNames 1 (tail args) - , head args : addrTy : tail args) - other -> (mkCArgNames 0 args, args) mkCArgNames :: Int -> [a] -> [SDoc] mkCArgNames n as = zipWith (\ _ n -> text ('a':show n)) as [n..] -- 1.7.10.4