Commit 4d4e7a51 authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

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
parent 68450878
......@@ -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
......
......@@ -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))
......
......@@ -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.
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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) }
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment