annotate C-- calls that do not return

[ghc-hetmet.git] / compiler / cmm / CmmParse.y

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 68bc26d..bce6f27 100644 (file)
--- 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) }
@@ -294,7 +296,7 @@ decl        :: { ExtCode }
        | STRING type names ';'         {% do k <- parseKind $1;
                                              return $ mapM_ (newLocal k $2) $3 }
 
-       | 'import' names ';'            { return () }  -- ignore imports
+       | 'import' names ';'            { mapM_ newImport $2 }
        | 'export' names ';'            { return () }  -- ignore exports
 
 names  :: { [FastString] }
@@ -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) }
@@ -770,9 +776,12 @@ instance Monad ExtFCode where
 -- an environment, which is looped back into the computation.  In this
 -- way, we can have embedded declarations that scope over the whole
 -- procedure, and imports that scope over the entire module.
+-- Discards the local declaration contained within decl'
 loopDecls :: ExtFCode a -> ExtFCode a
-loopDecls (EC fcode) = 
-   EC $ \e s -> fixC (\ ~(decls,a) -> fcode (addListToUFM e decls) [])
+loopDecls (EC fcode) =
+      EC $ \e globalDecls -> do
+       (decls', a) <- fixC (\ ~(decls,a) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls)
+       return (globalDecls, a)
 
 getEnv :: ExtFCode Env
 getEnv = EC $ \e s -> return (s, e)
@@ -790,6 +799,13 @@ newLocal kind ty name = do
    addVarDecl name (CmmReg (CmmLocal reg))
    return reg
 
+-- Creates a foreign label in the import. CLabel's labelDynamic
+-- classifies these labels as dynamic, hence the code generator emits the
+-- PIC code for them.
+newImport :: FastString -> ExtFCode ()
+newImport name =
+       addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True)))
+
 newLabel :: FastString -> ExtFCode BlockId
 newLabel name = do
    u <- code newUnique
@@ -857,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
@@ -867,17 +884,17 @@ foreignCall conv_string results_code expr_code args_code vols safety
          results <- sequence results_code
          expr <- expr_code
          args <- sequence args_code
-         --code (stmtC (CmmCall (CmmForeignCall expr convention) results args safety))
+         --code (stmtC (CmmCall (CmmCallee expr convention) results args safety))
           case convention of
             -- Temporary hack so at least some functions are CmmSafe
-            CmmCallConv -> code (stmtC (CmmCall (CmmForeignCall expr convention) results args safety))
+            CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety))
             _ -> case safety of
              CmmUnsafe ->
                 code (emitForeignCall' PlayRisky results 
-                   (CmmForeignCall expr convention) args vols NoC_SRT)
+                   (CmmCallee expr convention) args vols NoC_SRT)
               CmmSafe srt ->
                 code (emitForeignCall' (PlaySafe unused) results 
-                   (CmmForeignCall expr convention) args vols NoC_SRT) where
+                   (CmmCallee expr convention) args vols NoC_SRT) where
                unused = panic "not used by emitForeignCall'"
 
 primCall