Remove most functions from cmm/BlockId
authorMichal Terepeta <michal.terepeta@gmail.com>
Tue, 29 Nov 2016 22:49:27 +0000 (17:49 -0500)
committerBen Gamari <ben@smart-cactus.org>
Tue, 29 Nov 2016 23:46:32 +0000 (18:46 -0500)
It seems that `BlockId` module could simply go away in favor
of Hoopl's `Label`. This is the first step to do that.

In a few places I had to add some type signatures, but most of
them seem to help with code readability.

Signed-off-by: Michal Terepeta <michal.terepeta@gmail.com>
Test Plan: ./validate

Reviewers: austin, simonmar, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2765

compiler/cmm/BlockId.hs
compiler/cmm/CmmContFlowOpt.hs
compiler/cmm/CmmProcPoint.hs
compiler/nativeGen/AsmCodeGen.hs
compiler/nativeGen/RegAlloc/Graph/Spill.hs
compiler/nativeGen/RegAlloc/Graph/SpillClean.hs
compiler/nativeGen/RegAlloc/Linear/Main.hs
compiler/nativeGen/RegAlloc/Liveness.hs

index f54beec..9e96b97 100644 (file)
@@ -6,10 +6,9 @@ module BlockId
   ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
   , newBlockId
   , BlockSet, BlockEnv
-  , IsSet(..), setInsertList, setDeleteList, setUnions
-  , IsMap(..), mapInsertList, mapDeleteList, mapUnions
-  , emptyBlockSet, emptyBlockMap, lookupBlockMap, insertBlockMap
-  , blockLbl, infoTblLbl, retPtLbl
+  , IsSet(..)
+  , IsMap(..)
+  , blockLbl, infoTblLbl
   ) where
 
 import CLabel
@@ -48,9 +47,6 @@ mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique
 newBlockId :: MonadUnique m => m BlockId
 newBlockId = mkBlockId <$> getUniqueM
 
-retPtLbl :: BlockId -> CLabel
-retPtLbl label = mkReturnPtLabel $ getUnique label
-
 blockLbl :: BlockId -> CLabel
 blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs
 
@@ -63,20 +59,8 @@ type BlockEnv a = Hoopl.LabelMap a
 instance Outputable a => Outputable (BlockEnv a) where
   ppr = ppr . mapToList
 
-emptyBlockMap :: BlockEnv a
-emptyBlockMap = mapEmpty
-
-lookupBlockMap :: BlockId -> BlockEnv a -> Maybe a
-lookupBlockMap = mapLookup
-
-insertBlockMap :: BlockId -> a -> BlockEnv a -> BlockEnv a
-insertBlockMap = mapInsert
-
 -- Block sets
 type BlockSet = Hoopl.LabelSet
 
 instance Outputable BlockSet where
   ppr = ppr . setElems
-
-emptyBlockSet :: BlockSet
-emptyBlockSet = setEmpty
index ed953ac..b825f86 100644 (file)
@@ -402,7 +402,7 @@ removeUnreachableBlocksProc proc@(CmmProc info lbl live g)
              -- Remove any info_tbls for unreachable
 
      keep_used :: BlockEnv CmmInfoTable -> BlockEnv CmmInfoTable
-     keep_used bs = mapFoldWithKey keep emptyBlockMap bs
+     keep_used bs = mapFoldWithKey keep mapEmpty bs
 
      keep :: Label -> CmmInfoTable -> BlockEnv CmmInfoTable -> BlockEnv CmmInfoTable
      keep l i env | l `setMember` used_lbls = mapInsert l i env
index 9459a10..0efd45c 100644 (file)
@@ -243,7 +243,11 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
                   (CmmProc (TopInfo {info_tbls = info_tbls})
                            top_l _ g@(CmmGraph {g_entry=entry})) =
   do -- Build a map from procpoints to the blocks they reach
-     let addBlock b graphEnv =
+     let addBlock
+             :: CmmBlock
+             -> LabelMap (LabelMap CmmBlock)
+             -> LabelMap (LabelMap CmmBlock)
+         addBlock b graphEnv =
            case mapLookup bid procMap of
              Just ProcPoint -> add graphEnv bid bid b
              Just (ReachedBy set) ->
@@ -262,7 +266,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
                          regSetToList $
                          expectJust "ppLiveness" $ mapLookup pp liveness
 
-     graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g
+     graphEnv <- return $ foldGraphBlocks addBlock mapEmpty g
 
      -- Build a map from proc point BlockId to pairs of:
      --  * Labels for their new procedures
@@ -281,13 +285,21 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
 
      -- In each new graph, add blocks jumping off to the new procedures,
      -- and replace branches to procpoints with branches to the jump-off blocks
-     let add_jump_block (env, bs) (pp, l) =
+     let add_jump_block
+             :: (LabelMap Label, [CmmBlock])
+             -> (Label, CLabel)
+             -> UniqSM (LabelMap Label, [CmmBlock])
+         add_jump_block (env, bs) (pp, l) =
            do bid <- liftM mkBlockId getUniqueM
               let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump
                   live = ppLiveness pp
                   jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0
               return (mapInsert pp bid env, b : bs)
 
+         add_jumps
+             :: LabelMap CmmGraph
+             -> (Label, LabelMap CmmBlock)
+             -> UniqSM (LabelMap CmmGraph)
          add_jumps newGraphEnv (ppId, blockEnv) =
            do let needed_jumps = -- find which procpoints we currently branch to
                     mapFold add_if_branch_to_pp [] blockEnv
@@ -323,7 +335,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
               -- pprTrace "g' pre jumps" (ppr g') $ do
               return (mapInsert ppId g' newGraphEnv)
 
-     graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv
+     graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv
 
      let to_proc (bid, g)
              | bid == entry
@@ -360,7 +372,9 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
      -- The C back end expects to see return continuations before the
      -- call sites.  Here, we sort them in reverse order -- it gets
      -- reversed later.
-     let (_, block_order) = foldl add_block_num (0::Int, emptyBlockMap) (postorderDfs g)
+     let (_, block_order) =
+             foldl add_block_num (0::Int, mapEmpty :: LabelMap Int)
+                   (postorderDfs g)
          add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map)
          sort_fn (bid, _) (bid', _) =
            compare (expectJust "block_order" $ mapLookup bid  block_order)
index affb3e4..ad897ab 100644 (file)
@@ -877,7 +877,8 @@ build_mapping ncgImpl (CmmProc info lbl live (ListGraph (head:blocks)))
     -- find all the blocks that just consist of a jump that can be
     -- shorted.
     -- Don't completely eliminate loops here -- that can leave a dangling jump!
-    (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
+    (_, shortcut_blocks, others) =
+        foldl split (setEmpty :: LabelSet, [], []) blocks
     split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
         | Just jd <- canShortcut ncgImpl insn,
           Just dest <- getJumpDestBlockId ncgImpl jd,
index a9ea6e5..445f416 100644 (file)
@@ -135,7 +135,7 @@ regSpill_top platform regSlotMap cmm
          = let
                 -- Slots that are already recorded as being live.
                 curSlotsLive    = fromMaybe IntSet.empty
-                                $ lookupBlockMap blockId slotMap
+                                $ mapLookup blockId slotMap
 
                 moreSlotsLive   = IntSet.fromList
                                 $ catMaybes
@@ -144,8 +144,8 @@ regSpill_top platform regSlotMap cmm
                     -- See Note [Unique Determinism and code generation]
 
                 slotMap'
-                 = insertBlockMap blockId (IntSet.union curSlotsLive moreSlotsLive)
-                                  slotMap
+                 = mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive)
+                             slotMap
 
            in   slotMap'
 
index 1df4b25..c75bceb 100644 (file)
@@ -381,7 +381,7 @@ cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs)
                 let slotsReloadedByTargets
                         = IntSet.unions
                         $ catMaybes
-                        $ map (flip lookupBlockMap liveSlotsOnEntry)
+                        $ map (flip mapLookup liveSlotsOnEntry)
                         $ targets
 
                 let noReloads'
index 0fe2592..cec08a2 100644 (file)
@@ -234,7 +234,7 @@ linearRegAlloc'
 linearRegAlloc' dflags initFreeRegs entry_ids block_live sccs
  = do   us      <- getUniqueSupplyM
         let (_, stack, stats, blocks) =
-                runR dflags emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap dflags) us
+                runR dflags mapEmpty initFreeRegs emptyRegMap (emptyStackMap dflags) us
                     $ linearRA_SCCs entry_ids block_live [] sccs
         return  (blocks, stats, getStackUse stack)
 
index 988bda0..98b9659 100644 (file)
@@ -14,7 +14,7 @@
 module RegAlloc.Liveness (
         RegSet,
         RegMap, emptyRegMap,
-        BlockMap, emptyBlockMap,
+        BlockMap, mapEmpty,
         LiveCmmDecl,
         InstrSR   (..),
         LiveInstr (..),
@@ -646,7 +646,7 @@ natCmmTopToLive (CmmData i d)
         = CmmData i d
 
 natCmmTopToLive (CmmProc info lbl live (ListGraph []))
-        = CmmProc (LiveInfo info [] Nothing emptyBlockMap) lbl live []
+        = CmmProc (LiveInfo info [] Nothing mapEmpty) lbl live []
 
 natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _)))
  = let  first_id        = blockId first
@@ -657,7 +657,7 @@ natCmmTopToLive proc@(CmmProc info lbl live (ListGraph blocks@(first : _)))
                                         BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
                         $ sccs
 
-   in   CmmProc (LiveInfo info (first_id : entry_ids) Nothing emptyBlockMap)
+   in   CmmProc (LiveInfo info (first_id : entry_ids) Nothing mapEmpty)
                 lbl live sccsLive
 
 
@@ -723,7 +723,7 @@ regLiveness _ (CmmData i d)
 regLiveness _ (CmmProc info lbl live [])
         | LiveInfo static mFirst _ _    <- info
         = return $ CmmProc
-                        (LiveInfo static mFirst (Just mapEmpty) emptyBlockMap)
+                        (LiveInfo static mFirst (Just mapEmpty) mapEmpty)
                         lbl live []
 
 regLiveness platform (CmmProc info lbl live sccs)
@@ -805,7 +805,7 @@ computeLiveness
 
 computeLiveness platform sccs
  = case checkIsReverseDependent sccs of
-        Nothing         -> livenessSCCs platform emptyBlockMap [] sccs
+        Nothing         -> livenessSCCs platform mapEmpty [] sccs
         Just bad        -> pprPanic "RegAlloc.Liveness.computeLivenss"
                                 (vcat   [ text "SCCs aren't in reverse dependent order"
                                         , text "bad blockId" <+> ppr bad