SPARC NCG: Split out sanity checking into its own module

[ghc-hetmet.git] / compiler / nativeGen / SPARC / CodeGen / Sanity.hs

diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs
new file mode 100644 (file)
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
+
+