Fixed missing '#include "HsVersions.h"'

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

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 2b7605e..3842e65 100644 (file)
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -104,6 +104,7 @@ import System.Exit
        'jump'          { L _ (CmmT_jump) }
        'foreign'       { L _ (CmmT_foreign) }
        'prim'          { L _ (CmmT_prim) }
+       'return'        { L _ (CmmT_return) }
        'import'        { L _ (CmmT_import) }
        'switch'        { L _ (CmmT_switch) }
        'case'          { L _ (CmmT_case) }
@@ -279,8 +280,10 @@ stmt       :: { ExtCode }
                { doSwitch $2 $3 $5 $6 }
        | 'goto' NAME ';'
                { do l <- lookupLabel $2; stmtEC (CmmBranch l) }
-       | 'jump' expr {-maybe_actuals-} ';'
-               { do e <- $2; stmtEC (CmmJump e []) }
+       | 'jump' expr maybe_actuals ';'
+               { do e1 <- $2; e2 <- sequence $3; stmtEC (CmmJump e1 e2) }
+        | 'return' maybe_actuals ';'
+               { do e <- sequence $2; stmtEC (CmmReturn e) }
        | 'if' bool_expr '{' body '}' else      
                { ifThenElse $2 $4 $6 }
 
@@ -372,6 +375,10 @@ maybe_ty :: { MachRep }
        : {- empty -}                   { wordRep }
        | '::' type                     { $2 }
 
+maybe_actuals :: { [ExtFCode (CmmExpr, MachHint)] }
+       : {- empty -}           { [] }
+       | '(' hint_exprs0 ')'   { $2 }
+
 hint_exprs0 :: { [ExtFCode (CmmExpr, MachHint)] }
        : {- empty -}                   { [] }
        | hint_exprs                    { $1 }
@@ -525,9 +532,9 @@ machOps = listToUFM $
        ( "f2f32",    flip MO_S_Conv F32 ),  -- TODO; rounding mode
        ( "f2f64",    flip MO_S_Conv F64 ),  -- TODO; rounding mode
        ( "f2i8",     flip MO_S_Conv I8 ),
-       ( "f2i16",    flip MO_S_Conv I8 ),
-       ( "f2i32",    flip MO_S_Conv I8 ),
-       ( "f2i64",    flip MO_S_Conv I8 ),
+       ( "f2i16",    flip MO_S_Conv I16 ),
+       ( "f2i32",    flip MO_S_Conv I32 ),
+       ( "f2i64",    flip MO_S_Conv I64 ),
        ( "i2f32",    flip MO_S_Conv F32 ),
        ( "i2f64",    flip MO_S_Conv F64 )
        ]
@@ -724,16 +731,19 @@ conInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str = do
   return (lbl, info1, [desc_field])
 
 basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
+  let info_lbl = mkRtsInfoLabelFS name
   lit1 <- if opt_SccProfilingOn 
-                  then code $ mkStringCLit desc_str
+                  then code $ do lit <- mkStringCLit desc_str
+                                  return (makeRelativeRefTo info_lbl lit)
                   else return (mkIntCLit 0)
   lit2 <- if opt_SccProfilingOn 
-                  then code $ mkStringCLit ty_str
+                  then code $ do lit <- mkStringCLit ty_str
+                                  return (makeRelativeRefTo info_lbl lit)
                   else return (mkIntCLit 0)
   let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type) 
                        (fromIntegral srt_bitmap)
                        layout
-  return (mkRtsInfoLabelFS name, info1, [])
+  return (info_lbl, info1, [])
 
 funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
   (label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-}
@@ -757,15 +767,17 @@ foreignCall
        -> ExtFCode CmmExpr
        -> [ExtFCode (CmmExpr,MachHint)]
        -> Maybe [GlobalReg] -> P ExtCode
-foreignCall "C" results_code expr_code args_code vols
-  = return $ do
-       results <- sequence results_code
-       expr <- expr_code
-       args <- sequence args_code
-        code (emitForeignCall' PlayRisky results 
-                 (CmmForeignCall expr CCallConv) args vols)
-foreignCall conv _ _ _ _
-  = fail ("unknown calling convention: " ++ conv)
+foreignCall conv_string results_code expr_code args_code vols
+  = do  convention <- case conv_string of
+          "C" -> return CCallConv
+          "C--" -> return CmmCallConv
+          _ -> fail ("unknown calling convention: " ++ conv_string)
+       return $ do
+         results <- sequence results_code
+         expr <- expr_code
+         args <- sequence args_code
+          code (emitForeignCall' PlayRisky results 
+                 (CmmForeignCall expr convention) args vols) where
 
 primCall
        :: [ExtFCode (CmmReg,MachHint)]