X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=fee6209b391cd7beb45e3bc9754601b0a9f8761f;hp=0966404da98036ba7d857db6f0fc5880e9c73a4e;hb=f5d4c3239e57b0396672ffc302961f84398d730e;hpb=16a2f6a8a381af31c23b6a41a851951da9bc1803

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 0966404..fee6209 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -129,7 +129,7 @@ nativeCodeGen dflags h us cmms
 	let split_cmms	= concat $ map add_split cmms
 
  	(imports, prof)
-		<- cmmNativeGens dflags h us split_cmms [] []
+		<- cmmNativeGens dflags h us split_cmms [] [] 0
 
 	let (native, colorStats, linearStats)
 		= unzip3 prof
@@ -179,13 +179,13 @@ nativeCodeGen dflags h us cmms
 
 -- | Do native code generation on all these cmms.
 --
-cmmNativeGens dflags h us [] impAcc profAcc
+cmmNativeGens dflags h us [] impAcc profAcc count
 	= return (reverse impAcc, reverse profAcc)
 
-cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc
+cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
  = do
  	(us', native, imports, colorStats, linearStats)
-		<- cmmNativeGen dflags us cmm
+		<- cmmNativeGen dflags us cmm count
 
 	Pretty.printDoc Pretty.LeftMode h
 		$ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native
@@ -196,13 +196,18 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc
 			then native
 			else []
 
-	-- force evaulation of imports and lsPprNative to avoid space leak
+	let count'	= count + 1;
+
+
+	-- force evaulation all this stuff to avoid space leaks
 	seqString (showSDoc $ vcat $ map ppr imports) `seq` return ()
-	lsPprNative `seq` return ()
+	lsPprNative 	`seq` return ()
+	count'		`seq` return ()
 
 	cmmNativeGens dflags h us' cmms
 			(imports : impAcc)
 			((lsPprNative, colorStats, linearStats) : profAcc)
+			count'
 
  where	seqString []		= ()
 	seqString (x:xs)	= x `seq` seqString xs `seq` ()
@@ -214,15 +219,17 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc
 cmmNativeGen 
 	:: DynFlags
 	-> UniqSupply
-	-> RawCmmTop
+	-> RawCmmTop				-- ^ the cmm to generate code for
+	-> Int					-- ^ sequence number of this top thing
 	-> IO	( UniqSupply
-		, [NatCmmTop]
-		, [CLabel]
-		, Maybe [Color.RegAllocStats]
-		, Maybe [Linear.RegAllocStats])
+		, [NatCmmTop]			-- native code
+		, [CLabel]			-- things imported by this cmm
+		, Maybe [Color.RegAllocStats]	-- stats for the coloring register allocator
+		, Maybe [Linear.RegAllocStats])	-- stats for the linear register allocators
 
-cmmNativeGen dflags us cmm
+cmmNativeGen dflags us cmm count
  = do
+
 	-- rewrite assignments to global regs
  	let (fixed_cmm, usFix)	=
 		{-# SCC "fixAssignsTop" #-}
@@ -259,7 +266,8 @@ cmmNativeGen dflags us cmm
 		
 	-- allocate registers
 	(alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <-
-	 if dopt Opt_RegsGraph dflags
+	 if ( dopt Opt_RegsGraph dflags
+	   || dopt Opt_RegsIterative dflags)
 	  then do
 	  	-- the regs usable for allocation
 		let alloc_regs
@@ -268,20 +276,12 @@ cmmNativeGen dflags us cmm
 				emptyUFM
 			$ map RealReg allocatableRegs
 
-	 	-- if any of these dump flags are turned on we want to hang on to
-		--	intermediate structures in the allocator - otherwise tell the
-		--	allocator to ditch them early so we don't end up creating space leaks.
-		let generateRegAllocStats = or
-			[ dopt Opt_D_dump_asm_regalloc_stages dflags
-			, dopt Opt_D_dump_asm_stats dflags
-			, dopt Opt_D_dump_asm_conflicts dflags ]
-
 		-- graph coloring register allocation
 		let ((alloced, regAllocStats), usAlloc)
 			= {-# SCC "RegAlloc" #-}
 			  initUs usLive
 			  $ Color.regAlloc
-				generateRegAllocStats
+				dflags
 				alloc_regs
 				(mkUniqSet [0..maxSpillSlots])
 				withLiveness
@@ -294,7 +294,8 @@ cmmNativeGen dflags us cmm
 		dumpIfSet_dyn dflags
 			Opt_D_dump_asm_regalloc_stages "Build/spill stages"
 			(vcat 	$ map (\(stage, stats)
-					-> text "-- Stage " <> int stage
+					-> text "# --------------------------"
+					$$ text "#  cmm " <> int count <> text " Stage " <> int stage
 					$$ ppr stats)
 				$ zip [0..] regAllocStats)
 
@@ -718,9 +719,9 @@ cmmStmtConFold stmt
 			        e' <- cmmExprConFold CallReference e
 			        return $ CmmCallee e' conv
 			      other -> return other
-                 args' <- mapM (\(arg, hint) -> do
+                 args' <- mapM (\(CmmHinted arg hint) -> do
                                   arg' <- cmmExprConFold DataReference arg
-                                  return (arg', hint)) args
+                                  return (CmmHinted arg' hint)) args
 	         return $ CmmCall target' regs args' srt returns
 
         CmmCondBranch test dest
@@ -773,11 +774,11 @@ cmmExprConFold referenceKind expr
         CmmReg (CmmGlobal GCEnter1)
           | not opt_PIC
           -> cmmExprConFold referenceKind $
-             CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_enter_1"))) 
+             CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_enter_1"))) 
         CmmReg (CmmGlobal GCFun)
           | not opt_PIC
           -> cmmExprConFold referenceKind $
-             CmmLit (CmmLabel (mkRtsCodeLabel SLIT( "__stg_gc_fun")))
+             CmmLit (CmmLabel (mkRtsCodeLabel (sLit "__stg_gc_fun")))
 #endif
 
         CmmReg (CmmGlobal mid)