eraseDeltasLive,
patchEraseLive,
patchRegsLiveInstr,
+ reverseBlocksInTops,
regLiveness,
natCmmTopToLive
) 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
--
--
slurpReloadCoalesce
- :: Instruction instr
+ :: forall instr. Instruction instr
=> LiveCmmTop instr
-> Bag (Reg, Reg)
slurpReloadCoalesce live
= slurpCmm emptyBag live
- where slurpCmm cs CmmData{} = cs
+ where
+ slurpCmm :: Bag (Reg, Reg)
+ -> GenCmmTop t t1 [SCC (LiveBasicBlock instr)]
+ -> Bag (Reg, Reg)
+ slurpCmm cs CmmData{} = cs
slurpCmm cs (CmmProc _ _ _ sccs)
= slurpComp cs (flattenSCCs sccs)
+ slurpComp :: Bag (Reg, Reg)
+ -> [LiveBasicBlock instr]
+ -> Bag (Reg, Reg)
slurpComp cs blocks
= let (moveBags, _) = runState (slurpCompM blocks) emptyUFM
in unionManyBags (cs : moveBags)
+ slurpCompM :: [LiveBasicBlock instr]
+ -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
slurpCompM blocks
= do -- run the analysis once to record the mapping across jumps.
mapM_ (slurpBlock False) blocks
-- not worth the trouble.
mapM (slurpBlock True) blocks
+ slurpBlock :: Bool -> LiveBasicBlock instr
+ -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
slurpBlock propagate (BasicBlock blockId instrs)
= do -- grab the slot map for entry to this block
slotMap <- if propagate
(_, mMoves) <- mapAccumLM slurpLI slotMap instrs
return $ listToBag $ catMaybes mMoves
- slurpLI :: Instruction instr
- => UniqFM Reg -- current slotMap
+ slurpLI :: UniqFM Reg -- current slotMap
-> LiveInstr instr
-> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg]
-- for tracking slotMaps across jumps
-- Annotate code with register liveness information
--
regLiveness
- :: Instruction instr
+ :: (Outputable instr, Instruction instr)
=> LiveCmmTop instr
-> UniqSM (LiveCmmTop instr)
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 _ []
+ = 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 _ 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