Add type sigs to functions in RegAlloc.Graph.Spill
authorIan Lynagh <igloo@earth.li>
Wed, 31 Aug 2011 19:58:01 +0000 (20:58 +0100)
committerIan Lynagh <igloo@earth.li>
Wed, 31 Aug 2011 19:58:01 +0000 (20:58 +0100)
compiler/nativeGen/RegAlloc/Graph/Spill.hs

index e44a65d..d8a654a 100644 (file)
@@ -1,12 +1,11 @@
-{-# OPTIONS -fno-warn-missing-signatures #-}
 
 -- | When there aren't enough registers to hold all the vregs we have to spill some of those
 --   vregs to slots on the stack. This module is used modify the code to use those slots.
 --
 module RegAlloc.Graph.Spill (
-       regSpill,
-       SpillStats(..),
-       accSpillSL
+        regSpill,
+        SpillStats(..),
+        accSpillSL
 )
 where
 import RegAlloc.Liveness
@@ -24,14 +23,14 @@ import Outputable
 
 import Data.List
 import Data.Maybe
-import Data.Map                        (Map)
-import Data.Set                        (Set)
-import qualified Data.Map      as Map
-import qualified Data.Set      as Set
+import Data.Map                 (Map)
+import Data.Set                 (Set)
+import qualified Data.Map       as Map
+import qualified Data.Set       as Set
 
 
 -- | Spill all these virtual regs to stack slots.
--- 
+--
 --   TODO: See if we can split some of the live ranges instead of just globally
 --         spilling the virtual reg. This might make the spill cleaner's job easier.
 --
@@ -40,255 +39,274 @@ import qualified Data.Set as Set
 --         address the spill slot directly.
 --
 regSpill
-       :: Instruction instr
-       => [LiveCmmDecl statics instr]  -- ^ the code
-       -> UniqSet Int                  -- ^ available stack slots
-       -> UniqSet VirtualReg           -- ^ the regs to spill
-       -> UniqSM
-               ([LiveCmmDecl statics instr] -- code with SPILL and RELOAD meta instructions added.
-               , UniqSet Int               -- left over slots
-               , SpillStats )              -- stats about what happened during spilling
+        :: Instruction instr
+        => [LiveCmmDecl statics instr]  -- ^ the code
+        -> UniqSet Int                  -- ^ available stack slots
+        -> UniqSet VirtualReg           -- ^ the regs to spill
+        -> UniqSM
+                ([LiveCmmDecl statics instr] -- code with SPILL and RELOAD meta instructions added.
+                , UniqSet Int               -- left over slots
+                , SpillStats )              -- stats about what happened during spilling
 
 regSpill code slotsFree regs
 
-       -- not enough slots to spill these regs
-       | sizeUniqSet slotsFree < sizeUniqSet regs
-       = pprPanic "regSpill: out of spill slots!"
-               (  text "   regs to spill = " <> ppr (sizeUniqSet regs)
-               $$ text "   slots left    = " <> ppr (sizeUniqSet slotsFree))
+        -- not enough slots to spill these regs
+        | sizeUniqSet slotsFree < sizeUniqSet regs
+        = pprPanic "regSpill: out of spill slots!"
+                (  text "   regs to spill = " <> ppr (sizeUniqSet regs)
+                $$ text "   slots left    = " <> ppr (sizeUniqSet slotsFree))
 
-       | otherwise
-       = do
-               -- allocate a slot for each of the spilled regs
-               let slots       = take (sizeUniqSet regs) $ uniqSetToList slotsFree
-               let regSlotMap  = listToUFM
-                               $ zip (uniqSetToList regs) slots
+        | otherwise
+        = do
+                -- allocate a slot for each of the spilled regs
+                let slots       = take (sizeUniqSet regs) $ uniqSetToList slotsFree
+                let regSlotMap  = listToUFM
+                                $ zip (uniqSetToList regs) slots
 
-               -- grab the unique supply from the monad
-               us      <- getUs
+                -- grab the unique supply from the monad
+                us      <- getUs
 
-               -- run the spiller on all the blocks
-               let (code', state')     =
-                       runState (mapM (regSpill_top regSlotMap) code)
-                                (initSpillS us)
+                -- run the spiller on all the blocks
+                let (code', state')     =
+                        runState (mapM (regSpill_top regSlotMap) code)
+                                 (initSpillS us)
 
-               return  ( code'
-                       , minusUniqSet slotsFree (mkUniqSet slots)
-                       , makeSpillStats state')
+                return  ( code'
+                        , minusUniqSet slotsFree (mkUniqSet slots)
+                        , makeSpillStats state')
 
 
 -- | Spill some registers to stack slots in a top-level thing.
-regSpill_top 
-       :: Instruction instr
-       => RegMap Int                   -- ^ map of vregs to slots they're being spilled to.
-       -> LiveCmmDecl statics instr    -- ^ the top level thing.
-       -> SpillM (LiveCmmDecl statics instr)
-       
+regSpill_top
+        :: Instruction instr
+        => RegMap Int                   -- ^ map of vregs to slots they're being spilled to.
+        -> LiveCmmDecl statics instr    -- ^ the top level thing.
+        -> SpillM (LiveCmmDecl statics instr)
+
 regSpill_top regSlotMap cmm
  = case cmm of
-       CmmData{}                               
-        -> return cmm
-
-       CmmProc info label sccs
-        |  LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info
-        -> do  
-               -- We should only passed Cmms with the liveness maps filled in,  but we'll
-               -- create empty ones if they're not there just in case.
-               let liveVRegsOnEntry    = fromMaybe mapEmpty mLiveVRegsOnEntry
-               
-               -- The liveVRegsOnEntry contains the set of vregs that are live on entry to
-               -- each basic block. If we spill one of those vregs we remove it from that
-               -- set and add the corresponding slot number to the liveSlotsOnEntry set.
-               -- The spill cleaner needs this information to erase unneeded spill and 
-               -- reload instructions after we've done a successful allocation.
-               let liveSlotsOnEntry' :: Map BlockId (Set Int)
-                   liveSlotsOnEntry'
-                       = mapFoldWithKey patchLiveSlot liveSlotsOnEntry liveVRegsOnEntry
-
-               let info'
-                       = LiveInfo static firstId
-                               (Just liveVRegsOnEntry)
-                               liveSlotsOnEntry'
-                                       
-               -- Apply the spiller to all the basic blocks in the CmmProc.
-               sccs'           <- mapM (mapSCCM (regSpill_block regSlotMap)) sccs
-
-               return  $ CmmProc info' label sccs'
-
- where -- | Given a BlockId and the set of registers live in it, 
-       --   if registers in this block are being spilled to stack slots, 
-       --   then record the fact that these slots are now live in those blocks
-       --   in the given slotmap.
-       patchLiveSlot :: BlockId -> RegSet -> Map BlockId (Set Int) -> Map BlockId (Set Int)
-       patchLiveSlot blockId regsLive slotMap
-        = let  curSlotsLive    = fromMaybe Set.empty
-                               $ Map.lookup blockId slotMap
-
-               moreSlotsLive   = Set.fromList
-                               $ catMaybes 
-                               $ map (lookupUFM regSlotMap)
-                               $ uniqSetToList regsLive
-               
-               slotMap'        = Map.insert blockId (Set.union curSlotsLive moreSlotsLive) slotMap
-
-          in   slotMap'
+        CmmData{}
+         -> return cmm
+
+        CmmProc info label sccs
+         |  LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info
+         -> do
+                -- We should only passed Cmms with the liveness maps filled in,  but we'll
+                -- create empty ones if they're not there just in case.
+                let liveVRegsOnEntry    = fromMaybe mapEmpty mLiveVRegsOnEntry
+
+                -- The liveVRegsOnEntry contains the set of vregs that are live on entry to
+                -- each basic block. If we spill one of those vregs we remove it from that
+                -- set and add the corresponding slot number to the liveSlotsOnEntry set.
+                -- The spill cleaner needs this information to erase unneeded spill and
+                -- reload instructions after we've done a successful allocation.
+                let liveSlotsOnEntry' :: Map BlockId (Set Int)
+                    liveSlotsOnEntry'
+                        = mapFoldWithKey patchLiveSlot liveSlotsOnEntry liveVRegsOnEntry
+
+                let info'
+                        = LiveInfo static firstId
+                                (Just liveVRegsOnEntry)
+                                liveSlotsOnEntry'
+
+                -- Apply the spiller to all the basic blocks in the CmmProc.
+                sccs'           <- mapM (mapSCCM (regSpill_block regSlotMap)) sccs
+
+                return  $ CmmProc info' label sccs'
+
+ where  -- | Given a BlockId and the set of registers live in it,
+        --   if registers in this block are being spilled to stack slots,
+        --   then record the fact that these slots are now live in those blocks
+        --   in the given slotmap.
+        patchLiveSlot :: BlockId -> RegSet -> Map BlockId (Set Int) -> Map BlockId (Set Int)
+        patchLiveSlot blockId regsLive slotMap
+         = let  curSlotsLive    = fromMaybe Set.empty
+                                $ Map.lookup blockId slotMap
+
+                moreSlotsLive   = Set.fromList
+                                $ catMaybes
+                                $ map (lookupUFM regSlotMap)
+                                $ uniqSetToList regsLive
+
+                slotMap'        = Map.insert blockId (Set.union curSlotsLive moreSlotsLive) slotMap
+
+           in   slotMap'
 
 
 
 -- | Spill some registers to stack slots in a basic block.
 regSpill_block
-       :: Instruction instr
-       => UniqFM Int           -- ^ map of vregs to slots they're being spilled to.
-       -> LiveBasicBlock instr 
-       -> SpillM (LiveBasicBlock instr)
-       
+        :: Instruction instr
+        => UniqFM Int           -- ^ map of vregs to slots they're being spilled to.
+        -> LiveBasicBlock instr
+        -> SpillM (LiveBasicBlock instr)
+
 regSpill_block regSlotMap (BasicBlock i instrs)
- = do  instrss'        <- mapM (regSpill_instr regSlotMap) instrs
-       return  $ BasicBlock i (concat instrss')
+ = do   instrss'        <- mapM (regSpill_instr regSlotMap) instrs
+        return  $ BasicBlock i (concat instrss')
 
 
 -- | Spill some registers to stack slots in a single instruction.  If the instruction
 --   uses registers that need to be spilled, then it is prefixed (or postfixed) with
 --   the appropriate RELOAD or SPILL meta instructions.
 regSpill_instr
-       :: Instruction instr
-       => UniqFM Int           -- ^ map of vregs to slots they're being spilled to.
-       -> LiveInstr instr
-       -> SpillM [LiveInstr instr]
+        :: Instruction instr
+        => UniqFM Int           -- ^ map of vregs to slots they're being spilled to.
+        -> LiveInstr instr
+        -> SpillM [LiveInstr instr]
 
 regSpill_instr _ li@(LiveInstr _ Nothing)
- = do  return [li]
+ = do   return [li]
 
 regSpill_instr regSlotMap
-       (LiveInstr instr (Just _))
+        (LiveInstr instr (Just _))
  = do
-       -- work out which regs are read and written in this instr
-       let RU rlRead rlWritten = regUsageOfInstr instr
-
-       -- sometimes a register is listed as being read more than once,
-       --      nub this so we don't end up inserting two lots of spill code.
-       let rsRead_             = nub rlRead
-       let rsWritten_          = nub rlWritten
-
-       -- if a reg is modified, it appears in both lists, want to undo this..
-       let rsRead              = rsRead_    \\ rsWritten_
-       let rsWritten           = rsWritten_ \\ rsRead_
-       let rsModify            = intersect rsRead_ rsWritten_
-
-       -- work out if any of the regs being used are currently being spilled.
-       let rsSpillRead         = filter (\r -> elemUFM r regSlotMap) rsRead
-       let rsSpillWritten      = filter (\r -> elemUFM r regSlotMap) rsWritten
-       let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify
-
-       -- rewrite the instr and work out spill code.
-       (instr1, prepost1)      <- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead
-       (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten
-       (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify
-
-       let (mPrefixes, mPostfixes)     = unzip (prepost1 ++ prepost2 ++ prepost3)
-       let prefixes                    = concat mPrefixes
-       let postfixes                   = concat mPostfixes
-
-       -- final code
-       let instrs'     =  prefixes
-                       ++ [LiveInstr instr3 Nothing]
-                       ++ postfixes
-
-       return
-{-             $ pprTrace "* regSpill_instr spill"
-                       (  text "instr  = " <> ppr instr
-                       $$ text "read   = " <> ppr rsSpillRead
-                       $$ text "write  = " <> ppr rsSpillWritten
-                       $$ text "mod    = " <> ppr rsSpillModify
-                       $$ text "-- out"
-                       $$ (vcat $ map ppr instrs')
-                       $$ text " ")
+        -- work out which regs are read and written in this instr
+        let RU rlRead rlWritten = regUsageOfInstr instr
+
+        -- sometimes a register is listed as being read more than once,
+        --      nub this so we don't end up inserting two lots of spill code.
+        let rsRead_             = nub rlRead
+        let rsWritten_          = nub rlWritten
+
+        -- if a reg is modified, it appears in both lists, want to undo this..
+        let rsRead              = rsRead_    \\ rsWritten_
+        let rsWritten           = rsWritten_ \\ rsRead_
+        let rsModify            = intersect rsRead_ rsWritten_
+
+        -- work out if any of the regs being used are currently being spilled.
+        let rsSpillRead         = filter (\r -> elemUFM r regSlotMap) rsRead
+        let rsSpillWritten      = filter (\r -> elemUFM r regSlotMap) rsWritten
+        let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify
+
+        -- rewrite the instr and work out spill code.
+        (instr1, prepost1)      <- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead
+        (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten
+        (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify
+
+        let (mPrefixes, mPostfixes)     = unzip (prepost1 ++ prepost2 ++ prepost3)
+        let prefixes                    = concat mPrefixes
+        let postfixes                   = concat mPostfixes
+
+        -- final code
+        let instrs'     =  prefixes
+                        ++ [LiveInstr instr3 Nothing]
+                        ++ postfixes
+
+        return
+{-              $ pprTrace "* regSpill_instr spill"
+                        (  text "instr  = " <> ppr instr
+                        $$ text "read   = " <> ppr rsSpillRead
+                        $$ text "write  = " <> ppr rsSpillWritten
+                        $$ text "mod    = " <> ppr rsSpillModify
+                        $$ text "-- out"
+                        $$ (vcat $ map ppr instrs')
+                        $$ text " ")
 -}
-               $ instrs'
+                $ instrs'
 
 
+spillRead
+        :: Instruction instr
+        => UniqFM Int
+        -> instr
+        -> Reg
+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
 spillRead regSlotMap instr reg
-       | Just slot     <- lookupUFM regSlotMap reg
-       = do    (instr', nReg)  <- patchInstr reg instr
+        | Just slot     <- lookupUFM regSlotMap reg
+        = do    (instr', nReg)  <- patchInstr reg instr
 
-               modify $ \s -> s
-                       { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
+                modify $ \s -> s
+                        { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }
 
-               return  ( instr'
-                       , ( [LiveInstr (RELOAD slot nReg) Nothing]
-                         , []) )
+                return  ( instr'
+                        , ( [LiveInstr (RELOAD slot nReg) Nothing]
+                          , []) )
 
-       | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"
+        | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"
 
 
+spillWrite
+        :: Instruction instr
+        => UniqFM Int
+        -> instr
+        -> Reg
+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
 spillWrite regSlotMap instr reg
-       | Just slot     <- lookupUFM regSlotMap reg
-       = do    (instr', nReg)  <- patchInstr reg instr
+        | Just slot     <- lookupUFM regSlotMap reg
+        = do    (instr', nReg)  <- patchInstr reg instr
 
-               modify $ \s -> s
-                       { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
+                modify $ \s -> s
+                        { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }
 
-               return  ( instr'
-                       , ( []
-                         , [LiveInstr (SPILL nReg slot) Nothing]))
+                return  ( instr'
+                        , ( []
+                          , [LiveInstr (SPILL nReg slot) Nothing]))
 
-       | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg"
+        | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg"
 
 
+spillModify
+        :: Instruction instr
+        => UniqFM Int
+        -> instr
+        -> Reg
+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))
 spillModify regSlotMap instr reg
-       | Just slot     <- lookupUFM regSlotMap reg
-       = do    (instr', nReg)  <- patchInstr reg instr
+        | Just slot     <- lookupUFM regSlotMap reg
+        = do    (instr', nReg)  <- patchInstr reg instr
 
-               modify $ \s -> s
-                       { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
+                modify $ \s -> s
+                        { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }
 
-               return  ( instr'
-                       , ( [LiveInstr (RELOAD slot nReg) Nothing]
-                         , [LiveInstr (SPILL nReg slot) Nothing]))
+                return  ( instr'
+                        , ( [LiveInstr (RELOAD slot nReg) Nothing]
+                          , [LiveInstr (SPILL nReg slot) Nothing]))
 
-       | otherwise     = panic "RegSpill.spillModify: no slot defined for spilled reg"
+        | otherwise     = panic "RegSpill.spillModify: no slot defined for spilled reg"
 
 
 
 -- | Rewrite uses of this virtual reg in an instr to use a different virtual reg
-patchInstr 
-       :: Instruction instr
-       => Reg -> instr -> SpillM (instr, Reg)
+patchInstr
+        :: Instruction instr
+        => Reg -> instr -> SpillM (instr, Reg)
 
 patchInstr reg instr
- = do  nUnique         <- newUnique
-       let nReg        = case reg of 
-                               RegVirtual vr   -> RegVirtual (renameVirtualReg nUnique vr)
-                               RegReal{}       -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg"
-       let instr'      = patchReg1 reg nReg instr
-       return          (instr', nReg)
+ = do   nUnique         <- newUnique
+        let nReg        = case reg of
+                                RegVirtual vr   -> RegVirtual (renameVirtualReg nUnique vr)
+                                RegReal{}       -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg"
+        let instr'      = patchReg1 reg nReg instr
+        return          (instr', nReg)
 
-patchReg1 
-       :: Instruction instr
-       => Reg -> Reg -> instr -> instr
+patchReg1
+        :: Instruction instr
+        => Reg -> Reg -> instr -> instr
 
 patchReg1 old new instr
- = let patchF r
-               | r == old      = new
-               | otherwise     = r
-   in  patchRegsOfInstr instr patchF
+ = let  patchF r
+                | r == old      = new
+                | otherwise     = r
+   in   patchRegsOfInstr instr patchF
 
 
 -- Spiller monad --------------------------------------------------------------
 data SpillS
-       = SpillS
-       { -- | unique supply for generating fresh vregs.
-         stateUS       :: UniqSupply
-       
-         -- | spilled vreg vs the number of times it was loaded, stored 
-       , stateSpillSL  :: UniqFM (Reg, Int, Int) }
+        = SpillS
+        { -- | unique supply for generating fresh vregs.
+          stateUS       :: UniqSupply
+
+          -- | spilled vreg vs the number of times it was loaded, stored
+        , stateSpillSL  :: UniqFM (Reg, Int, Int) }
 
+initSpillS :: UniqSupply -> SpillS
 initSpillS uniqueSupply
-       = SpillS
-       { stateUS       = uniqueSupply
-       , stateSpillSL  = emptyUFM }
+        = SpillS
+        { stateUS       = uniqueSupply
+        , stateSpillSL  = emptyUFM }
 
-type SpillM a  = State SpillS a
+type SpillM a   = State SpillS a
 
 newUnique :: SpillM Unique
 newUnique
@@ -298,22 +316,23 @@ newUnique
           -> do modify $ \s -> s { stateUS = us' }
                 return uniq
 
+accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)
 accSpillSL (r1, s1, l1) (_, s2, l2)
-       = (r1, s1 + s2, l1 + l2)
+        = (r1, s1 + s2, l1 + l2)
 
 
 -- Spiller stats --------------------------------------------------------------
 data SpillStats
-       = SpillStats
-       { spillStoreLoad        :: UniqFM (Reg, Int, Int) }
+        = SpillStats
+        { spillStoreLoad        :: UniqFM (Reg, Int, Int) }
 
 makeSpillStats :: SpillS -> SpillStats
 makeSpillStats s
-       = SpillStats
-       { spillStoreLoad        = stateSpillSL s }
+        = SpillStats
+        { spillStoreLoad        = stateSpillSL s }
 
 instance Outputable SpillStats where
  ppr stats
-       = (vcat $ map (\(r, s, l) -> ppr r <+> int s <+> int l)
-                       $ eltsUFM (spillStoreLoad stats))
+        = (vcat $ map (\(r, s, l) -> ppr r <+> int s <+> int l)
+                        $ eltsUFM (spillStoreLoad stats))