Commit 07310822 authored by nr@eecs.harvard.edu's avatar nr@eecs.harvard.edu

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!
parent 1cb7a870
......@@ -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
......
......@@ -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 ),
......
......@@ -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
......
......@@ -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
......@@ -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
{
......
......@@ -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 */
......
This diff is collapsed.
......@@ -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 "}"
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment