X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmParse.y;h=840b564a837fb13627802d33eb5b6691856c232d;hp=ab50799df706a8643d3798a0306527b1cedc61ea;hb=d31dfb32ea936c22628b508c28a36c12e631430a;hpb=f96e9aa0444de0e673b3c4055c6e43299639bc5b

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index ab50799..840b564 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -200,44 +200,72 @@ lits	:: { [ExtFCode CmmExpr] }
 
 cmmproc :: { ExtCode }
 -- TODO: add real SRT/info tables to parsed Cmm
---	: info maybe_formals '{' body '}'
---		{ do (info_lbl, info1, info2) <- $1;
---		     formals <- sequence $2;
---		     stmts <- getCgStmtsEC (loopDecls $4)
---		     blks <- code (cgStmtsToBlocks stmts)
---		     code (emitInfoTableAndCode info_lbl info1 info2 formals blks) }
---
---	| info maybe_formals ';'
---		{ do (info_lbl, info1, info2) <- $1;
---		     formals <- sequence $2;
---		     code (emitInfoTableAndCode info_lbl info1 info2 formals []) }
-
-	: NAME maybe_formals '{' body '}'
+	: info maybe_formals '{' body '}'
+		{ do (info_lbl, info) <- $1;
+		     formals <- sequence $2;
+		     stmts <- getCgStmtsEC (loopDecls $4)
+		     blks <- code (cgStmtsToBlocks stmts)
+		     code (emitInfoTableAndCode info_lbl info formals blks) }
+
+	| info maybe_formals ';'
+		{ do (info_lbl, info) <- $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);
-		     code (emitProc CmmNonInfo (mkRtsCodeLabelFS $1) formals blks) }
+		     code (emitProc (CmmNonInfo Nothing) (mkRtsCodeLabelFS $1) formals blks) }
 
-info	:: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
+info	:: { ExtFCode (CLabel, CmmInfo) }
 	: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- ptrs, nptrs, closure type, description, type
-		{ stdInfo $3 $5 $7 0 $9 $11 $13 }
+		{ do prof <- profilingInfo $11 $13
+		     return (mkRtsInfoLabelFS $3,
+			CmmInfo prof Nothing (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
-		{ funInfo $3 $5 $7 $9 $11 $13 $15 }
+		{ 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)) }
+		-- we leave most of the fields zero here.  This is only used
+		-- to generate the BCO info table in the RTS at the moment.
 	
 	| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- ptrs, nptrs, tag, closure type, description, type
-		{ conInfo $3 $5 $7 $9 $11 $13 $15 }
+		{ do prof <- profilingInfo $13 $15
+		     -- If profiling is on, this string gets duplicated,
+		     -- 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)) }
 	
 	| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- selector, closure type, description, type
-		{ basicInfo $3 (mkIntCLit (fromIntegral $5)) 0 $7 $9 $11 }
-
-	| 'INFO_TABLE_RET' '(' NAME ',' INT ',' INT ',' INT ')'
-		-- size, live bits, closure type
-		{ retInfo $3 $5 $7 $9 }
+		{ do prof <- profilingInfo $9 $11
+		     return (mkRtsInfoLabelFS $3,
+			CmmInfo prof Nothing (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)) }
+
+	| '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)) }
 
 body	:: { ExtCode }
 	: {- empty -}			{ return () }
@@ -766,48 +794,15 @@ forkLabelledCodeEC ec = do
   stmts <- getCgStmtsEC ec
   code (forkCgStmts stmts)
 
-retInfo name size live_bits cl_type = do
-  let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
-      info_lbl = mkRtsRetInfoLabelFS name
-      (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT 
-				(fromIntegral cl_type)
-  return (info_lbl, info1, info2)
-
-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
+
+profilingInfo desc_str ty_str = do
   lit1 <- if opt_SccProfilingOn 
-		   then code $ do lit <- mkStringCLit desc_str
-                                  return (makeRelativeRefTo info_lbl lit)
+		   then code $ mkStringCLit desc_str
 		   else return (mkIntCLit 0)
   lit2 <- if opt_SccProfilingOn 
-		   then code $ do lit <- mkStringCLit ty_str
-                                  return (makeRelativeRefTo info_lbl lit)
+		   then code $ mkStringCLit ty_str
 		   else return (mkIntCLit 0)
-  let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type) 
-			(fromIntegral srt_bitmap)
-			layout
-  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-}
-			 cl_type desc_str ty_str 
-  let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero
-		-- we leave most of the fields zero here.  This is only used
-		-- to generate the BCO info table in the RTS at the moment.
-  return (label,info1,info2)
- where
-   zero = mkIntCLit 0
+  return (ProfilingInfo lit1 lit2)
 
 
 staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
@@ -872,6 +867,7 @@ emitRetUT args = do
   emitStmts stmts
   when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
   stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
+  -- TODO (when using CPS): emitStmt (CmmReturn (map snd args))
 
 -- -----------------------------------------------------------------------------
 -- If-then-else and boolean expressions