summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Marlow <marlowsd@gmail.com>2018-02-18 11:08:52 -0500
committerBen Gamari <ben@smart-cactus.org>2018-02-18 11:57:45 -0500
commitccda4862102104e080a200e4d9c2ca8f42eb5b70 (patch)
treeec60814f7262b71dc0dff0bd1706f9a0efc24923
parentbfb90bcab844ded9051370b822f0a9582c35e83e (diff)
downloadhaskell-ccda4862102104e080a200e4d9c2ca8f42eb5b70.tar.gz
Tidy up and consolidate canned CmmReg and CmmGlobals
Test Plan: validate Reviewers: bgamari, erikd Reviewed By: bgamari Subscribers: rwbarton, thomie, carter Differential Revision: https://phabricator.haskell.org/D4380
-rw-r--r--compiler/cmm/CmmExpr.hs13
-rw-r--r--compiler/cmm/CmmLayoutStack.hs16
-rw-r--r--compiler/cmm/CmmSink.hs2
-rw-r--r--compiler/cmm/CmmUtils.hs18
-rw-r--r--compiler/codeGen/CgUtils.hs2
-rw-r--r--compiler/codeGen/StgCmmBind.hs11
-rw-r--r--compiler/codeGen/StgCmmCon.hs4
-rw-r--r--compiler/codeGen/StgCmmForeign.hs47
-rw-r--r--compiler/codeGen/StgCmmHeap.hs9
-rw-r--r--compiler/codeGen/StgCmmLayout.hs3
-rw-r--r--compiler/codeGen/StgCmmPrim.hs18
-rw-r--r--compiler/codeGen/StgCmmProf.hs15
-rw-r--r--compiler/codeGen/StgCmmUtils.hs2
13 files changed, 83 insertions, 77 deletions
diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs
index 6a0220eb4f..bae5a739ca 100644
--- a/compiler/cmm/CmmExpr.hs
+++ b/compiler/cmm/CmmExpr.hs
@@ -10,7 +10,10 @@ module CmmExpr
, CmmReg(..), cmmRegType
, CmmLit(..), cmmLitType
, LocalReg(..), localRegType
- , GlobalReg(..), isArgReg, globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
+ , GlobalReg(..), isArgReg, globalRegType
+ , spReg, hpReg, spLimReg, hpLimReg, nodeReg
+ , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg
+ , node, baseReg
, VGcPtr(..)
, DefinerOfRegs, UserOfRegs
@@ -551,12 +554,18 @@ instance Ord GlobalReg where
compare _ EagerBlackholeInfo = GT
-- convenient aliases
-baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg
+baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,
+ currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: CmmReg
baseReg = CmmGlobal BaseReg
spReg = CmmGlobal Sp
hpReg = CmmGlobal Hp
+hpLimReg = CmmGlobal HpLim
spLimReg = CmmGlobal SpLim
nodeReg = CmmGlobal node
+currentTSOReg = CmmGlobal CurrentTSO
+currentNurseryReg = CmmGlobal CurrentNursery
+hpAllocReg = CmmGlobal HpAlloc
+cccsReg = CmmGlobal CCCS
node :: GlobalReg
node = VanillaReg 1 VGcPtr
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 6cf8f8ea01..2602dc8d14 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -582,7 +582,7 @@ makeFixupBlock dflags sp0 l stack tscope assigs
= block `blockSnoc` CmmUnwind [(Sp, Just unwind_val)]
| otherwise
= block
- where unwind_val = cmmOffset dflags (CmmReg spReg) (sm_sp stack)
+ where unwind_val = cmmOffset dflags spExpr (sm_sp stack)
block = blockJoin (CmmEntry tmp_lbl tscope)
( maybeAddSpAdj dflags sp_off
$ maybeAddUnwind
@@ -895,7 +895,7 @@ maybeAddSpAdj :: DynFlags -> ByteOff -> Block CmmNode O O -> Block CmmNode O O
maybeAddSpAdj _ 0 block = block
maybeAddSpAdj dflags sp_off block = block `blockSnoc` adj
where
- adj = CmmAssign spReg (cmmOffset dflags (CmmReg spReg) sp_off)
+ adj = CmmAssign spReg (cmmOffset dflags spExpr sp_off)
{- Note [SP old/young offsets]
@@ -918,7 +918,7 @@ arguments.
areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)
- = cmmOffset dflags (CmmReg spReg) (sp_old - area_off area - n)
+ = cmmOffset dflags spExpr (sp_old - area_off area - n)
-- Replace (CmmStackSlot area n) with an offset from Sp
areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)
@@ -1088,7 +1088,7 @@ insertReloads dflags stackmap live =
[ CmmAssign (CmmLocal reg)
-- This cmmOffset basically corresponds to manifesting
-- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]
- (CmmLoad (cmmOffset dflags (CmmReg spReg) (sp_off - reg_off))
+ (CmmLoad (cmmOffset dflags spExpr (sp_off - reg_off))
(localRegType reg))
| (reg, reg_off) <- stackSlotRegs stackmap
, reg `elemRegSet` live
@@ -1141,7 +1141,7 @@ lowerSafeForeignCall dflags block
-- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS-only objects and are not subject to garbage collection
id <- newTemp (bWord dflags)
- new_base <- newTemp (cmmRegType dflags (CmmGlobal BaseReg))
+ new_base <- newTemp (cmmRegType dflags baseReg)
let (caller_save, caller_load) = callerSaveVolatileRegs dflags
save_state_code <- saveThreadState dflags
load_state_code <- loadThreadState dflags
@@ -1152,7 +1152,7 @@ lowerSafeForeignCall dflags block
resume = mkMiddle (callResumeThread new_base id) <*>
-- Assign the result to BaseReg: we
-- might now have a different Capability!
- mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
+ mkAssign baseReg (CmmReg (CmmLocal new_base)) <*>
caller_load <*>
load_state_code
@@ -1167,7 +1167,7 @@ lowerSafeForeignCall dflags block
-- different. Hence we continue by jumping to the top stack frame,
-- not by jumping to succ.
jump = CmmCall { cml_target = entryCode dflags $
- CmmLoad (CmmReg spReg) (bWord dflags)
+ CmmLoad spExpr (bWord dflags)
, cml_cont = Just succ
, cml_args_regs = regs
, cml_args = widthInBytes (wordWidth dflags)
@@ -1197,7 +1197,7 @@ callSuspendThread dflags id intrbl =
CmmUnsafeForeignCall
(ForeignTarget (foreignLbl (fsLit "suspendThread"))
(ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))
- [id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)]
+ [id] [baseExpr, mkIntExpr dflags (fromEnum intrbl)]
callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
callResumeThread new_base id =
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
index 76ce18b534..464a041c1e 100644
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/cmm/CmmSink.hs
@@ -745,7 +745,7 @@ loadAddr dflags e w =
case e of
CmmReg r -> regAddr dflags r 0 w
CmmRegOff r i -> regAddr dflags r i w
- _other | regUsedIn dflags (CmmGlobal Sp) e -> StackMem
+ _other | regUsedIn dflags spReg e -> StackMem
| otherwise -> AnyMem
regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 8e8c1edeaf..4a1d874d8f 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -37,6 +37,9 @@ module CmmUtils(
isTrivialCmmExpr, hasNoGlobalRegs,
+ baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
+ currentTSOExpr, currentNurseryExpr, cccsExpr,
+
-- Statics
blankWord,
@@ -567,3 +570,18 @@ blockTicks b = reverse $ foldBlockNodesF goStmt b []
where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]
goStmt (CmmTick t) ts = t:ts
goStmt _other ts = ts
+
+
+-- -----------------------------------------------------------------------------
+-- Access to common global registers
+
+baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,
+ spLimExpr, hpLimExpr, cccsExpr :: CmmExpr
+baseExpr = CmmReg baseReg
+spExpr = CmmReg spReg
+spLimExpr = CmmReg spLimReg
+hpExpr = CmmReg hpReg
+hpLimExpr = CmmReg hpLimReg
+currentTSOExpr = CmmReg currentTSOReg
+currentNurseryExpr = CmmReg currentNurseryReg
+cccsExpr = CmmReg cccsReg
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index a9f13c6ffa..c20f1fd1d0 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -118,7 +118,7 @@ regTableOffset dflags n =
get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
get_Regtable_addr_from_offset dflags _ offset =
if haveRegBase (targetPlatform dflags)
- then CmmRegOff (CmmGlobal BaseReg) offset
+ then CmmRegOff baseReg offset
else regTableOffset dflags offset
-- | Fixup global registers so that they assign to locations within the
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index 13f908e846..cf602ef0b8 100644
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -24,7 +24,7 @@ import StgCmmMonad
import StgCmmEnv
import StgCmmCon
import StgCmmHeap
-import StgCmmProf (curCCS, ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,
+import StgCmmProf (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,
initUpdFrameProf)
import StgCmmTicky
import StgCmmLayout
@@ -367,7 +367,7 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body
-- BUILD THE OBJECT
-- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
- ; let use_cc = curCCS; blame_cc = curCCS
+ ; let use_cc = cccsExpr; blame_cc = cccsExpr
; emit (mkComment $ mkFastString "calling allocDynClosure")
; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
; let info_tbl = mkCmmInfo closure_info
@@ -405,7 +405,7 @@ cgRhsStdThunk bndr lf_info payload
descr
-- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
- ; let use_cc = curCCS; blame_cc = curCCS
+ ; let use_cc = cccsExpr; blame_cc = cccsExpr
-- BUILD THE OBJECT
@@ -632,8 +632,7 @@ emitBlackHoleCode node = do
-- work with profiling.
when eager_blackholing $ do
- emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags))
- (CmmReg (CmmGlobal CurrentTSO))
+ emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr
emitPrimCall [] MO_WriteBarrier []
emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))
@@ -718,7 +717,7 @@ link_caf node _is_upd = do
ForeignLabelInExternalPackage IsFunction
; bh <- newTemp (bWord dflags)
; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl
- [ (CmmReg (CmmGlobal BaseReg), AddrHint),
+ [ (baseExpr, AddrHint),
(CmmReg (CmmLocal node), AddrHint) ]
False
diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs
index a38f7bce37..197291006b 100644
--- a/compiler/codeGen/StgCmmCon.hs
+++ b/compiler/codeGen/StgCmmCon.hs
@@ -28,9 +28,9 @@ import StgCmmHeap
import StgCmmLayout
import StgCmmUtils
import StgCmmClosure
-import StgCmmProf ( curCCS )
import CmmExpr
+import CmmUtils
import CLabel
import MkGraph
import SMRep
@@ -246,7 +246,7 @@ buildDynCon' dflags _ binder actually_bound ccs con args
; return (mkRhsInit dflags reg lf_info hp_plus_n) }
where
use_cc -- cost-centre to stick in the object
- | isCurrentCCS ccs = curCCS
+ | isCurrentCCS ccs = cccsExpr
| otherwise = panic "buildDynCon: non-current CCS not implemented"
blame_cc = use_cc -- cost-centre on which to blame the alloc (same)
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index fc3d42aa8b..d0ad17f59b 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -25,7 +25,7 @@ module StgCmmForeign (
import GhcPrelude hiding( succ, (<*>) )
import StgSyn
-import StgCmmProf (storeCurCCS, ccsType, curCCS)
+import StgCmmProf (storeCurCCS, ccsType)
import StgCmmEnv
import StgCmmMonad
import StgCmmUtils
@@ -287,7 +287,7 @@ saveThreadState dflags = do
close_nursery <- closeNursery dflags tso
pure $ catAGraphs [
-- tso = CurrentTSO;
- mkAssign (CmmLocal tso) stgCurrentTSO,
+ mkAssign (CmmLocal tso) currentTSOExpr,
-- tso->stackobj->sp = Sp;
mkStore (cmmOffset dflags
(CmmLoad (cmmOffset dflags
@@ -295,11 +295,11 @@ saveThreadState dflags = do
(tso_stackobj dflags))
(bWord dflags))
(stack_SP dflags))
- stgSp,
+ spExpr,
close_nursery,
-- and save the current cost centre stack in the TSO when profiling:
if gopt Opt_SccProfilingOn dflags then
- mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) curCCS
+ mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr
else mkNop
]
@@ -308,7 +308,7 @@ emitCloseNursery = do
dflags <- getDynFlags
tso <- newTemp (bWord dflags)
code <- closeNursery dflags tso
- emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> code
+ emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code
{- |
@closeNursery dflags tso@ produces code to close the nursery.
@@ -336,14 +336,14 @@ closeNursery df tso = do
let tsoreg = CmmLocal tso
cnreg <- CmmLocal <$> newTemp (bWord df)
pure $ catAGraphs [
- mkAssign cnreg stgCurrentNursery,
+ mkAssign cnreg currentNurseryExpr,
-- CurrentNursery->free = Hp+1;
- mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df stgHp 1),
+ mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df hpExpr 1),
let alloc =
CmmMachOp (mo_wordSub df)
- [ cmmOffsetW df stgHp 1
+ [ cmmOffsetW df hpExpr 1
, CmmLoad (nursery_bdescr_start df cnreg) (bWord df)
]
@@ -370,18 +370,18 @@ loadThreadState dflags = do
open_nursery <- openNursery dflags tso
pure $ catAGraphs [
-- tso = CurrentTSO;
- mkAssign (CmmLocal tso) stgCurrentTSO,
+ mkAssign (CmmLocal tso) currentTSOExpr,
-- stack = tso->stackobj;
mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),
-- Sp = stack->sp;
- mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),
+ mkAssign spReg (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),
-- SpLim = stack->stack + RESERVED_STACK_WORDS;
- mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
+ mkAssign spLimReg (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
(rESERVED_STACK_WORDS dflags)),
-- HpAlloc = 0;
-- HpAlloc is assumed to be set to non-zero only by a failed
-- a heap check, see HeapStackCheck.cmm:GC_GENERIC
- mkAssign hpAlloc (zeroExpr dflags),
+ mkAssign hpAllocReg (zeroExpr dflags),
open_nursery,
-- and load the current cost centre stack from the TSO when profiling:
if gopt Opt_SccProfilingOn dflags
@@ -397,7 +397,7 @@ emitOpenNursery = do
dflags <- getDynFlags
tso <- newTemp (bWord dflags)
code <- openNursery dflags tso
- emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*> code
+ emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code
{- |
@openNursery dflags tso@ produces code to open the nursery. A local register
@@ -439,17 +439,17 @@ openNursery df tso = do
-- what code we generate, look at the assembly for
-- stg_returnToStackTop in rts/StgStartup.cmm.
pure $ catAGraphs [
- mkAssign cnreg stgCurrentNursery,
+ mkAssign cnreg currentNurseryExpr,
mkAssign bdfreereg (CmmLoad (nursery_bdescr_free df cnreg) (bWord df)),
-- Hp = CurrentNursery->free - 1;
- mkAssign hp (cmmOffsetW df (CmmReg bdfreereg) (-1)),
+ mkAssign hpReg (cmmOffsetW df (CmmReg bdfreereg) (-1)),
mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)),
-- HpLim = CurrentNursery->start +
-- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
- mkAssign hpLim
+ mkAssign hpLimReg
(cmmOffsetExpr df
(CmmReg bdstartreg)
(cmmOffset df
@@ -496,21 +496,6 @@ stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags)
closureField :: DynFlags -> ByteOff -> ByteOff
closureField dflags off = off + fixedHdrSize dflags
-stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
-stgSp = CmmReg sp
-stgHp = CmmReg hp
-stgCurrentTSO = CmmReg currentTSO
-stgCurrentNursery = CmmReg currentNursery
-
-sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg
-sp = CmmGlobal Sp
-spLim = CmmGlobal SpLim
-hp = CmmGlobal Hp
-hpLim = CmmGlobal HpLim
-currentTSO = CmmGlobal CurrentTSO
-currentNursery = CmmGlobal CurrentNursery
-hpAlloc = CmmGlobal HpAlloc
-
-- -----------------------------------------------------------------------------
-- For certain types passed to foreign calls, we adjust the actual
-- value passed to the call. For ByteArray#/Array# we pass the
diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 2a1165395c..07633ed4ae 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -603,7 +603,7 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
let
Just alloc_lit = mb_alloc_lit
- bump_hp = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit
+ bump_hp = cmmOffsetExprB dflags hpExpr alloc_lit
-- Sp overflow if ((old + 0) - CmmHighStack < SpLim)
-- At the beginning of a function old + 0 = Sp
@@ -617,10 +617,9 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
-- Hp overflow if (Hp > HpLim)
-- (Hp has been incremented by now)
-- HpLim points to the LAST WORD of valid allocation space.
- hp_oflo = CmmMachOp (mo_wordUGt dflags)
- [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
+ hp_oflo = CmmMachOp (mo_wordUGt dflags) [hpExpr, hpLimExpr]
- alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit
+ alloc_n = mkAssign hpAllocReg alloc_lit
case mb_stk_hwm of
Nothing -> return ()
@@ -645,7 +644,7 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
when (checkYield && not (gopt Opt_OmitYields dflags)) $ do
-- Yielding if HpLim == 0
let yielding = CmmMachOp (mo_wordEq dflags)
- [CmmReg (CmmGlobal HpLim),
+ [CmmReg hpLimReg,
CmmLit (zeroCLit dflags)]
emit =<< mkCmmIfGoto' yielding gc_id (Just False)
diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs
index 5111b93bc5..95828ad4c6 100644
--- a/compiler/codeGen/StgCmmLayout.hs
+++ b/compiler/codeGen/StgCmmLayout.hs
@@ -39,7 +39,6 @@ import StgCmmArgRep -- notably: ( slowCallPattern )
import StgCmmTicky
import StgCmmMonad
import StgCmmUtils
-import StgCmmProf (curCCS)
import MkGraph
import SMRep
@@ -373,7 +372,7 @@ slowArgs dflags args -- careful: reps contains voids (V), but args does not
stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat
this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args
- save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just curCCS)]
+ save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)]
save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")
-------------------------------------------------------------------------
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 8ec132b1d3..7661e9f8fb 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -26,7 +26,7 @@ import StgCmmMonad
import StgCmmUtils
import StgCmmTicky
import StgCmmHeap
-import StgCmmProf ( costCentreFrom, curCCS )
+import StgCmmProf ( costCentreFrom )
import DynFlags
import Platform
@@ -281,7 +281,7 @@ emitPrimOp _ [res] ParOp [arg]
emitCCall
[(res,NoHint)]
(CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
- [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)]
+ [(baseExpr, AddrHint), (arg,AddrHint)]
emitPrimOp dflags [res] SparkOp [arg]
= do
@@ -293,7 +293,7 @@ emitPrimOp dflags [res] SparkOp [arg]
emitCCall
[(tmp2,NoHint)]
(CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))
- [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
+ [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]
emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))
emitPrimOp dflags [res] GetCCSOfOp [arg]
@@ -304,7 +304,7 @@ emitPrimOp dflags [res] GetCCSOfOp [arg]
| otherwise = CmmLit (zeroCLit dflags)
emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg]
- = emitAssign (CmmLocal res) curCCS
+ = emitAssign (CmmLocal res) cccsExpr
emitPrimOp dflags [res] ReadMutVarOp [mutv]
= emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))
@@ -317,7 +317,7 @@ emitPrimOp dflags res@[] WriteMutVarOp [mutv,var]
emitCCall
[{-no results-}]
(CmmLit (CmmLabel mkDirty_MUT_VAR_Label))
- [(CmmReg (CmmGlobal BaseReg), AddrHint), (mutv,AddrHint)]
+ [(baseExpr, AddrHint), (mutv,AddrHint)]
-- #define sizzeofByteArrayzh(r,a) \
-- r = ((StgArrBytes *)(a))->bytes
@@ -1730,7 +1730,7 @@ doNewByteArrayOp res_r n = do
let hdr_size = fixedHdrSize dflags
- base <- allocHeapClosure rep info_ptr curCCS
+ base <- allocHeapClosure rep info_ptr cccsExpr
[ (mkIntExpr dflags n,
hdr_size + oFFSET_StgArrBytes_bytes dflags)
]
@@ -1898,7 +1898,7 @@ doNewArrayOp res_r rep info payload n init = do
(mkIntExpr dflags (nonHdrSize dflags rep))
(zeroExpr dflags)
- base <- allocHeapClosure rep info_ptr curCCS payload
+ base <- allocHeapClosure rep info_ptr cccsExpr payload
arr <- CmmLocal `fmap` newTemp (bWord dflags)
emit $ mkAssign arr base
@@ -2080,7 +2080,7 @@ emitCloneArray info_p res_r src src_off n = do
let hdr_size = fixedHdrSize dflags
- base <- allocHeapClosure rep info_ptr curCCS
+ base <- allocHeapClosure rep info_ptr cccsExpr
[ (mkIntExpr dflags n,
hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)
, (mkIntExpr dflags (nonHdrSizeW rep),
@@ -2119,7 +2119,7 @@ emitCloneSmallArray info_p res_r src src_off n = do
let hdr_size = fixedHdrSize dflags
- base <- allocHeapClosure rep info_ptr curCCS
+ base <- allocHeapClosure rep info_ptr cccsExpr
[ (mkIntExpr dflags n,
hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)
]
diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs
index e5e1379877..a0bca5d661 100644
--- a/compiler/codeGen/StgCmmProf.hs
+++ b/compiler/codeGen/StgCmmProf.hs
@@ -16,7 +16,7 @@ module StgCmmProf (
dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
enterCostCentreThunk, enterCostCentreFun,
costCentreFrom,
- curCCS, storeCurCCS,
+ storeCurCCS,
emitSetCCC,
saveCurrentCostCentre, restoreCurrentCostCentre,
@@ -62,11 +62,8 @@ ccsType = bWord
ccType :: DynFlags -> CmmType -- Type of a cost centre
ccType = bWord
-curCCS :: CmmExpr
-curCCS = CmmReg (CmmGlobal CCCS)
-
storeCurCCS :: CmmExpr -> CmmAGraph
-storeCurCCS e = mkAssign (CmmGlobal CCCS) e
+storeCurCCS e = mkAssign cccsReg e
mkCCostCentre :: CostCentre -> CmmLit
mkCCostCentre cc = CmmLabel (mkCCLabel cc)
@@ -93,7 +90,7 @@ initUpdFrameProf :: CmmExpr -> FCode ()
initUpdFrameProf frame
= ifProfiling $ -- frame->header.prof.ccs = CCCS
do dflags <- getDynFlags
- emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) curCCS
+ emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) cccsExpr
-- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
-- is unnecessary because it is not used anyhow.
@@ -133,7 +130,7 @@ saveCurrentCostCentre
if not (gopt Opt_SccProfilingOn dflags)
then return Nothing
else do local_cc <- newTemp (ccType dflags)
- emitAssign (CmmLocal local_cc) curCCS
+ emitAssign (CmmLocal local_cc) cccsExpr
return (Just local_cc)
restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
@@ -186,7 +183,7 @@ enterCostCentreFun ccs closure =
if isCurrentCCS ccs
then do dflags <- getDynFlags
emitRtsCall rtsUnitId (fsLit "enterFunCCS")
- [(CmmReg (CmmGlobal BaseReg), AddrHint),
+ [(baseExpr, AddrHint),
(costCentreFrom dflags closure, AddrHint)] False
else return () -- top-level function, nothing to do
@@ -280,7 +277,7 @@ emitSetCCC cc tick push
if not (gopt Opt_SccProfilingOn dflags)
then return ()
else do tmp <- newTemp (ccsType dflags)
- pushCostCentre tmp curCCS cc
+ pushCostCentre tmp cccsExpr cc
when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index b6092e8358..94013f5c6d 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -280,7 +280,7 @@ regTableOffset dflags n =
get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
get_Regtable_addr_from_offset dflags _rep offset =
if haveRegBase (targetPlatform dflags)
- then CmmRegOff (CmmGlobal BaseReg) offset
+ then CmmRegOff baseReg offset
else regTableOffset dflags offset