From 63b9fc6eccc2e9e9fae11a68f3adc0a05d7b7206 Mon Sep 17 00:00:00 2001
From: "Michael D. Adams" <t-madams@microsoft.com>
Date: Thu, 28 Jun 2007 10:13:12 +0000
Subject: [PATCH] Fix a bug in the Cmm parser where formal params didn't get
 bound

---
 compiler/cmm/CmmParse.y |   42 ++++++++++++++++++++++++++++--------------
 1 file changed, 28 insertions(+), 14 deletions(-)

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 840b564..2bb9869 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -201,30 +201,37 @@ lits	:: { [ExtFCode CmmExpr] }
 cmmproc :: { ExtCode }
 -- TODO: add real SRT/info tables to parsed Cmm
 	: info maybe_formals '{' body '}'
-		{ do (info_lbl, info) <- $1;
-		     formals <- sequence $2;
-		     stmts <- getCgStmtsEC (loopDecls $4)
+		{ do ((info_lbl, info, live, formals), stmts) <-
+		       getCgStmtsEC' $ loopDecls $ do {
+		         (info_lbl, info, live) <- $1;
+		         formals <- sequence $2;
+		         $4;
+		         return (info_lbl, info, live, formals) }
 		     blks <- code (cgStmtsToBlocks stmts)
 		     code (emitInfoTableAndCode info_lbl info formals blks) }
 
 	| info maybe_formals ';'
-		{ do (info_lbl, info) <- $1;
+		{ do (info_lbl, info, live) <- $1;
 		     formals <- sequence $2;
 		     code (emitInfoTableAndCode info_lbl info formals []) }
 
 	| NAME maybe_formals '{' body '}'
-		{ do formals <- sequence $2;
-		     stmts <- getCgStmtsEC (loopDecls $4);
-		     blks <- code (cgStmtsToBlocks stmts);
+		{ do (formals, stmts) <-
+			getCgStmtsEC' $ loopDecls $ do {
+		          formals <- sequence $2;
+		          $4;
+		          return formals }
+                     blks <- code (cgStmtsToBlocks stmts)
 		     code (emitProc (CmmNonInfo Nothing) (mkRtsCodeLabelFS $1) formals blks) }
 
-info	:: { ExtFCode (CLabel, CmmInfo) }
+info	:: { ExtFCode (CLabel, CmmInfo, [Maybe LocalReg]) }
 	: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- ptrs, nptrs, closure type, description, type
 		{ do prof <- profilingInfo $11 $13
 		     return (mkRtsInfoLabelFS $3,
 			CmmInfo prof Nothing (fromIntegral $9)
-				(ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT)) }
+				(ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
+			[]) }
 	
 	| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
 		-- ptrs, nptrs, closure type, description, type, fun type
@@ -233,7 +240,8 @@ info	:: { ExtFCode (CLabel, CmmInfo) }
 			CmmInfo prof Nothing (fromIntegral $9)
 				(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
 				 (ArgSpec 0)
-				 zeroCLit)) }
+				 zeroCLit),
+			[]) }
 		-- we leave most of the fields zero here.  This is only used
 		-- to generate the BCO info table in the RTS at the moment.
 	
@@ -245,27 +253,31 @@ info	:: { ExtFCode (CLabel, CmmInfo) }
 		     desc_lit <- code $ mkStringCLit $13
 		     return (mkRtsInfoLabelFS $3,
 			CmmInfo prof Nothing (fromIntegral $11)
-				(ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit)) }
+				(ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
+			[]) }
 	
 	| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- selector, closure type, description, type
 		{ do prof <- profilingInfo $9 $11
 		     return (mkRtsInfoLabelFS $3,
 			CmmInfo prof Nothing (fromIntegral $7)
-				(ThunkSelectorInfo (fromIntegral $5) NoC_SRT)) }
+				(ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
+			[]) }
 
 	| 'INFO_TABLE_RET' '(' NAME ',' INT ')'
 		-- closure type (no live regs)
 		{ return (mkRtsInfoLabelFS $3,
 			CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5)
-				(ContInfo [] NoC_SRT)) }
+				(ContInfo [] NoC_SRT),
+			[]) }
 
 	| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
 		-- closure type, live regs
 		{ do live <- sequence (map (liftM Just) $7)
 		     return (mkRtsInfoLabelFS $3,
 			CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5)
-			(ContInfo live NoC_SRT)) }
+			(ContInfo live NoC_SRT),
+			live) }
 
 body	:: { ExtCode }
 	: {- empty -}			{ return () }
@@ -789,6 +801,8 @@ nopEC = code nopC
 stmtEC stmt = code (stmtC stmt)
 stmtsEC stmts = code (stmtsC stmts)
 getCgStmtsEC = code2 getCgStmts'
+getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f)
+  where f ((decl, b), c) = return ((decl, b), (b, c))
 
 forkLabelledCodeEC ec = do
   stmts <- getCgStmtsEC ec
-- 
1.7.10.4