X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmParse.y;h=38c30b24f520e77f60793279bb6277395d80db6f;hb=f2cc8b5bc34519a65581dc40b7bfebac97bffd73;hp=72a57137c2ea529410f55c1711a87377ee36aeb0;hpb=9ff76535edb25ab7434284adddb5c64708ecb547;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 72a5713..38c30b2 100644
--- 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) }
@@ -224,7 +225,7 @@ info	:: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
 	
 	| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- ptrs, nptrs, tag, closure type, description, type
-		{ stdInfo $3 $5 $7 $9 $11 $13 $15 }
+		{ conInfo $3 $5 $7 $9 $11 $13 $15 }
 	
 	| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- selector, closure type, description, type
@@ -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 )
 	]
@@ -607,6 +614,7 @@ stmtMacros = listToUFM [
   ( FSLIT("RET_NN"),	\[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
   ( FSLIT("RET_NP"),	\[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
   ( FSLIT("RET_PPP"),	\[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
+  ( FSLIT("RET_NPP"),	\[a,b,c] ->   emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
   ( FSLIT("RET_NNP"),	\[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
   ( FSLIT("RET_NNNP"),	\[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
   ( FSLIT("RET_NPNP"),	\[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
@@ -715,17 +723,27 @@ stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
   basicInfo name (packHalfWordsCLit ptrs nptrs) 
 	srt_bitmap cl_type desc_str ty_str
 
+conInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str = do
+  (lbl, info1, _) <- basicInfo name (packHalfWordsCLit ptrs nptrs) 
+                	srt_bitmap cl_type desc_str ty_str
+  desc_lit <- code $ mkStringCLit desc_str
+  let desc_field = makeRelativeRefTo lbl desc_lit
+  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-}