diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-07-07 18:48:31 +0200 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-07-25 00:45:08 -0400 |
commit | 9dfeca6c2019fdb46613a68ccd6e650e40c7baac (patch) | |
tree | 29a2cda3faddedc7024be259011f4406b6473f45 /compiler/GHC/StgToCmm | |
parent | 6333d7391068d8029eed3e8eff019b9e2c104c7b (diff) | |
download | haskell-9dfeca6c2019fdb46613a68ccd6e650e40c7baac.tar.gz |
Remove platform constant wrappers
Platform constant wrappers took a DynFlags parameter, hence implicitly
used the target platform constants. We removed them to allow support
for several platforms at once (#14335) and to avoid having to pass
the full DynFlags to every function (#17957).
Metric Decrease:
T4801
Diffstat (limited to 'compiler/GHC/StgToCmm')
-rw-r--r-- | compiler/GHC/StgToCmm/Bind.hs | 126 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/CgUtils.hs | 177 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Closure.hs | 141 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/DataCon.hs | 53 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Env.hs | 18 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Expr.hs | 45 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/ExtCode.hs | 19 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Foreign.hs | 192 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Heap.hs | 58 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Layout.hs | 57 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Monad.hs | 44 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Prim.hs | 205 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Prof.hs | 144 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Ticky.hs | 34 | ||||
-rw-r--r-- | compiler/GHC/StgToCmm/Utils.hs | 26 |
15 files changed, 700 insertions, 639 deletions
diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index c83bca2217..4fbdc4a153 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -14,7 +14,9 @@ module GHC.StgToCmm.Bind ( ) where import GHC.Prelude hiding ((<*>)) + import GHC.Platform +import GHC.Platform.Profile import GHC.StgToCmm.Expr import GHC.StgToCmm.Monad @@ -60,7 +62,7 @@ import Control.Monad -- For closures bound at top level, allocate in static space. -- They should have no free variables. -cgTopRhsClosure :: DynFlags +cgTopRhsClosure :: Platform -> RecFlag -- member of a recursive group? -> Id -> CostCentreStack -- Optional cost centre annotation @@ -69,12 +71,11 @@ cgTopRhsClosure :: DynFlags -> CgStgExpr -> (CgIdInfo, FCode ()) -cgTopRhsClosure dflags rec id ccs upd_flag args body = - let platform = targetPlatform dflags - closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) - cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) +cgTopRhsClosure platform rec id ccs upd_flag args body = + let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) + cg_id_info = litIdInfo platform id lf_info (CmmLabel closure_label) lf_info = mkClosureLFInfo platform id TopLevel [] upd_flag args - in (cg_id_info, gen_code dflags lf_info closure_label) + in (cg_id_info, gen_code lf_info closure_label) where -- special case for a indirection (f = g). We create an IND_STATIC -- closure pointing directly to the indirectee. This is exactly @@ -89,17 +90,19 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body = -- hole detection from working in that case. Test -- concurrent/should_run/4030 fails, for instance. -- - gen_code _ _ closure_label + gen_code _ closure_label | StgApp f [] <- body, null args, isNonRec rec = do cg_info <- getCgIdInfo f emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)] - gen_code dflags lf_info _closure_label - = do { let name = idName id + gen_code lf_info _closure_label + = do { profile <- getProfile + ; dflags <- getDynFlags + ; let name = idName id ; mod_name <- getModuleName ; let descr = closureDescription dflags mod_name name - closure_info = mkClosureInfo dflags True id lf_info 0 0 descr + closure_info = mkClosureInfo profile True id lf_info 0 0 descr -- We don't generate the static closure here, because we might -- want to add references to static closures to it later. The @@ -108,7 +111,7 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body = ; let fv_details :: [(NonVoid Id, ByteOff)] header = if isLFThunk lf_info then ThunkHeader else StdHeader - (_, _, fv_details) = mkVirtHeapOffsets dflags header [] + (_, _, fv_details) = mkVirtHeapOffsets profile header [] -- Don't drop the non-void args until the closure info has been made ; forkClosureBody (closureCodeBody True id closure_info ccs args body fv_details) @@ -208,14 +211,14 @@ cgRhs id (StgRhsCon cc con args) {- See Note [GC recovery] in "GHC.StgToCmm.Closure" -} cgRhs id (StgRhsClosure fvs cc upd_flag args body) - = do dflags <- getDynFlags - mkRhsClosure dflags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body + = do profile <- getProfile + mkRhsClosure profile id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body ------------------------------------------------------------------------ -- Non-constructor right hand sides ------------------------------------------------------------------------ -mkRhsClosure :: DynFlags -> Id -> CostCentreStack +mkRhsClosure :: Profile -> Id -> CostCentreStack -> [NonVoid Id] -- Free vars -> UpdateFlag -> [Id] -- Args @@ -258,7 +261,7 @@ for semi-obvious reasons. -} ---------- Note [Selectors] ------------------ -mkRhsClosure dflags bndr _cc +mkRhsClosure profile bndr _cc [NonVoid the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk @@ -271,14 +274,14 @@ mkRhsClosure dflags bndr _cc , StgApp selectee [{-no args-}] <- strip sel_expr , the_fv == scrutinee -- Scrutinee is the only free variable - , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params)) + , let (_, _, params_w_offsets) = mkVirtConstrOffsets profile (addIdReps (assertNonVoidIds params)) -- pattern binders are always non-void, -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee) - , let offset_into_int = bytesToWordsRoundUp (targetPlatform dflags) the_offset - - fixedHdrSizeW dflags - , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough + , let offset_into_int = bytesToWordsRoundUp (profilePlatform profile) the_offset + - fixedHdrSizeW profile + , offset_into_int <= pc_MAX_SPEC_SELECTEE_SIZE (profileConstants profile) -- Offset is small enough = -- NOT TRUE: ASSERT(is_single_constructor) -- The simplifier may have statically determined that the single alternative -- is the only possible case and eliminated the others, even if there are @@ -291,7 +294,7 @@ mkRhsClosure dflags bndr _cc in cgRhsStdThunk bndr lf_info [StgVarArg the_fv] ---------- Note [Ap thunks] ------------------ -mkRhsClosure dflags bndr _cc +mkRhsClosure profile bndr _cc fvs upd_flag [] -- No args; a thunk @@ -306,8 +309,8 @@ mkRhsClosure dflags bndr _cc -- Missed opportunity: (f x x) is not detected , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs , isUpdatable upd_flag - , n_fvs <= mAX_SPEC_AP_SIZE dflags - , not (sccProfilingEnabled dflags) + , n_fvs <= pc_MAX_SPEC_AP_SIZE (profileConstants profile) + , not (profileIsProfiling profile) -- not when profiling: we don't want to -- lose information about this particular -- thunk (e.g. its type) (#949) @@ -324,12 +327,11 @@ mkRhsClosure dflags bndr _cc payload = StgVarArg fun_id : args ---------- Default case ------------------ -mkRhsClosure dflags bndr cc fvs upd_flag args body - = do { let lf_info = mkClosureLFInfo platform bndr NotTopLevel fvs upd_flag args +mkRhsClosure profile bndr cc fvs upd_flag args body + = do { let lf_info = mkClosureLFInfo (profilePlatform profile) bndr NotTopLevel fvs upd_flag args ; (id_info, reg) <- rhsIdInfo bndr lf_info ; return (id_info, gen_code lf_info reg) } where - platform = targetPlatform dflags gen_code lf_info reg = do { -- LAY OUT THE OBJECT -- If the binder is itself a free variable, then don't store @@ -341,15 +343,19 @@ mkRhsClosure dflags bndr cc fvs upd_flag args body -- Node points to it... ; let reduced_fvs = filter (NonVoid bndr /=) fvs + ; profile <- getProfile + ; let platform = profilePlatform profile + -- MAKE CLOSURE INFO FOR THIS CLOSURE ; mod_name <- getModuleName + ; dflags <- getDynFlags ; let name = idName bndr descr = closureDescription dflags mod_name name fv_details :: [(NonVoid Id, ByteOff)] header = if isLFThunk lf_info then ThunkHeader else StdHeader (tot_wds, ptr_wds, fv_details) - = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs) - closure_info = mkClosureInfo dflags False -- Not static + = mkVirtHeapOffsets profile header (addIdReps reduced_fvs) + closure_info = mkClosureInfo profile False -- Not static bndr lf_info tot_wds ptr_wds descr @@ -371,7 +377,7 @@ mkRhsClosure dflags bndr cc fvs upd_flag args body (map toVarArg fv_details) -- RETURN - ; return (mkRhsInit dflags reg lf_info hp_plus_n) } + ; return (mkRhsInit platform reg lf_info hp_plus_n) } ------------------------- cgRhsStdThunk @@ -391,13 +397,15 @@ cgRhsStdThunk bndr lf_info payload { -- LAY OUT THE OBJECT mod_name <- getModuleName ; dflags <- getDynFlags - ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader + ; profile <- getProfile + ; let platform = profilePlatform profile + header = if isLFThunk lf_info then ThunkHeader else StdHeader (tot_wds, ptr_wds, payload_w_offsets) - = mkVirtHeapOffsets dflags header + = mkVirtHeapOffsets profile header (addArgReps (nonVoidStgArgs payload)) descr = closureDescription dflags mod_name (idName bndr) - closure_info = mkClosureInfo dflags False -- Not static + closure_info = mkClosureInfo profile False -- Not static bndr lf_info tot_wds ptr_wds descr @@ -411,7 +419,7 @@ cgRhsStdThunk bndr lf_info payload use_cc blame_cc payload_w_offsets -- RETURN - ; return (mkRhsInit dflags reg lf_info hp_plus_n) } + ; return (mkRhsInit platform reg lf_info hp_plus_n) } mkClosureLFInfo :: Platform @@ -480,9 +488,9 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details \(_offset, node, arg_regs) -> do -- Emit slow-entry code (for entering a closure through a PAP) { mkSlowEntryCode bndr cl_info arg_regs - ; dflags <- getDynFlags + ; profile <- getProfile ; platform <- getPlatform - ; let node_points = nodeMustPointToIt dflags lf_info + ; let node_points = nodeMustPointToIt profile lf_info node' = if node_points then Just node else Nothing ; loop_header_id <- newBlockId -- Extend reader monad with information that @@ -499,7 +507,7 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details ; enterCostCentreFun cc (CmmMachOp (mo_wordSub platform) [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification] - , mkIntExpr platform (funTag dflags cl_info) ]) + , mkIntExpr platform (funTag platform cl_info) ]) ; fv_bindings <- mapM bind_fv fv_details -- Load free vars out of closure *after* -- heap check, to reduce live vars over check @@ -528,9 +536,8 @@ bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) } load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode () load_fvs node lf_info = mapM_ (\ (reg, off) -> - do dflags <- getDynFlags - platform <- getPlatform - let tag = lfDynTag dflags lf_info + do platform <- getPlatform + let tag = lfDynTag platform lf_info emit $ mkTaggedObjectLoad platform reg node off tag) ----------------------------------------- @@ -548,13 +555,13 @@ mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode () -- Here, we emit the slow-entry code. mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node' | Just (_, ArgGen _) <- closureFunInfo cl_info - = do dflags <- getDynFlags + = do profile <- getProfile platform <- getPlatform let node = idToReg platform (NonVoid bndr) slow_lbl = closureSlowEntryLabel cl_info fast_lbl = closureLocalEntryLabel platform cl_info -- mkDirectJump does not clobber `Node' containing function closure - jump = mkJump dflags NativeNodeCall + jump = mkJump profile NativeNodeCall (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) (node : arg_regs)) (initUpdFrameOff platform) @@ -567,8 +574,8 @@ mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node' thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack -> LocalReg -> CgStgExpr -> FCode () thunkCode cl_info fv_details _cc node body - = do { dflags <- getDynFlags - ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info) + = do { profile <- getProfile + ; let node_points = nodeMustPointToIt profile (closureLFInfo cl_info) node' = if node_points then Just node else Nothing ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling @@ -606,7 +613,8 @@ blackHoleIt node_reg emitBlackHoleCode :: CmmExpr -> FCode () emitBlackHoleCode node = do dflags <- getDynFlags - let platform = targetPlatform dflags + profile <- getProfile + let platform = profilePlatform profile -- Eager blackholing is normally disabled, but can be turned on with -- -feager-blackholing. When it is on, we replace the info pointer @@ -626,7 +634,7 @@ emitBlackHoleCode node = do -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, -- because emitBlackHoleCode is called from GHC.Cmm.Parser. - let eager_blackholing = not (sccProfilingEnabled dflags) + let eager_blackholing = not (profileIsProfiling profile) && gopt Opt_EagerBlackHoling dflags -- Profiling needs slop filling (to support LDV -- profiling), so currently eager blackholing doesn't @@ -634,7 +642,7 @@ emitBlackHoleCode node = do when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node - emitStore (cmmOffsetW platform node (fixedHdrSizeW dflags)) currentTSOExpr + emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) currentTSOExpr -- See Note [Heap memory barriers] in SMP.h. emitPrimCall [] MO_WriteBarrier [] emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo)) @@ -684,20 +692,21 @@ pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode () pushUpdateFrame lbl updatee body = do updfr <- getUpdFrameOff - dflags <- getDynFlags + profile <- getProfile let - hdr = fixedHdrSize dflags - frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags + hdr = fixedHdrSize profile + frame = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile) -- - emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee + emitUpdateFrame (CmmStackSlot Old frame) lbl updatee withUpdFrameOff frame body -emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode () -emitUpdateFrame dflags frame lbl updatee = do +emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode () +emitUpdateFrame frame lbl updatee = do + profile <- getProfile let - hdr = fixedHdrSize dflags - off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags - platform = targetPlatform dflags + hdr = fixedHdrSize profile + off_updatee = hdr + pc_OFFSET_StgUpdateFrame_updatee (platformConstants platform) + platform = profilePlatform profile -- emitStore frame (mkLblExpr lbl) emitStore (cmmOffset platform frame off_updatee) updatee @@ -713,12 +722,12 @@ link_caf :: LocalReg -- pointer to the closure -- This function returns the address of the black hole, so it can be -- updated with the new value when available. link_caf node = do - { dflags <- getDynFlags + { profile <- getProfile -- Call the RTS function newCAF, returning the newly-allocated -- blackhole indirection closure ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing ForeignLabelInExternalPackage IsFunction - ; let platform = targetPlatform dflags + ; let platform = profilePlatform profile ; bh <- newTemp (bWord platform) ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl [ (baseExpr, AddrHint), @@ -727,11 +736,12 @@ link_caf node = do -- see Note [atomic CAF entry] in rts/sm/Storage.c ; updfr <- getUpdFrameOff - ; let target = entryCode platform (closureInfoPtr dflags (CmmReg (CmmLocal node))) + ; ptr_opts <- getPtrOpts + ; let target = entryCode platform (closureInfoPtr ptr_opts (CmmReg (CmmLocal node))) ; emit =<< mkCmmIfThen (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform)) -- re-enter the CAF - (mkJump dflags NativeNodeCall target [] updfr) + (mkJump profile NativeNodeCall target [] updfr) ; return (CmmReg (CmmLocal bh)) } diff --git a/compiler/GHC/StgToCmm/CgUtils.hs b/compiler/GHC/StgToCmm/CgUtils.hs index 25cd5e04c1..36ba21cb15 100644 --- a/compiler/GHC/StgToCmm/CgUtils.hs +++ b/compiler/GHC/StgToCmm/CgUtils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- @@ -19,82 +20,84 @@ module GHC.StgToCmm.CgUtils ( import GHC.Prelude import GHC.Platform.Regs +import GHC.Platform import GHC.Cmm import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Utils import GHC.Cmm.CLabel -import GHC.Driver.Session import GHC.Utils.Outputable -- ----------------------------------------------------------------------------- -- Information about global registers -baseRegOffset :: DynFlags -> GlobalReg -> Int - -baseRegOffset dflags (VanillaReg 1 _) = oFFSET_StgRegTable_rR1 dflags -baseRegOffset dflags (VanillaReg 2 _) = oFFSET_StgRegTable_rR2 dflags -baseRegOffset dflags (VanillaReg 3 _) = oFFSET_StgRegTable_rR3 dflags -baseRegOffset dflags (VanillaReg 4 _) = oFFSET_StgRegTable_rR4 dflags -baseRegOffset dflags (VanillaReg 5 _) = oFFSET_StgRegTable_rR5 dflags -baseRegOffset dflags (VanillaReg 6 _) = oFFSET_StgRegTable_rR6 dflags -baseRegOffset dflags (VanillaReg 7 _) = oFFSET_StgRegTable_rR7 dflags -baseRegOffset dflags (VanillaReg 8 _) = oFFSET_StgRegTable_rR8 dflags -baseRegOffset dflags (VanillaReg 9 _) = oFFSET_StgRegTable_rR9 dflags -baseRegOffset dflags (VanillaReg 10 _) = oFFSET_StgRegTable_rR10 dflags -baseRegOffset _ (VanillaReg n _) = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") -baseRegOffset dflags (FloatReg 1) = oFFSET_StgRegTable_rF1 dflags -baseRegOffset dflags (FloatReg 2) = oFFSET_StgRegTable_rF2 dflags -baseRegOffset dflags (FloatReg 3) = oFFSET_StgRegTable_rF3 dflags -baseRegOffset dflags (FloatReg 4) = oFFSET_StgRegTable_rF4 dflags -baseRegOffset dflags (FloatReg 5) = oFFSET_StgRegTable_rF5 dflags -baseRegOffset dflags (FloatReg 6) = oFFSET_StgRegTable_rF6 dflags -baseRegOffset _ (FloatReg n) = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")") -baseRegOffset dflags (DoubleReg 1) = oFFSET_StgRegTable_rD1 dflags -baseRegOffset dflags (DoubleReg 2) = oFFSET_StgRegTable_rD2 dflags -baseRegOffset dflags (DoubleReg 3) = oFFSET_StgRegTable_rD3 dflags -baseRegOffset dflags (DoubleReg 4) = oFFSET_StgRegTable_rD4 dflags -baseRegOffset dflags (DoubleReg 5) = oFFSET_StgRegTable_rD5 dflags -baseRegOffset dflags (DoubleReg 6) = oFFSET_StgRegTable_rD6 dflags -baseRegOffset _ (DoubleReg n) = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")") -baseRegOffset dflags (XmmReg 1) = oFFSET_StgRegTable_rXMM1 dflags -baseRegOffset dflags (XmmReg 2) = oFFSET_StgRegTable_rXMM2 dflags -baseRegOffset dflags (XmmReg 3) = oFFSET_StgRegTable_rXMM3 dflags -baseRegOffset dflags (XmmReg 4) = oFFSET_StgRegTable_rXMM4 dflags -baseRegOffset dflags (XmmReg 5) = oFFSET_StgRegTable_rXMM5 dflags -baseRegOffset dflags (XmmReg 6) = oFFSET_StgRegTable_rXMM6 dflags -baseRegOffset _ (XmmReg n) = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")") -baseRegOffset dflags (YmmReg 1) = oFFSET_StgRegTable_rYMM1 dflags -baseRegOffset dflags (YmmReg 2) = oFFSET_StgRegTable_rYMM2 dflags -baseRegOffset dflags (YmmReg 3) = oFFSET_StgRegTable_rYMM3 dflags -baseRegOffset dflags (YmmReg 4) = oFFSET_StgRegTable_rYMM4 dflags -baseRegOffset dflags (YmmReg 5) = oFFSET_StgRegTable_rYMM5 dflags -baseRegOffset dflags (YmmReg 6) = oFFSET_StgRegTable_rYMM6 dflags -baseRegOffset _ (YmmReg n) = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")") -baseRegOffset dflags (ZmmReg 1) = oFFSET_StgRegTable_rZMM1 dflags -baseRegOffset dflags (ZmmReg 2) = oFFSET_StgRegTable_rZMM2 dflags -baseRegOffset dflags (ZmmReg 3) = oFFSET_StgRegTable_rZMM3 dflags -baseRegOffset dflags (ZmmReg 4) = oFFSET_StgRegTable_rZMM4 dflags -baseRegOffset dflags (ZmmReg 5) = oFFSET_StgRegTable_rZMM5 dflags -baseRegOffset dflags (ZmmReg 6) = oFFSET_StgRegTable_rZMM6 dflags -baseRegOffset _ (ZmmReg n) = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")") -baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags -baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags -baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags -baseRegOffset _ (LongReg n) = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")") -baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags -baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags -baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags -baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags -baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags -baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags -baseRegOffset dflags EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo dflags -baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags -baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags -baseRegOffset _ BaseReg = panic "CgUtils.baseRegOffset:BaseReg" -baseRegOffset _ PicBaseReg = panic "CgUtils.baseRegOffset:PicBaseReg" -baseRegOffset _ MachSp = panic "CgUtils.baseRegOffset:MachSp" -baseRegOffset _ UnwindReturnReg = panic "CgUtils.baseRegOffset:UnwindReturnReg" +baseRegOffset :: Platform -> GlobalReg -> Int +baseRegOffset platform reg = case reg of + VanillaReg 1 _ -> pc_OFFSET_StgRegTable_rR1 constants + VanillaReg 2 _ -> pc_OFFSET_StgRegTable_rR2 constants + VanillaReg 3 _ -> pc_OFFSET_StgRegTable_rR3 constants + VanillaReg 4 _ -> pc_OFFSET_StgRegTable_rR4 constants + VanillaReg 5 _ -> pc_OFFSET_StgRegTable_rR5 constants + VanillaReg 6 _ -> pc_OFFSET_StgRegTable_rR6 constants + VanillaReg 7 _ -> pc_OFFSET_StgRegTable_rR7 constants + VanillaReg 8 _ -> pc_OFFSET_StgRegTable_rR8 constants + VanillaReg 9 _ -> pc_OFFSET_StgRegTable_rR9 constants + VanillaReg 10 _ -> pc_OFFSET_StgRegTable_rR10 constants + VanillaReg n _ -> panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") + FloatReg 1 -> pc_OFFSET_StgRegTable_rF1 constants + FloatReg 2 -> pc_OFFSET_StgRegTable_rF2 constants + FloatReg 3 -> pc_OFFSET_StgRegTable_rF3 constants + FloatReg 4 -> pc_OFFSET_StgRegTable_rF4 constants + FloatReg 5 -> pc_OFFSET_StgRegTable_rF5 constants + FloatReg 6 -> pc_OFFSET_StgRegTable_rF6 constants + FloatReg n -> panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")") + DoubleReg 1 -> pc_OFFSET_StgRegTable_rD1 constants + DoubleReg 2 -> pc_OFFSET_StgRegTable_rD2 constants + DoubleReg 3 -> pc_OFFSET_StgRegTable_rD3 constants + DoubleReg 4 -> pc_OFFSET_StgRegTable_rD4 constants + DoubleReg 5 -> pc_OFFSET_StgRegTable_rD5 constants + DoubleReg 6 -> pc_OFFSET_StgRegTable_rD6 constants + DoubleReg n -> panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")") + XmmReg 1 -> pc_OFFSET_StgRegTable_rXMM1 constants + XmmReg 2 -> pc_OFFSET_StgRegTable_rXMM2 constants + XmmReg 3 -> pc_OFFSET_StgRegTable_rXMM3 constants + XmmReg 4 -> pc_OFFSET_StgRegTable_rXMM4 constants + XmmReg 5 -> pc_OFFSET_StgRegTable_rXMM5 constants + XmmReg 6 -> pc_OFFSET_StgRegTable_rXMM6 constants + XmmReg n -> panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")") + YmmReg 1 -> pc_OFFSET_StgRegTable_rYMM1 constants + YmmReg 2 -> pc_OFFSET_StgRegTable_rYMM2 constants + YmmReg 3 -> pc_OFFSET_StgRegTable_rYMM3 constants + YmmReg 4 -> pc_OFFSET_StgRegTable_rYMM4 constants + YmmReg 5 -> pc_OFFSET_StgRegTable_rYMM5 constants + YmmReg 6 -> pc_OFFSET_StgRegTable_rYMM6 constants + YmmReg n -> panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")") + ZmmReg 1 -> pc_OFFSET_StgRegTable_rZMM1 constants + ZmmReg 2 -> pc_OFFSET_StgRegTable_rZMM2 constants + ZmmReg 3 -> pc_OFFSET_StgRegTable_rZMM3 constants + ZmmReg 4 -> pc_OFFSET_StgRegTable_rZMM4 constants + ZmmReg 5 -> pc_OFFSET_StgRegTable_rZMM5 constants + ZmmReg 6 -> pc_OFFSET_StgRegTable_rZMM6 constants + ZmmReg n -> panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")") + Sp -> pc_OFFSET_StgRegTable_rSp constants + SpLim -> pc_OFFSET_StgRegTable_rSpLim constants + LongReg 1 -> pc_OFFSET_StgRegTable_rL1 constants + LongReg n -> panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")") + Hp -> pc_OFFSET_StgRegTable_rHp constants + HpLim -> pc_OFFSET_StgRegTable_rHpLim constants + CCCS -> pc_OFFSET_StgRegTable_rCCCS constants + CurrentTSO -> pc_OFFSET_StgRegTable_rCurrentTSO constants + CurrentNursery -> pc_OFFSET_StgRegTable_rCurrentNursery constants + HpAlloc -> pc_OFFSET_StgRegTable_rHpAlloc constants + EagerBlackholeInfo -> pc_OFFSET_stgEagerBlackholeInfo constants + GCEnter1 -> pc_OFFSET_stgGCEnter1 constants + GCFun -> pc_OFFSET_stgGCFun constants + BaseReg -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:BaseReg" + PicBaseReg -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:PicBaseReg" + MachSp -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:MachSp" + UnwindReturnReg -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:UnwindReturnReg" + where + !constants = platformConstants platform -- ----------------------------------------------------------------------------- @@ -107,40 +110,38 @@ baseRegOffset _ UnwindReturnReg = panic "CgUtils.baseRegOffset:UnwindRe -- to real machine registers or stored as offsets from BaseReg. Given -- a GlobalReg, get_GlobalReg_addr always produces the -- register table address for it. -get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr -get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0 -get_GlobalReg_addr dflags mid - = get_Regtable_addr_from_offset dflags (baseRegOffset dflags mid) +get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr +get_GlobalReg_addr platform BaseReg = regTableOffset platform 0 +get_GlobalReg_addr platform mid + = get_Regtable_addr_from_offset platform (baseRegOffset platform mid) -- Calculate a literal representing an offset into the register table. -- Used when we don't have an actual BaseReg to offset from. -regTableOffset :: DynFlags -> Int -> CmmExpr -regTableOffset dflags n = - CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n)) +regTableOffset :: Platform -> Int -> CmmExpr +regTableOffset platform n = + CmmLit (CmmLabelOff mkMainCapabilityLabel (pc_OFFSET_Capability_r (platformConstants platform) + n)) -get_Regtable_addr_from_offset :: DynFlags -> Int -> CmmExpr -get_Regtable_addr_from_offset dflags offset = - if haveRegBase (targetPlatform dflags) +get_Regtable_addr_from_offset :: Platform -> Int -> CmmExpr +get_Regtable_addr_from_offset platform offset = + if haveRegBase platform then cmmRegOff baseReg offset - else regTableOffset dflags offset + else regTableOffset platform offset -- | Fixup global registers so that they assign to locations within the -- RegTable if they aren't pinned for the current target. -fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl +fixStgRegisters :: Platform -> RawCmmDecl -> RawCmmDecl fixStgRegisters _ top@(CmmData _ _) = top -fixStgRegisters dflags (CmmProc info lbl live graph) = - let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph +fixStgRegisters platform (CmmProc info lbl live graph) = + let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock platform)) graph in CmmProc info lbl live graph' -fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x -fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block +fixStgRegBlock :: Platform -> Block CmmNode e x -> Block CmmNode e x +fixStgRegBlock platform block = mapBlock (fixStgRegStmt platform) block -fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x -fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt +fixStgRegStmt :: Platform -> CmmNode e x -> CmmNode e x +fixStgRegStmt platform stmt = fixAssign $ mapExpDeep fixExpr stmt where - platform = targetPlatform dflags - fixAssign stmt = case stmt of CmmAssign (CmmGlobal reg) src @@ -148,7 +149,7 @@ fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt -- information | reg == MachSp -> stmt | otherwise -> - let baseAddr = get_GlobalReg_addr dflags reg + let baseAddr = get_GlobalReg_addr platform reg in case reg `elem` activeStgRegs platform of True -> CmmAssign (CmmGlobal reg) src False -> CmmStore baseAddr src @@ -167,7 +168,7 @@ fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt case reg `elem` activeStgRegs platform of True -> expr False -> - let baseAddr = get_GlobalReg_addr dflags reg + let baseAddr = get_GlobalReg_addr platform reg in case reg of BaseReg -> baseAddr _other -> CmmLoad baseAddr (globalRegType platform reg) diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index a21be98ceb..98a15f0ef5 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -31,7 +31,8 @@ module GHC.StgToCmm.Closure ( -- * Used by other modules CgLoc(..), SelfLoopInfo, CallMethod(..), - nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod, + nodeMustPointToIt, isKnownFun, funTag, tagForArity, + CallOpts(..), getCallMethod, -- * ClosureInfo ClosureInfo, @@ -66,10 +67,12 @@ module GHC.StgToCmm.Closure ( import GHC.Prelude import GHC.Platform +import GHC.Platform.Profile import GHC.Stg.Syntax import GHC.Runtime.Heap.Layout import GHC.Cmm +import GHC.Cmm.Utils import GHC.Cmm.Ppr.Expr() -- For Outputable instances import GHC.StgToCmm.Types @@ -87,7 +90,6 @@ import GHC.Core.TyCon import GHC.Types.RepType import GHC.Types.Basic import GHC.Utils.Outputable -import GHC.Driver.Session import GHC.Utils.Misc import Data.Coerce (coerce) @@ -308,24 +310,25 @@ type DynTag = Int -- The tag on a *pointer* -- -- Also see Note [Tagging big families] in GHC.StgToCmm.Expr -isSmallFamily :: DynFlags -> Int -> Bool -isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags +isSmallFamily :: Platform -> Int -> Bool +isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform -tagForCon :: DynFlags -> DataCon -> DynTag -tagForCon dflags con = min (dataConTag con) (mAX_PTR_TAG dflags) +tagForCon :: Platform -> DataCon -> DynTag +tagForCon platform con = min (dataConTag con) (mAX_PTR_TAG platform) -- NB: 1-indexed -tagForArity :: DynFlags -> RepArity -> DynTag -tagForArity dflags arity - | isSmallFamily dflags arity = arity - | otherwise = 0 +tagForArity :: Platform -> RepArity -> DynTag +tagForArity platform arity + | isSmallFamily platform arity = arity + | otherwise = 0 -lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag --- Return the tag in the low order bits of a variable bound +-- | Return the tag in the low order bits of a variable bound -- to this LambdaForm -lfDynTag dflags (LFCon con) = tagForCon dflags con -lfDynTag dflags (LFReEntrant _ arity _ _) = tagForArity dflags arity -lfDynTag _ _other = 0 +lfDynTag :: Platform -> LambdaFormInfo -> DynTag +lfDynTag platform lf = case lf of + LFCon con -> tagForCon platform con + LFReEntrant _ arity _ _ -> tagForArity platform arity + _other -> 0 ----------------------------------------------------------------------------- @@ -365,7 +368,7 @@ thunkClosureType _ = Thunk -- nodeMustPointToIt ----------------------------------------------------------------------------- -nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool +nodeMustPointToIt :: Profile -> LambdaFormInfo -> Bool -- If nodeMustPointToIt is true, then the entry convention for -- this closure has R1 (the "Node" register) pointing to the -- closure itself --- the "self" argument @@ -377,11 +380,11 @@ nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) -- non-inherited (i.e. non-top-level) function. -- The isNotTopLevel test above ensures this is ok. -nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _) +nodeMustPointToIt profile (LFThunk top no_fvs updatable NonStandardThunk _) = not no_fvs -- Self parameter || isNotTopLevel top -- Note [GC recovery] || updatable -- Need to push update frame - || sccProfilingEnabled dflags + || profileIsProfiling profile -- For the non-updatable (single-entry case): -- -- True if has fvs (in which case we need access to them, and we @@ -476,7 +479,13 @@ data CallMethod CLabel -- The code label RepArity -- Its arity -getCallMethod :: DynFlags +data CallOpts = CallOpts + { co_profile :: !Profile -- ^ Platform profile + , co_loopification :: !Bool -- ^ Loopification enabled (cf @-floopification@) + , co_ticky :: !Bool -- ^ Ticky profiling enabled (cf @-ticky@) + } + +getCallMethod :: CallOpts -> Name -- Function being applied -> Id -- Function Id used to chech if it can refer to -- CAF's and whether the function is tail-calling @@ -492,9 +501,9 @@ getCallMethod :: DynFlags -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call? -> CallMethod -getCallMethod dflags _ id _ n_args v_args _cg_loc +getCallMethod opts _ id _ n_args v_args _cg_loc (Just (self_loop_id, block_id, args)) - | gopt Opt_Loopification dflags + | co_loopification opts , id == self_loop_id , args `lengthIs` (n_args - v_args) -- If these patterns match then we know that: @@ -505,14 +514,14 @@ getCallMethod dflags _ id _ n_args v_args _cg_loc -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details = JumpToIt block_id args -getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc +getCallMethod opts name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info | n_args == 0 -- No args at all - && not (sccProfilingEnabled dflags) + && not (profileIsProfiling (co_profile opts)) -- See Note [Evaluating functions with profiling] in rts/Apply.cmm = ASSERT( arity /= 0 ) ReturnIt | n_args < arity = SlowCall -- Not enough args - | otherwise = DirectEntry (enterIdLabel (targetPlatform dflags) name (idCafInfo id)) arity + | otherwise = DirectEntry (enterIdLabel (profilePlatform (co_profile opts)) name (idCafInfo id)) arity getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info = ASSERT( n_args == 0 ) ReturnIt @@ -522,14 +531,14 @@ getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info -- n_args=0 because it'd be ill-typed to apply a saturated -- constructor application to anything -getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun) +getCallMethod opts name id (LFThunk _ _ updatable std_form_info is_fun) n_args _v_args _cg_loc _self_loop_info | is_fun -- it *might* be a function, so we must "call" it (which is always safe) = SlowCall -- We cannot just enter it [in eval/apply, the entry code -- is the fast-entry code] -- Since is_fun is False, we are *definitely* looking at a data value - | updatable || gopt Opt_Ticky dflags -- to catch double entry + | updatable || co_ticky opts -- to catch double entry {- OLD: || opt_SMP I decided to remove this, because in SMP mode it doesn't matter if we enter the same thunk multiple times, so the optimisation @@ -551,7 +560,7 @@ getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun) | otherwise -- Jump direct to code for single-entry thunks = ASSERT( n_args == 0 ) - DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info + DirectEntry (thunkEntryLabel (profilePlatform (co_profile opts)) name (idCafInfo id) std_form_info updatable) 0 getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info @@ -619,14 +628,14 @@ mkCmmInfo ClosureInfo {..} id ccs -- Building ClosureInfos -------------------------------------- -mkClosureInfo :: DynFlags +mkClosureInfo :: Profile -> Bool -- Is static -> Id -> LambdaFormInfo -> Int -> Int -- Total and pointer words -> String -- String descriptor -> ClosureInfo -mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr +mkClosureInfo profile is_static id lf_info tot_wds ptr_wds val_descr = ClosureInfo { closureName = name , closureLFInfo = lf_info , closureInfoLabel = info_lbl -- These three fields are @@ -634,11 +643,11 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr , closureProf = prof } -- (we don't have an SRT yet) where name = idName id - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) - prof = mkProfilingInfo dflags id val_descr + sm_rep = mkHeapRep profile is_static ptr_wds nonptr_wds (lfClosureType lf_info) + prof = mkProfilingInfo profile id val_descr nonptr_wds = tot_wds - ptr_wds - info_lbl = mkClosureInfoTableLabel dflags id lf_info + info_lbl = mkClosureInfoTableLabel (profilePlatform profile) id lf_info -------------------------------------- -- Other functions over ClosureInfo @@ -761,9 +770,9 @@ lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) lfFunInfo _ = Nothing -funTag :: DynFlags -> ClosureInfo -> DynTag -funTag dflags (ClosureInfo { closureLFInfo = lf_info }) - = lfDynTag dflags lf_info +funTag :: Platform -> ClosureInfo -> DynTag +funTag platform (ClosureInfo { closureLFInfo = lf_info }) + = lfDynTag platform lf_info isToplevClosure :: ClosureInfo -> Bool isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) @@ -787,14 +796,14 @@ closureLocalEntryLabel platform | platformTablesNextToCode platform = toInfoLbl . closureInfoLabel | otherwise = toEntryLbl . closureInfoLabel -mkClosureInfoTableLabel :: DynFlags -> Id -> LambdaFormInfo -> CLabel -mkClosureInfoTableLabel dflags id lf_info +mkClosureInfoTableLabel :: Platform -> Id -> LambdaFormInfo -> CLabel +mkClosureInfoTableLabel platform id lf_info = case lf_info of LFThunk _ _ upd_flag (SelectorThunk offset) _ - -> mkSelectorInfoLabel dflags upd_flag offset + -> mkSelectorInfoLabel platform upd_flag offset LFThunk _ _ upd_flag (ApThunk arity) _ - -> mkApInfoTableLabel dflags upd_flag arity + -> mkApInfoTableLabel platform upd_flag arity LFThunk{} -> std_mk_lbl name cafs LFReEntrant{} -> std_mk_lbl name cafs @@ -814,29 +823,23 @@ mkClosureInfoTableLabel dflags id lf_info -- invariants in "GHC.CoreToStg.Prep" anything else gets eta expanded. -thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel --- thunkEntryLabel is a local help function, not exported. It's used from +-- | thunkEntryLabel is a local help function, not exported. It's used from -- getCallMethod. -thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag - = enterApLabel dflags upd_flag arity -thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag - = enterSelectorLabel dflags upd_flag offset -thunkEntryLabel dflags thunk_id c _ _ - = enterIdLabel (targetPlatform dflags) thunk_id c - -enterApLabel :: DynFlags -> Bool -> Arity -> CLabel -enterApLabel dflags is_updatable arity - | platformTablesNextToCode platform = mkApInfoTableLabel dflags is_updatable arity - | otherwise = mkApEntryLabel dflags is_updatable arity - where - platform = targetPlatform dflags - -enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel -enterSelectorLabel dflags upd_flag offset - | platformTablesNextToCode platform = mkSelectorInfoLabel dflags upd_flag offset - | otherwise = mkSelectorEntryLabel dflags upd_flag offset - where - platform = targetPlatform dflags +thunkEntryLabel :: Platform -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel +thunkEntryLabel platform thunk_id caf_info sfi upd_flag = case sfi of + ApThunk arity -> enterApLabel platform upd_flag arity + SelectorThunk offset -> enterSelectorLabel platform upd_flag offset + _ -> enterIdLabel platform thunk_id caf_info + +enterApLabel :: Platform -> Bool -> Arity -> CLabel +enterApLabel platform is_updatable arity + | platformTablesNextToCode platform = mkApInfoTableLabel platform is_updatable arity + | otherwise = mkApEntryLabel platform is_updatable arity + +enterSelectorLabel :: Platform -> Bool -> WordOff -> CLabel +enterSelectorLabel platform upd_flag offset + | platformTablesNextToCode platform = mkSelectorInfoLabel platform upd_flag offset + | otherwise = mkSelectorEntryLabel platform upd_flag offset enterIdLabel :: Platform -> Name -> CafInfo -> CLabel enterIdLabel platform id c @@ -857,10 +860,10 @@ enterIdLabel platform id c -- The type is determined from the type information stored with the @Id@ -- in the closure info using @closureTypeDescr@. -mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo -mkProfilingInfo dflags id val_descr - | not (sccProfilingEnabled dflags) = NoProfilingInfo - | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr) +mkProfilingInfo :: Profile -> Id -> String -> ProfilingInfo +mkProfilingInfo profile id val_descr + | not (profileIsProfiling profile) = NoProfilingInfo + | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr) where ty_descr_w8 = BS8.pack (getTyDescription (idType id)) @@ -891,8 +894,8 @@ getTyLitDescription l = -- CmmInfoTable-related things -------------------------------------- -mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable -mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds +mkDataConInfoTable :: Profile -> DataCon -> Bool -> Int -> Int -> CmmInfoTable +mkDataConInfoTable profile data_con is_static ptr_wds nonptr_wds = CmmInfoTable { cit_lbl = info_lbl , cit_rep = sm_rep , cit_prof = prof @@ -901,12 +904,12 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds where name = dataConName data_con info_lbl = mkConInfoTableLabel name NoCafRefs - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type + sm_rep = mkHeapRep profile is_static ptr_wds nonptr_wds cl_type cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con) -- We keep the *zero-indexed* tag in the srt_len field -- of the info table of a data constructor. - prof | not (sccProfilingEnabled dflags) = NoProfilingInfo + prof | not (profileIsProfiling profile) = NoProfilingInfo | otherwise = ProfilingInfo ty_descr val_descr ty_descr = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs index 30eeb25ab8..fdd4214b51 100644 --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -19,6 +19,9 @@ module GHC.StgToCmm.DataCon ( import GHC.Prelude +import GHC.Platform +import GHC.Platform.Profile + import GHC.Stg.Syntax import GHC.Core ( AltCon(..) ) @@ -46,7 +49,6 @@ import GHC.Types.RepType (countConRepArgs) import GHC.Types.Literal import GHC.Builtin.Utils import GHC.Utils.Outputable -import GHC.Platform import GHC.Utils.Misc import GHC.Utils.Monad (mapMaybeM) @@ -79,14 +81,16 @@ cgTopRhsCon dflags id con args = (id_Info, gen_code) where - id_Info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) + platform = targetPlatform dflags + id_Info = litIdInfo platform id (mkConLFInfo con) (CmmLabel closure_label) name = idName id caffy = idCafInfo id -- any stgArgHasCafRefs args closure_label = mkClosureLabel name caffy gen_code = - do { this_mod <- getModuleName - ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ + do { profile <- getProfile + ; this_mod <- getModuleName + ; when (platformOS platform == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) ) ; ASSERT( args `lengthIs` countConRepArgs con ) return () @@ -96,7 +100,7 @@ cgTopRhsCon dflags id con args (tot_wds, -- #ptr_wds + #nonptr_wds ptr_wds, -- #ptr_wds nv_args_w_offsets) = - mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args) + mkVirtHeapOffsetsWithPadding profile StdHeader (addArgReps args) mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len)) mk_payload (FieldOff arg _) = do @@ -110,7 +114,7 @@ cgTopRhsCon dflags id con args -- we're not really going to emit an info table, so having -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields -- needs to poke around inside it. - info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds + info_tbl = mkDataConInfoTable profile con True ptr_wds nonptr_wds ; payload <- mapM mk_payload nv_args_w_offsets @@ -165,7 +169,7 @@ buildDynCon' dflags binder _ _cc con args = return (cgInfo, return mkNop) -------- buildDynCon': the general case ----------- -buildDynCon' dflags binder actually_bound ccs con args +buildDynCon' _ binder actually_bound ccs con args = do { (id_info, reg) <- rhsIdInfo binder lf_info ; return (id_info, gen_code reg) } @@ -173,17 +177,19 @@ buildDynCon' dflags binder actually_bound ccs con args lf_info = mkConLFInfo con gen_code reg - = do { let (tot_wds, ptr_wds, args_w_offsets) - = mkVirtConstrOffsets dflags (addArgReps args) + = do { profile <- getProfile + ; let platform = profilePlatform profile + (tot_wds, ptr_wds, args_w_offsets) + = mkVirtConstrOffsets profile (addArgReps args) nonptr_wds = tot_wds - ptr_wds - info_tbl = mkDataConInfoTable dflags con False + info_tbl = mkDataConInfoTable profile con False ptr_wds nonptr_wds ; let ticky_name | actually_bound = Just binder | otherwise = Nothing ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info use_cc blame_cc args_w_offsets - ; return (mkRhsInit dflags reg lf_info hp_plus_n) } + ; return (mkRhsInit platform reg lf_info hp_plus_n) } where use_cc -- cost-centre to stick in the object | isCurrentCCS ccs = cccsExpr @@ -293,7 +299,7 @@ precomputedStaticConInfo_maybe :: DynFlags -> Id -> DataCon -> [NonVoid StgArg] precomputedStaticConInfo_maybe dflags binder con [] -- Nullary constructors | isNullaryRepDataCon con - = Just $ litIdInfo dflags binder (mkConLFInfo con) + = Just $ litIdInfo (targetPlatform dflags) binder (mkConLFInfo con) (CmmLabel (mkClosureLabel (dataConName con) NoCafRefs)) precomputedStaticConInfo_maybe dflags binder con [arg] -- Int/Char values with existing closures in the RTS @@ -303,12 +309,13 @@ precomputedStaticConInfo_maybe dflags binder con [arg] , inRange val = let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit label) val_int = fromIntegral val :: Int - offsetW = (val_int - (fromIntegral min_static_range)) * (fixedHdrSizeW dflags + 1) + offsetW = (val_int - (fromIntegral min_static_range)) * (fixedHdrSizeW profile + 1) -- INTLIKE/CHARLIKE closures consist of a header and one word payload static_amode = cmmLabelOffW platform intlike_lbl offsetW - in Just $ litIdInfo dflags binder (mkConLFInfo con) static_amode + in Just $ litIdInfo platform binder (mkConLFInfo con) static_amode where - platform = targetPlatform dflags + profile = targetProfile dflags + platform = profilePlatform profile intClosure = maybeIntLikeCon con charClosure = maybeCharLikeCon con getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val))) = Just val @@ -319,14 +326,16 @@ precomputedStaticConInfo_maybe dflags binder con [arg] inRange val = val >= min_static_range && val <= max_static_range + constants = platformConstants platform + min_static_range :: Integer min_static_range - | intClosure = fromIntegral (mIN_INTLIKE dflags) - | charClosure = fromIntegral (mIN_CHARLIKE dflags) + | intClosure = fromIntegral (pc_MIN_INTLIKE constants) + | charClosure = fromIntegral (pc_MIN_CHARLIKE constants) | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" max_static_range - | intClosure = fromIntegral (mAX_INTLIKE dflags) - | charClosure = fromIntegral (mAX_CHARLIKE dflags) + | intClosure = fromIntegral (pc_MAX_INTLIKE constants) + | charClosure = fromIntegral (pc_MAX_CHARLIKE constants) | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" label | intClosure = "stg_INTLIKE" @@ -346,10 +355,10 @@ bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg] -- found a con bindConArgs (DataAlt con) base args = ASSERT(not (isUnboxedTupleCon con)) - do dflags <- getDynFlags + do profile <- getProfile platform <- getPlatform - let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args) - tag = tagForCon dflags con + let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args) + tag = tagForCon platform con -- The binding below forces the masking out of the tag bits -- when accessing the constructor field. diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs index 9ee04c0617..e1a1e3c184 100644 --- a/compiler/GHC/StgToCmm/Env.hs +++ b/compiler/GHC/StgToCmm/Env.hs @@ -58,13 +58,12 @@ mkCgIdInfo id lf expr = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = CmmLoc expr } -litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo -litIdInfo dflags id lf lit +litIdInfo :: Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo +litIdInfo platform id lf lit = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = CmmLoc (addDynTag platform (CmmLit lit) tag) } where - tag = lfDynTag dflags lf - platform = targetPlatform dflags + tag = lfDynTag platform lf lneIdInfo :: Platform -> Id -> [NonVoid Id] -> CgIdInfo lneIdInfo platform id regs @@ -81,10 +80,9 @@ rhsIdInfo id lf_info reg <- newTemp (gcWord platform) return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) -mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph -mkRhsInit dflags reg lf_info expr - = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag dflags lf_info)) - where platform = targetPlatform dflags +mkRhsInit :: Platform -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph +mkRhsInit platform reg lf_info expr + = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag platform lf_info)) idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer @@ -124,7 +122,7 @@ addBindsC new_bindings = do getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id - = do { dflags <- getDynFlags + = do { platform <- targetPlatform <$> getDynFlags ; local_binds <- getBinds -- Try local bindings first ; case lookupVarEnv local_binds id of { Just info -> return info ; @@ -141,7 +139,7 @@ getCgIdInfo id mkBytesLabel name | otherwise = mkClosureLabel name $ idCafInfo id in return $ - litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl) + litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl) else cgLookupPanic id -- Bug }}} diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 6b4bddca33..61a4da571c 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -36,9 +36,9 @@ import GHC.Cmm.Graph import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info +import GHC.Cmm.Utils ( mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon -import GHC.Driver.Session ( mAX_PTR_TAG ) import GHC.Types.ForeignCall import GHC.Types.Id import GHC.Builtin.PrimOps @@ -71,13 +71,13 @@ cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = -- dataToTag# :: a -> Int# -- See Note [dataToTag#] in primops.txt.pp cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do - dflags <- getDynFlags platform <- getPlatform emitComment (mkFastString "dataToTag#") tmp <- newTemp (bWord platform) _ <- withSequel (AssignTo [tmp] False) (cgIdApp a []) -- TODO: For small types look at the tag bits instead of reading info table - emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))] + ptr_opts <- getPtrOpts + emitReturn [getConstrTag ptr_opts (cmmUntag platform (CmmReg (CmmLocal tmp)))] cgExpr (StgOpApp op args ty) = cgOpApp op args ty cgExpr (StgConApp con args _)= cgConApp con args @@ -564,18 +564,17 @@ cgAlts gc_plan bndr (PrimAlt _) alts ; return AssignedDirectly } cgAlts gc_plan bndr (AlgAlt tycon) alts - = do { dflags <- getDynFlags - ; platform <- getPlatform + = do { platform <- getPlatform ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts ; let !fam_sz = tyConFamilySize tycon !bndr_reg = CmmLocal (idToReg platform bndr) - !ptag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg) + !ptag_expr = cmmConstrTag1 platform (CmmReg bndr_reg) !branches' = first succ <$> branches - !maxpt = mAX_PTR_TAG dflags + !maxpt = mAX_PTR_TAG platform (!via_ptr, !via_info) = partition ((< maxpt) . fst) branches' - !small = isSmallFamily dflags fam_sz + !small = isSmallFamily platform fam_sz -- Is the constructor tag in the node reg? -- See Note [Tagging big families] @@ -587,8 +586,9 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts else -- No, the get exact tag from info table when mAX_PTR_TAG -- See Note [Double switching for big families] do - let !untagged_ptr = cmmUntag dflags (CmmReg bndr_reg) - !itag_expr = getConstrTag dflags untagged_ptr + ptr_opts <- getPtrOpts + let !untagged_ptr = cmmUntag platform (CmmReg bndr_reg) + !itag_expr = getConstrTag ptr_opts untagged_ptr !info0 = first pred <$> via_info if null via_ptr then emitSwitch itag_expr info0 mb_deflt 0 (fam_sz - 1) @@ -857,17 +857,17 @@ cgConApp con stg_args cgIdApp :: Id -> [StgArg] -> FCode ReturnKind cgIdApp fun_id args = do - dflags <- getDynFlags fun_info <- getCgIdInfo fun_id self_loop_info <- getSelfLoop + call_opts <- getCallOpts + profile <- getProfile let fun_arg = StgVarArg fun_id fun_name = idName fun_id fun = idInfoToAmode fun_info lf_info = cg_lf fun_info n_args = length args v_args = length $ filter (isVoidTy . stgArgType) args - node_points dflags = nodeMustPointToIt dflags lf_info - case getCallMethod dflags fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of + case getCallMethod call_opts fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of -- A value in WHNF, so we can just return it. ReturnIt | isVoidTy (idType fun_id) -> emitReturn [] @@ -885,7 +885,7 @@ cgIdApp fun_id args = do -- A direct function call (possibly with some left-over arguments) DirectEntry lbl arity -> do { tickyDirectCall arity args - ; if node_points dflags + ; if nodeMustPointToIt profile lf_info then directCall NativeNodeCall lbl arity (fun_arg:args) else directCall NativeDirectCall lbl arity args } @@ -1006,8 +1006,9 @@ cgIdApp fun_id args = do emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do - { dflags <- getDynFlags + { ptr_opts <- getPtrOpts ; platform <- getPlatform + ; profile <- getProfile ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff @@ -1021,9 +1022,9 @@ emitEnter fun = do -- Right now, we do what the old codegen did, and omit the tag -- test, just generating an enter. Return -> do - { let entry = entryCode platform $ closureInfoPtr dflags $ CmmReg nodeReg - ; emit $ mkJump dflags NativeNodeCall entry - [cmmUntag dflags fun] updfr_off + { let entry = entryCode platform $ closureInfoPtr ptr_opts $ CmmReg nodeReg + ; emit $ mkJump profile NativeNodeCall entry + [cmmUntag platform fun] updfr_off ; return AssignedDirectly } @@ -1054,21 +1055,21 @@ emitEnter fun = do -- AssignTo res_regs _ -> do { lret <- newBlockId - ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs [] + ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs [] ; lcall <- newBlockId ; updfr_off <- getUpdFrameOff ; let area = Young lret - ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area + ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area [fun] updfr_off [] -- refer to fun via nodeReg after the copyout, to avoid having -- both live simultaneously; this sometimes enables fun to be -- inlined in the RHS of the R1 assignment. - ; let entry = entryCode platform (closureInfoPtr dflags (CmmReg nodeReg)) + ; let entry = entryCode platform (closureInfoPtr ptr_opts (CmmReg nodeReg)) the_call = toCall entry (Just lret) updfr_off off outArgs regs ; tscope <- getTickScope ; emit $ copyout <*> - mkCbranch (cmmIsTagged dflags (CmmReg nodeReg)) + mkCbranch (cmmIsTagged platform (CmmReg nodeReg)) lret lcall Nothing <*> outOfLine lcall (the_call,tscope) <*> mkLabel lret tscope <*> diff --git a/compiler/GHC/StgToCmm/ExtCode.hs b/compiler/GHC/StgToCmm/ExtCode.hs index 05909d4bb5..380e4458e2 100644 --- a/compiler/GHC/StgToCmm/ExtCode.hs +++ b/compiler/GHC/StgToCmm/ExtCode.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TupleSections #-} -- | Our extended FCode monad. -- We add a mapping from names to CmmExpr, to support local variable names in @@ -32,19 +33,24 @@ module GHC.StgToCmm.ExtCode ( emit, emitLabel, emitAssign, emitStore, getCode, getCodeR, getCodeScoped, emitOutOfLine, - withUpdFrameOff, getUpdFrameOff + withUpdFrameOff, getUpdFrameOff, + getProfile, getPlatform, getPtrOpts ) where import GHC.Prelude +import GHC.Platform +import GHC.Platform.Profile + import qualified GHC.StgToCmm.Monad as F import GHC.StgToCmm.Monad (FCode, newUnique) import GHC.Cmm import GHC.Cmm.CLabel import GHC.Cmm.Graph +import GHC.Cmm.Info import GHC.Cmm.BlockId import GHC.Driver.Session @@ -98,9 +104,16 @@ instance MonadUnique CmmParse where return (decls, u) instance HasDynFlags CmmParse where - getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags - return (d, dflags)) + getDynFlags = EC (\_ _ d -> (d,) <$> getDynFlags) + +getProfile :: CmmParse Profile +getProfile = EC (\_ _ d -> (d,) <$> F.getProfile) + +getPlatform :: CmmParse Platform +getPlatform = EC (\_ _ d -> (d,) <$> F.getPlatform) +getPtrOpts :: CmmParse PtrOpts +getPtrOpts = EC (\_ _ d -> (d,) <$> F.getPtrOpts) -- | Takes the variable declarations and imports from the monad -- and makes an environment, which is looped back into the computation. diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs index aaffa17699..1f0939d344 100644 --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -22,6 +22,9 @@ module GHC.StgToCmm.Foreign ( import GHC.Prelude hiding( succ, (<*>) ) +import GHC.Platform +import GHC.Platform.Profile + import GHC.Stg.Syntax import GHC.StgToCmm.Prof (storeCurCCS, ccsType) import GHC.StgToCmm.Env @@ -40,8 +43,6 @@ import GHC.Types.RepType import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout import GHC.Types.ForeignCall -import GHC.Driver.Session -import GHC.Platform import GHC.Data.Maybe import GHC.Utils.Outputable import GHC.Types.Unique.Supply @@ -216,8 +217,8 @@ emitForeignCall -> FCode ReturnKind emitForeignCall safety results target args | not (playSafe safety) = do - dflags <- getDynFlags - let (caller_save, caller_load) = callerSaveVolatileRegs dflags + platform <- getPlatform + let (caller_save, caller_load) = callerSaveVolatileRegs platform emit caller_save target' <- load_target_into_temp target args' <- mapM maybe_assign_temp args @@ -226,13 +227,13 @@ emitForeignCall safety results target args return AssignedDirectly | otherwise = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform updfr_off <- getUpdFrameOff target' <- load_target_into_temp target args' <- mapM maybe_assign_temp args k <- newBlockId - let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results [] + let (off, _, copyout) = copyInOflow profile NativeReturn (Young k) results [] -- see Note [safe foreign call convention] tscope <- getTickScope emit $ @@ -283,32 +284,35 @@ maybe_assign_temp e = do emitSaveThreadState :: FCode () emitSaveThreadState = do - dflags <- getDynFlags - code <- saveThreadState dflags + profile <- getProfile + code <- saveThreadState profile emit code -- | Produce code to save the current thread state to @CurrentTSO@ -saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph -saveThreadState dflags = do - let platform = targetPlatform dflags +saveThreadState :: MonadUnique m => Profile -> m CmmAGraph +saveThreadState profile = do + let platform = profilePlatform profile tso <- newTemp (gcWord platform) - close_nursery <- closeNursery dflags tso - pure $ catAGraphs [ - -- tso = CurrentTSO; - mkAssign (CmmLocal tso) currentTSOExpr, - -- tso->stackobj->sp = Sp; - mkStore (cmmOffset platform - (CmmLoad (cmmOffset platform - (CmmReg (CmmLocal tso)) - (tso_stackobj dflags)) - (bWord platform)) - (stack_SP dflags)) - spExpr, - close_nursery, - -- and save the current cost centre stack in the TSO when profiling: - if sccProfilingEnabled dflags then - mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr - else mkNop + close_nursery <- closeNursery profile tso + pure $ catAGraphs + [ -- tso = CurrentTSO; + mkAssign (CmmLocal tso) currentTSOExpr + + , -- tso->stackobj->sp = Sp; + mkStore (cmmOffset platform + (CmmLoad (cmmOffset platform + (CmmReg (CmmLocal tso)) + (tso_stackobj profile)) + (bWord platform)) + (stack_SP profile)) + spExpr + + , close_nursery + + , -- and save the current cost centre stack in the TSO when profiling: + if profileIsProfiling profile + then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile)) cccsExpr + else mkNop ] @@ -323,26 +327,26 @@ saveThreadState dflags = do -- are live, we might have to save them all. emitSaveRegs :: FCode () emitSaveRegs = do - dflags <- getDynFlags - let regs = realArgRegsCover dflags - save = catAGraphs (map (callerSaveGlobalReg dflags) regs) + platform <- getPlatform + let regs = realArgRegsCover platform + save = catAGraphs (map (callerSaveGlobalReg platform) regs) emit save -- | Restore STG registers (see 'emitSaveRegs') emitRestoreRegs :: FCode () emitRestoreRegs = do - dflags <- getDynFlags - let regs = realArgRegsCover dflags - save = catAGraphs (map (callerRestoreGlobalReg dflags) regs) - emit save + platform <- getPlatform + let regs = realArgRegsCover platform + restore = catAGraphs (map (callerRestoreGlobalReg platform) regs) + emit restore emitCloseNursery :: FCode () emitCloseNursery = do - dflags <- getDynFlags - platform <- getPlatform + profile <- getProfile + let platform = profilePlatform profile tso <- newTemp (bWord platform) - code <- closeNursery dflags tso + code <- closeNursery profile tso emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code {- | @@ -366,24 +370,24 @@ Closing the nursery corresponds to the following code: cn->free = Hp + WDS(1); @ -} -closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph -closeNursery df tso = do - let tsoreg = CmmLocal tso - platform = targetPlatform df +closeNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph +closeNursery profile tso = do + let tsoreg = CmmLocal tso + platform = profilePlatform profile cnreg <- CmmLocal <$> newTemp (bWord platform) pure $ catAGraphs [ mkAssign cnreg currentNurseryExpr, -- CurrentNursery->free = Hp+1; - mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW platform hpExpr 1), + mkStore (nursery_bdescr_free platform cnreg) (cmmOffsetW platform hpExpr 1), let alloc = CmmMachOp (mo_wordSub platform) [ cmmOffsetW platform hpExpr 1 - , CmmLoad (nursery_bdescr_start df cnreg) (bWord platform) + , CmmLoad (nursery_bdescr_start platform cnreg) (bWord platform) ] - alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit df) + alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit profile) in -- tso->alloc_limit += alloc @@ -394,51 +398,51 @@ closeNursery df tso = do emitLoadThreadState :: FCode () emitLoadThreadState = do - dflags <- getDynFlags - code <- loadThreadState dflags + profile <- getProfile + code <- loadThreadState profile emit code -- | Produce code to load the current thread state from @CurrentTSO@ -loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph -loadThreadState dflags = do - let platform = targetPlatform dflags +loadThreadState :: MonadUnique m => Profile -> m CmmAGraph +loadThreadState profile = do + let platform = profilePlatform profile tso <- newTemp (gcWord platform) stack <- newTemp (gcWord platform) - open_nursery <- openNursery dflags tso + open_nursery <- openNursery profile tso pure $ catAGraphs [ -- tso = CurrentTSO; mkAssign (CmmLocal tso) currentTSOExpr, -- stack = tso->stackobj; - mkAssign (CmmLocal stack) (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord platform)), + mkAssign (CmmLocal stack) (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj profile)) (bWord platform)), -- Sp = stack->sp; - mkAssign spReg (CmmLoad (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord platform)), + mkAssign spReg (CmmLoad (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile)) (bWord platform)), -- SpLim = stack->stack + RESERVED_STACK_WORDS; - mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK dflags)) - (rESERVED_STACK_WORDS dflags)), + mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK profile)) + (pc_RESERVED_STACK_WORDS (platformConstants platform))), -- HpAlloc = 0; -- HpAlloc is assumed to be set to non-zero only by a failed -- a heap check, see HeapStackCheck.cmm:GC_GENERIC mkAssign hpAllocReg (zeroExpr platform), open_nursery, -- and load the current cost centre stack from the TSO when profiling: - if sccProfilingEnabled dflags + if profileIsProfiling profile then storeCurCCS (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) - (tso_CCCS dflags)) (ccsType platform)) + (tso_CCCS profile)) (ccsType platform)) else mkNop ] emitOpenNursery :: FCode () emitOpenNursery = do - dflags <- getDynFlags - platform <- getPlatform + profile <- getProfile + let platform = profilePlatform profile tso <- newTemp (bWord platform) - code <- openNursery dflags tso + code <- openNursery profile tso emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code {- | -@openNursery dflags tso@ produces code to open the nursery. A local register +@openNursery profile tso@ produces code to open the nursery. A local register holding the value of @CurrentTSO@ is expected for efficiency. Opening the nursery corresponds to the following code: @@ -465,10 +469,10 @@ Opening the nursery corresponds to the following code: HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1; @ -} -openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph -openNursery dflags tso = do - let tsoreg = CmmLocal tso - platform = targetPlatform dflags +openNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph +openNursery profile tso = do + let tsoreg = CmmLocal tso + platform = profilePlatform profile cnreg <- CmmLocal <$> newTemp (bWord platform) bdfreereg <- CmmLocal <$> newTemp (bWord platform) bdstartreg <- CmmLocal <$> newTemp (bWord platform) @@ -479,12 +483,12 @@ openNursery dflags tso = do -- stg_returnToStackTop in rts/StgStartup.cmm. pure $ catAGraphs [ mkAssign cnreg currentNurseryExpr, - mkAssign bdfreereg (CmmLoad (nursery_bdescr_free dflags cnreg) (bWord platform)), + mkAssign bdfreereg (CmmLoad (nursery_bdescr_free platform cnreg) (bWord platform)), -- Hp = CurrentNursery->free - 1; mkAssign hpReg (cmmOffsetW platform (CmmReg bdfreereg) (-1)), - mkAssign bdstartreg (CmmLoad (nursery_bdescr_start dflags cnreg) (bWord platform)), + mkAssign bdstartreg (CmmLoad (nursery_bdescr_start platform cnreg) (bWord platform)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; @@ -494,8 +498,8 @@ openNursery dflags tso = do (cmmOffset platform (CmmMachOp (mo_wordMul platform) [ CmmMachOp (MO_SS_Conv W32 (wordWidth platform)) - [CmmLoad (nursery_bdescr_blocks dflags cnreg) b32], - mkIntExpr platform (bLOCK_SIZE dflags) + [CmmLoad (nursery_bdescr_blocks platform cnreg) b32], + mkIntExpr platform (pc_BLOCK_SIZE (platformConstants platform)) ]) (-1) ) @@ -505,7 +509,7 @@ openNursery dflags tso = do let alloc = CmmMachOp (mo_wordSub platform) [CmmReg bdfreereg, CmmReg bdstartreg] - alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit dflags) + alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit profile) in -- tso->alloc_limit += alloc @@ -516,24 +520,24 @@ openNursery dflags tso = do ] nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks - :: DynFlags -> CmmReg -> CmmExpr -nursery_bdescr_free dflags cn = - cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_free dflags) -nursery_bdescr_start dflags cn = - cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_start dflags) -nursery_bdescr_blocks dflags cn = - cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_blocks dflags) + :: Platform -> CmmReg -> CmmExpr +nursery_bdescr_free platform cn = + cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_free (platformConstants platform)) +nursery_bdescr_start platform cn = + cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_start (platformConstants platform)) +nursery_bdescr_blocks platform cn = + cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_blocks (platformConstants platform)) -tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff -tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags) -tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags) -tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags) -stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags) -stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) +tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: Profile -> ByteOff +tso_stackobj profile = closureField profile (pc_OFFSET_StgTSO_stackobj (profileConstants profile)) +tso_alloc_limit profile = closureField profile (pc_OFFSET_StgTSO_alloc_limit (profileConstants profile)) +tso_CCCS profile = closureField profile (pc_OFFSET_StgTSO_cccs (profileConstants profile)) +stack_STACK profile = closureField profile (pc_OFFSET_StgStack_stack (profileConstants profile)) +stack_SP profile = closureField profile (pc_OFFSET_StgStack_sp (profileConstants profile)) -closureField :: DynFlags -> ByteOff -> ByteOff -closureField dflags off = off + fixedHdrSize dflags +closureField :: Profile -> ByteOff -> ByteOff +closureField profile off = off + fixedHdrSize profile -- Note [Unlifted boxed arguments to foreign calls] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -601,8 +605,8 @@ getFCallArgs args typ = return Nothing | otherwise = do { cmm <- getArgAmode (NonVoid arg) - ; dflags <- getDynFlags - ; return (Just (add_shim dflags typ cmm, hint)) } + ; profile <- getProfile + ; return (Just (add_shim profile typ cmm, hint)) } where arg_ty = stgArgType arg arg_reps = typePrimRep arg_ty @@ -618,14 +622,14 @@ data StgFArgType | StgByteArrayType -- See Note [Unlifted boxed arguments to foreign calls] -add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr -add_shim dflags ty expr = case ty of - StgPlainType -> expr - StgArrayType -> cmmOffsetB platform expr (arrPtrsHdrSize dflags) - StgSmallArrayType -> cmmOffsetB platform expr (smallArrPtrsHdrSize dflags) - StgByteArrayType -> cmmOffsetB platform expr (arrWordsHdrSize dflags) +add_shim :: Profile -> StgFArgType -> CmmExpr -> CmmExpr +add_shim profile ty expr = case ty of + StgPlainType -> expr + StgArrayType -> cmmOffsetB platform expr (arrPtrsHdrSize profile) + StgSmallArrayType -> cmmOffsetB platform expr (smallArrPtrsHdrSize profile) + StgByteArrayType -> cmmOffsetB platform expr (arrWordsHdrSize profile) where - platform = targetPlatform dflags + platform = profilePlatform profile -- From a function, extract information needed to determine -- the offset of each argument when used as a C FFI argument. diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs index 1804193de4..2edbdbf6c8 100644 --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -47,6 +47,7 @@ import GHC.Types.Id ( Id ) import GHC.Unit import GHC.Driver.Session import GHC.Platform +import GHC.Platform.Profile import GHC.Data.FastString( mkFastString, fsLit ) import GHC.Utils.Panic( sorry ) @@ -135,20 +136,19 @@ allocHeapClosure rep info_ptr use_cc payload = do hpStore base payload -- Bump the virtual heap pointer - dflags <- getDynFlags - setVirtHp (virt_hp + heapClosureSizeW dflags rep) + profile <- getProfile + setVirtHp (virt_hp + heapClosureSizeW profile rep) return base emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitSetDynHdr base info_ptr ccs - = do dflags <- getDynFlags - let platform = targetPlatform dflags - hpStore base (zip (header dflags) [0, platformWordSizeInBytes platform ..]) + = do profile <- getProfile + hpStore base (zip (header profile) [0, profileWordSizeInBytes profile ..]) where - header :: DynFlags -> [CmmExpr] - header dflags = [info_ptr] ++ dynProfHdr dflags ccs + header :: Profile -> [CmmExpr] + header profile = [info_ptr] ++ dynProfHdr profile ccs -- ToDo: Parallel stuff -- No ticky header @@ -167,17 +167,17 @@ hpStore base vals = do -- and adding a static link field if necessary. mkStaticClosureFields - :: DynFlags + :: Profile -> CmmInfoTable -> CostCentreStack -> CafInfo -> [CmmLit] -- Payload -> [CmmLit] -- The full closure -mkStaticClosureFields dflags info_tbl ccs caf_refs payload - = mkStaticClosure dflags info_lbl ccs payload padding +mkStaticClosureFields profile info_tbl ccs caf_refs payload + = mkStaticClosure profile info_lbl ccs payload padding static_link_field saved_info_field where - platform = targetPlatform dflags + platform = profilePlatform profile info_lbl = cit_lbl info_tbl -- CAFs must have consistent layout, regardless of whether they @@ -219,11 +219,11 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload -- See Note [STATIC_LINK fields] -- in rts/sm/Storage.h -mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] +mkStaticClosure :: Profile -> CLabel -> CostCentreStack -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field +mkStaticClosure profile info_lbl ccs payload padding static_link_field saved_info_field = [CmmLabel info_lbl] - ++ staticProfHdr dflags ccs + ++ staticProfHdr profile ccs ++ payload ++ padding ++ static_link_field @@ -352,7 +352,7 @@ entryHeapCheck' :: Bool -- is a known function pattern -> FCode () -> FCode () entryHeapCheck' is_fastf node arity args code - = do dflags <- getDynFlags + = do profile <- getProfile let is_thunk = arity == 0 args' = map (CmmReg . CmmLocal) args @@ -367,13 +367,13 @@ entryHeapCheck' is_fastf node arity args code -} gc_call upd | is_thunk - = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd + = mkJump profile NativeNodeCall stg_gc_enter1 [node] upd | is_fastf - = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd + = mkJump profile NativeNodeCall stg_gc_fun (node : args') upd | otherwise - = mkJump dflags Slow stg_gc_fun (node : args') upd + = mkJump profile Slow stg_gc_fun (node : args') upd updfr_sz <- getUpdFrameOff @@ -404,13 +404,13 @@ altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a altOrNoEscapeHeapCheck checkYield regs code = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform case cannedGCEntryPoint platform regs of Nothing -> genericGC checkYield code Just gc -> do lret <- newBlockId - let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs [] + let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) regs [] lcont <- newBlockId tscope <- getTickScope emitOutOfLine lret (copyin <*> mkBranch lcont, tscope) @@ -434,9 +434,9 @@ cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code - = do dflags <- getDynFlags + = do profile <- getProfile updfr_sz <- getUpdFrameOff - heapCheck False checkYield (gc_call dflags gc updfr_sz) code + heapCheck False checkYield (gc_call profile gc updfr_sz) code where reg_exprs = map (CmmReg . CmmLocal) regs -- Note [stg_gc arguments] @@ -445,11 +445,11 @@ cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code -- to the canned heap-check routines, because we are in a case -- alternative and hence the [LocalReg] was passed to us in the -- NativeReturn convention. - gc_call dflags label sp + gc_call profile label sp | cont_on_stack - = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp + = mkJumpReturnsTo profile label NativeReturn reg_exprs lret off sp | otherwise - = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp [] + = mkCallReturnsTo profile label NativeReturn reg_exprs lret off sp [] genericGC :: Bool -> FCode a -> FCode a genericGC checkYield code @@ -521,8 +521,7 @@ heapCheck checkStack checkYield do_gc code = getHeapUsage $ \ hpHw -> -- Emit heap checks, but be sure to do it lazily so -- that the conditionals on hpHw don't cause a black hole - do { dflags <- getDynFlags - ; platform <- getPlatform + do { platform <- getPlatform ; let mb_alloc_bytes | hpHw > mBLOCK_SIZE = sorry $ unlines [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.", @@ -533,7 +532,10 @@ heapCheck checkStack checkYield do_gc code "structures in code."] | hpHw > 0 = Just (mkIntExpr platform (hpHw * (platformWordSizeInBytes platform))) | otherwise = Nothing - where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags + where + constants = platformConstants platform + bLOCK_SIZE_W = pc_BLOCK_SIZE (platformConstants platform) `quot` platformWordSizeInBytes platform + mBLOCK_SIZE = pc_BLOCKS_PER_MBLOCK constants * bLOCK_SIZE_W stk_hwm | checkStack = Just (CmmLit CmmHighStackMark) | otherwise = Nothing ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs index 3ccc3c51ac..566e6666ad 100644 --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -54,6 +54,7 @@ import GHC.Core.TyCon ( PrimRep(..), primRepSizeB ) import GHC.Types.Basic ( RepArity ) import GHC.Driver.Session import GHC.Platform +import GHC.Platform.Profile import GHC.Unit import GHC.Utils.Misc @@ -78,7 +79,7 @@ import Control.Monad -- emitReturn :: [CmmExpr] -> FCode ReturnKind emitReturn results - = do { dflags <- getDynFlags + = do { profile <- getProfile ; platform <- getPlatform ; sequel <- getSequel ; updfr_off <- getUpdFrameOff @@ -86,7 +87,7 @@ emitReturn results Return -> do { adjustHpBackwards ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform) - ; emit (mkReturn dflags (entryCode platform e) results updfr_off) + ; emit (mkReturn profile (entryCode platform e) results updfr_off) } AssignTo regs adjust -> do { when adjust adjustHpBackwards @@ -113,19 +114,19 @@ emitCallWithExtraStack :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> [CmmExpr] -> FCode ReturnKind emitCallWithExtraStack (callConv, retConv) fun args extra_stack - = do { dflags <- getDynFlags + = do { profile <- getProfile ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff ; case sequel of Return -> do - emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack + emit $ mkJumpExtra profile callConv fun args updfr_off extra_stack return AssignedDirectly AssignTo res_regs _ -> do k <- newBlockId let area = Young k - (off, _, copyin) = copyInOflow dflags retConv area res_regs [] - copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off + (off, _, copyin) = copyInOflow profile retConv area res_regs [] + copyout = mkCallReturnsTo profile fun callConv args k off updfr_off extra_stack tscope <- getTickScope emit (copyout <*> mkLabel k tscope <*> copyin) @@ -191,7 +192,8 @@ slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind -- (slowCall fun args) applies fun to args, returning the results to Sequel slowCall fun stg_args = do dflags <- getDynFlags - platform <- getPlatform + profile <- getProfile + let platform = profilePlatform profile argsreps <- getArgRepsAmodes stg_args let (rts_fun, arity) = slowCallPattern (map fst argsreps) @@ -207,9 +209,10 @@ slowCall fun stg_args let n_args = length stg_args if n_args > arity && optLevel dflags >= 2 then do + ptr_opts <- getPtrOpts funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun fun_iptr <- (CmmReg . CmmLocal) `fmap` - assignTemp (closureInfoPtr dflags (cmmUntag dflags funv)) + assignTemp (closureInfoPtr ptr_opts (cmmUntag platform funv)) -- ToDo: we could do slightly better here by reusing the -- continuation from the slow call, which we have in r. @@ -230,11 +233,11 @@ slowCall fun stg_args is_tagged_lbl <- newBlockId end_lbl <- newBlockId - let correct_arity = cmmEqWord platform (funInfoArity dflags fun_iptr) + let correct_arity = cmmEqWord platform (funInfoArity profile fun_iptr) (mkIntExpr platform n_args) tscope <- getTickScope - emit (mkCbranch (cmmIsTagged dflags funv) + emit (mkCbranch (cmmIsTagged platform funv) is_tagged_lbl slow_lbl (Just True) <*> mkLabel is_tagged_lbl tscope <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True) @@ -411,7 +414,7 @@ data ClosureHeader | ThunkHeader mkVirtHeapOffsetsWithPadding - :: DynFlags + :: Profile -> ClosureHeader -- What kind of header to account for -> [NonVoid (PrimRep, a)] -- Things to make offsets for -> ( WordOff -- Total number of words allocated @@ -426,18 +429,18 @@ mkVirtHeapOffsetsWithPadding -- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets -- than the unboxed things -mkVirtHeapOffsetsWithPadding dflags header things = +mkVirtHeapOffsetsWithPadding profile header things = ASSERT(not (any (isVoidRep . fst . fromNonVoid) things)) ( tot_wds , bytesToWordsRoundUp platform bytes_of_ptrs , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad ) where - platform = targetPlatform dflags + platform = profilePlatform profile hdr_words = case header of NoHeader -> 0 - StdHeader -> fixedHdrSizeW dflags - ThunkHeader -> thunkHdrSize dflags + StdHeader -> fixedHdrSizeW profile + ThunkHeader -> thunkHdrSize profile hdr_bytes = wordsToBytes platform hdr_words (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things @@ -485,36 +488,36 @@ mkVirtHeapOffsetsWithPadding dflags header things = mkVirtHeapOffsets - :: DynFlags + :: Profile -> ClosureHeader -- What kind of header to account for -> [NonVoid (PrimRep,a)] -- Things to make offsets for -> (WordOff, -- _Total_ number of words allocated WordOff, -- Number of words allocated for *pointers* [(NonVoid a, ByteOff)]) -mkVirtHeapOffsets dflags header things = +mkVirtHeapOffsets profile header things = ( tot_wds , ptr_wds , [ (field, offset) | (FieldOff field offset) <- things_offsets ] ) where (tot_wds, ptr_wds, things_offsets) = - mkVirtHeapOffsetsWithPadding dflags header things + mkVirtHeapOffsetsWithPadding profile header things -- | Just like mkVirtHeapOffsets, but for constructors mkVirtConstrOffsets - :: DynFlags -> [NonVoid (PrimRep, a)] + :: Profile -> [NonVoid (PrimRep, a)] -> (WordOff, WordOff, [(NonVoid a, ByteOff)]) -mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags StdHeader +mkVirtConstrOffsets profile = mkVirtHeapOffsets profile StdHeader -- | Just like mkVirtConstrOffsets, but used when we don't have the actual -- arguments. Useful when e.g. generating info tables; we just need to know -- sizes of pointer and non-pointer fields. -mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff) -mkVirtConstrSizes dflags field_reps +mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff) +mkVirtConstrSizes profile field_reps = (tot_wds, ptr_wds) where (tot_wds, ptr_wds, _) = - mkVirtConstrOffsets dflags + mkVirtConstrOffsets profile (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps) ------------------------------------------------------------------------- @@ -601,19 +604,19 @@ emitClosureProcAndInfoTable :: Bool -- top-level? -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body -> FCode () emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body - = do { dflags <- getDynFlags + = do { profile <- getProfile ; platform <- getPlatform -- Bind the binder itself, but only if it's not a top-level -- binding. We need non-top let-bindings to refer to the -- top-level binding, which this binding would incorrectly shadow. ; node <- if top_lvl then return $ idToReg platform (NonVoid bndr) else bindToReg (NonVoid bndr) lf_info - ; let node_points = nodeMustPointToIt dflags lf_info + ; let node_points = nodeMustPointToIt profile lf_info ; arg_regs <- bindArgsToRegs args ; let args' = if node_points then (node : arg_regs) else arg_regs - conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall + conv = if nodeMustPointToIt profile lf_info then NativeNodeCall else NativeDirectCall - (offset, _, _) = mkCallEntry dflags conv args' [] + (offset, _, _) = mkCallEntry profile conv args' [] ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs) } diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs index 6beb08398b..802f3ae54d 100644 --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -22,8 +22,9 @@ module GHC.StgToCmm.Monad ( emitOutOfLine, emitAssign, emitStore, emitComment, emitTick, emitUnwind, - getCmm, aGraphToGraph, getPlatform, + getCmm, aGraphToGraph, getPlatform, getProfile, getCodeR, getCode, getCodeScoped, getHeapUsage, + getCallOpts, getPtrOpts, mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto', @@ -62,6 +63,7 @@ module GHC.StgToCmm.Monad ( import GHC.Prelude hiding( sequence, succ ) import GHC.Platform +import GHC.Platform.Profile import GHC.Cmm import GHC.StgToCmm.Closure import GHC.Driver.Session @@ -69,6 +71,7 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Graph as CmmGraph import GHC.Cmm.BlockId import GHC.Cmm.CLabel +import GHC.Cmm.Info import GHC.Runtime.Heap.Layout import GHC.Unit import GHC.Types.Id @@ -471,8 +474,31 @@ withSelfLoop self_loop code = do instance HasDynFlags FCode where getDynFlags = liftM cgd_dflags getInfoDown +getProfile :: FCode Profile +getProfile = targetProfile <$> getDynFlags + getPlatform :: FCode Platform -getPlatform = targetPlatform <$> getDynFlags +getPlatform = profilePlatform <$> getProfile + +getCallOpts :: FCode CallOpts +getCallOpts = do + dflags <- getDynFlags + profile <- getProfile + pure $ CallOpts + { co_profile = profile + , co_loopification = gopt Opt_Loopification dflags + , co_ticky = gopt Opt_Ticky dflags + } + +getPtrOpts :: FCode PtrOpts +getPtrOpts = do + dflags <- getDynFlags + profile <- getProfile + pure $ PtrOpts + { po_profile = profile + , po_align_check = gopt Opt_AlignmentSanitisation dflags + } + withInfoDown :: FCode a -> CgInfoDownwards -> FCode a withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state @@ -742,8 +768,8 @@ emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False } emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True -- do layout - = do { dflags <- getDynFlags - ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args + = do { profile <- getProfile + ; let (offset, live, entry) = mkCallEntry profile conv args stk_args graph' = entry CmmGraph.<*> graph ; emitProc mb_info lbl live (graph', tscope) offset True } @@ -837,12 +863,12 @@ mkCmmIfThen' e tbranch l = do mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do - dflags <- getDynFlags - k <- newBlockId - tscp <- getTickScope + profile <- getProfile + k <- newBlockId + tscp <- getTickScope let area = Young k - (off, _, copyin) = copyInOflow dflags retConv area results [] - copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack + (off, _, copyin) = copyInOflow profile retConv area results [] + copyout = mkCallReturnsTo profile f callConv actuals k off updfr_off extra_stack return $ catAGraphs [copyout, mkLabel k tscp, copyin] mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index c3a14f9b1c..374b5241fc 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -27,6 +27,9 @@ module GHC.StgToCmm.Prim ( import GHC.Prelude hiding ((<*>)) +import GHC.Platform +import GHC.Platform.Profile + import GHC.StgToCmm.Layout import GHC.StgToCmm.Foreign import GHC.StgToCmm.Env @@ -38,7 +41,6 @@ import GHC.StgToCmm.Prof ( costCentreFrom ) import GHC.Driver.Session import GHC.Driver.Backend -import GHC.Platform import GHC.Types.Basic import GHC.Cmm.BlockId import GHC.Cmm.Graph @@ -165,11 +167,11 @@ emitPrimOp dflags primop = case primop of NewArrayOp -> \case [(CmmLit (CmmInt n w)), init] | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) - -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel + -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel [ (mkIntExpr platform (fromInteger n), - fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags) - , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))), - fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags) + fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)) + , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep platform (fromInteger n))), + fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_size (platformConstants platform)) ] (fromInteger n) init _ -> PrimopCmmEmit_External @@ -224,7 +226,7 @@ emitPrimOp dflags primop = case primop of -> opIntoRegs $ \ [res] -> doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel [ (mkIntExpr platform (fromInteger n), - fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags) + fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)) ] (fromInteger n) init _ -> PrimopCmmEmit_External @@ -288,7 +290,7 @@ emitPrimOp dflags primop = case primop of GetCCSOfOp -> \[arg] -> opIntoRegs $ \[res] -> do let val - | sccProfilingEnabled dflags = costCentreFrom dflags (cmmUntag dflags arg) + | profileIsProfiling profile = costCentreFrom platform (cmmUntag platform arg) | otherwise = CmmLit (zeroCLit platform) emitAssign (CmmLocal res) val @@ -299,11 +301,11 @@ emitPrimOp dflags primop = case primop of emitAssign (CmmLocal res) currentTSOExpr ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] -> do - emitAssign (CmmLocal res) (cmmLoadIndexW platform mutv (fixedHdrSizeW dflags) (gcWord platform)) + emitAssign (CmmLocal res) (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform)) WriteMutVarOp -> \[mutv, var] -> opIntoRegs $ \res@[] -> do old_val <- CmmLocal <$> newTemp (cmmExprType platform var) - emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW dflags) (gcWord platform)) + emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform)) -- Without this write barrier, other CPUs may see this pointer before -- the writes for the closure it points to have occurred. @@ -311,7 +313,7 @@ emitPrimOp dflags primop = case primop of -- that the read of old_val comes before another core's write to the -- MutVar's value. emitPrimCall res MO_WriteBarrier [] - emitStore (cmmOffsetW platform mutv (fixedHdrSizeW dflags)) var + emitStore (cmmOffsetW platform mutv (fixedHdrSizeW profile)) var emitCCall [{-no results-}] (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) @@ -320,7 +322,7 @@ emitPrimOp dflags primop = case primop of -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do - emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform)) + emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) -- #define sizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes @@ -329,7 +331,7 @@ emitPrimOp dflags primop = case primop of -- #define getSizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do - emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform)) + emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) -- #define touchzh(o) /* nothing */ @@ -338,11 +340,11 @@ emitPrimOp dflags primop = case primop of -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) ByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] -> do - emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize dflags)) + emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile)) -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] -> do - emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform)) + emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] -> do emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2]) @@ -423,7 +425,7 @@ emitPrimOp dflags primop = case primop of SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg - (fixedHdrSizeW dflags + bytesToWordsRoundUp platform (oFFSET_StgMutArrPtrs_ptrs dflags)) + (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))) (bWord platform)) SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp @@ -431,7 +433,7 @@ emitPrimOp dflags primop = case primop of SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg - (fixedHdrSizeW dflags + bytesToWordsRoundUp platform (oFFSET_StgSmallMutArrPtrs_ptrs dflags)) + (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform))) (bWord platform)) SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp @@ -1518,7 +1520,8 @@ emitPrimOp dflags primop = case primop of SetThreadAllocationCounter -> alwaysExternal where - platform = targetPlatform dflags + profile = targetProfile dflags + platform = profilePlatform profile result_info = getPrimOpResultInfo primop opNop :: [CmmExpr] -> PrimopCmmEmit @@ -1963,8 +1966,8 @@ doIndexByteArrayOp :: Maybe MachOp -> [CmmExpr] -> FCode () doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] - = do dflags <- getDynFlags - mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx + = do profile <- getProfile + mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx doIndexByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp" @@ -1975,8 +1978,8 @@ doIndexByteArrayOpAs :: Maybe MachOp -> [CmmExpr] -> FCode () doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] - = do dflags <- getDynFlags - mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx + = do profile <- getProfile + mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx doIndexByteArrayOpAs _ _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs" @@ -1985,9 +1988,9 @@ doReadPtrArrayOp :: LocalReg -> CmmExpr -> FCode () doReadPtrArrayOp res addr idx - = do dflags <- getDynFlags + = do profile <- getProfile platform <- getPlatform - mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord platform) res addr (gcWord platform) idx + mkBasicIndexedRead (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx doWriteOffAddrOp :: Maybe MachOp -> CmmType @@ -2005,8 +2008,8 @@ doWriteByteArrayOp :: Maybe MachOp -> [CmmExpr] -> FCode () doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val] - = do dflags <- getDynFlags - mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val + = do profile <- getProfile + mkBasicIndexedWrite (arrWordsHdrSize profile) maybe_pre_write_cast addr idx_ty idx val doWriteByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp" @@ -2015,10 +2018,10 @@ doWritePtrArrayOp :: CmmExpr -> CmmExpr -> FCode () doWritePtrArrayOp addr idx val - = do dflags <- getDynFlags + = do profile <- getProfile platform <- getPlatform let ty = cmmExprType platform val - hdr_size = arrPtrsHdrSize dflags + hdr_size = arrPtrsHdrSize profile -- Update remembered set for non-moving collector whenUpdRemSetEnabled $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform hdr_size ty addr ty idx) @@ -2033,15 +2036,15 @@ doWritePtrArrayOp addr idx val emit $ mkStore ( cmmOffsetExpr platform (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size) - (loadArrPtrsSize dflags addr)) + (loadArrPtrsSize profile addr)) (CmmMachOp (mo_wordUShr platform) [idx, - mkIntExpr platform (mUT_ARR_PTRS_CARD_BITS dflags)]) + mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))]) ) (CmmLit (CmmInt 1 W8)) -loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr -loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB platform addr off) (bWord platform) - where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags - platform = targetPlatform dflags +loadArrPtrsSize :: Profile -> CmmExpr -> CmmExpr +loadArrPtrsSize profile addr = CmmLoad (cmmOffsetB platform addr off) (bWord platform) + where off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (profileConstants profile) + platform = profilePlatform profile mkBasicIndexedRead :: ByteOff -- Initial offset in bytes -> Maybe MachOp -- Optional result cast @@ -2171,11 +2174,12 @@ checkVecCompatibility dflags vcat l w = do ,"Please use -fllvm."] check vecWidth vcat l w where + platform = targetPlatform dflags check :: Width -> PrimOpVecCat -> Length -> Width -> FCode () - check W128 FloatVec 4 W32 | not (isSseEnabled dflags) = + check W128 FloatVec 4 W32 | not (isSseEnabled platform) = sorry $ "128-bit wide single-precision floating point " ++ "SIMD vector instructions require at least -msse." - check W128 _ _ _ | not (isSse2Enabled dflags) = + check W128 _ _ _ | not (isSse2Enabled platform) = sorry $ "128-bit wide integer and double precision " ++ "SIMD vector instructions require at least -msse2." check W256 FloatVec _ _ | not (isAvxEnabled dflags) = @@ -2302,8 +2306,8 @@ doPrefetchByteArrayOp :: Int -> [CmmExpr] -> FCode () doPrefetchByteArrayOp locality [addr,idx] - = do dflags <- getDynFlags - mkBasicPrefetch locality (arrWordsHdrSize dflags) addr idx + = do profile <- getProfile + mkBasicPrefetch locality (arrWordsHdrSize profile) addr idx doPrefetchByteArrayOp _ _ = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" @@ -2312,8 +2316,8 @@ doPrefetchMutableByteArrayOp :: Int -> [CmmExpr] -> FCode () doPrefetchMutableByteArrayOp locality [addr,idx] - = do dflags <- getDynFlags - mkBasicPrefetch locality (arrWordsHdrSize dflags) addr idx + = do profile <- getProfile + mkBasicPrefetch locality (arrWordsHdrSize profile) addr idx doPrefetchMutableByteArrayOp _ _ = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" @@ -2355,21 +2359,21 @@ mkBasicPrefetch locality off base idx -- 'MutableByteArray#'. doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode () doNewByteArrayOp res_r n = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let info_ptr = mkLblExpr mkArrWords_infoLabel rep = arrWordsRep platform n - tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize dflags)) + tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize profile)) (mkIntExpr platform (nonHdrSize platform rep)) (zeroExpr platform) - let hdr_size = fixedHdrSize dflags + let hdr_size = fixedHdrSize profile base <- allocHeapClosure rep info_ptr cccsExpr [ (mkIntExpr platform n, - hdr_size + oFFSET_StgArrBytes_bytes dflags) + hdr_size + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)) ] emit $ mkAssign (CmmLocal res_r) base @@ -2380,10 +2384,10 @@ doNewByteArrayOp res_r n = do doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform - ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize dflags)) ba1_off - ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize dflags)) ba2_off + ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off + ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off -- short-cut in case of equal pointers avoiding a costly -- subroutine call to the memcmp(3) routine; the Cmm logic below @@ -2469,14 +2473,14 @@ emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitCopyByteArray copy src src_off dst dst_off n = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let byteArrayAlignment = wordAlignment platform srcOffAlignment = cmmExprAlignment src_off dstOffAlignment = cmmExprAlignment dst_off align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment] - dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize dflags)) dst_off - src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize dflags)) src_off + dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off + src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off copy src dst dst_p src_p n align -- | Takes a source 'ByteArray#', an offset in the source array, a @@ -2485,9 +2489,9 @@ emitCopyByteArray copy src src_off dst dst_off n = do doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doCopyByteArrayToAddrOp src src_off dst_p bytes = do -- Use memcpy (we are allowed to assume the arrays aren't overlapping) - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform - src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize dflags)) src_off + src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off emitMemcpyCall dst_p src_p bytes (mkAlignment 1) -- | Takes a source 'MutableByteArray#', an offset in the source array, a @@ -2503,9 +2507,9 @@ doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doCopyAddrToByteArrayOp src_p dst dst_off bytes = do -- Use memcpy (we are allowed to assume the arrays aren't overlapping) - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform - dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize dflags)) dst_off + dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off emitMemcpyCall dst_p src_p bytes (mkAlignment 1) @@ -2518,14 +2522,14 @@ doCopyAddrToByteArrayOp src_p dst dst_off bytes = do doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doSetByteArrayOp ba off len c = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap offsetAlignment = cmmExprAlignment off align = min byteArrayAlignment offsetAlignment - p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize dflags)) off + p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize profile)) off emitMemsetCall p c len align -- ---------------------------------------------------------------------------- @@ -2540,12 +2544,12 @@ doNewArrayOp :: CmmFormal -- ^ return register -> CmmExpr -- ^ initial element -> FCode () doNewArrayOp res_r rep info payload n init = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let info_ptr = mkLblExpr info - tickyAllocPrim (mkIntExpr platform (hdrSize dflags rep)) + tickyAllocPrim (mkIntExpr platform (hdrSize profile rep)) (mkIntExpr platform (nonHdrSize platform rep)) (zeroExpr platform) @@ -2555,7 +2559,7 @@ doNewArrayOp res_r rep info payload n init = do emit $ mkAssign arr base -- Initialise all elements of the array - let mkOff off = cmmOffsetW platform (CmmReg arr) (hdrSizeW dflags rep + off) + let mkOff off = cmmOffsetW platform (CmmReg arr) (hdrSizeW profile rep + off) initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ] emit (catAGraphs initialization) @@ -2624,7 +2628,7 @@ emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff -> FCode () emitCopyArray copy src0 src_off dst0 dst_off0 n = when (n /= 0) $ do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform -- Passed as arguments (be careful) @@ -2633,23 +2637,23 @@ emitCopyArray copy src0 src_off dst0 dst_off0 n = dst_off <- assignTempE dst_off0 -- Nonmoving collector write barrier - emitCopyUpdRemSetPush platform (arrPtrsHdrSizeW dflags) dst dst_off n + emitCopyUpdRemSetPush platform (arrPtrsHdrSizeW profile) dst dst_off n -- Set the dirty bit in the header. emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) dst_elems_p <- assignTempE $ cmmOffsetB platform dst - (arrPtrsHdrSize dflags) + (arrPtrsHdrSize profile) dst_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p dst_off src_p <- assignTempE $ cmmOffsetExprW platform - (cmmOffsetB platform src (arrPtrsHdrSize dflags)) src_off + (cmmOffsetB platform src (arrPtrsHdrSize profile)) src_off let bytes = wordsToBytes platform n copy src dst dst_p src_p bytes -- The base address of the destination card table dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p - (loadArrPtrsSize dflags dst) + (loadArrPtrsSize profile dst) emitSetCards dst_off dst_cards_p n @@ -2691,7 +2695,7 @@ emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff -> FCode () emitCopySmallArray copy src0 src_off dst0 dst_off n = when (n /= 0) $ do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform -- Passed as arguments (be careful) @@ -2699,15 +2703,15 @@ emitCopySmallArray copy src0 src_off dst0 dst_off n = dst <- assignTempE dst0 -- Nonmoving collector write barrier - emitCopyUpdRemSetPush platform (smallArrPtrsHdrSizeW dflags) dst dst_off n + emitCopyUpdRemSetPush platform (smallArrPtrsHdrSizeW profile) dst dst_off n -- Set the dirty bit in the header. emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) dst_p <- assignTempE $ cmmOffsetExprW platform - (cmmOffsetB platform dst (smallArrPtrsHdrSize dflags)) dst_off + (cmmOffsetB platform dst (smallArrPtrsHdrSize profile)) dst_off src_p <- assignTempE $ cmmOffsetExprW platform - (cmmOffsetB platform src (smallArrPtrsHdrSize dflags)) src_off + (cmmOffsetB platform src (smallArrPtrsHdrSize profile)) src_off let bytes = wordsToBytes platform n copy src dst dst_p src_p bytes @@ -2719,33 +2723,34 @@ emitCopySmallArray copy src0 src_off dst0 dst_off n = emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff -> FCode () emitCloneArray info_p res_r src src_off n = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let info_ptr = mkLblExpr info_p - rep = arrPtrsRep dflags n + rep = arrPtrsRep platform n - tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize dflags)) + tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize profile)) (mkIntExpr platform (nonHdrSize platform rep)) (zeroExpr platform) - let hdr_size = fixedHdrSize dflags + let hdr_size = fixedHdrSize profile + constants = platformConstants platform base <- allocHeapClosure rep info_ptr cccsExpr [ (mkIntExpr platform n, - hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags) + hdr_size + pc_OFFSET_StgMutArrPtrs_ptrs constants) , (mkIntExpr platform (nonHdrSizeW rep), - hdr_size + oFFSET_StgMutArrPtrs_size dflags) + hdr_size + pc_OFFSET_StgMutArrPtrs_size constants) ] arr <- CmmLocal `fmap` newTemp (bWord platform) emit $ mkAssign arr base dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr) - (arrPtrsHdrSize dflags) + (arrPtrsHdrSize profile) src_p <- assignTempE $ cmmOffsetExprW platform src (cmmAddWord platform - (mkIntExpr platform (arrPtrsHdrSizeW dflags)) src_off) + (mkIntExpr platform (arrPtrsHdrSizeW profile)) src_off) emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) (wordAlignment platform) @@ -2759,31 +2764,31 @@ emitCloneArray info_p res_r src src_off n = do emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff -> FCode () emitCloneSmallArray info_p res_r src src_off n = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let info_ptr = mkLblExpr info_p rep = smallArrPtrsRep n - tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize dflags)) + tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize profile)) (mkIntExpr platform (nonHdrSize platform rep)) (zeroExpr platform) - let hdr_size = fixedHdrSize dflags + let hdr_size = fixedHdrSize profile base <- allocHeapClosure rep info_ptr cccsExpr [ (mkIntExpr platform n, - hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags) + hdr_size + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)) ] arr <- CmmLocal `fmap` newTemp (bWord platform) emit $ mkAssign arr base dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr) - (smallArrPtrsHdrSize dflags) + (smallArrPtrsHdrSize profile) src_p <- assignTempE $ cmmOffsetExprW platform src (cmmAddWord platform - (mkIntExpr platform (smallArrPtrsHdrSizeW dflags)) src_off) + (mkIntExpr platform (smallArrPtrsHdrSizeW profile)) src_off) emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) (wordAlignment platform) @@ -2796,10 +2801,9 @@ emitCloneSmallArray info_p res_r src src_off n = do -- Marks the relevant cards as dirty. emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode () emitSetCards dst_start dst_cards_start n = do - dflags <- getDynFlags platform <- getPlatform - start_card <- assignTempE $ cardCmm dflags dst_start - let end_card = cardCmm dflags + start_card <- assignTempE $ cardCmm platform dst_start + let end_card = cardCmm platform (cmmSubWord platform (cmmAddWord platform dst_start (mkIntExpr platform n)) (mkIntExpr platform 1)) @@ -2809,10 +2813,9 @@ emitSetCards dst_start dst_cards_start n = do (mkAlignment 1) -- no alignment (1 byte) -- Convert an element index to a card index -cardCmm :: DynFlags -> CmmExpr -> CmmExpr -cardCmm dflags i = - cmmUShrWord platform i (mkIntExpr platform (mUT_ARR_PTRS_CARD_BITS dflags)) - where platform = targetPlatform dflags +cardCmm :: Platform -> CmmExpr -> CmmExpr +cardCmm platform i = + cmmUShrWord platform i (mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))) ------------------------------------------------------------------------------ -- SmallArray PrimOp implementations @@ -2822,9 +2825,9 @@ doReadSmallPtrArrayOp :: LocalReg -> CmmExpr -> FCode () doReadSmallPtrArrayOp res addr idx = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform - mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord platform) res addr + mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx doWriteSmallPtrArrayOp :: CmmExpr @@ -2832,17 +2835,17 @@ doWriteSmallPtrArrayOp :: CmmExpr -> CmmExpr -> FCode () doWriteSmallPtrArrayOp addr idx val = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let ty = cmmExprType platform val -- Update remembered set for non-moving collector tmp <- newTemp ty - mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing ty tmp addr ty idx + mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp)) emitPrimCall [] MO_WriteBarrier [] -- #12469 - mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val + mkBasicIndexedWrite (smallArrPtrsHdrSize profile) Nothing addr ty idx val emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) ------------------------------------------------------------------------------ @@ -2859,10 +2862,10 @@ doAtomicRMW :: LocalReg -- ^ Result reg -> CmmExpr -- ^ Op argument (e.g. amount to add) -> FCode () doAtomicRMW res amop mba idx idx_ty n = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let width = typeWidth idx_ty - addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags) + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx emitPrimCall [ res ] @@ -2877,10 +2880,10 @@ doAtomicReadByteArray -> CmmType -- ^ Type of element by which we are indexing -> FCode () doAtomicReadByteArray res mba idx idx_ty = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let width = typeWidth idx_ty - addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags) + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx emitPrimCall [ res ] @@ -2895,10 +2898,10 @@ doAtomicWriteByteArray -> CmmExpr -- ^ Value to write -> FCode () doAtomicWriteByteArray mba idx idx_ty val = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let width = typeWidth idx_ty - addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags) + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx emitPrimCall [ {- no results -} ] @@ -2914,10 +2917,10 @@ doCasByteArray -> CmmExpr -- ^ New value -> FCode () doCasByteArray res mba idx idx_ty old new = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let width = (typeWidth idx_ty) - addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags) + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx emitPrimCall [ res ] diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs index 1381617f89..d58f20cfd1 100644 --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -26,6 +26,7 @@ module GHC.StgToCmm.Prof ( import GHC.Prelude import GHC.Platform +import GHC.Platform.Profile import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad @@ -67,32 +68,30 @@ mkCCostCentre cc = CmmLabel (mkCCLabel cc) mkCCostCentreStack :: CostCentreStack -> CmmLit mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) -costCentreFrom :: DynFlags - -> CmmExpr -- A closure pointer +costCentreFrom :: Platform + -> CmmExpr -- A closure pointer -> CmmExpr -- The cost centre from that closure -costCentreFrom dflags cl = CmmLoad (cmmOffsetB platform cl (oFFSET_StgHeader_ccs dflags)) (ccsType platform) - where platform = targetPlatform dflags +costCentreFrom platform cl = CmmLoad (cmmOffsetB platform cl (pc_OFFSET_StgHeader_ccs (platformConstants platform))) (ccsType platform) -- | The profiling header words in a static closure -staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] -staticProfHdr dflags ccs - | sccProfilingEnabled dflags = [mkCCostCentreStack ccs, staticLdvInit platform] +staticProfHdr :: Profile -> CostCentreStack -> [CmmLit] +staticProfHdr profile ccs + | profileIsProfiling profile = [mkCCostCentreStack ccs, staticLdvInit platform] | otherwise = [] - where platform = targetPlatform dflags + where platform = profilePlatform profile -- | Profiling header words in a dynamic closure -dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] -dynProfHdr dflags ccs - | sccProfilingEnabled dflags = [ccs, dynLdvInit dflags] +dynProfHdr :: Profile -> CmmExpr -> [CmmExpr] +dynProfHdr profile ccs + | profileIsProfiling profile = [ccs, dynLdvInit (profilePlatform profile)] | otherwise = [] -- | Initialise the profiling field of an update frame initUpdFrameProf :: CmmExpr -> FCode () initUpdFrameProf frame = ifProfiling $ -- frame->header.prof.ccs = CCCS - do dflags <- getDynFlags - platform <- getPlatform - emitStore (cmmOffset platform frame (oFFSET_StgHeader_ccs dflags)) cccsExpr + do platform <- getPlatform + emitStore (cmmOffset platform frame (pc_OFFSET_StgHeader_ccs (platformConstants platform))) cccsExpr -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) -- is unnecessary because it is not used anyhow. @@ -152,9 +151,9 @@ restoreCurrentCostCentre (Just local_cc) profDynAlloc :: SMRep -> CmmExpr -> FCode () profDynAlloc rep ccs = ifProfiling $ - do dflags <- getDynFlags - platform <- getPlatform - profAlloc (mkIntExpr platform (heapClosureSizeW dflags rep)) ccs + do profile <- targetProfile <$> getDynFlags + let platform = profilePlatform profile + profAlloc (mkIntExpr platform (heapClosureSizeW profile rep)) ccs -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts @@ -162,16 +161,16 @@ profDynAlloc rep ccs profAlloc :: CmmExpr -> CmmExpr -> FCode () profAlloc words ccs = ifProfiling $ - do dflags <- getDynFlags - platform <- getPlatform - let alloc_rep = rEP_CostCentreStack_mem_alloc dflags - emit (addToMemE alloc_rep - (cmmOffsetB platform ccs (oFFSET_CostCentreStack_mem_alloc dflags)) + do profile <- targetProfile <$> getDynFlags + let platform = profilePlatform profile + let alloc_rep = rEP_CostCentreStack_mem_alloc platform + emit $ addToMemE alloc_rep + (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_mem_alloc (platformConstants platform))) (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) $ - [CmmMachOp (mo_wordSub platform) [words, - mkIntExpr platform (profHdrSize dflags)]])) - -- subtract the "profiling overhead", which is the - -- profiling header in a closure. + -- subtract the "profiling overhead", which is the + -- profiling header in a closure. + [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (profHdrSize profile)]] + ) -- ----------------------------------------------------------------------- -- Setting the current cost centre on entry to a closure @@ -179,23 +178,23 @@ profAlloc words ccs enterCostCentreThunk :: CmmExpr -> FCode () enterCostCentreThunk closure = ifProfiling $ do - dflags <- getDynFlags - emit $ storeCurCCS (costCentreFrom dflags closure) + platform <- getPlatform + emit $ storeCurCCS (costCentreFrom platform closure) enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () enterCostCentreFun ccs closure = ifProfiling $ do if isCurrentCCS ccs - then do dflags <- getDynFlags + then do platform <- getPlatform emitRtsCall rtsUnitId (fsLit "enterFunCCS") [(baseExpr, AddrHint), - (costCentreFrom dflags closure, AddrHint)] False + (costCentreFrom platform closure, AddrHint)] False else return () -- top-level function, nothing to do ifProfiling :: FCode () -> FCode () ifProfiling code - = do dflags <- getDynFlags - if sccProfilingEnabled dflags + = do profile <- targetProfile <$> getDynFlags + if profileIsProfiling profile then code else return () @@ -206,10 +205,9 @@ ifProfiling code initCostCentres :: CollectedCCs -> FCode () -- Emit the declarations initCostCentres (local_CCs, singleton_CCSs) - = do dflags <- getDynFlags - when (sccProfilingEnabled dflags) $ - do mapM_ emitCostCentreDecl local_CCs - mapM_ emitCostCentreStackDecl singleton_CCSs + = ifProfiling $ do + mapM_ emitCostCentreDecl local_CCs + mapM_ emitCostCentreStackDecl singleton_CCSs emitCostCentreDecl :: CostCentre -> FCode () @@ -243,11 +241,10 @@ emitCostCentreStackDecl :: CostCentreStack -> FCode () emitCostCentreStackDecl ccs = case maybeSingletonCCS ccs of Just cc -> - do dflags <- getDynFlags - platform <- getPlatform + do platform <- getPlatform let mk_lits cc = zero platform : mkCCostCentre cc : - replicate (sizeof_ccs_words dflags - 2) (zero platform) + replicate (sizeof_ccs_words platform - 2) (zero platform) -- Note: to avoid making any assumptions about how the -- C compiler (that compiles the RTS, in particular) does -- layouts of structs containing long-longs, simply @@ -261,27 +258,26 @@ zero platform = mkIntCLit platform 0 zero64 :: CmmLit zero64 = CmmInt 0 W64 -sizeof_ccs_words :: DynFlags -> Int -sizeof_ccs_words dflags +sizeof_ccs_words :: Platform -> Int +sizeof_ccs_words platform -- round up to the next word. | ms == 0 = ws | otherwise = ws + 1 where - platform = targetPlatform dflags - (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` platformWordSizeInBytes platform + (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform -- --------------------------------------------------------------------------- -- Set the current cost centre stack emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () emitSetCCC cc tick push - = do dflags <- getDynFlags - platform <- getPlatform - if not (sccProfilingEnabled dflags) + = do profile <- targetProfile <$> getDynFlags + let platform = profilePlatform profile + if not (profileIsProfiling profile) then return () else do tmp <- newTemp (ccsType platform) pushCostCentre tmp cccsExpr cc - when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp))) + when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp))) when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () @@ -292,11 +288,10 @@ pushCostCentre result ccs cc (CmmLit (mkCCostCentre cc), AddrHint)] False -bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph -bumpSccCount dflags ccs - = addToMem (rEP_CostCentreStack_scc_count dflags) - (cmmOffsetB platform ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 - where platform = targetPlatform dflags +bumpSccCount :: Platform -> CmmExpr -> CmmAGraph +bumpSccCount platform ccs + = addToMem (rEP_CostCentreStack_scc_count platform) + (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_scc_count (platformConstants platform))) 1 ----------------------------------------------------------------------------- -- @@ -313,22 +308,20 @@ staticLdvInit = zeroCLit -- -- Initial value of the LDV field in a dynamic closure -- -dynLdvInit :: DynFlags -> CmmExpr -dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE +dynLdvInit :: Platform -> CmmExpr +dynLdvInit platform = -- (era << LDV_SHIFT) | LDV_STATE_CREATE CmmMachOp (mo_wordOr platform) [ - CmmMachOp (mo_wordShl platform) [loadEra dflags, mkIntExpr platform (lDV_SHIFT dflags)], - CmmLit (mkWordCLit platform (iLDV_STATE_CREATE dflags)) + CmmMachOp (mo_wordShl platform) [loadEra platform, mkIntExpr platform (pc_LDV_SHIFT (platformConstants platform))], + CmmLit (mkWordCLit platform (pc_ILDV_STATE_CREATE (platformConstants platform))) ] - where - platform = targetPlatform dflags -- -- Initialise the LDV word of a new closure -- ldvRecordCreate :: CmmExpr -> FCode () ldvRecordCreate closure = do - dflags <- getDynFlags - emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags) + platform <- getPlatform + emit $ mkStore (ldvWord platform closure) (dynLdvInit platform) -- -- | Called when a closure is entered, marks the closure as having @@ -337,40 +330,37 @@ ldvRecordCreate closure = do -- ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode () ldvEnterClosure closure_info node_reg = do - dflags <- getDynFlags platform <- getPlatform - let tag = funTag dflags closure_info + let tag = funTag platform closure_info -- don't forget to subtract node's tag ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-tag)) ldvEnter :: CmmExpr -> FCode () -- Argument is a closure pointer ldvEnter cl_ptr = do - dflags <- getDynFlags platform <- getPlatform - let -- don't forget to subtract node's tag - ldv_wd = ldvWord dflags cl_ptr + let constants = platformConstants platform + -- don't forget to subtract node's tag + ldv_wd = ldvWord platform cl_ptr new_ldv_wd = cmmOrWord platform (cmmAndWord platform (CmmLoad ldv_wd (bWord platform)) - (CmmLit (mkWordCLit platform (iLDV_CREATE_MASK dflags)))) - (cmmOrWord platform (loadEra dflags) (CmmLit (mkWordCLit platform (iLDV_STATE_USE dflags)))) + (CmmLit (mkWordCLit platform (pc_ILDV_CREATE_MASK constants)))) + (cmmOrWord platform (loadEra platform) (CmmLit (mkWordCLit platform (pc_ILDV_STATE_USE constants)))) ifProfiling $ -- if (era > 0) { -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | -- era | LDV_STATE_USE } - emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra dflags, CmmLit (zeroCLit platform)]) + emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra platform, CmmLit (zeroCLit platform)]) (mkStore ldv_wd new_ldv_wd) mkNop -loadEra :: DynFlags -> CmmExpr -loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth platform)) +loadEra :: Platform -> CmmExpr +loadEra platform = CmmMachOp (MO_UU_Conv (cIntWidth platform) (wordWidth platform)) [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era"))) - (cInt dflags)] - where platform = targetPlatform dflags + (cInt platform)] -ldvWord :: DynFlags -> CmmExpr -> CmmExpr --- Takes the address of a closure, and returns +-- | Takes the address of a closure, and returns -- the address of the LDV word in the closure -ldvWord dflags closure_ptr - = cmmOffsetB platform closure_ptr (oFFSET_StgHeader_ldvw dflags) - where platform = targetPlatform dflags +ldvWord :: Platform -> CmmExpr -> CmmExpr +ldvWord platform closure_ptr + = cmmOffsetB platform closure_ptr (pc_OFFSET_StgHeader_ldvw (platformConstants platform)) diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs index cf412c6384..733af2db96 100644 --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -103,6 +103,8 @@ module GHC.StgToCmm.Ticky ( import GHC.Prelude import GHC.Platform +import GHC.Platform.Profile + import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString ) import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils @@ -340,20 +342,20 @@ registerTickyCtr :: CLabel -> FCode () -- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */ -- f_ct.registeredp = 1 } registerTickyCtr ctr_lbl = do - dflags <- getDynFlags platform <- getPlatform let + constants = platformConstants platform -- krc: code generator doesn't handle Not, so we test for Eq 0 instead test = CmmMachOp (MO_Eq (wordWidth platform)) [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl - (oFFSET_StgEntCounter_registeredp dflags))) (bWord platform), + (pc_OFFSET_StgEntCounter_registeredp constants))) (bWord platform), zeroExpr platform] register_stmts - = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags))) + = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_link constants))) (CmmLoad ticky_entry_ctrs (bWord platform)) , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl) , mkStore (CmmLit (cmmLabelOffB ctr_lbl - (oFFSET_StgEntCounter_registeredp dflags))) + (pc_OFFSET_StgEntCounter_registeredp constants))) (mkIntExpr platform 1) ] ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs")) emit =<< mkCmmIfThen test (catAGraphs register_stmts) @@ -440,9 +442,9 @@ tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode () -- -- TODO what else to count while we're here? tickyDynAlloc mb_id rep lf = ifTicky $ do - dflags <- getDynFlags - let platform = targetPlatform dflags - bytes = platformWordSizeInBytes platform * heapClosureSizeW dflags rep + profile <- getProfile + let platform = profilePlatform profile + bytes = platformWordSizeInBytes platform * heapClosureSizeW profile rep countGlobal tot ctr = do bumpTickyCounterBy tot bytes @@ -482,8 +484,7 @@ tickyAllocHeap :: -- Must be lazy in the amount of allocation! tickyAllocHeap genuine hp = ifTicky $ - do { dflags <- getDynFlags - ; platform <- getPlatform + do { platform <- getPlatform ; ticky_ctr <- getTickyCtrLabel ; emit $ catAGraphs $ -- only test hp from within the emit so that the monadic @@ -492,8 +493,8 @@ tickyAllocHeap genuine hp if hp == 0 then [] else let !bytes = platformWordSizeInBytes platform * hp in [ -- Bump the allocation total in the closure's StgEntCounter - addToMem (rEP_StgEntCounter_allocs dflags) - (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags))) + addToMem (rEP_StgEntCounter_allocs platform) + (CmmLit (cmmLabelOffB ticky_ctr (pc_OFFSET_StgEntCounter_allocs (platformConstants platform)))) bytes, -- Bump the global allocation total ALLOC_HEAP_tot addToMemLbl (bWord platform) @@ -576,13 +577,13 @@ bumpTickyCounterByE lbl = bumpTickyLblByE (mkRtsCmmDataLabel lbl) bumpTickyEntryCount :: CLabel -> FCode () bumpTickyEntryCount lbl = do - dflags <- getDynFlags - bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags)) + platform <- getPlatform + bumpTickyLit (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) bumpTickyAllocd :: CLabel -> Int -> FCode () bumpTickyAllocd lbl bytes = do - dflags <- getDynFlags - bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes + platform <- getPlatform + bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_allocd (platformConstants platform))) bytes bumpTickyLbl :: CLabel -> FCode () bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1 @@ -608,9 +609,8 @@ bumpTickyLitByE lhs e = do bumpHistogram :: FastString -> Int -> FCode () bumpHistogram lbl n = do - dflags <- getDynFlags platform <- getPlatform - let offset = n `min` (tICKY_BIN_COUNT dflags - 1) + let offset = n `min` (pc_TICKY_BIN_COUNT (platformConstants platform) - 1) emit (addToMem (bWord platform) (cmmIndexExpr platform (wordWidth platform) diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 27c79a8e62..8531ca2283 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -197,9 +197,9 @@ emitRtsCallGen -> Bool -- True <=> CmmSafe call -> FCode () emitRtsCallGen res lbl args safe - = do { dflags <- getDynFlags + = do { platform <- targetPlatform <$> getDynFlags ; updfr_off <- getUpdFrameOff - ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags + ; let (caller_save, caller_load) = callerSaveVolatileRegs platform ; emit caller_save ; call updfr_off ; emit caller_load } @@ -245,13 +245,11 @@ emitRtsCallGen res lbl args safe -- "GHC.Cmm.Node". Right now the workaround is to avoid inlining across -- unsafe foreign calls in rewriteAssignments, but this is strictly -- temporary. -callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph) -callerSaveVolatileRegs dflags = (caller_save, caller_load) +callerSaveVolatileRegs :: Platform -> (CmmAGraph, CmmAGraph) +callerSaveVolatileRegs platform = (caller_save, caller_load) where - platform = targetPlatform dflags - - caller_save = catAGraphs (map (callerSaveGlobalReg dflags) regs_to_save) - caller_load = catAGraphs (map (callerRestoreGlobalReg dflags) regs_to_save) + caller_save = catAGraphs (map (callerSaveGlobalReg platform) regs_to_save) + caller_load = catAGraphs (map (callerRestoreGlobalReg platform) regs_to_save) system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery {- ,SparkHd,SparkTl,SparkBase,SparkLim -} @@ -259,14 +257,14 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load) regs_to_save = filter (callerSaves platform) system_regs -callerSaveGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph -callerSaveGlobalReg dflags reg - = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg)) +callerSaveGlobalReg :: Platform -> GlobalReg -> CmmAGraph +callerSaveGlobalReg platform reg + = mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal reg)) -callerRestoreGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph -callerRestoreGlobalReg dflags reg +callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph +callerRestoreGlobalReg platform reg = mkAssign (CmmGlobal reg) - (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType (targetPlatform dflags) reg)) + (CmmLoad (get_GlobalReg_addr platform reg) (globalRegType platform reg)) ------------------------------------------------------------------------- |