X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FnativeGen%2FAsmCodeGen.lhs;h=615cc0c7bade96d485a90b0b021978ecc52b69dd;hb=2662dbc5b2c30fc11ccb99e7f9b2dba794d680ba;hp=8613a8ed1ff06215316d655f81e90dbc2873ef9b;hpb=b04a210e26ca57242fd052f2aa91011a80b76299;p=ghc-hetmet.git

diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index 8613a8e..615cc0c 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -25,7 +25,6 @@ import Alpha.CodeGen
 import Alpha.Regs
 import Alpha.RegInfo
 import Alpha.Instr
-import Alpha.Ppr
 
 #elif i386_TARGET_ARCH || x86_64_TARGET_ARCH
 import X86.CodeGen
@@ -37,12 +36,13 @@ import X86.Ppr
 #elif sparc_TARGET_ARCH
 import SPARC.CodeGen
 import SPARC.Regs
-import SPARC.RegInfo
 import SPARC.Instr
 import SPARC.Ppr
+import SPARC.ShortcutJump
 
 #elif powerpc_TARGET_ARCH
 import PPC.CodeGen
+import PPC.Cond
 import PPC.Regs
 import PPC.RegInfo
 import PPC.Instr
@@ -62,14 +62,17 @@ import qualified RegAlloc.Graph.Stats		as Color
 import qualified RegAlloc.Graph.Coalesce	as Color
 import qualified RegAlloc.Graph.TrivColorable	as Color
 
-import qualified TargetReg			as Target
+import qualified SPARC.CodeGen.Expand		as SPARC
 
+import TargetReg
 import Platform
 import Instruction
 import PIC
 import Reg
+import RegClass
 import NCGMonad
 
+import BlockId
 import Cmm
 import CmmOpt		( cmmMiniInline, cmmMachOpFold )
 import PprCmm
@@ -79,7 +82,6 @@ import State
 import UniqFM
 import Unique		( Unique, getUnique )
 import UniqSupply
-import List		( groupBy, sortBy )
 import DynFlags
 #if powerpc_TARGET_ARCH
 import StaticFlags	( opt_Static, opt_PIC )
@@ -195,7 +197,11 @@ nativeCodeGen dflags h us cmms
 
 		dumpIfSet_dyn dflags
 			Opt_D_dump_asm_conflicts "Register conflict graph"
-			$ Color.dotGraph Target.targetRegDotColor (Color.trivColorable Target.targetRegClass)
+			$ Color.dotGraph 
+				targetRegDotColor 
+				(Color.trivColorable 
+					targetVirtualRegSqueeze 
+					targetRealRegSqueeze)
 			$ graphGlobal)
 
 
@@ -231,19 +237,19 @@ cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count
 	Pretty.bufLeftRender h
 		$ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native
 
-	let lsPprNative =
+           -- carefully evaluate this strictly.  Binding it with 'let'
+           -- and then using 'seq' doesn't work, because the let
+           -- apparently gets inlined first.
+	lsPprNative <- return $!
 		if  dopt Opt_D_dump_asm       dflags
 	         || dopt Opt_D_dump_asm_stats dflags
 			then native
 			else []
 
-	let count'	= count + 1;
-
+	count' <- return $! count + 1;
 
 	-- force evaulation all this stuff to avoid space leaks
 	seqString (showSDoc $ vcat $ map ppr imports) `seq` return ()
-	lsPprNative 	`seq` return ()
-	count'		`seq` return ()
 
 	cmmNativeGens dflags h us' cmms
 			(imports : impAcc)
@@ -311,13 +317,14 @@ cmmNativeGen dflags us cmm count
 	   || dopt Opt_RegsIterative dflags)
 	  then do
 	  	-- the regs usable for allocation
-		let alloc_regs
+		let (alloc_regs :: UniqFM (UniqSet RealReg))
 			= foldr (\r -> plusUFM_C unionUniqSets
-					$ unitUFM (regClass r) (unitUniqSet r))
+					$ unitUFM (targetClassOfRealReg r) (unitUniqSet r))
 				emptyUFM
-			$ map RealReg allocatableRegs
+			$ allocatableRegs
+
 
-		-- graph coloring register allocation
+		-- do the graph coloring register allocation
 		let ((alloced, regAllocStats), usAlloc)
 			= {-# SCC "RegAlloc" #-}
 			  initUs usLive
@@ -385,7 +392,7 @@ cmmNativeGen dflags us cmm count
 	 	map sequenceTop shorted
 
 	---- x86fp_kludge
-	let final_mach_code =
+	let kludged =
 #if i386_TARGET_ARCH
 	 	{-# SCC "x86fp_kludge" #-}
 	 	map x86fp_kludge sequenced
@@ -393,15 +400,29 @@ cmmNativeGen dflags us cmm count
 		sequenced
 #endif
 
+	---- expansion of SPARC synthetic instrs
+#if sparc_TARGET_ARCH
+	let expanded = 
+		{-# SCC "sparc_expand" #-}
+		map SPARC.expandTop kludged
+
+	dumpIfSet_dyn dflags
+		Opt_D_dump_asm_expanded "Synthetic instructions expanded"
+		(vcat $ map (docToSDoc . pprNatCmmTop) expanded)
+#else
+	let expanded = 
+		kludged
+#endif
+
 	return 	( usAlloc
-		, final_mach_code
+		, expanded
 		, lastMinuteImports ++ imports
 		, ppr_raStatsColor
 		, ppr_raStatsLinear)
 
 
 #if i386_TARGET_ARCH
-x86fp_kludge :: NatCmmTop -> NatCmmTop
+x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr
 x86fp_kludge top@(CmmData _ _) = top
 x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) = 
 	CmmProc info lbl params (ListGraph $ i386_insert_ffrees code)
@@ -476,9 +497,8 @@ makeImportsDoc dflags imports
 -- fallthroughs.
 
 sequenceTop 
-	:: Instruction instr
-	=> NatCmmTop instr
-	-> NatCmmTop instr
+	:: NatCmmTop Instr
+	-> NatCmmTop Instr
 
 sequenceTop top@(CmmData _ _) = top
 sequenceTop (CmmProc info lbl params (ListGraph blocks)) = 
@@ -552,9 +572,8 @@ reorder id accum (b@(block,id',out) : rest)
 -- big, we have to work around this limitation.
 
 makeFarBranches 
-	:: Instruction instr
-	=> [NatBasicBlock instr] 
-	-> [NatBasicBlock instr]
+	:: [NatBasicBlock Instr] 
+	-> [NatBasicBlock Instr]
 
 #if powerpc_TARGET_ARCH
 makeFarBranches blocks
@@ -612,10 +631,17 @@ build_mapping (CmmProc info lbl params (ListGraph (head:blocks)))
   where
     -- find all the blocks that just consist of a jump that can be
     -- shorted.
-    (shortcut_blocks, others) = partitionWith split blocks
-    split (BasicBlock id [insn]) | Just dest <- canShortcut insn 
-                                 = Left (id,dest)
-    split other = Right other
+    -- Don't completely eliminate loops here -- that can leave a dangling jump!
+    (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
+    split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
+        | Just (DestBlockId dest) <- canShortcut insn,
+          (elemBlockSet dest s) || dest == id -- loop checks
+        = (s, shortcut_blocks, b : others)
+    split (s, shortcut_blocks, others) (BasicBlock id [insn])
+        | Just dest <- canShortcut insn
+        = (extendBlockSet s id, (id,dest) : shortcut_blocks, others)
+    split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
+
 
     -- build a mapping from BlockId to JumpDest for shorting branches
     mapping = foldl add emptyUFM shortcut_blocks