X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsForeign.lhs;h=6c7ad10dc2cb78acde4f0e47a38d67cb7be60aa3;hb=cefef1567861563d7ca427bf172f675f6bba86f1;hp=6efaea41c52b73a6d142480bf5d770497ccadc3f;hpb=69e14f75a4b031e489b7774914e5a176409cea78;p=ghc-hetmet.git diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 6efaea4..6c7ad10 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -12,50 +12,54 @@ module DsForeign ( dsForeigns ) where import CoreSyn -import DsCCall ( dsCCall, boxResult, unboxArg, wrapUnboxedValue ) +import DsCCall ( dsCCall, mkCCall, boxResult, unboxArg, resultWrapper ) import DsMonad -import DsUtils -import HsSyn ( ExtName(..), ForeignDecl(..), isDynamic, ForKind(..) ) +import HsSyn ( ExtName(..), ForeignDecl(..), isDynamicExtName, ForKind(..) ) +import HsDecls ( extNameStatic ) import CallConv import TcHsSyn ( TypecheckedForeignDecl ) -import CoreUtils ( coreExprType ) -import Const ( Con(..), mkMachInt ) -import DataCon ( DataCon, dataConId ) -import Id ( Id, idType, idName, mkWildId, mkVanillaId ) -import Const ( Literal(..) ) -import Module ( Module ) +import CoreUtils ( exprType, mkInlineMe ) +import Id ( Id, idType, idName, mkVanillaId, mkSysLocal, + setInlinePragma ) +import IdInfo ( neverInlinePrag ) +import Literal ( Literal(..) ) +import Module ( Module, moduleUserString ) import Name ( mkGlobalName, nameModule, nameOccName, getOccString, mkForeignExportOcc, isLocalName, NamedThing(..), Provenance(..), ExportFlag(..) ) -import PrelInfo ( deRefStablePtr_NAME, bindIO_NAME, makeStablePtr_NAME, realWorldPrimId ) -import Type ( splitAlgTyConApp_maybe, +import Type ( unUsgTy, repType, splitTyConApp_maybe, splitFunTys, splitForAllTys, Type, mkFunTys, mkForAllTys, mkTyConApp, - mkTyVarTy, mkFunTy, splitAppTy + mkTyVarTy, mkFunTy, splitAppTy, applyTy, funResultTy ) -import PrimOp ( PrimOp(..) ) -import Var ( TyVar ) -import TysPrim ( realWorldStatePrimTy, addrPrimTy ) -import TysWiredIn ( unitTyCon, addrTy, stablePtrTyCon, - unboxedTupleCon, addrDataCon +import PrimOp ( PrimOp(..), CCall(..), + CCallTarget(..), dynamicTarget ) +import TysWiredIn ( unitTy, addrTy, stablePtrTyCon, + addrDataCon ) -import Unique +import TysPrim ( addrPrimTy ) +import Unique ( Uniquable(..), hasKey, + ioTyConKey, deRefStablePtrIdKey, returnIOIdKey, + bindIOIdKey, makeStablePtrIdKey + ) import Outputable + +import Maybe ( fromJust ) \end{code} Desugaring of @foreign@ declarations is naturally split up into parts, an @import@ and an @export@ part. A @foreign import@ -declaration - +declaration +\begin{verbatim} foreign import cc nm f :: prim_args -> IO prim_res - +\end{verbatim} is the same as - +\begin{verbatim} f :: prim_args -> IO prim_res f a1 ... an = _ccall_ nm cc a1 ... an - +\end{verbatim} so we reuse the desugaring code in @DsCCall@ to deal with these. \begin{code} @@ -63,19 +67,21 @@ dsForeigns :: Module -> [TypecheckedForeignDecl] -> DsM ( [CoreBind] -- desugared foreign imports , [CoreBind] -- helper functions for foreign exports - , SDoc -- Header file prototypes for "foreign exported" functions. - , SDoc -- C stubs to use when calling "foreign exported" funs. + , SDoc -- Header file prototypes for + -- "foreign exported" functions. + , SDoc -- C stubs to use when calling + -- "foreign exported" functions. ) dsForeigns mod_name fos = foldlDs combine ([],[],empty,empty) fos where combine (acc_fi, acc_fe, acc_h, acc_c) fo@(ForeignDecl i imp_exp _ ext_nm cconv _) | isForeignImport = -- foreign import (dynamic)? - dsFImport i (idType i) uns ext_nm cconv `thenDs` \ b -> - returnDs (b:acc_fi, acc_fe, acc_h, acc_c) + dsFImport i (idType i) uns ext_nm cconv `thenDs` \ bs -> + returnDs (bs ++ acc_fi, acc_fe, acc_h, acc_c) | isForeignLabel = - dsFLabel i ext_nm `thenDs` \ b -> + dsFLabel i (idType i) ext_nm `thenDs` \ b -> returnDs (b:acc_fi, acc_fe, acc_h, acc_c) - | isDynamic ext_nm = + | isDynamicExtName ext_nm = dsFExportDynamic i (idType i) mod_name ext_nm cconv `thenDs` \ (fi,fe,h,c) -> returnDs (fi:acc_fi, fe:acc_fe, h $$ acc_h, c $$ acc_c) @@ -99,7 +105,22 @@ dsForeigns mod_name fos = foldlDs combine ([],[],empty,empty) fos Desugaring foreign imports is just the matter of creating a binding that on its RHS unboxes its arguments, performs the external call -(using the CCallOp primop), before boxing the result up and returning it. +(using the @CCallOp@ primop), before boxing the result up and returning it. + +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. + \begin{code} dsFImport :: Id @@ -107,110 +128,61 @@ dsFImport :: Id -> Bool -- True <=> might cause Haskell GC -> ExtName -> CallConv - -> DsM CoreBind -dsFImport nm ty may_not_gc ext_name cconv = - newSysLocalDs realWorldStatePrimTy `thenDs` \ old_s -> - splitForeignTyDs ty `thenDs` \ (tvs, args, mbIoDataCon, io_res_ty) -> - let - the_state_arg - | is_io_action = old_s - | otherwise = realWorldPrimId - - arg_exprs = map (Var) args - - is_io_action = - case mbIoDataCon of - Nothing -> False - _ -> True + -> DsM [CoreBind] +dsFImport fn_id ty may_not_gc ext_name cconv + = let + (tvs, fun_ty) = splitForAllTys ty + (arg_tys, io_res_ty) = splitFunTys fun_ty in - mapAndUnzipDs unboxArg arg_exprs `thenDs` \ (unboxed_args, arg_wrappers) -> - (if not is_io_action then - newSysLocalDs realWorldStatePrimTy `thenDs` \ state_tok -> - wrapUnboxedValue io_res_ty `thenDs` \ (ccall_result_ty, v, res_v) -> - returnDs ( ccall_result_ty - , \ prim_app -> Case prim_app (mkWildId ccall_result_ty) - [(DataCon (unboxedTupleCon 2), [state_tok, v], res_v)]) - else - boxResult io_res_ty) `thenDs` \ (final_result_ty, res_wrapper) -> - (case ext_name of - Dynamic -> getUniqueDs `thenDs` \ u -> - returnDs (Right u) - ExtName fs _ -> returnDs (Left fs)) `thenDs` \ label -> - let - val_args = Var the_state_arg : unboxed_args - final_args = Type inst_ty : val_args - - -- A CCallOp has type (forall a. a), so we must instantiate - -- it at the full type, including the state argument - inst_ty = mkFunTys (map coreExprType val_args) final_result_ty - - the_ccall_op = CCallOp label False (not may_not_gc) cconv - - the_prim_app = mkPrimApp the_ccall_op (final_args :: [CoreArg]) - - body = foldr ($) (res_wrapper the_prim_app) arg_wrappers + newSysLocalsDs arg_tys `thenDs` \ args -> + mapAndUnzipDs unboxArg (map Var args) `thenDs` \ (val_args, arg_wrappers) -> + boxResult io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) -> - the_body - | not is_io_action = body - | otherwise = Lam old_s body - in - newSysLocalDs (coreExprType the_body) `thenDs` \ ds -> + getUniqueDs `thenDs` \ ccall_uniq -> + getUniqueDs `thenDs` \ work_uniq -> let - io_app = - case mbIoDataCon of - Nothing -> Var ds - Just ioDataCon -> - mkApps (Var (dataConId ioDataCon)) - [Type io_res_ty, Var ds] - - fo_rhs = mkLams (tvs ++ args) - (mkDsLet (NonRec ds (the_body::CoreExpr)) io_app) + lbl = case ext_name of + Dynamic -> dynamicTarget + ExtName fs _ -> StaticTarget fs + + -- 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) + work_id = mkSysLocal SLIT("$wccall") work_uniq worker_ty + + -- Build the wrapper + work_app = mkApps (mkVarApps (Var work_id) tvs) val_args + wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers + wrap_rhs = mkInlineMe (mkLams (tvs ++ args) wrapper_body) in - returnDs (NonRec nm fo_rhs) + returnDs [NonRec work_id work_rhs, NonRec fn_id wrap_rhs] \end{code} -Given the type of a foreign import declaration, split it up into -its constituent parts. +Foreign labels \begin{code} -splitForeignTyDs :: Type -> DsM ([TyVar], [Id], Maybe DataCon, Type) -splitForeignTyDs ty = - newSysLocalsDs arg_tys `thenDs` \ ds_args -> - case splitAlgTyConApp_maybe res_ty of - Just (_,(io_res_ty:_),(ioCon:_)) -> -- .... -> IO t - returnDs (tvs, ds_args, Just ioCon, io_res_ty) - _ -> -- .... -> t - returnDs (tvs, ds_args, Nothing, res_ty) +dsFLabel :: Id -> Type -> ExtName -> DsM CoreBind +dsFLabel nm ty ext_name = + ASSERT(fromJust res_ty == addrPrimTy) -- typechecker ensures this + returnDs (NonRec nm (fo_rhs (mkLit (MachLabel enm)))) where - (arg_tys, res_ty) = splitFunTys sans_foralls - (tvs, sans_foralls) = splitForAllTys ty - + (res_ty, fo_rhs) = resultWrapper ty + enm = extNameStatic ext_name \end{code} -foreign labels - -\begin{code} -dsFLabel :: Id -> ExtName -> DsM CoreBind -dsFLabel nm ext_name = returnDs (NonRec nm fo_rhs) - where - fo_rhs = mkConApp addrDataCon [mkLit (MachLitLit enm addrPrimTy)] - enm = - case ext_name of - ExtName f _ -> f - Dynamic -> panic "dsFLabel: Dynamic - shouldn't ever happen." - -\end{code} - -The function that does most of the work for 'foreign export' declarations. -(see below for the boilerplate code a 'foreign export' declaration expands +The function that does most of the work for `@foreign export@' declarations. +(see below for the boilerplate code a `@foreign export@' declaration expands into.) -For each 'foreign export foo' in a module M we generate: - -* a C function 'foo', which calls -* a Haskell stub 'M.$ffoo', which calls - -the user-written Haskell function 'M.foo'. +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@'. \begin{code} dsFExport :: Id @@ -224,138 +196,119 @@ dsFExport :: Id , SDoc , SDoc ) -dsFExport i ty mod_name ext_name cconv isDyn = - getUniqueDs `thenDs` \ uniq -> - getSrcLocDs `thenDs` \ src_loc -> - let - f_helper_glob = mkVanillaId helper_name helper_ty - where - name = idName i - mod - | isLocalName name = mod_name - | otherwise = nameModule name - - occ = mkForeignExportOcc (nameOccName name) - prov = LocalDef src_loc Exported - helper_name = mkGlobalName uniq mod occ prov - in - newSysLocalsDs fe_arg_tys `thenDs` \ fe_args -> +dsFExport fn_id ty mod_name ext_name cconv isDyn + = -- 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]) + -> ASSERT( ioTyCon `hasKey` ioTyConKey ) + -- 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 + dsLookupGlobalValue returnIOIdKey `thenDs` \ retIOId -> + 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 (if isDyn then newSysLocalDs stbl_ptr_ty `thenDs` \ stbl_ptr -> newSysLocalDs stbl_ptr_to_ty `thenDs` \ stbl_value -> - dsLookupGlobalValue deRefStablePtr_NAME `thenDs` \ deRefStablePtrId -> + dsLookupGlobalValue deRefStablePtrIdKey `thenDs` \ deRefStablePtrId -> + dsLookupGlobalValue bindIOIdKey `thenDs` \ bindIOId -> let the_deref_app = mkApps (Var deRefStablePtrId) [ Type stbl_ptr_to_ty, Var stbl_ptr ] - in - newSysLocalDs (coreExprType the_deref_app) `thenDs` \ x_deref_app -> - dsLookupGlobalValue bindIO_NAME `thenDs` \ bindIOId -> - newSysLocalDs (mkFunTy stbl_ptr_to_ty - (mkTyConApp ioTyCon [res_ty])) `thenDs` \ x_cont -> - let - stbl_app = \ cont -> - bindNonRec x_cont (mkLams [stbl_value] cont) $ - bindNonRec x_deref_app the_deref_app - (mkApps (Var bindIOId) - [ Type stbl_ptr_to_ty - , Type res_ty - , Var x_deref_app - , Var x_cont]) + + stbl_app cont = mkApps (Var bindIOId) + [ Type stbl_ptr_to_ty + , Type res_ty + , the_deref_app + , mkLams [stbl_value] cont] in returnDs (stbl_value, stbl_app, stbl_ptr) else - returnDs (i, + returnDs (fn_id, \ body -> body, panic "stbl_ptr" -- should never be touched. - )) `thenDs` \ (i, getFun_wrapper, stbl_ptr) -> - let - wrapper_args - | isDyn = stbl_ptr:fe_args - | otherwise = fe_args + )) `thenDs` \ (i, getFun_wrapper, stbl_ptr) -> - wrapper_arg_tys - | isDyn = stbl_ptr_ty:helper_arg_tys - | otherwise = helper_arg_tys - the_app = - getFun_wrapper $ - mkApps (Var i) (map (Type . mkTyVarTy) tvs ++ map Var fe_args) - in - getModuleAndGroupDs `thenDs` \ (mod,_) -> + -- BUILD THE HELPER + getModuleDs `thenDs` \ mod -> getUniqueDs `thenDs` \ uniq -> + getSrcLocDs `thenDs` \ src_loc -> + newSysLocalsDs fe_arg_tys `thenDs` \ fe_args -> let - the_body = mkLams (tvs ++ wrapper_args) the_app + wrapper_args | isDyn = stbl_ptr:fe_args + | otherwise = fe_args + + 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 + + f_helper_glob = mkVanillaId helper_name helper_ty + where + name = idName fn_id + mod + | isLocalName name = mod_name + | otherwise = nameModule name - c_nm = - case ext_name of - ExtName fs _ -> fs - Dynamic -> panic "dsFExport: Dynamic - shouldn't ever happen." + occ = mkForeignExportOcc (nameOccName name) + prov = LocalDef src_loc Exported + helper_name = mkGlobalName uniq mod occ prov - (h_stub, c_stub) = fexportEntry c_nm f_helper_glob wrapper_arg_tys the_result_ty cconv isDyn + 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) + c_nm f_helper_glob + wrapper_arg_tys res_ty cconv isDyn in returnDs (NonRec f_helper_glob the_body, h_stub, c_stub) where - (tvs,sans_foralls) = splitForAllTys ty - (fe_arg_tys', io_res) = splitFunTys sans_foralls - - - Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res + (fe_arg_tys', orig_res_ty) = splitFunTys sans_foralls (_, stbl_ptr_ty') = splitForAllTys stbl_ptr_ty (_, stbl_ptr_to_ty) = splitAppTy stbl_ptr_ty' - fe_arg_tys - | isDyn = tail fe_arg_tys' - | otherwise = fe_arg_tys' - - (stbl_ptr_ty, helper_arg_tys) = - case fe_arg_tys' of - (x:xs) | isDyn -> (x,xs) - ls -> (error "stbl_ptr_ty", ls) - - helper_ty = - mkForAllTys tvs $ - mkFunTys arg_tys io_res - where - arg_tys - | isDyn = stbl_ptr_ty : helper_arg_tys - | otherwise = helper_arg_tys - - the_result_ty = - case splitTyConApp_maybe io_res of - Just (_,[res_ty]) -> - case splitTyConApp_maybe res_ty of - Just (tc,_) | getUnique tc /= getUnique unitTyCon -> Just res_ty - _ -> Nothing - _ -> Nothing - + 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" \end{code} -"foreign export dynamic" lets you dress up Haskell IO actions +@foreign export dynamic@ lets you dress up Haskell IO actions of some fixed type behind an externally callable interface (i.e., as a C function pointer). Useful for callbacks and stuff. \begin{verbatim} -foreign export stdcall f :: (Addr -> Int -> IO Int) -> IO Addr +foreign export dynamic f :: (Addr -> Int -> IO Int) -> IO Addr --- Haskell-visible constructor, which is generated from the --- above: +-- Haskell-visible constructor, which is generated from the above: +-- SUP: No check for NULL from createAdjustor anymore??? f :: (Addr -> Int -> IO Int) -> IO Addr -f cback = IO ( \ s1# -> - case makeStablePtr# cback s1# of { StateAndStablePtr# s2# sp# -> - case _ccall_ "mkAdjustor" sp# ``f_helper'' s2# of - StateAndAddr# s3# a# -> - case addr2Int# a# of - 0# -> IOfail s# err - _ -> - let - a :: Addr - a = A# a# - in - IOok s3# a) +f cback = + bindIO (makeStablePtr cback) + (\StablePtr sp# -> IO (\s1# -> + case _ccall_ createAdjustor cconv sp# ``f_helper'' s1# of + (# s2#, a# #) -> (# s2#, A# a# #))) 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 @@ -373,29 +326,26 @@ dsFExportDynamic i ty mod_name ext_name cconv = newSysLocalDs ty `thenDs` \ fe_id -> let -- hack: need to get at the name of the C stub we're about to generate. - fe_nm = toCName fe_id + fe_nm = moduleUserString mod_name ++ "_" ++ toCName fe_id fe_ext_name = ExtName (_PK_ fe_nm) Nothing in - dsFExport i export_ty mod_name fe_ext_name cconv True `thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) -> - newSysLocalDs arg_ty `thenDs` \ cback -> - dsLookupGlobalValue makeStablePtr_NAME `thenDs` \ makeStablePtrId -> + dsFExport i export_ty mod_name fe_ext_name cconv True + `thenDs` \ (fe@(NonRec fe_helper fe_expr), h_code, c_code) -> + newSysLocalDs arg_ty `thenDs` \ cback -> + dsLookupGlobalValue makeStablePtrIdKey `thenDs` \ makeStablePtrId -> let mk_stbl_ptr_app = mkApps (Var makeStablePtrId) [ Type arg_ty, Var cback ] - mk_stbl_ptr_app_ty = coreExprType mk_stbl_ptr_app in - newSysLocalDs mk_stbl_ptr_app_ty `thenDs` \ x_mk_stbl_ptr_app -> - dsLookupGlobalValue bindIO_NAME `thenDs` \ bindIOId -> + dsLookupGlobalValue bindIOIdKey `thenDs` \ bindIOId -> newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value -> let - stbl_app = \ x_cont cont ret_ty -> - bindNonRec x_cont cont $ - bindNonRec x_mk_stbl_ptr_app mk_stbl_ptr_app $ - (mkApps (Var bindIOId) - [ Type (mkTyConApp stablePtrTyCon [arg_ty]) - , Type ret_ty - , Var x_mk_stbl_ptr_app - , Var x_cont - ]) + stbl_app cont ret_ty + = mkApps (Var bindIOId) + [ Type (mkTyConApp stablePtrTyCon [arg_ty]) + , Type ret_ty + , mk_stbl_ptr_app + , cont + ] {- The arguments to the external function which will @@ -404,42 +354,41 @@ dsFExportDynamic i ty mod_name ext_name cconv = to be entered using an external calling convention (stdcall, ccall). -} - adj_args = [ mkLit (mkMachInt (fromInt (callConvToInt cconv))) + adj_args = [ mkIntLitInt (callConvToInt cconv) , Var stbl_value - , mkLit (MachLitLit (_PK_ fe_nm) addrPrimTy) + , mkLit (MachLabel (_PK_ fe_nm)) ] -- name of external entry point providing these services. -- (probably in the RTS.) adjustor = SLIT("createAdjustor") in - dsCCall adjustor adj_args False False addrTy `thenDs` \ ccall_adj -> - let ccall_adj_ty = coreExprType ccall_adj - in - newSysLocalDs ccall_adj_ty `thenDs` \ x_ccall_adj -> - let ccall_io_adj = - mkLams [stbl_value] $ - bindNonRec x_ccall_adj ccall_adj $ - Note (Coerce (mkTyConApp ioTyCon [res_ty]) ccall_adj_ty) - (Var x_ccall_adj) + dsCCall adjustor adj_args False False io_res_ty `thenDs` \ ccall_adj -> + let ccall_adj_ty = exprType ccall_adj + ccall_io_adj = mkLams [stbl_value] $ + Note (Coerce io_res_ty (unUsgTy ccall_adj_ty)) + ccall_adj in - newSysLocalDs (coreExprType ccall_io_adj) `thenDs` \ x_ccall_io_adj -> let io_app = mkLams tvs $ mkLams [cback] $ - stbl_app x_ccall_io_adj ccall_io_adj addrTy + stbl_app ccall_io_adj res_ty in - returnDs (NonRec i io_app, fe, h_code, c_code) + -- Never inline the f.e.d. function, because the litlit might not be in scope + -- in other modules. + returnDs (NonRec (i `setInlinePragma` neverInlinePrag) io_app, fe, h_code, c_code) where (tvs,sans_foralls) = splitForAllTys ty - ([arg_ty], io_res) = splitFunTys sans_foralls + ([arg_ty], io_res_ty) = splitFunTys sans_foralls - Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res + Just (ioTyCon, [res_ty]) = splitTyConApp_maybe io_res_ty export_ty = mkFunTy (mkTyConApp stablePtrTyCon [arg_ty]) arg_ty + ioAddrTy :: Type -- IO Addr + ioAddrTy = mkTyConApp ioTyCon [addrTy] + toCName :: Id -> String toCName i = showSDoc (pprCode CStyle (ppr (idName i))) - \end{code} %* @@ -453,14 +402,15 @@ The C stub constructs the application of the exported Haskell function using the hugs/ghc rts invocation API. \begin{code} -fexportEntry :: FAST_STRING +fexportEntry :: String + -> FAST_STRING -> Id -> [Type] - -> Maybe Type + -> Type -> CallConv -> Bool -> (SDoc, SDoc) -fexportEntry c_nm helper args res cc isDyn = (header_bits, c_bits) +fexportEntry mod_nm c_nm helper args res_ty cc isDyn = (header_bits, c_bits) where -- name of the (Haskell) helper function generated by the desugarer. h_nm = ppr helper <> text "_closure" @@ -480,7 +430,9 @@ fexportEntry c_nm helper args res cc isDyn = (header_bits, c_bits) -- create the application + perform it. , text "rc=rts_evalIO" <> parens (foldl appArg (text "(StgClosure*)&" <> h_nm) (zip args c_args) <> comma <> text "&ret") <> semi - , returnResult + , text "rts_checkSchedStatus" <> parens (doubleQuotes (ptext c_nm) + <> comma <> text "rc") <> semi + , text "return" <> return_what <> semi , rbrace ] @@ -489,10 +441,10 @@ fexportEntry c_nm helper args res cc isDyn = (header_bits, c_bits) cParamTypes = map showStgType real_args - cResType = - case res of - Nothing -> text "void" - Just t -> showStgType t + res_ty_is_unit = res_ty == unitTy + + cResType | res_ty_is_unit = text "void" + | otherwise = showStgType res_ty pprCconv | cc == cCallConv = empty @@ -504,17 +456,8 @@ fexportEntry c_nm helper args res cc isDyn = (header_bits, c_bits) mkExtern ty nm = text "extern" <+> ty <+> nm <> semi - returnResult = - text "rts_checkSchedStatus" <> - parens (doubleQuotes (ptext c_nm) <> comma <> text "rc") <> semi $$ - (case res of - Nothing -> text "return" - Just _ -> text "return" <> parens (res_name)) <> semi - - res_name = - case res of - Nothing -> empty - Just t -> unpackHObj t <> parens (text "ret") + return_what | res_ty_is_unit = empty + | otherwise = parens (unpackHObj res_ty <> parens (text "ret")) c_args = mkCArgNames 0 args @@ -545,7 +488,7 @@ showStgType t = text "Stg" <> text (showFFIType t) showFFIType :: Type -> String showFFIType t = getOccString (getName tc) where - tc = case splitTyConApp_maybe t of + tc = case splitTyConApp_maybe (repType t) of Just (tc,_) -> tc Nothing -> pprPanic "showFFIType" (ppr t) \end{code}