From 42222f95a101fb3647f8728302bbf1098b74e59e Mon Sep 17 00:00:00 2001
From: "Ben.Lippmeier@anu.edu.au" <unknown>
Date: Mon, 23 Feb 2009 07:12:07 +0000
Subject: [PATCH] SPARC NCG: Split out sanity checking into its own module

---
 compiler/ghc.cabal.in                      |    1 +
 compiler/nativeGen/SPARC/CodeGen.hs        |   39 ++--------------
 compiler/nativeGen/SPARC/CodeGen/Sanity.hs |   70 ++++++++++++++++++++++++++++
 compiler/nativeGen/SPARC/Instr.hs          |   13 ++++++
 4 files changed, 88 insertions(+), 35 deletions(-)
 create mode 100644 compiler/nativeGen/SPARC/CodeGen/Sanity.hs

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 0bca608..483303d 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -495,6 +495,7 @@ Library
             SPARC.CodeGen.CondCode
             SPARC.CodeGen.Gen32
             SPARC.CodeGen.Gen64
+            SPARC.CodeGen.Sanity
             RegAlloc.Liveness
             RegAlloc.Graph.Main
             RegAlloc.Graph.Stats
diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs
index 13907c7..6a34557 100644
--- a/compiler/nativeGen/SPARC/CodeGen.hs
+++ b/compiler/nativeGen/SPARC/CodeGen.hs
@@ -18,6 +18,7 @@ where
 #include "MachDeps.h"
 
 -- NCG stuff:
+import SPARC.CodeGen.Sanity
 import SPARC.CodeGen.Amode
 import SPARC.CodeGen.CondCode
 import SPARC.CodeGen.Gen64
@@ -77,7 +78,7 @@ basicBlockCodeGen
 	-> NatM ( [NatBasicBlock Instr]
 		, [NatCmmTop Instr])
 
-basicBlockCodeGen (BasicBlock id stmts) = do
+basicBlockCodeGen cmm@(BasicBlock id stmts) = do
   instrs <- stmtsToInstrs stmts
   let
 	(top,other_blocks,statics) 
@@ -92,46 +93,14 @@ basicBlockCodeGen (BasicBlock id stmts) = do
 	mkBlocks instr (instrs,blocks,statics)
 	  = (instr:instrs, blocks, statics)
 
+	-- do intra-block sanity checking
 	blocksChecked
-	  	= map checkBlockEnd
+	  	= map (checkBlock cmm)
 	  	$ BasicBlock id top : other_blocks
 
   return (blocksChecked, statics)
 
 
--- | Enforce the invariant that all basic blocks must end with a jump.
---	For SPARC this is a jump, then a nop for the branch delay slot.
---
---	If the branch isn't there then the register liveness determinator
---	will get the liveness information wrong. This will cause a bad
---	allocation, which is seriously difficult to debug.
---
---	If there is an instr in the branch delay slot, then the allocator
---	will also get confused and give a bad allocation.
---
-checkBlockEnd 
-	:: NatBasicBlock Instr -> NatBasicBlock Instr
-
-checkBlockEnd block@(BasicBlock _ instrs)
-	| Just (i1, i2)	<- takeLast2 instrs
-	, isJumpishInstr i1
-	, NOP		<- i2
-	= block
-	
-	| otherwise
-	= pprPanic 
-		("SPARC.CodeGen: bad instrs at end of block\n")
-		(text "block:\n" <> ppr block)
-
-takeLast2 :: [a] -> Maybe (a, a)
-takeLast2 xx
- = case xx of
- 	[]		-> Nothing
-	_:[]		-> Nothing
-	x1:x2:[]	-> Just (x1, x2)
-	_:xs		-> takeLast2 xs
-
-
 -- | Convert some Cmm statements to SPARC instructions.
 stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
 stmtsToInstrs stmts
diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
new file mode 100644
index 0000000..5d2f481
--- /dev/null
+++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
@@ -0,0 +1,70 @@
+
+-- | One ounce of sanity checking is worth 10000000000000000 ounces 
+--	of staring blindly at assembly code trying to find the problem..
+--
+module SPARC.CodeGen.Sanity (
+	checkBlock
+)
+
+where
+
+import SPARC.Instr
+import SPARC.Ppr	()
+import Instruction
+
+import Cmm
+
+import Outputable
+
+
+-- | Enforce intra-block invariants.
+--
+checkBlock
+	:: CmmBasicBlock -> NatBasicBlock Instr -> NatBasicBlock Instr
+
+checkBlock cmm block@(BasicBlock _ instrs)
+	| checkBlockInstrs instrs
+	= block
+	
+	| otherwise
+	= pprPanic 
+		("SPARC.CodeGen: bad block\n")
+		( vcat	[ text " -- cmm -----------------\n"
+			, ppr cmm
+			, text " -- native code ---------\n"
+			, ppr block ])
+
+
+checkBlockInstrs :: [Instr] -> Bool
+checkBlockInstrs ii
+
+	-- An unconditional jumps end the block.
+	--	There must be an unconditional jump in the block, otherwise
+	--	the register liveness determinator will get the liveness
+	--	information wrong. 
+	--
+	--	If the block ends with a cmm call that never returns
+	--	then there can be unreachable instructions after the jump,
+	--	but we don't mind here.
+	--
+	| instr : NOP : _	<- ii 
+	, isUnconditionalJump instr
+	= True
+	
+	-- All jumps must have a NOP in their branch delay slot.
+	--	The liveness determinator and register allocators aren't smart
+	--	enough to handle branch delay slots.
+	--
+	| instr : NOP : is	<- ii
+	, isJumpishInstr instr
+	= checkBlockInstrs is
+
+	-- keep checking
+	| _:i2:is		<- ii
+	= checkBlockInstrs (i2:is)
+
+	-- this block is no good	
+	| otherwise
+	= False
+
+
diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs
index 6c7af5b..b21f947 100644
--- a/compiler/nativeGen/SPARC/Instr.hs
+++ b/compiler/nativeGen/SPARC/Instr.hs
@@ -16,6 +16,8 @@ module SPARC.Instr (
 	fpRelEA,
 	moveSp,
 	
+	isUnconditionalJump,
+	
 	Instr(..),
 	maxSpillSlots
 )
@@ -69,6 +71,17 @@ moveSp :: Int -> Instr
 moveSp n
    = ADD False False sp (RIImm (ImmInt (n * wordLength))) sp
 
+-- | An instruction that will cause the one after it never to be exectuted
+isUnconditionalJump :: Instr -> Bool
+isUnconditionalJump ii
+ = case ii of
+ 	CALL{}		-> True
+	JMP{}		-> True
+	JMP_TBL{}	-> True
+	BI ALWAYS _ _	-> True
+	BF ALWAYS _ _ 	-> True
+	_		-> False
+
 
 -- | instance for sparc instruction set
 instance Instruction Instr where
-- 
1.7.10.4