summaryrefslogtreecommitdiff
path: root/compiler/GHC/StgToCmm
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2020-07-07 18:48:31 +0200
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-07-25 00:45:08 -0400
commit9dfeca6c2019fdb46613a68ccd6e650e40c7baac (patch)
tree29a2cda3faddedc7024be259011f4406b6473f45 /compiler/GHC/StgToCmm
parent6333d7391068d8029eed3e8eff019b9e2c104c7b (diff)
downloadhaskell-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.hs126
-rw-r--r--compiler/GHC/StgToCmm/CgUtils.hs177
-rw-r--r--compiler/GHC/StgToCmm/Closure.hs141
-rw-r--r--compiler/GHC/StgToCmm/DataCon.hs53
-rw-r--r--compiler/GHC/StgToCmm/Env.hs18
-rw-r--r--compiler/GHC/StgToCmm/Expr.hs45
-rw-r--r--compiler/GHC/StgToCmm/ExtCode.hs19
-rw-r--r--compiler/GHC/StgToCmm/Foreign.hs192
-rw-r--r--compiler/GHC/StgToCmm/Heap.hs58
-rw-r--r--compiler/GHC/StgToCmm/Layout.hs57
-rw-r--r--compiler/GHC/StgToCmm/Monad.hs44
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs205
-rw-r--r--compiler/GHC/StgToCmm/Prof.hs144
-rw-r--r--compiler/GHC/StgToCmm/Ticky.hs34
-rw-r--r--compiler/GHC/StgToCmm/Utils.hs26
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))
-------------------------------------------------------------------------
View Lorry Controller Status