SPARC NCG: Split out sanity checking into its own module

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 0bca608..483303d 100644 (file)
--- 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 (file)
--- 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 (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
+
+

diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs
index 6c7af5b..b21f947 100644 (file)
--- 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