Use newBlockId instead of newLabelC

This seems like a clearer name and the fewer functions that
one needs to remember, the better.

Test Plan: validate

Reviewers: austin, simonmar, michalt

Reviewed By: simonmar, michalt

Subscribers: thomie

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

11 files changed, 48 insertions, 41 deletions

diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs
index ac3af90..f54beec 100644
--- a/compiler/cmm/BlockId.hs
+++ b/compiler/cmm/BlockId.hs
@@ -4,6 +4,7 @@
 {- BlockId module should probably go away completely, being superseded by Label -}
 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
@@ -16,6 +17,7 @@ import IdInfo
 import Name
 import Outputable
 import Unique
+import UniqSupply
 
 import Compiler.Hoopl as Hoopl hiding (Unique)
 import Compiler.Hoopl.Internals (uniqueToLbl, lblToUnique)
@@ -43,6 +45,9 @@ instance Outputable BlockId where
 mkBlockId :: Unique -> BlockId
 mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique
 
+newBlockId :: MonadUnique m => m BlockId
+newBlockId = mkBlockId <$> getUniqueM
+
 retPtLbl :: BlockId -> CLabel
 retPtLbl label = mkReturnPtLabel $ getUnique label
 
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 96231ec..d1e7eae 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -32,7 +32,6 @@ import Control.Monad.Fix
 import Data.Array as Array
 import Data.Bits
 import Data.List (nub)
-import Control.Monad (liftM)
 
 import Prelude hiding ((<*>))
 
@@ -526,7 +525,7 @@ makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap
 makeFixupBlock dflags sp0 l stack tscope assigs
   | null assigs && sp0 == sm_sp stack = return (l, [])
   | otherwise = do
-    tmp_lbl <- liftM mkBlockId $ getUniqueM
+    tmp_lbl <- newBlockId
     let sp_off = sp0 - sm_sp stack
         block = blockJoin (CmmEntry tmp_lbl tscope)
                           (maybeAddSpAdj dflags sp_off (blockFromList assigs))
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index e173f35..31775d6 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -32,6 +32,7 @@ import StgCmmForeign    (emitPrimCall)
 
 import MkGraph
 import CoreSyn          ( AltCon(..), tickishIsCode )
+import BlockId
 import SMRep
 import Cmm
 import CmmInfo
@@ -485,7 +486,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
                 ; dflags <- getDynFlags
                 ; let node_points = nodeMustPointToIt dflags lf_info
                       node' = if node_points then Just node else Nothing
-                ; loop_header_id <- newLabelC
+                ; loop_header_id <- newBlockId
                 -- Extend reader monad with information that
                 -- self-recursive tail calls can be optimized into local
                 -- jumps. See Note [Self-recursive tail calls] in StgCmmExpr.
diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index cd73ec5..8282f1e 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -427,7 +427,7 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _
        ; withSequel (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut)
        ; restoreCurrentCostCentre mb_cc
        ; emitComment $ mkFastString "should be unreachable code"
-       ; l <- newLabelC
+       ; l <- newBlockId
        ; emitLabel l
        ; emit (mkBranch l)  -- an infinite loop
        ; return AssignedDirectly
@@ -891,9 +891,9 @@ emitEnter fun = do
       -- code in the enclosing case expression.
       --
       AssignTo res_regs _ -> do
-       { lret <- newLabelC
+       { lret <- newBlockId
        ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []
-       ; lcall <- newLabelC
+       ; lcall <- newBlockId
        ; updfr_off <- getUpdFrameOff
        ; let area = Young lret
        ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area
diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs
index f3bb6ee..f12ada2 100644
--- a/compiler/codeGen/StgCmmExtCode.hs
+++ b/compiler/codeGen/StgCmmExtCode.hs
@@ -43,13 +43,13 @@ import Cmm
 import CLabel
 import MkGraph
 
--- import BasicTypes
 import BlockId
 import DynFlags
 import FastString
 import Module
 import UniqFM
 import Unique
+import UniqSupply
 
 import Control.Monad (liftM, ap)
 
@@ -90,6 +90,12 @@ instance Applicative CmmParse where
 instance Monad CmmParse where
   (>>=) = thenExtFC
 
+instance MonadUnique CmmParse where
+  getUniqueSupplyM = code getUniqueSupplyM
+  getUniqueM = EC $ \_ _ decls -> do
+    u <- getUniqueM
+    return (decls, u)
+
 instance HasDynFlags CmmParse where
     getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags
                                    return (d, dflags))
@@ -155,9 +161,6 @@ newLabel name = do
    addLabel name (mkBlockId u)
    return (mkBlockId u)
 
-newBlockId :: CmmParse BlockId
-newBlockId = code F.newLabelC
-
 -- | Add add a local function to the environment.
 newFunctionName
         :: FastString   -- ^ name of the function
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index fdfdb77..d12eaaf 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -30,6 +30,7 @@ import StgCmmUtils
 import StgCmmClosure
 import StgCmmLayout
 
+import BlockId (newBlockId)
 import Cmm
 import CmmUtils
 import MkGraph
@@ -223,7 +224,7 @@ emitForeignCall safety results target args
     updfr_off <- getUpdFrameOff
     target' <- load_target_into_temp target
     args' <- mapM maybe_assign_temp args
-    k <- newLabelC
+    k <- newBlockId
     let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results []
        -- see Note [safe foreign call convention]
     tscope <- getTickScope
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index aa88556..a0b822d 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -38,6 +38,7 @@ import MkGraph
 
 import Hoopl
 import SMRep
+import BlockId
 import Cmm
 import CmmUtils
 import CostCentre
@@ -386,7 +387,7 @@ entryHeapCheck' is_fastf node arity args code
 
        updfr_sz <- getUpdFrameOff
 
-       loop_id <- newLabelC
+       loop_id <- newBlockId
        emitLabel loop_id
        heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code
 
@@ -417,9 +418,9 @@ altOrNoEscapeHeapCheck checkYield regs code = do
     case cannedGCEntryPoint dflags regs of
       Nothing -> genericGC checkYield code
       Just gc -> do
-        lret <- newLabelC
+        lret <- newBlockId
         let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []
-        lcont <- newLabelC
+        lcont <- newBlockId
         tscope <- getTickScope
         emitOutOfLine lret (copyin <*> mkBranch lcont, tscope)
         emitLabel lcont
@@ -462,7 +463,7 @@ cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code
 genericGC :: Bool -> FCode a -> FCode a
 genericGC checkYield code
   = do updfr_sz <- getUpdFrameOff
-       lretry <- newLabelC
+       lretry <- newBlockId
        emitLabel lretry
        call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
        heapCheck False checkYield (call <*> mkBranch lretry) code
@@ -551,7 +552,7 @@ heapCheck checkStack checkYield do_gc code
 heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()
 heapStackCheckGen stk_hwm mb_bytes
   = do updfr_sz <- getUpdFrameOff
-       lretry <- newLabelC
+       lretry <- newBlockId
        emitLabel lretry
        call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
        do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry)
@@ -610,7 +611,7 @@ do_checks :: Maybe CmmExpr    -- Should we check the stack?
           -> FCode ()
 do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
   dflags <- getDynFlags
-  gc_id <- newLabelC
+  gc_id <- newBlockId
 
   let
     Just alloc_lit = mb_alloc_lit
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 21698c7..dc80036 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -37,6 +37,7 @@ import StgCmmProf (curCCS)
 
 import MkGraph
 import SMRep
+import BlockId
 import Cmm
 import CmmUtils
 import CmmInfo
@@ -113,7 +114,7 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack
               emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack
               return AssignedDirectly
             AssignTo res_regs _ -> do
-              k <- newLabelC
+              k <- newBlockId
               let area = Young k
                   (off, _, copyin) = copyInOflow dflags retConv area res_regs []
                   copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off
@@ -215,10 +216,10 @@ slowCall fun stg_args
                   (entryCode dflags fun_iptr)
                   (nonVArgs ((P,Just funv):argsreps))
 
-             slow_lbl <- newLabelC
-             fast_lbl <- newLabelC
-             is_tagged_lbl <- newLabelC
-             end_lbl <- newLabelC
+             slow_lbl <- newBlockId
+             fast_lbl <- newBlockId
+             is_tagged_lbl <- newBlockId
+             end_lbl <- newBlockId
 
              let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr)
                                                   (mkIntExpr dflags n_args)
diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs
index 2184e12..fadf5ab 100644
--- a/compiler/codeGen/StgCmmMonad.hs
+++ b/compiler/codeGen/StgCmmMonad.hs
@@ -15,7 +15,7 @@ module StgCmmMonad (
         returnFC, fixC,
         newUnique, newUniqSupply,
 
-        newLabelC, emitLabel,
+        emitLabel,
 
         emit, emitDecl, emitProc,
         emitProcWithConvention, emitProcWithStackFrame,
@@ -747,11 +747,6 @@ emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))
 emitStore :: CmmExpr  -> CmmExpr -> FCode ()
 emitStore l r = emitCgStmt (CgStmt (CmmStore l r))
 
-
-newLabelC :: FCode BlockId
-newLabelC = do { u <- newUnique
-               ; return $ mkBlockId u }
-
 emit :: CmmAGraph -> FCode ()
 emit ag
   = do  { state <- getState
@@ -804,7 +799,7 @@ emitProc_ :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped
           -> Int -> Bool -> FCode ()
 emitProc_ mb_info lbl live blocks offset do_layout
   = do  { dflags <- getDynFlags
-        ; l <- newLabelC
+        ; l <- newBlockId
         ; let
               blks = labelAGraph l blocks
 
@@ -841,9 +836,9 @@ mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph
                  -> Maybe Bool -> FCode CmmAGraph
 mkCmmIfThenElse' e tbranch fbranch likely = do
   tscp  <- getTickScope
-  endif <- newLabelC
-  tid   <- newLabelC
-  fid   <- newLabelC
+  endif <- newBlockId
+  tid   <- newBlockId
+  fid   <- newBlockId
 
   let
     (test, then_, else_, likely') = case likely of
@@ -864,7 +859,7 @@ mkCmmIfGoto e tid = mkCmmIfGoto' e tid Nothing
 
 mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph
 mkCmmIfGoto' e tid l = do
-  endif <- newLabelC
+  endif <- newBlockId
   tscp  <- getTickScope
   return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ]
 
@@ -873,8 +868,8 @@ mkCmmIfThen e tbranch = mkCmmIfThen' e tbranch Nothing
 
 mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
 mkCmmIfThen' e tbranch l = do
-  endif <- newLabelC
-  tid   <- newLabelC
+  endif <- newBlockId
+  tid   <- newBlockId
   tscp  <- getTickScope
   return $ catAGraphs [ mkCbranch e tid endif l
                       , mkLabel tid tscp, tbranch, mkLabel endif tscp ]
@@ -883,7 +878,7 @@ mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr]
        -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph
 mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
   dflags <- getDynFlags
-  k      <- newLabelC
+  k      <- newBlockId
   tscp   <- getTickScope
   let area = Young k
       (off, _, copyin) = copyInOflow dflags retConv area results []
@@ -901,5 +896,5 @@ mkCmmCall f results actuals updfr_off
 
 aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph
 aGraphToGraph stmts
-  = do  { l <- newLabelC
+  = do  { l <- newBlockId
         ; return (labelAGraph l stmts) }
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 34c2d06..14eb425 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -29,6 +29,7 @@ import StgCmmProf ( costCentreFrom, curCCS )
 import DynFlags
 import Platform
 import BasicTypes
+import BlockId
 import MkGraph
 import StgSyn
 import Cmm
@@ -1784,7 +1785,7 @@ doNewArrayOp res_r rep info payload n init = do
 
     -- Initialise all elements of the the array
     p <- assignTemp $ cmmOffsetB dflags (CmmReg arr) (hdrSize dflags rep)
-    for <- newLabelC
+    for <- newBlockId
     emitLabel for
     let loopBody =
             [ mkStore (CmmReg (CmmLocal p)) init
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 7372ab9..dedc114 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -459,7 +459,7 @@ emitSwitch _ [(_,code)] Nothing     _ _ = emit (fst code)
 
 -- Right, off we go
 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do
-    join_lbl      <- newLabelC
+    join_lbl      <- newBlockId
     mb_deflt_lbl  <- label_default join_lbl mb_deflt
     branches_lbls <- label_branches join_lbl branches
     tag_expr'     <- assignTemp' tag_expr
@@ -517,7 +517,7 @@ emitCmmLitSwitch :: CmmExpr                    -- Tag to switch on
 emitCmmLitSwitch _scrut []       deflt = emit $ fst deflt
 emitCmmLitSwitch scrut  branches deflt = do
     scrut' <- assignTemp' scrut
-    join_lbl <- newLabelC
+    join_lbl <- newBlockId
     deflt_lbl <- label_code join_lbl deflt
     branches_lbls <- label_branches join_lbl branches
 
@@ -604,7 +604,7 @@ label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
 --  [L: code; goto J]
 -- and returns L
 label_code join_lbl (code,tsc) = do
-    lbl <- newLabelC
+    lbl <- newBlockId
     emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)
     return lbl