From 9e9367d67db0f6c4834c1f706b10afffdfac86d4 Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 27 Jun 2002 15:38:58 +0000 Subject: [PATCH] [project @ 2002-06-27 15:38:56 by simonmar] Finally fix foreign export and foreign import "wrapper" so that exceptions raised during the call are handled properly rather than causing the RTS to bomb out. In particular, calling System.exitWith in a foreign export will cause the program to terminate cleanly with the desired exit code. All other exceptions are printed on stderr (and the program is terminated). Details: GHC.TopHandler.runMain is now called runIO, and has type IO a -> IO a (previously it had type IO a -> IO (), but that's not general enough for a foreign export). The stubs for foreign export and forein import "wrapper" now automatically wrap the computation in runIO or its dual, runNonIO. It turned out to be simpler to do it this way than to do the wrapping in Haskell land (plain foreign exports don't have wrappers in Haskell). --- ghc/compiler/deSugar/DsForeign.lhs | 14 +++++++++++--- ghc/compiler/prelude/PrelNames.lhs | 4 ++-- ghc/compiler/rename/RnEnv.lhs | 6 +++--- ghc/compiler/typecheck/TcModule.lhs | 16 ++++++++-------- ghc/includes/RtsAPI.h | 15 +++++++++++++-- ghc/rts/Prelude.h | 6 +++++- 6 files changed, 42 insertions(+), 19 deletions(-) diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 706b733..84f5529 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -462,9 +462,17 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc , text "SchedulerStatus rc;" , declareResult -- create the application + perform it. - , text (if is_IO_res_ty then "rc=rts_evalIO" else "rc=rts_eval") - <> parens (expr_to_run <+> comma <> text "&ret") - <> semi + , text "rc=rts_evalIO" <> parens ( + text "rts_apply" <> parens ( + text "(HaskellObj)" + <> text (if is_IO_res_ty + then "runIO_closure" + else "runNonIO_closure") + <> comma + <> expr_to_run + ) <+> comma + <> text "&ret" + ) <> semi , text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm) <> comma <> text "rc") <> semi , text "return" <> return_what <> semi diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index b99e354..b371077 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -97,7 +97,7 @@ knownKeyNames = [ -- Type constructors (synonyms especially) ioTyConName, ioDataConName, - runMainName, + runIOName, orderingTyConName, rationalTyConName, ratioDataConName, @@ -336,7 +336,7 @@ and it's convenient to write them all down in one place. \begin{code} dollarMainName = varQual mAIN_Name FSLIT("$main") dollarMainKey -runMainName = varQual pREL_TOP_HANDLER_Name FSLIT("runMain") runMainKey +runIOName = varQual pREL_TOP_HANDLER_Name FSLIT("runIO") runMainKey -- Stuff from GHC.Prim usOnceTyConName = kindQual FSLIT(".") usOnceTyConKey diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 30853d9..59c1b51 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -43,7 +43,7 @@ import Module ( ModuleName, moduleName, mkVanillaModule, import PrelNames ( mkUnboundName, derivingOccurrences, mAIN_Name, main_RDR_Unqual, - runMainName, intTyConName, + runIOName, intTyConName, boolTyConName, funTyConName, unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName, printName, @@ -567,7 +567,7 @@ ubiquitousNames checkMain ghci_mode mod_name gbl_env -- LOOKUP main IF WE'RE IN MODULE Main -- The main point of this is to drag in the declaration for 'main', - -- its in another module, and for the Prelude function 'runMain', + -- its in another module, and for the Prelude function 'runIO', -- so that the type checker will find them -- -- We have to return the main_name separately, because it's a @@ -582,7 +582,7 @@ checkMain ghci_mode mod_name gbl_env | otherwise = lookupSrcName gbl_env main_RDR_Unqual `thenRn` \ main_name -> - returnRn (Just main_name, unitFV main_name, unitFV runMainName) + returnRn (Just main_name, unitFV main_name, unitFV runIOName) where complain_no_main | ghci_mode == Interactive = addWarnRn noMainMsg diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 6f31598..342c623 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -18,7 +18,7 @@ import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..), isSourceInstDecl, mkSimpleMatch, placeHolderType, isCoreDecl ) import PrelNames ( ioTyConName, printName, - returnIOName, bindIOName, failIOName, thenIOName, runMainName, + returnIOName, bindIOName, failIOName, thenIOName, runIOName, dollarMainName, itName ) import MkId ( unsafeCoerceId ) @@ -751,10 +751,10 @@ We must check that in module Main, b) Main.main :: forall a1...an. IO t, for some type t Then we build - $main = PrelTopHandler.runMain Main.main + $main = GHC.TopHandler.runIO Main.main The function - PrelTopHandler :: IO a -> IO () + GHC.TopHandler.runIO :: IO a -> IO a catches the top level exceptions. It accepts a Main.main of any type (IO a). @@ -770,17 +770,17 @@ tcCheckMain (Just main_name) newTyVarTy liftedTypeKind `thenNF_Tc` \ ty -> tcMonoExpr rhs ty `thenTc` \ (main_expr, lie) -> zonkTcType ty `thenNF_Tc` \ ty -> - ASSERT( is_io_unit ty ) + ASSERT( is_io ty ) let dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) in returnTc (VarMonoBind dollar_main_id main_expr, lie) where - rhs = HsApp (HsVar runMainName) (HsVar main_name) + rhs = HsApp (HsVar runIOName) (HsVar main_name) -is_io_unit :: Type -> Bool -- True for IO () -is_io_unit tau = case tcSplitTyConApp_maybe tau of - Just (tc, [arg]) -> getName tc == ioTyConName && isUnitTy arg +is_io :: Type -> Bool -- True for IO a +is_io tau = case tcSplitTyConApp_maybe tau of + Just (tc, [_]) -> getName tc == ioTyConName other -> False mainCtxt = ptext SLIT("When checking the type of 'main'") diff --git a/ghc/includes/RtsAPI.h b/ghc/includes/RtsAPI.h index 7672dc6..20c9683 100644 --- a/ghc/includes/RtsAPI.h +++ b/ghc/includes/RtsAPI.h @@ -1,5 +1,5 @@ /* ---------------------------------------------------------------------------- - * $Id: RtsAPI.h,v 1.26 2002/02/15 07:23:02 sof Exp $ + * $Id: RtsAPI.h,v 1.27 2002/06/27 15:38:58 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -116,7 +116,18 @@ rts_evalLazyIO ( HaskellObj p, unsigned int stack_size, /*out*/HaskellObj *ret ) void rts_checkSchedStatus ( char* site, SchedulerStatus rc); -/* -------------------------------------------------------------------------- */ +/* -------------------------------------------------------------------------- + Wrapper closures + + These are used by foreign export and foreign import "wrapper" stubs. + ----------------------------------------------------------------------- */ + +extern DLL_IMPORT const StgClosure GHCziTopHandler_runIO_closure; +extern DLL_IMPORT const StgClosure GHCziTopHandler_runNonIO_closure; +#define runIO_closure (&GHCziTopHandler_runIO_closure) +#define runNonIO_closure (&GHCziTopHandler_runNonIO_closure) + +/* ------------------------------------------------------------------------ */ #ifdef __cplusplus } diff --git a/ghc/rts/Prelude.h b/ghc/rts/Prelude.h index c5a0bef..8a8212a 100644 --- a/ghc/rts/Prelude.h +++ b/ghc/rts/Prelude.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Prelude.h,v 1.19 2002/02/12 15:17:22 simonmar Exp $ + * $Id: Prelude.h,v 1.20 2002/06/27 15:38:58 simonmar Exp $ * * (c) The GHC Team, 1998-2001 * @@ -19,6 +19,8 @@ extern DLL_IMPORT const StgClosure GHCziBase_False_closure; extern DLL_IMPORT const StgClosure GHCziPack_unpackCString_closure; extern DLL_IMPORT const StgClosure GHCziWeak_runFinalizzerBatch_closure; extern const StgClosure Main_zdmain_closure; +extern DLL_IMPORT const StgClosure GHCziTopHandler_runIO_closure; +extern DLL_IMPORT const StgClosure GHCziTopHandler_runNonIO_closure; extern DLL_IMPORT const StgClosure GHCziIOBase_stackOverflow_closure; extern DLL_IMPORT const StgClosure GHCziIOBase_heapOverflow_closure; @@ -64,6 +66,8 @@ extern DLL_IMPORT const StgInfoTable GHCziStable_StablePtr_con_info; #define unpackCString_closure (&GHCziPack_unpackCString_closure) #define runFinalizerBatch_closure (&GHCziWeak_runFinalizzerBatch_closure) #define mainIO_closure (&Main_zdmain_closure) +#define runIO_closure (&GHCziTopHandler_runIO_closure) +#define runNonIO_closure (&GHCziTopHandler_runNonIO_closure) #define stackOverflow_closure (&GHCziIOBase_stackOverflow_closure) #define heapOverflow_closure (&GHCziIOBase_heapOverflow_closure) -- 1.7.10.4