From 0731082288212fbc6d68204b609f201b8a79149a Mon Sep 17 00:00:00 2001 From: Norman Ramsey Date: Mon, 20 Aug 2007 16:41:05 +0000 Subject: [PATCH] annotate C-- calls that do not return * The correct definition of C-- requires that a procedure not 'fall off the end'. The 'never returns' annotation tells us if a (foreign) call is not going to return. Validated! --- compiler/cmm/Cmm.hs | 4 +++ compiler/cmm/CmmLex.x | 4 +++ compiler/cmm/CmmParse.y | 13 +++++++-- compiler/main/GHC.hs | 2 +- rts/Apply.cmm | 2 +- rts/PrimOps.cmm | 12 ++++---- rts/StgMiscClosures.cmm | 68 ++++++++++++++++++++++---------------------- utils/genapply/GenApply.hs | 2 +- 8 files changed, 61 insertions(+), 46 deletions(-) diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 5b3ad16..442eb60 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -12,6 +12,7 @@ module Cmm ( CmmInfo(..), UpdateFrame(..), CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag, GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, + ReturnInfo(..), CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals, CmmSafety(..), CmmCallTarget(..), @@ -140,6 +141,9 @@ data ClosureTypeInfo [Maybe LocalReg] -- Forced stack parameters C_SRT +data ReturnInfo = MayReturn + | NeverReturns + -- TODO: These types may need refinement data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc type ClosureTypeTag = StgHalfWord diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x index ec9f585..5b8aa98 100644 --- a/compiler/cmm/CmmLex.x +++ b/compiler/cmm/CmmLex.x @@ -138,8 +138,10 @@ data CmmToken | CmmT_if | CmmT_jump | CmmT_foreign + | CmmT_never | CmmT_prim | CmmT_return + | CmmT_returns | CmmT_import | CmmT_switch | CmmT_case @@ -214,8 +216,10 @@ reservedWordsFM = listToUFM $ ( "if", CmmT_if ), ( "jump", CmmT_jump ), ( "foreign", CmmT_foreign ), + ( "never", CmmT_never ), ( "prim", CmmT_prim ), ( "return", CmmT_return ), + ( "returns", CmmT_returns ), ( "import", CmmT_import ), ( "switch", CmmT_switch ), ( "case", CmmT_case ), diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index c2dd22f..bce6f27 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -103,8 +103,10 @@ import System.Exit 'if' { L _ (CmmT_if) } 'jump' { L _ (CmmT_jump) } 'foreign' { L _ (CmmT_foreign) } + 'never' { L _ (CmmT_never) } 'prim' { L _ (CmmT_prim) } 'return' { L _ (CmmT_return) } + 'returns' { L _ (CmmT_returns) } 'import' { L _ (CmmT_import) } 'switch' { L _ (CmmT_switch) } 'case' { L _ (CmmT_case) } @@ -318,8 +320,8 @@ stmt :: { ExtCode } -- we tweak the syntax to avoid the conflict. The later -- option is taken here because the other way would require -- multiple levels of expanding and get unwieldy. - | maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' safety vols ';' - {% foreignCall $3 $1 $4 $6 $9 $8 } + | maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' safety vols opt_never_returns ';' + {% foreignCall $3 $1 $4 $6 $9 $8 $10 } | maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' safety vols ';' {% primCall $1 $4 $6 $9 $8 } -- stmt-level macros, stealing syntax from ordinary C-- function calls. @@ -337,6 +339,10 @@ stmt :: { ExtCode } | 'if' bool_expr '{' body '}' else { ifThenElse $2 $4 $6 } +opt_never_returns :: { ReturnInfo } + : { MayReturn } + | 'never' 'returns' { NeverReturns } + bool_expr :: { ExtFCode BoolExpr } : bool_op { $1 } | expr { do e <- $1; return (BoolTest e) } @@ -867,8 +873,9 @@ foreignCall -> [ExtFCode (CmmExpr,MachHint)] -> Maybe [GlobalReg] -> CmmSafety + -> ReturnInfo -> P ExtCode -foreignCall conv_string results_code expr_code args_code vols safety +foreignCall conv_string results_code expr_code args_code vols safety _ret = do convention <- case conv_string of "C" -> return CCallConv "C--" -> return CmmCallConv diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index dcfd02a..1fc3605 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -1987,4 +1987,4 @@ findModule' hsc_env mod_name maybe_pkg = getHistorySpan :: Session -> History -> IO SrcSpan getHistorySpan sess h = withSession sess $ \hsc_env -> return$ InteractiveEval.getHistorySpan hsc_env h -#endif \ No newline at end of file +#endif diff --git a/rts/Apply.cmm b/rts/Apply.cmm index cf8a108..c9c7daa 100644 --- a/rts/Apply.cmm +++ b/rts/Apply.cmm @@ -58,7 +58,7 @@ stg_ap_0_fast -------------------------------------------------------------------------- */ INFO_TABLE(stg_PAP,/*special layout*/0,0,PAP,"PAP","PAP") -{ foreign "C" barf("PAP object entered!"); } +{ foreign "C" barf("PAP object entered!") never returns; } stg_PAP_apply { diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm index 4cce586..f3f23d6 100644 --- a/rts/PrimOps.cmm +++ b/rts/PrimOps.cmm @@ -1969,7 +1969,7 @@ waitReadzh_fast { /* args: R1 */ #ifdef THREADED_RTS - foreign "C" barf("waitRead# on threaded RTS"); + foreign "C" barf("waitRead# on threaded RTS") never returns; #else ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); @@ -1986,7 +1986,7 @@ waitWritezh_fast { /* args: R1 */ #ifdef THREADED_RTS - foreign "C" barf("waitWrite# on threaded RTS"); + foreign "C" barf("waitWrite# on threaded RTS") never returns; #else ASSERT(StgTSO_why_blocked(CurrentTSO) == NotBlocked::I16); @@ -2011,7 +2011,7 @@ delayzh_fast #endif #ifdef THREADED_RTS - foreign "C" barf("delay# on threaded RTS"); + foreign "C" barf("delay# on threaded RTS") never returns; #else /* args: R1 (microsecond delay amount) */ @@ -2077,7 +2077,7 @@ asyncReadzh_fast CInt reqID; #ifdef THREADED_RTS - foreign "C" barf("asyncRead# on threaded RTS"); + foreign "C" barf("asyncRead# on threaded RTS") never returns; #else /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */ @@ -2105,7 +2105,7 @@ asyncWritezh_fast CInt reqID; #ifdef THREADED_RTS - foreign "C" barf("asyncWrite# on threaded RTS"); + foreign "C" barf("asyncWrite# on threaded RTS") never returns; #else /* args: R1 = fd, R2 = isSock, R3 = len, R4 = buf */ @@ -2133,7 +2133,7 @@ asyncDoProczh_fast CInt reqID; #ifdef THREADED_RTS - foreign "C" barf("asyncDoProc# on threaded RTS"); + foreign "C" barf("asyncDoProc# on threaded RTS") never returns; #else /* args: R1 = proc, R2 = param */ diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm index c6cc541..9e1eaf9 100644 --- a/rts/StgMiscClosures.cmm +++ b/rts/StgMiscClosures.cmm @@ -343,13 +343,13 @@ INFO_TABLE(stg_RBH,1,1,RBH,"RBH","RBH") } INFO_TABLE(stg_RBH_Save_0,0,2,CONSTR,"RBH_Save_0","RBH_Save_0") -{ foreign "C" barf("RBH_Save_0 object entered!"); } +{ foreign "C" barf("RBH_Save_0 object entered!") never returns; } INFO_TABLE(stg_RBH_Save_1,1,1,CONSTR,"RBH_Save_1","RBH_Save_1"); -{ foreign "C" barf("RBH_Save_1 object entered!"); } +{ foreign "C" barf("RBH_Save_1 object entered!") never returns; } INFO_TABLE(stg_RBH_Save_2,2,0,CONSTR,"RBH_Save_2","RBH_Save_2"); -{ foreign "C" barf("RBH_Save_2 object entered!"); } +{ foreign "C" barf("RBH_Save_2 object entered!") never returns; } #endif /* defined(PAR) || defined(GRAN) */ @@ -386,10 +386,10 @@ INFO_TABLE(stg_CAF_BLACKHOLE,0,1,CAF_BLACKHOLE,"CAF_BLACKHOLE","CAF_BLACKHOLE") #ifdef EAGER_BLACKHOLING INFO_TABLE(stg_SE_BLACKHOLE,0,1,SE_BLACKHOLE,"SE_BLACKHOLE","SE_BLACKHOLE") -{ foreign "C" barf("SE_BLACKHOLE object entered!"); } +{ foreign "C" barf("SE_BLACKHOLE object entered!") never returns; } INFO_TABLE(stg_SE_CAF_BLACKHOLE,0,1,SE_CAF_BLACKHOLE,"SE_CAF_BLACKHOLE","SE_CAF_BLACKHOLE") -{ foreign "C" barf("SE_CAF_BLACKHOLE object entered!"); } +{ foreign "C" barf("SE_CAF_BLACKHOLE object entered!") never returns; } #endif /* ---------------------------------------------------------------------------- @@ -400,7 +400,7 @@ INFO_TABLE(stg_SE_CAF_BLACKHOLE,0,1,SE_CAF_BLACKHOLE,"SE_CAF_BLACKHOLE","SE_CAF_ ------------------------------------------------------------------------- */ INFO_TABLE(stg_WHITEHOLE, 0,0, BLACKHOLE, "WHITEHOLE", "WHITEHOLE") -{ foreign "C" barf("WHITEHOLE object entered!"); } +{ foreign "C" barf("WHITEHOLE object entered!") never returns; } /* ---------------------------------------------------------------------------- Some static info tables for things that don't get entered, and @@ -409,7 +409,7 @@ INFO_TABLE(stg_WHITEHOLE, 0,0, BLACKHOLE, "WHITEHOLE", "WHITEHOLE") ------------------------------------------------------------------------- */ INFO_TABLE(stg_TSO, 0,0,TSO, "TSO", "TSO") -{ foreign "C" barf("TSO object entered!"); } +{ foreign "C" barf("TSO object entered!") never returns; } /* ---------------------------------------------------------------------------- Evacuees are left behind by the garbage collector. Any attempt to enter @@ -417,7 +417,7 @@ INFO_TABLE(stg_TSO, 0,0,TSO, "TSO", "TSO") ------------------------------------------------------------------------- */ INFO_TABLE(stg_EVACUATED,1,0,EVACUATED,"EVACUATED","EVACUATED") -{ foreign "C" barf("EVACUATED object entered!"); } +{ foreign "C" barf("EVACUATED object entered!") never returns; } /* ---------------------------------------------------------------------------- Weak pointers @@ -428,7 +428,7 @@ INFO_TABLE(stg_EVACUATED,1,0,EVACUATED,"EVACUATED","EVACUATED") ------------------------------------------------------------------------- */ INFO_TABLE(stg_WEAK,0,4,WEAK,"WEAK","WEAK") -{ foreign "C" barf("WEAK object entered!"); } +{ foreign "C" barf("WEAK object entered!") never returns; } /* * It's important when turning an existing WEAK into a DEAD_WEAK @@ -437,7 +437,7 @@ INFO_TABLE(stg_WEAK,0,4,WEAK,"WEAK","WEAK") * DEAD_WEAK 4 non-pointer fields, the same as WEAK. */ INFO_TABLE_CONSTR(stg_DEAD_WEAK,0,4,0,CONSTR,"DEAD_WEAK","DEAD_WEAK") -{ foreign "C" barf("DEAD_WEAK object entered!"); } +{ foreign "C" barf("DEAD_WEAK object entered!") never returns; } /* ---------------------------------------------------------------------------- NO_FINALIZER @@ -447,7 +447,7 @@ INFO_TABLE_CONSTR(stg_DEAD_WEAK,0,4,0,CONSTR,"DEAD_WEAK","DEAD_WEAK") ------------------------------------------------------------------------- */ INFO_TABLE_CONSTR(stg_NO_FINALIZER,0,0,0,CONSTR_NOCAF_STATIC,"NO_FINALIZER","NO_FINALIZER") -{ foreign "C" barf("NO_FINALIZER object entered!"); } +{ foreign "C" barf("NO_FINALIZER object entered!") never returns; } CLOSURE(stg_NO_FINALIZER_closure,stg_NO_FINALIZER); @@ -456,7 +456,7 @@ CLOSURE(stg_NO_FINALIZER_closure,stg_NO_FINALIZER); ------------------------------------------------------------------------- */ INFO_TABLE(stg_STABLE_NAME,0,1,STABLE_NAME,"STABLE_NAME","STABLE_NAME") -{ foreign "C" barf("STABLE_NAME object entered!"); } +{ foreign "C" barf("STABLE_NAME object entered!") never returns; } /* ---------------------------------------------------------------------------- MVars @@ -466,44 +466,44 @@ INFO_TABLE(stg_STABLE_NAME,0,1,STABLE_NAME,"STABLE_NAME","STABLE_NAME") ------------------------------------------------------------------------- */ INFO_TABLE(stg_FULL_MVAR,3,0,MVAR,"MVAR","MVAR") -{ foreign "C" barf("FULL_MVAR object entered!"); } +{ foreign "C" barf("FULL_MVAR object entered!") never returns; } INFO_TABLE(stg_EMPTY_MVAR,3,0,MVAR,"MVAR","MVAR") -{ foreign "C" barf("EMPTY_MVAR object entered!"); } +{ foreign "C" barf("EMPTY_MVAR object entered!") never returns; } /* ----------------------------------------------------------------------------- STM -------------------------------------------------------------------------- */ INFO_TABLE(stg_TVAR, 0, 0, TVAR, "TVAR", "TVAR") -{ foreign "C" barf("TVAR object entered!"); } +{ foreign "C" barf("TVAR object entered!") never returns; } INFO_TABLE(stg_TVAR_WATCH_QUEUE, 0, 0, TVAR_WATCH_QUEUE, "TVAR_WATCH_QUEUE", "TVAR_WATCH_QUEUE") -{ foreign "C" barf("TVAR_WATCH_QUEUE object entered!"); } +{ foreign "C" barf("TVAR_WATCH_QUEUE object entered!") never returns; } INFO_TABLE(stg_ATOMIC_INVARIANT, 0, 0, ATOMIC_INVARIANT, "ATOMIC_INVARIANT", "ATOMIC_INVARIANT") -{ foreign "C" barf("ATOMIC_INVARIANT object entered!"); } +{ foreign "C" barf("ATOMIC_INVARIANT object entered!") never returns; } INFO_TABLE(stg_INVARIANT_CHECK_QUEUE, 0, 0, INVARIANT_CHECK_QUEUE, "INVARIANT_CHECK_QUEUE", "INVARIANT_CHECK_QUEUE") -{ foreign "C" barf("INVARIANT_CHECK_QUEUE object entered!"); } +{ foreign "C" barf("INVARIANT_CHECK_QUEUE object entered!") never returns; } INFO_TABLE(stg_TREC_CHUNK, 0, 0, TREC_CHUNK, "TREC_CHUNK", "TREC_CHUNK") -{ foreign "C" barf("TREC_CHUNK object entered!"); } +{ foreign "C" barf("TREC_CHUNK object entered!") never returns; } INFO_TABLE(stg_TREC_HEADER, 0, 0, TREC_HEADER, "TREC_HEADER", "TREC_HEADER") -{ foreign "C" barf("TREC_HEADER object entered!"); } +{ foreign "C" barf("TREC_HEADER object entered!") never returns; } INFO_TABLE_CONSTR(stg_END_STM_WATCH_QUEUE,0,0,0,CONSTR_NOCAF_STATIC,"END_STM_WATCH_QUEUE","END_STM_WATCH_QUEUE") -{ foreign "C" barf("END_STM_WATCH_QUEUE object entered!"); } +{ foreign "C" barf("END_STM_WATCH_QUEUE object entered!") never returns; } INFO_TABLE_CONSTR(stg_END_INVARIANT_CHECK_QUEUE,0,0,0,CONSTR_NOCAF_STATIC,"END_INVARIANT_CHECK_QUEUE","END_INVARIANT_CHECK_QUEUE") -{ foreign "C" barf("END_INVARIANT_CHECK_QUEUE object entered!"); } +{ foreign "C" barf("END_INVARIANT_CHECK_QUEUE object entered!") never returns; } INFO_TABLE_CONSTR(stg_END_STM_CHUNK_LIST,0,0,0,CONSTR_NOCAF_STATIC,"END_STM_CHUNK_LIST","END_STM_CHUNK_LIST") -{ foreign "C" barf("END_STM_CHUNK_LIST object entered!"); } +{ foreign "C" barf("END_STM_CHUNK_LIST object entered!") never returns; } INFO_TABLE_CONSTR(stg_NO_TREC,0,0,0,CONSTR_NOCAF_STATIC,"NO_TREC","NO_TREC") -{ foreign "C" barf("NO_TREC object entered!"); } +{ foreign "C" barf("NO_TREC object entered!") never returns; } CLOSURE(stg_END_STM_WATCH_QUEUE_closure,stg_END_STM_WATCH_QUEUE); @@ -521,7 +521,7 @@ CLOSURE(stg_NO_TREC_closure,stg_NO_TREC); ------------------------------------------------------------------------- */ INFO_TABLE_CONSTR(stg_END_TSO_QUEUE,0,0,0,CONSTR_NOCAF_STATIC,"END_TSO_QUEUE","END_TSO_QUEUE") -{ foreign "C" barf("END_TSO_QUEUE object entered!"); } +{ foreign "C" barf("END_TSO_QUEUE object entered!") never returns; } CLOSURE(stg_END_TSO_QUEUE_closure,stg_END_TSO_QUEUE); @@ -530,12 +530,12 @@ CLOSURE(stg_END_TSO_QUEUE_closure,stg_END_TSO_QUEUE); ------------------------------------------------------------------------- */ INFO_TABLE_CONSTR(stg_END_EXCEPTION_LIST,0,0,0,CONSTR_NOCAF_STATIC,"END_EXCEPTION_LIST","END_EXCEPTION_LIST") -{ foreign "C" barf("END_EXCEPTION_LIST object entered!"); } +{ foreign "C" barf("END_EXCEPTION_LIST object entered!") never returns; } CLOSURE(stg_END_EXCEPTION_LIST_closure,stg_END_EXCEPTION_LIST); INFO_TABLE(stg_EXCEPTION_CONS,1,1,CONSTR,"EXCEPTION_CONS","EXCEPTION_CONS") -{ foreign "C" barf("EXCEPTION_CONS object entered!"); } +{ foreign "C" barf("EXCEPTION_CONS object entered!") never returns; } /* ---------------------------------------------------------------------------- Arrays @@ -553,28 +553,28 @@ INFO_TABLE(stg_EXCEPTION_CONS,1,1,CONSTR,"EXCEPTION_CONS","EXCEPTION_CONS") ------------------------------------------------------------------------- */ INFO_TABLE(stg_ARR_WORDS, 0, 0, ARR_WORDS, "ARR_WORDS", "ARR_WORDS") -{ foreign "C" barf("ARR_WORDS object entered!"); } +{ foreign "C" barf("ARR_WORDS object entered!") never returns; } INFO_TABLE(stg_MUT_ARR_PTRS_CLEAN, 0, 0, MUT_ARR_PTRS_CLEAN, "MUT_ARR_PTRS_CLEAN", "MUT_ARR_PTRS_CLEAN") -{ foreign "C" barf("MUT_ARR_PTRS_CLEAN object entered!"); } +{ foreign "C" barf("MUT_ARR_PTRS_CLEAN object entered!") never returns; } INFO_TABLE(stg_MUT_ARR_PTRS_DIRTY, 0, 0, MUT_ARR_PTRS_DIRTY, "MUT_ARR_PTRS_DIRTY", "MUT_ARR_PTRS_DIRTY") -{ foreign "C" barf("MUT_ARR_PTRS_DIRTY object entered!"); } +{ foreign "C" barf("MUT_ARR_PTRS_DIRTY object entered!") never returns; } INFO_TABLE(stg_MUT_ARR_PTRS_FROZEN, 0, 0, MUT_ARR_PTRS_FROZEN, "MUT_ARR_PTRS_FROZEN", "MUT_ARR_PTRS_FROZEN") -{ foreign "C" barf("MUT_ARR_PTRS_FROZEN object entered!"); } +{ foreign "C" barf("MUT_ARR_PTRS_FROZEN object entered!") never returns; } INFO_TABLE(stg_MUT_ARR_PTRS_FROZEN0, 0, 0, MUT_ARR_PTRS_FROZEN0, "MUT_ARR_PTRS_FROZEN0", "MUT_ARR_PTRS_FROZEN0") -{ foreign "C" barf("MUT_ARR_PTRS_FROZEN0 object entered!"); } +{ foreign "C" barf("MUT_ARR_PTRS_FROZEN0 object entered!") never returns; } /* ---------------------------------------------------------------------------- Mutable Variables ------------------------------------------------------------------------- */ INFO_TABLE(stg_MUT_VAR_CLEAN, 1, 0, MUT_VAR_CLEAN, "MUT_VAR_CLEAN", "MUT_VAR_CLEAN") -{ foreign "C" barf("MUT_VAR_CLEAN object entered!"); } +{ foreign "C" barf("MUT_VAR_CLEAN object entered!") never returns; } INFO_TABLE(stg_MUT_VAR_DIRTY, 1, 0, MUT_VAR_DIRTY, "MUT_VAR_DIRTY", "MUT_VAR_DIRTY") -{ foreign "C" barf("MUT_VAR_DIRTY object entered!"); } +{ foreign "C" barf("MUT_VAR_DIRTY object entered!") never returns; } /* ---------------------------------------------------------------------------- Dummy return closure diff --git a/utils/genapply/GenApply.hs b/utils/genapply/GenApply.hs index c42ccb1..e46b37a 100644 --- a/utils/genapply/GenApply.hs +++ b/utils/genapply/GenApply.hs @@ -602,7 +602,7 @@ genApply regstatus args = text "default: {", nest 4 ( - text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\");" + text "foreign \"C\" barf(\"" <> fun_ret_label <> text "\") never returns;" ), text "}" -- 1.7.10.4