NCG: Reverse SCCs after each round in the graph allocator

[ghc-hetmet.git] / compiler / nativeGen / RegAlloc / Liveness.hs

diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index 18dd01a..cc1bf12 100644 (file)
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -27,6 +27,7 @@ module RegAlloc.Liveness (
        eraseDeltasLive,
        patchEraseLive,
        patchRegsLiveInstr,
+       reverseBlocksInTops,
        regLiveness,
        natCmmTopToLive
   ) where
@@ -141,8 +142,6 @@ instance Instruction instr => Instruction (InstrSR instr) where
 -- | An instruction with liveness information.
 data LiveInstr instr
        = LiveInstr (InstrSR instr) (Maybe Liveness)
-       
-
 
 -- | Liveness information.
 --     The regs which die are ones which are no longer live in the *next* instruction
@@ -447,9 +446,8 @@ slurpReloadCoalesce live
 
 
 -- | Strip away liveness information, yielding NatCmmTop
-
 stripLive 
-       :: Instruction instr
+       :: (Outputable instr, Instruction instr)
        => LiveCmmTop instr 
        -> NatCmmTop instr
 
@@ -470,8 +468,14 @@ stripLive live
           in   CmmProc info label params
                           (ListGraph $ map stripLiveBlock $ first' : rest')
 
-       stripCmm _
-                = panic "RegAlloc.Liveness.stripLive: no first_id on proc"     
+       -- procs used for stg_split_markers don't contain any blocks, and have no first_id.
+       stripCmm (CmmProc (LiveInfo info Nothing _) label params [])
+        =      CmmProc info label params (ListGraph [])
+
+       -- If the proc has blocks but we don't know what the first one was, then we're dead.
+       stripCmm proc
+                = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)
+                       
 
 -- | Strip away liveness information from a basic block,
 --     and make real spill instructions out of SPILL, RELOAD pseudos along the way.
@@ -646,7 +650,7 @@ sccBlocks blocks = stronglyConnCompFromEdgedVertices graph
 -- Annotate code with register liveness information
 --
 regLiveness
-       :: Instruction instr
+       :: (Outputable instr, Instruction instr)
        => LiveCmmTop instr
        -> UniqSM (LiveCmmTop instr)
 
@@ -667,25 +671,78 @@ regLiveness (CmmProc info lbl params sccs)
                           lbl params ann_sccs
 
 
-
 -- -----------------------------------------------------------------------------
--- Computing liveness
+-- | Check ordering of Blocks
+--     The computeLiveness function requires SCCs to be in reverse dependent order.
+--     If they're not the liveness information will be wrong, and we'll get a bad allocation.
+--     Better to check for this precondition explicitly or some other poor sucker will
+--     waste a day staring at bad assembly code..
+--     
+checkIsReverseDependent
+       :: Instruction instr
+       => [SCC (LiveBasicBlock instr)]         -- ^ SCCs of blocks that we're about to run the liveness determinator on.
+       -> Maybe BlockId                        -- ^ BlockIds that fail the test (if any)
+       
+checkIsReverseDependent sccs'
+ = go emptyUniqSet sccs'
+
+ where         go blockssSeen []
+        = Nothing
+       
+       go blocksSeen (AcyclicSCC block : sccs)
+        = let  dests           = slurpJumpDestsOfBlock block
+               blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet [blockId block]
+               badDests        = dests `minusUniqSet` blocksSeen'
+          in   case uniqSetToList badDests of
+                []             -> go blocksSeen' sccs
+                bad : _        -> Just bad
+               
+       go blocksSeen (CyclicSCC blocks : sccs)
+        = let  dests           = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks
+               blocksSeen'     = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks
+               badDests        = dests `minusUniqSet` blocksSeen'
+          in   case uniqSetToList badDests of
+                []             -> go blocksSeen' sccs
+                bad : _        -> Just bad
+               
+       slurpJumpDestsOfBlock (BasicBlock blockId instrs)
+               = unionManyUniqSets
+               $ map (mkUniqSet . jumpDestsOfInstr) 
+                       [ i | LiveInstr i _ <- instrs]
+
+
+-- | If we've compute liveness info for this code already we have to reverse
+--   the SCCs in each top to get them back to the right order so we can do it again.
+reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr
+reverseBlocksInTops top
+ = case top of
+       CmmData{}                       -> top
+       CmmProc info lbl params sccs    -> CmmProc info lbl params (reverse sccs)
 
+       
+-- | Computing liveness
+--     
+--  On entry, the SCCs must be in "reverse" order: later blocks may transfer
+--  control to earlier ones only, else `panic`.
+-- 
+--  The SCCs returned are in the *opposite* order, which is exactly what we
+--  want for the next pass.
+--
 computeLiveness
-       :: Instruction instr
+       :: (Outputable instr, Instruction instr)
        => [SCC (LiveBasicBlock instr)]
        -> ([SCC (LiveBasicBlock instr)],       -- instructions annotated with list of registers
                                                -- which are "dead after this instruction".
               BlockMap RegSet)                 -- blocks annontated with set of live registers
                                                -- on entry to the block.
-       
-  -- NOTE: on entry, the SCCs are in "reverse" order: later blocks may transfer
-  -- control to earlier ones only.  The SCCs returned are in the *opposite* 
-  -- order, which is exactly what we want for the next pass.
 
 computeLiveness sccs
-       = livenessSCCs emptyBlockMap [] sccs
-
+ = case checkIsReverseDependent sccs of
+       Nothing         -> livenessSCCs emptyBlockMap [] sccs
+       Just bad        -> pprPanic "RegAlloc.Liveness.computeLivenss"
+                               (vcat   [ text "SCCs aren't in reverse dependent order"
+                                       , text "bad blockId" <+> ppr bad 
+                                       , ppr sccs])
 
 livenessSCCs
        :: Instruction instr