X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=8598e7e9a8cbd2ad93793fcb5e046e69acfe0d38;hb=b7f448a4ebb2b924f279bf49432f07338f41a764;hp=ebff1f0dbae8376035857198827d9bc996ba33db;hpb=b8c0cca3b6d0203144bf4ef213be4597ce86eb33;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index ebff1f0..8598e7e 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -7,11 +7,11 @@
 -- -----------------------------------------------------------------------------
 
 \begin{code}
-{-# OPTIONS_GHC -w #-}
+{-# OPTIONS -w #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
---     http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
 
 module AsmCodeGen ( nativeCodeGen ) where
@@ -174,7 +174,7 @@ nativeCodeGen dflags h us cmms
 		| dopt Opt_SplitObjs dflags = split_marker : tops
 		| otherwise		    = tops
 
-	split_marker = CmmProc [] mkSplitMarkerLabel [] []
+	split_marker = CmmProc [] mkSplitMarkerLabel [] (ListGraph [])
 
 
 -- | Do native code generation on all these cmms.
@@ -197,9 +197,10 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc
 			else []
 
 	-- force evaulation of imports and lsPprNative to avoid space leak
-	seqString (showSDoc $ vcat $ map ppr imports)
-	 `seq`  lsPprNative
-	 `seq`	cmmNativeGens dflags h us' cmms
+	seqString (showSDoc $ vcat $ map ppr imports) `seq` return ()
+	lsPprNative `seq` return ()
+
+	cmmNativeGens dflags h us' cmms
 			(imports : impAcc)
 			((lsPprNative, colorStats, linearStats) : profAcc)
 
@@ -267,15 +268,6 @@ cmmNativeGen dflags us cmm
 				emptyUFM
 			$ map RealReg allocatableRegs
 
-		-- aggressively coalesce moves between virtual regs
-		let (coalesced, usCoalesce)
-			= {-# SCC "regCoalesce" #-}
-			  initUs usLive $ regCoalesce withLiveness
-
-		dumpIfSet_dyn dflags
-			Opt_D_dump_asm_coalesce "Reg-Reg moves coalesced"
-			(vcat $ map ppr coalesced)
-
 	 	-- 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.
@@ -286,13 +278,13 @@ cmmNativeGen dflags us cmm
 
 		-- graph coloring register allocation
 		let ((alloced, regAllocStats), usAlloc)
-			= {-# SCC "regAlloc(color)" #-}
-			  initUs usCoalesce
+			= {-# SCC "RegAlloc" #-}
+			  initUs usLive
 			  $ Color.regAlloc
 				generateRegAllocStats
 				alloc_regs
 				(mkUniqSet [0..maxSpillSlots])
-				coalesced
+				withLiveness
 
 		-- dump out what happened during register allocation
 		dumpIfSet_dyn dflags
@@ -311,15 +303,16 @@ cmmNativeGen dflags us cmm
 			 then Just regAllocStats else Nothing
 
 		-- force evaluation of the Maybe to avoid space leak
-		mPprStats
-		 `seq`	return	( alloced, usAlloc
-				, mPprStats
-				, Nothing)
+		mPprStats `seq` return ()
+
+		return	( alloced, usAlloc
+			, mPprStats
+			, Nothing)
 
 	  else do
 	  	-- do linear register allocation
 		let ((alloced, regAllocStats), usAlloc) 
-			= {-# SCC "regAlloc(linear)" #-}
+			= {-# SCC "RegAlloc" #-}
   			  initUs usLive
  			  $ liftM unzip
 			  $ mapUs Linear.regAlloc withLiveness
@@ -333,10 +326,11 @@ cmmNativeGen dflags us cmm
 			 then Just (catMaybes regAllocStats) else Nothing
 
 		-- force evaluation of the Maybe to avoid space leak
-		mPprStats
-		 `seq`	return	( alloced, usAlloc
-				, Nothing
-				, mPprStats)
+		mPprStats `seq` return ()
+
+		return	( alloced, usAlloc
+			, Nothing
+			, mPprStats)
 
 	---- shortcut branches
 	let shorted	=
@@ -367,8 +361,8 @@ cmmNativeGen dflags us cmm
 #if i386_TARGET_ARCH
 x86fp_kludge :: NatCmmTop -> NatCmmTop
 x86fp_kludge top@(CmmData _ _) = top
-x86fp_kludge top@(CmmProc info lbl params code) = 
-	CmmProc info lbl params (map bb_i386_insert_ffrees code)
+x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) = 
+	CmmProc info lbl params (ListGraph $ map bb_i386_insert_ffrees code)
 	where
 		bb_i386_insert_ffrees (BasicBlock id instrs) =
 			BasicBlock id (i386_insert_ffrees instrs)
@@ -441,8 +435,8 @@ makeImportsDoc imports
 
 sequenceTop :: NatCmmTop -> NatCmmTop
 sequenceTop top@(CmmData _ _) = top
-sequenceTop (CmmProc info lbl params blocks) = 
-  CmmProc info lbl params (makeFarBranches $ sequenceBlocks blocks)
+sequenceTop (CmmProc info lbl params (ListGraph blocks)) = 
+  CmmProc info lbl params (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
 
 -- The algorithm is very simple (and stupid): we make a graph out of
 -- the blocks where there is an edge from one block to another iff the
@@ -538,10 +532,10 @@ shortcutBranches dflags tops
     mapping = foldr plusUFM emptyUFM mappings
 
 build_mapping top@(CmmData _ _) = (top, emptyUFM)
-build_mapping (CmmProc info lbl params [])
-  = (CmmProc info lbl params [], emptyUFM)
-build_mapping (CmmProc info lbl params (head:blocks))
-  = (CmmProc info lbl params (head:others), mapping)
+build_mapping (CmmProc info lbl params (ListGraph []))
+  = (CmmProc info lbl params (ListGraph []), emptyUFM)
+build_mapping (CmmProc info lbl params (ListGraph (head:blocks)))
+  = (CmmProc info lbl params (ListGraph (head:others)), mapping)
         -- drop the shorted blocks, but don't ever drop the first one,
         -- because it is pointed to by a global label.
   where
@@ -560,8 +554,8 @@ apply_mapping ufm (CmmData sec statics)
   = CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
   -- we need to get the jump tables, so apply the mapping to the entries
   -- of a CmmData too.
-apply_mapping ufm (CmmProc info lbl params blocks)
-  = CmmProc info lbl params (map short_bb blocks)
+apply_mapping ufm (CmmProc info lbl params (ListGraph blocks))
+  = CmmProc info lbl params (ListGraph $ map short_bb blocks)
   where
     short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
     short_insn i = shortcutJump (lookupUFM ufm) i
@@ -611,9 +605,9 @@ genMachCode dflags cmm_top
 
 fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
 fixAssignsTop top@(CmmData _ _) = returnUs top
-fixAssignsTop (CmmProc info lbl params blocks) =
+fixAssignsTop (CmmProc info lbl params (ListGraph blocks)) =
   mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
-  returnUs (CmmProc info lbl params blocks')
+  returnUs (CmmProc info lbl params (ListGraph blocks'))
 
 fixAssignsBlock :: CmmBasicBlock -> UniqSM CmmBasicBlock
 fixAssignsBlock (BasicBlock id stmts) =
@@ -668,9 +662,9 @@ Ideas for other things we could do (ToDo):
 
 cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
 cmmToCmm _ top@(CmmData _ _) = (top, [])
-cmmToCmm dflags (CmmProc info lbl params blocks) = runCmmOpt dflags $ do
+cmmToCmm dflags (CmmProc info lbl params (ListGraph blocks)) = runCmmOpt dflags $ do
   blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
-  return $ CmmProc info lbl params blocks'
+  return $ CmmProc info lbl params (ListGraph blocks')
 
 newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))