X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmParse.y;h=23f98801522380a79f33ef63e043b06b52987bd1;hb=8a2809c29de9f23eba7ca682b48390033a9d40f6;hp=27fce3bf88156eb8aef4a706efd55aa89a168f5e;hpb=603bf8c5496b9ac71552e7097eb88ad97db15e70;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 27fce3b..23f9880 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -200,47 +200,51 @@ lits	:: { [ExtFCode CmmExpr] }
 
 cmmproc :: { ExtCode }
 -- TODO: add real SRT/info tables to parsed Cmm
-	: info maybe_formals '{' body '}'
-		{ do ((info_lbl, info, live, formals), stmts) <-
+	: info maybe_formals maybe_frame maybe_gc_block '{' body '}'
+		{ do ((info_lbl, info, live, formals, frame, gc_block), stmts) <-
 		       getCgStmtsEC' $ loopDecls $ do {
 		         (info_lbl, info, live) <- $1;
 		         formals <- sequence $2;
-		         $4;
-		         return (info_lbl, info, live, formals) }
+		         frame <- $3;
+		         gc_block <- $4;
+		         $6;
+		         return (info_lbl, info, live, formals, frame, gc_block) }
 		     blks <- code (cgStmtsToBlocks stmts)
-		     code (emitInfoTableAndCode info_lbl info formals blks) }
+		     code (emitInfoTableAndCode info_lbl (CmmInfo Nothing frame info) formals blks) }
 
 	| info maybe_formals ';'
 		{ do (info_lbl, info, live) <- $1;
 		     formals <- sequence $2;
-		     code (emitInfoTableAndCode info_lbl info formals []) }
+		     code (emitInfoTableAndCode info_lbl (CmmInfo Nothing Nothing info) formals []) }
 
-	| NAME maybe_formals '{' body '}'
-		{ do (formals, stmts) <-
+	| NAME maybe_formals maybe_frame maybe_gc_block '{' body '}'
+		{ do ((formals, frame, gc_block), stmts) <-
 			getCgStmtsEC' $ loopDecls $ do {
 		          formals <- sequence $2;
-		          $4;
-		          return formals }
+			  frame <- $3;
+		          gc_block <- $4;
+		          $6;
+		          return (formals, frame, gc_block) }
                      blks <- code (cgStmtsToBlocks stmts)
-		     code (emitProc (CmmNonInfo Nothing) (mkRtsCodeLabelFS $1) formals blks) }
+		     code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkRtsCodeLabelFS $1) formals blks) }
 
-info	:: { ExtFCode (CLabel, CmmInfo, [Maybe LocalReg]) }
+info	:: { ExtFCode (CLabel, CmmInfoTable, [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),
+			CmmInfoTable prof (fromIntegral $9)
+				     (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
 		{ do prof <- profilingInfo $11 $13
 		     return (mkRtsInfoLabelFS $3,
-			CmmInfo prof Nothing (fromIntegral $9)
-				(FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
-				 (ArgSpec 0)
-				 zeroCLit),
+			CmmInfoTable prof (fromIntegral $9)
+				     (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
+				      (ArgSpec 0)
+				      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.
@@ -252,31 +256,31 @@ info	:: { ExtFCode (CLabel, CmmInfo, [Maybe LocalReg]) }
 		     -- but that's the way the old code did it we can fix it some other time.
 		     desc_lit <- code $ mkStringCLit $13
 		     return (mkRtsInfoLabelFS $3,
-			CmmInfo prof Nothing (fromIntegral $11)
-				(ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
+			CmmInfoTable prof (fromIntegral $11)
+				     (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),
+			CmmInfoTable prof (fromIntegral $7)
+				     (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),
+			CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
+				     (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),
+			CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
+			             (ContInfo live NoC_SRT),
 			live) }
 
 body	:: { ExtCode }
@@ -503,6 +507,17 @@ formal :: { ExtFCode LocalReg }
 	| STRING type NAME	{% do k <- parseKind $1;
 				     return $ newLocal k $2 $3 }
 
+maybe_frame :: { ExtFCode (Maybe UpdateFrame) }
+	: {- empty -}			{ return Nothing }
+	| 'jump' expr '(' exprs0 ')'	{ do { target <- $2;
+					       args <- sequence $4;
+					       return $ Just (UpdateFrame target args) } }
+
+maybe_gc_block :: { ExtFCode (Maybe BlockId) }
+	: {- empty -}			{ return Nothing }
+	| 'goto' NAME
+		{ do l <- lookupLabel $2; return (Just l) }
+
 type	:: { MachRep }
 	: 'bits8'		{ I8 }
 	| typenot8		{ $1 }
@@ -851,6 +866,7 @@ 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))
           case convention of
             -- Temporary hack so at least some functions are CmmSafe
             CmmCallConv -> code (stmtC (CmmCall (CmmForeignCall expr convention) results args safety))