summaryrefslogtreecommitdiff
path: root/compiler/GHC/Cmm
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/Cmm
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/Cmm')
-rw-r--r--compiler/GHC/Cmm/CLabel.hs24
-rw-r--r--compiler/GHC/Cmm/CallConv.hs136
-rw-r--r--compiler/GHC/Cmm/Graph.hs85
-rw-r--r--compiler/GHC/Cmm/Info.hs178
-rw-r--r--compiler/GHC/Cmm/Info/Build.hs44
-rw-r--r--compiler/GHC/Cmm/LayoutStack.hs21
-rw-r--r--compiler/GHC/Cmm/Monad.hs22
-rw-r--r--compiler/GHC/Cmm/Parser.y145
-rw-r--r--compiler/GHC/Cmm/Type.hs33
-rw-r--r--compiler/GHC/Cmm/Utils.hs26
10 files changed, 375 insertions, 339 deletions
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index ab1ecede5f..425b1b862d 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -599,24 +599,24 @@ mkLocalBlockLabel u = LocalBlockLabel u
mkRtsPrimOpLabel :: PrimOp -> CLabel
mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop)
-mkSelectorInfoLabel :: DynFlags -> Bool -> Int -> CLabel
-mkSelectorInfoLabel dflags upd offset =
- ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)
+mkSelectorInfoLabel :: Platform -> Bool -> Int -> CLabel
+mkSelectorInfoLabel platform upd offset =
+ ASSERT(offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform))
RtsLabel (RtsSelectorInfoTable upd offset)
-mkSelectorEntryLabel :: DynFlags -> Bool -> Int -> CLabel
-mkSelectorEntryLabel dflags upd offset =
- ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)
+mkSelectorEntryLabel :: Platform -> Bool -> Int -> CLabel
+mkSelectorEntryLabel platform upd offset =
+ ASSERT(offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform))
RtsLabel (RtsSelectorEntry upd offset)
-mkApInfoTableLabel :: DynFlags -> Bool -> Int -> CLabel
-mkApInfoTableLabel dflags upd arity =
- ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)
+mkApInfoTableLabel :: Platform -> Bool -> Int -> CLabel
+mkApInfoTableLabel platform upd arity =
+ ASSERT(arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform))
RtsLabel (RtsApInfoTable upd arity)
-mkApEntryLabel :: DynFlags -> Bool -> Int -> CLabel
-mkApEntryLabel dflags upd arity =
- ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)
+mkApEntryLabel :: Platform -> Bool -> Int -> CLabel
+mkApEntryLabel platform upd arity =
+ ASSERT(arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform))
RtsLabel (RtsApEntry upd arity)
diff --git a/compiler/GHC/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs
index b1133896a7..09d1d26924 100644
--- a/compiler/GHC/Cmm/CallConv.hs
+++ b/compiler/GHC/Cmm/CallConv.hs
@@ -14,6 +14,7 @@ import GHC.Cmm.Ppr () -- For Outputable instances
import GHC.Driver.Session
import GHC.Platform
+import GHC.Platform.Profile
import GHC.Utils.Outputable
-- Calculate the 'GlobalReg' or stack locations for function call
@@ -31,7 +32,7 @@ instance Outputable ParamLocation where
-- Given a list of arguments, and a function that tells their types,
-- return a list showing where each argument is passed
--
-assignArgumentsPos :: DynFlags
+assignArgumentsPos :: Profile
-> ByteOff -- stack offset to start with
-> Convention
-> (a -> CmmType) -- how to get a type from an arg
@@ -41,16 +42,16 @@ assignArgumentsPos :: DynFlags
, [(a, ParamLocation)] -- args and locations
)
-assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
+assignArgumentsPos profile off conv arg_ty reps = (stk_off, assignments)
where
- platform = targetPlatform dflags
+ platform = profilePlatform profile
regs = case (reps, conv) of
- (_, NativeNodeCall) -> getRegsWithNode dflags
- (_, NativeDirectCall) -> getRegsWithoutNode dflags
- ([_], NativeReturn) -> allRegs dflags
- (_, NativeReturn) -> getRegsWithNode dflags
+ (_, NativeNodeCall) -> getRegsWithNode platform
+ (_, NativeDirectCall) -> getRegsWithoutNode platform
+ ([_], NativeReturn) -> allRegs platform
+ (_, NativeReturn) -> getRegsWithNode platform
-- GC calling convention *must* put values in registers
- (_, GC) -> allRegs dflags
+ (_, GC) -> allRegs platform
(_, Slow) -> nodeOnly
-- The calling conventions first assign arguments to registers,
-- then switch to the stack when we first run out of registers
@@ -67,11 +68,11 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
| otherwise = int
where vec = case (w, regs) of
(W128, (vs, fs, ds, ls, s:ss))
- | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))
+ | passVectorInReg W128 profile -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))
(W256, (vs, fs, ds, ls, s:ss))
- | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))
+ | passVectorInReg W256 profile -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))
(W512, (vs, fs, ds, ls, s:ss))
- | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))
+ | passVectorInReg W512 profile -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))
_ -> (assts, (r:rs))
float = case (w, regs) of
(W32, (vs, fs, ds, ls, s:ss))
@@ -107,7 +108,7 @@ passFloatArgsInXmm platform = case platformArch platform of
-- support vector registers in its calling convention. However, this has now
-- been fixed. This function remains only as a convenient way to re-enable
-- spilling when debugging code generation.
-passVectorInReg :: Width -> DynFlags -> Bool
+passVectorInReg :: Width -> Profile -> Bool
passVectorInReg _ _ = True
assignStack :: Platform -> ByteOff -> (a -> CmmType) -> [a]
@@ -142,56 +143,57 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
-- We take these register supplies from the *real* registers, i.e. those
-- that are guaranteed to map to machine registers.
-getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
-getRegsWithoutNode dflags =
- ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)
- , realFloatRegs dflags
- , realDoubleRegs dflags
- , realLongRegs dflags
- , realXmmRegNos dflags)
+getRegsWithoutNode, getRegsWithNode :: Platform -> AvailRegs
+getRegsWithoutNode platform =
+ ( filter (\r -> r VGcPtr /= node) (realVanillaRegs platform)
+ , realFloatRegs platform
+ , realDoubleRegs platform
+ , realLongRegs platform
+ , realXmmRegNos platform)
-- getRegsWithNode uses R1/node even if it isn't a register
-getRegsWithNode dflags =
- ( if null (realVanillaRegs dflags)
+getRegsWithNode platform =
+ ( if null (realVanillaRegs platform)
then [VanillaReg 1]
- else realVanillaRegs dflags
- , realFloatRegs dflags
- , realDoubleRegs dflags
- , realLongRegs dflags
- , realXmmRegNos dflags)
-
-allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]
-allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
-allXmmRegs :: DynFlags -> [Int]
-
-allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)
-allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags)
-allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags)
-allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags)
-allXmmRegs dflags = regList (mAX_XMM_REG dflags)
-
-realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]
-realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
-realXmmRegNos :: DynFlags -> [Int]
-
-realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)
-realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags)
-realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags)
-realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags)
-
-realXmmRegNos dflags
- | isSse2Enabled dflags = regList (mAX_Real_XMM_REG dflags)
- | otherwise = []
+ else realVanillaRegs platform
+ , realFloatRegs platform
+ , realDoubleRegs platform
+ , realLongRegs platform
+ , realXmmRegNos platform)
+
+allFloatRegs, allDoubleRegs, allLongRegs :: Platform -> [GlobalReg]
+allVanillaRegs :: Platform -> [VGcPtr -> GlobalReg]
+allXmmRegs :: Platform -> [Int]
+
+allVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Vanilla_REG (platformConstants platform))
+allFloatRegs platform = map FloatReg $ regList (pc_MAX_Float_REG (platformConstants platform))
+allDoubleRegs platform = map DoubleReg $ regList (pc_MAX_Double_REG (platformConstants platform))
+allLongRegs platform = map LongReg $ regList (pc_MAX_Long_REG (platformConstants platform))
+allXmmRegs platform = regList (pc_MAX_XMM_REG (platformConstants platform))
+
+realFloatRegs, realDoubleRegs, realLongRegs :: Platform -> [GlobalReg]
+realVanillaRegs :: Platform -> [VGcPtr -> GlobalReg]
+
+realVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Real_Vanilla_REG (platformConstants platform))
+realFloatRegs platform = map FloatReg $ regList (pc_MAX_Real_Float_REG (platformConstants platform))
+realDoubleRegs platform = map DoubleReg $ regList (pc_MAX_Real_Double_REG (platformConstants platform))
+realLongRegs platform = map LongReg $ regList (pc_MAX_Real_Long_REG (platformConstants platform))
+
+realXmmRegNos :: Platform -> [Int]
+realXmmRegNos platform
+ | isSse2Enabled platform = regList (pc_MAX_Real_XMM_REG (platformConstants platform))
+ | otherwise = []
regList :: Int -> [Int]
regList n = [1 .. n]
-allRegs :: DynFlags -> AvailRegs
-allRegs dflags = (allVanillaRegs dflags,
- allFloatRegs dflags,
- allDoubleRegs dflags,
- allLongRegs dflags,
- allXmmRegs dflags)
+allRegs :: Platform -> AvailRegs
+allRegs platform = ( allVanillaRegs platform
+ , allFloatRegs platform
+ , allDoubleRegs platform
+ , allLongRegs platform
+ , allXmmRegs platform
+ )
nodeOnly :: AvailRegs
nodeOnly = ([VanillaReg 1], [], [], [], [])
@@ -201,18 +203,18 @@ nodeOnly = ([VanillaReg 1], [], [], [], [])
-- now just x86-64, where Float and Double registers overlap---passing this set
-- of registers is guaranteed to preserve the contents of all live registers. We
-- only use this functionality in hand-written C-- code in the RTS.
-realArgRegsCover :: DynFlags -> [GlobalReg]
-realArgRegsCover dflags
- | passFloatArgsInXmm (targetPlatform dflags)
- = map ($VGcPtr) (realVanillaRegs dflags) ++
- realLongRegs dflags ++
- realDoubleRegs dflags -- we only need to save the low Double part of XMM registers.
- -- Moreover, the NCG can't load/store full XMM
- -- registers for now...
+realArgRegsCover :: Platform -> [GlobalReg]
+realArgRegsCover platform
+ | passFloatArgsInXmm platform
+ = map ($VGcPtr) (realVanillaRegs platform) ++
+ realLongRegs platform ++
+ realDoubleRegs platform -- we only need to save the low Double part of XMM registers.
+ -- Moreover, the NCG can't load/store full XMM
+ -- registers for now...
| otherwise
- = map ($VGcPtr) (realVanillaRegs dflags) ++
- realFloatRegs dflags ++
- realDoubleRegs dflags ++
- realLongRegs dflags
+ = map ($VGcPtr) (realVanillaRegs platform) ++
+ realFloatRegs platform ++
+ realDoubleRegs platform ++
+ realLongRegs platform
-- we don't save XMM registers if they are not used for parameter passing
diff --git a/compiler/GHC/Cmm/Graph.hs b/compiler/GHC/Cmm/Graph.hs
index edf51d8b7f..be7eafb162 100644
--- a/compiler/GHC/Cmm/Graph.hs
+++ b/compiler/GHC/Cmm/Graph.hs
@@ -23,6 +23,8 @@ where
import GHC.Prelude hiding ( (<*>) ) -- avoid importing (<*>)
+import GHC.Platform.Profile
+
import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.CallConv
@@ -31,7 +33,6 @@ import GHC.Cmm.Switch (SwitchTargets)
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
-import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Types.ForeignCall
import GHC.Data.OrdList
@@ -196,28 +197,28 @@ mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore l r = mkMiddle $ CmmStore l r
---------- Control transfer
-mkJump :: DynFlags -> Convention -> CmmExpr
+mkJump :: Profile -> Convention -> CmmExpr
-> [CmmExpr]
-> UpdFrameOffset
-> CmmAGraph
-mkJump dflags conv e actuals updfr_off =
- lastWithArgs dflags Jump Old conv actuals updfr_off $
+mkJump profile conv e actuals updfr_off =
+ lastWithArgs profile Jump Old conv actuals updfr_off $
toCall e Nothing updfr_off 0
-- | A jump where the caller says what the live GlobalRegs are. Used
-- for low-level hand-written Cmm.
-mkRawJump :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg]
+mkRawJump :: Profile -> CmmExpr -> UpdFrameOffset -> [GlobalReg]
-> CmmAGraph
-mkRawJump dflags e updfr_off vols =
- lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $
+mkRawJump profile e updfr_off vols =
+ lastWithArgs profile Jump Old NativeNodeCall [] updfr_off $
\arg_space _ -> toCall e Nothing updfr_off 0 arg_space vols
-mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]
+mkJumpExtra :: Profile -> Convention -> CmmExpr -> [CmmExpr]
-> UpdFrameOffset -> [CmmExpr]
-> CmmAGraph
-mkJumpExtra dflags conv e actuals updfr_off extra_stack =
- lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
+mkJumpExtra profile conv e actuals updfr_off extra_stack =
+ lastWithArgsAndExtraStack profile Jump Old conv actuals updfr_off extra_stack $
toCall e Nothing updfr_off 0
mkCbranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
@@ -227,42 +228,42 @@ mkCbranch pred ifso ifnot likely =
mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph
mkSwitch e tbl = mkLast $ CmmSwitch e tbl
-mkReturn :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset
+mkReturn :: Profile -> CmmExpr -> [CmmExpr] -> UpdFrameOffset
-> CmmAGraph
-mkReturn dflags e actuals updfr_off =
- lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $
+mkReturn profile e actuals updfr_off =
+ lastWithArgs profile Ret Old NativeReturn actuals updfr_off $
toCall e Nothing updfr_off 0
mkBranch :: BlockId -> CmmAGraph
mkBranch bid = mkLast (CmmBranch bid)
-mkFinalCall :: DynFlags
+mkFinalCall :: Profile
-> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset
-> CmmAGraph
-mkFinalCall dflags f _ actuals updfr_off =
- lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
+mkFinalCall profile f _ actuals updfr_off =
+ lastWithArgs profile Call Old NativeDirectCall actuals updfr_off $
toCall f Nothing updfr_off 0
-mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
+mkCallReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]
-> BlockId
-> ByteOff
-> UpdFrameOffset
-> [CmmExpr]
-> CmmAGraph
-mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
- lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
+mkCallReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
+ lastWithArgsAndExtraStack profile Call (Young ret_lbl) callConv actuals
updfr_off extra_stack $
toCall f (Just ret_lbl) updfr_off ret_off
-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
-- already on the stack).
-mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
+mkJumpReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]
-> BlockId
-> ByteOff
-> UpdFrameOffset
-> CmmAGraph
-mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off = do
- lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $
+mkJumpReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off = do
+ lastWithArgs profile JumpRet (Young ret_lbl) callConv actuals updfr_off $
toCall f (Just ret_lbl) updfr_off ret_off
mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
@@ -292,25 +293,25 @@ stackStubExpr w = CmmLit (CmmInt 0 w)
-- variables in their spill slots. Therefore, for copying arguments
-- and results, we provide different functions to pass the arguments
-- in an overflow area and to pass them in spill slots.
-copyInOflow :: DynFlags -> Convention -> Area
+copyInOflow :: Profile -> Convention -> Area
-> [CmmFormal]
-> [CmmFormal]
-> (Int, [GlobalReg], CmmAGraph)
-copyInOflow dflags conv area formals extra_stk
+copyInOflow profile conv area formals extra_stk
= (offset, gregs, catAGraphs $ map mkMiddle nodes)
- where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk
+ where (offset, gregs, nodes) = copyIn profile conv area formals extra_stk
-- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments.
-copyIn :: DynFlags -> Convention -> Area
+copyIn :: Profile -> Convention -> Area
-> [CmmFormal]
-> [CmmFormal]
-> (ByteOff, [GlobalReg], [CmmNode O O])
-copyIn dflags conv area formals extra_stk
+copyIn profile conv area formals extra_stk
= (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
where
- platform = targetPlatform dflags
+ platform = profilePlatform profile
-- See Note [Width of parameters]
ci (reg, RegisterParam r@(VanillaReg {})) =
let local = CmmLocal reg
@@ -346,7 +347,7 @@ copyIn dflags conv area formals extra_stk
(stk_off, stk_args) = assignStack platform init_offset localRegType extra_stk
- (stk_size, args) = assignArgumentsPos dflags stk_off conv
+ (stk_size, args) = assignArgumentsPos profile stk_off conv
localRegType formals
-- Factoring out the common parts of the copyout functions yielded something
@@ -354,7 +355,7 @@ copyIn dflags conv area formals extra_stk
data Transfer = Call | JumpRet | Jump | Ret deriving Eq
-copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]
+copyOutOflow :: Profile -> Convention -> Transfer -> Area -> [CmmExpr]
-> UpdFrameOffset
-> [CmmExpr] -- extra stack args
-> (Int, [GlobalReg], CmmAGraph)
@@ -368,10 +369,10 @@ copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]
-- the info table for return and adjust the offsets of the other
-- parameters. If this is a call instruction, we adjust the offsets
-- of the other parameters.
-copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
+copyOutOflow profile conv transfer area actuals updfr_off extra_stack_stuff
= (stk_size, regs, graph)
where
- platform = targetPlatform dflags
+ platform = profilePlatform profile
(regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
-- See Note [Width of parameters]
@@ -419,7 +420,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
assignStack platform init_offset (cmmExprType platform) extra_stack_stuff
args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
- (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv
+ (stk_size, args) = assignArgumentsPos profile extra_stack_off conv
(cmmExprType platform) actuals
@@ -450,29 +451,29 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
-- https://github.com/ghc-proposals/ghc-proposals/pull/74
-mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
+mkCallEntry :: Profile -> Convention -> [CmmFormal] -> [CmmFormal]
-> (Int, [GlobalReg], CmmAGraph)
-mkCallEntry dflags conv formals extra_stk
- = copyInOflow dflags conv Old formals extra_stk
+mkCallEntry profile conv formals extra_stk
+ = copyInOflow profile conv Old formals extra_stk
-lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr]
+lastWithArgs :: Profile -> Transfer -> Area -> Convention -> [CmmExpr]
-> UpdFrameOffset
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
-lastWithArgs dflags transfer area conv actuals updfr_off last =
- lastWithArgsAndExtraStack dflags transfer area conv actuals
+lastWithArgs profile transfer area conv actuals updfr_off last =
+ lastWithArgsAndExtraStack profile transfer area conv actuals
updfr_off noExtraStack last
-lastWithArgsAndExtraStack :: DynFlags
+lastWithArgsAndExtraStack :: Profile
-> Transfer -> Area -> Convention -> [CmmExpr]
-> UpdFrameOffset -> [CmmExpr]
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
-lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
+lastWithArgsAndExtraStack profile transfer area conv actuals updfr_off
extra_stack last =
copies <*> last outArgs regs
where
- (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
+ (outArgs, regs, copies) = copyOutOflow profile conv transfer area actuals
updfr_off extra_stack
diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs
index 1d26c7d5ee..c650a66581 100644
--- a/compiler/GHC/Cmm/Info.hs
+++ b/compiler/GHC/Cmm/Info.hs
@@ -5,6 +5,7 @@ module GHC.Cmm.Info (
srtEscape,
-- info table accessors
+ PtrOpts (..),
closureInfoPtr,
entryCode,
getConstrTag,
@@ -45,6 +46,7 @@ import qualified GHC.Data.Stream as Stream
import GHC.Cmm.Dataflow.Collections
import GHC.Platform
+import GHC.Platform.Profile
import GHC.Data.Maybe
import GHC.Driver.Session
import GHC.Utils.Error (withTimingSilent)
@@ -367,7 +369,7 @@ mkLivenessBits dflags liveness
[b] -> b
_ -> panic "mkLiveness"
bitmap_word = toStgWord platform (fromIntegral n_bits)
- .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
+ .|. (small_bitmap `shiftL` pc_BITMAP_BITS_SHIFT (platformConstants platform))
lits = mkWordCLit platform (fromIntegral n_bits)
: map (mkStgWordCLit platform) bitmap
@@ -441,20 +443,25 @@ srtEscape platform = toStgHalfWord platform (-1)
--
-------------------------------------------------------------------------
+data PtrOpts = PtrOpts
+ { po_profile :: !Profile -- ^ Platform profile
+ , po_align_check :: !Bool -- ^ Insert alignment check (cf @-falignment-sanitisation@)
+ }
+
-- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is
-- enabled.
-wordAligned :: DynFlags -> CmmExpr -> CmmExpr
-wordAligned dflags e
- | gopt Opt_AlignmentSanitisation dflags
+wordAligned :: PtrOpts -> CmmExpr -> CmmExpr
+wordAligned opts e
+ | po_align_check opts
= CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e]
| otherwise
= e
- where platform = targetPlatform dflags
+ where platform = profilePlatform (po_profile opts)
-closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
--- Takes a closure pointer and returns the info table pointer
-closureInfoPtr dflags e =
- CmmLoad (wordAligned dflags e) (bWord (targetPlatform dflags))
+-- | Takes a closure pointer and returns the info table pointer
+closureInfoPtr :: PtrOpts -> CmmExpr -> CmmExpr
+closureInfoPtr opts e =
+ CmmLoad (wordAligned opts e) (bWord (profilePlatform (po_profile opts)))
-- | Takes an info pointer (the first word of a closure) and returns its entry
-- code
@@ -464,92 +471,93 @@ entryCode platform e =
then e
else CmmLoad e (bWord platform)
-getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
--- Takes a closure pointer, and return the *zero-indexed*
+-- | Takes a closure pointer, and return the *zero-indexed*
-- constructor tag obtained from the info table
-- This lives in the SRT field of the info table
-- (constructors don't need SRTs).
-getConstrTag dflags closure_ptr
- = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag dflags info_table]
+getConstrTag :: PtrOpts -> CmmExpr -> CmmExpr
+getConstrTag opts closure_ptr
+ = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag profile info_table]
where
- info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
- platform = targetPlatform dflags
+ info_table = infoTable profile (closureInfoPtr opts closure_ptr)
+ platform = profilePlatform profile
+ profile = po_profile opts
-cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
--- Takes a closure pointer, and return the closure type
+-- | Takes a closure pointer, and return the closure type
-- obtained from the info table
-cmmGetClosureType dflags closure_ptr
- = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType dflags info_table]
+cmmGetClosureType :: PtrOpts -> CmmExpr -> CmmExpr
+cmmGetClosureType opts closure_ptr
+ = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType profile info_table]
where
- info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
- platform = targetPlatform dflags
+ info_table = infoTable profile (closureInfoPtr opts closure_ptr)
+ platform = profilePlatform profile
+ profile = po_profile opts
-infoTable :: DynFlags -> CmmExpr -> CmmExpr
--- Takes an info pointer (the first word of a closure)
+-- | Takes an info pointer (the first word of a closure)
-- and returns a pointer to the first word of the standard-form
-- info table, excluding the entry-code word (if present)
-infoTable dflags info_ptr
- | platformTablesNextToCode platform = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags)
+infoTable :: Profile -> CmmExpr -> CmmExpr
+infoTable profile info_ptr
+ | platformTablesNextToCode platform = cmmOffsetB platform info_ptr (- stdInfoTableSizeB profile)
| otherwise = cmmOffsetW platform info_ptr 1 -- Past the entry code pointer
- where platform = targetPlatform dflags
+ where platform = profilePlatform profile
-infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
--- Takes an info table pointer (from infoTable) and returns the constr tag
+-- | Takes an info table pointer (from infoTable) and returns the constr tag
-- field of the info table (same as the srt_bitmap field)
+infoTableConstrTag :: Profile -> CmmExpr -> CmmExpr
infoTableConstrTag = infoTableSrtBitmap
-infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
--- Takes an info table pointer (from infoTable) and returns the srt_bitmap
+-- | Takes an info table pointer (from infoTable) and returns the srt_bitmap
-- field of the info table
-infoTableSrtBitmap dflags info_tbl
- = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord platform)
- where platform = targetPlatform dflags
+infoTableSrtBitmap :: Profile -> CmmExpr -> CmmExpr
+infoTableSrtBitmap profile info_tbl
+ = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset profile)) (bHalfWord platform)
+ where platform = profilePlatform profile
-infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
--- Takes an info table pointer (from infoTable) and returns the closure type
+-- | Takes an info table pointer (from infoTable) and returns the closure type
-- field of the info table.
-infoTableClosureType dflags info_tbl
- = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset dflags)) (bHalfWord platform)
- where platform = targetPlatform dflags
-
-infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
-infoTablePtrs dflags info_tbl
- = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset dflags)) (bHalfWord platform)
- where platform = targetPlatform dflags
-
-infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
-infoTableNonPtrs dflags info_tbl
- = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset dflags)) (bHalfWord platform)
- where platform = targetPlatform dflags
-
-funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
--- Takes the info pointer of a function,
--- and returns a pointer to the first word of the StgFunInfoExtra struct
--- in the info table.
-funInfoTable dflags info_ptr
+infoTableClosureType :: Profile -> CmmExpr -> CmmExpr
+infoTableClosureType profile info_tbl
+ = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset profile)) (bHalfWord platform)
+ where platform = profilePlatform profile
+
+infoTablePtrs :: Profile -> CmmExpr -> CmmExpr
+infoTablePtrs profile info_tbl
+ = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset profile)) (bHalfWord platform)
+ where platform = profilePlatform profile
+
+infoTableNonPtrs :: Profile -> CmmExpr -> CmmExpr
+infoTableNonPtrs profile info_tbl
+ = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset profile)) (bHalfWord platform)
+ where platform = profilePlatform profile
+
+-- | Takes the info pointer of a function, and returns a pointer to the first
+-- word of the StgFunInfoExtra struct in the info table.
+funInfoTable :: Profile -> CmmExpr -> CmmExpr
+funInfoTable profile info_ptr
| platformTablesNextToCode platform
- = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
+ = cmmOffsetB platform info_ptr (- stdInfoTableSizeB profile - pc_SIZEOF_StgFunInfoExtraRev (platformConstants platform))
| otherwise
- = cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW dflags)
+ = cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW profile)
-- Past the entry code pointer
where
- platform = targetPlatform dflags
+ platform = profilePlatform profile
--- Takes the info pointer of a function, returns the function's arity
-funInfoArity :: DynFlags -> CmmExpr -> CmmExpr
-funInfoArity dflags iptr
+-- | Takes the info pointer of a function, returns the function's arity
+funInfoArity :: Profile -> CmmExpr -> CmmExpr
+funInfoArity profile iptr
= cmmToWord platform (cmmLoadIndex platform rep fun_info (offset `div` rep_bytes))
where
- platform = targetPlatform dflags
- fun_info = funInfoTable dflags iptr
+ platform = profilePlatform profile
+ fun_info = funInfoTable profile iptr
rep = cmmBits (widthFromBytes rep_bytes)
tablesNextToCode = platformTablesNextToCode platform
(rep_bytes, offset)
| tablesNextToCode = ( pc_REP_StgFunInfoExtraRev_arity pc
- , oFFSET_StgFunInfoExtraRev_arity dflags )
+ , pc_OFFSET_StgFunInfoExtraRev_arity pc )
| otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc
- , oFFSET_StgFunInfoExtraFwd_arity dflags )
+ , pc_OFFSET_StgFunInfoExtraFwd_arity pc )
pc = platformConstants platform
@@ -559,13 +567,13 @@ funInfoArity dflags iptr
--
-----------------------------------------------------------------------------
-stdInfoTableSizeW :: DynFlags -> WordOff
+stdInfoTableSizeW :: Profile -> WordOff
-- The size of a standard info table varies with profiling/ticky etc,
-- so we can't get it from Constants
-- It must vary in sync with mkStdInfoTable
-stdInfoTableSizeW dflags
+stdInfoTableSizeW profile
= fixedInfoTableSizeW
- + if sccProfilingEnabled dflags
+ + if profileIsProfiling profile
then profInfoTableSizeW
else 0
@@ -586,28 +594,24 @@ maxRetInfoTableSizeW =
maxStdInfoTableSizeW
+ 1 {- srt label -}
-stdInfoTableSizeB :: DynFlags -> ByteOff
-stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * platformWordSizeInBytes platform
- where platform = targetPlatform dflags
+stdInfoTableSizeB :: Profile -> ByteOff
+stdInfoTableSizeB profile = stdInfoTableSizeW profile * profileWordSizeInBytes profile
-stdSrtBitmapOffset :: DynFlags -> ByteOff
--- Byte offset of the SRT bitmap half-word which is
--- in the *higher-addressed* part of the type_lit
-stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize platform
- where platform = targetPlatform dflags
+-- | Byte offset of the SRT bitmap half-word which is in the *higher-addressed*
+-- part of the type_lit
+stdSrtBitmapOffset :: Profile -> ByteOff
+stdSrtBitmapOffset profile = stdInfoTableSizeB profile - halfWordSize (profilePlatform profile)
-stdClosureTypeOffset :: DynFlags -> ByteOff
--- Byte offset of the closure type half-word
-stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - platformWordSizeInBytes platform
- where platform = targetPlatform dflags
+-- | Byte offset of the closure type half-word
+stdClosureTypeOffset :: Profile -> ByteOff
+stdClosureTypeOffset profile = stdInfoTableSizeB profile - profileWordSizeInBytes profile
-stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
-stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * platformWordSizeInBytes platform
- where platform = targetPlatform dflags
+stdPtrsOffset :: Profile -> ByteOff
+stdPtrsOffset profile = stdInfoTableSizeB profile - 2 * profileWordSizeInBytes profile
-stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * platformWordSizeInBytes platform + halfWordSize platform
- where platform = targetPlatform dflags
+stdNonPtrsOffset :: Profile -> ByteOff
+stdNonPtrsOffset profile = stdInfoTableSizeB profile - 2 * profileWordSizeInBytes profile
+ + halfWordSize (profilePlatform profile)
-conInfoTableSizeB :: DynFlags -> Int
-conInfoTableSizeB dflags = stdInfoTableSizeB dflags + platformWordSizeInBytes platform
- where platform = targetPlatform dflags
+conInfoTableSizeB :: Profile -> Int
+conInfoTableSizeB profile = stdInfoTableSizeB profile + profileWordSizeInBytes profile
diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs
index 92e2f671fb..54eb48efc6 100644
--- a/compiler/GHC/Cmm/Info/Build.hs
+++ b/compiler/GHC/Cmm/Info/Build.hs
@@ -10,6 +10,9 @@ module GHC.Cmm.Info.Build
import GHC.Prelude hiding (succ)
+import GHC.Platform
+import GHC.Platform.Profile
+
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Cmm.BlockId
@@ -19,7 +22,6 @@ import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow
import GHC.Unit.Module
-import GHC.Platform
import GHC.Data.Graph.Directed
import GHC.Cmm.CLabel
import GHC.Cmm
@@ -32,7 +34,6 @@ import GHC.Types.Unique.Supply
import GHC.Types.CostCentre
import GHC.StgToCmm.Heap
import GHC.CmmToAsm.Monad
-import GHC.CmmToAsm.Config
import Control.Monad
import Data.Map.Strict (Map)
@@ -765,6 +766,8 @@ doSRTs
doSRTs dflags moduleSRTInfo procs data_ = do
us <- mkSplitUniqSupply 'u'
+ let profile = targetProfile dflags
+
-- Ignore the original grouping of decls, and combine all the
-- CAFEnvs into a single CAFEnv.
let static_data_env :: Map CLabel CAFSet
@@ -834,7 +837,7 @@ doSRTs dflags moduleSRTInfo procs data_ = do
funSRTMap = mapFromList (concat funSRTs)
has_caf_refs' = or has_caf_refs
decls' =
- concatMap (updInfoSRTs dflags srtFieldMap funSRTMap has_caf_refs') decls
+ concatMap (updInfoSRTs profile srtFieldMap funSRTMap has_caf_refs') decls
-- Finally update CafInfos for raw static literals (CmmStaticsRaw). Those are
-- not analysed in oneSRT so we never add entries for them to the SRTMap.
@@ -929,6 +932,7 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
let
config = initConfig dflags
+ profile = targetProfile dflags
srtMap = moduleSRTMap topSRT
blockids = getBlockLabels lbls
@@ -1032,7 +1036,7 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
-- MachO relocations can't express offsets between compilation units at
-- all, so we are always forced to build a singleton SRT in this case.
- && (not (osMachOTarget $ platformOS $ ncgPlatform config)
+ && (not (osMachOTarget $ platformOS $ profilePlatform profile)
|| isLocalCLabel this_mod lbl) -> do
-- If we have a static function closure, then it becomes the
@@ -1070,7 +1074,7 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
Just (fun,block) ->
return ( [], [(block, cafList)], SRTEntry fun )
Nothing -> do
- (decls, entry) <- lift $ buildSRTChain dflags cafList
+ (decls, entry) <- lift $ buildSRTChain profile cafList
return (decls, [], entry)
updateSRTMap (Just srtEntry)
let allBelowThis = Set.union allBelow filtered
@@ -1089,38 +1093,38 @@ oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
return (decls, map (,lbl) blockids, funSRTs, True)
--- | build a static SRT object (or a chain of objects) from a list of
+-- | Build a static SRT object (or a chain of objects) from a list of
-- SRTEntries.
buildSRTChain
- :: DynFlags
+ :: Profile
-> [SRTEntry]
-> UniqSM
( [CmmDeclSRTs] -- The SRT object(s)
, SRTEntry -- label to use in the info table
)
buildSRTChain _ [] = panic "buildSRT: empty"
-buildSRTChain dflags cafSet =
+buildSRTChain profile cafSet =
case splitAt mAX_SRT_SIZE cafSet of
(these, []) -> do
- (decl,lbl) <- buildSRT dflags these
+ (decl,lbl) <- buildSRT profile these
return ([decl], lbl)
(these,those) -> do
- (rest, rest_lbl) <- buildSRTChain dflags (head these : those)
- (decl,lbl) <- buildSRT dflags (rest_lbl : tail these)
+ (rest, rest_lbl) <- buildSRTChain profile (head these : those)
+ (decl,lbl) <- buildSRT profile (rest_lbl : tail these)
return (decl:rest, lbl)
where
mAX_SRT_SIZE = 16
-buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)
-buildSRT dflags refs = do
+buildSRT :: Profile -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)
+buildSRT profile refs = do
id <- getUniqueM
let
lbl = mkSRTLabel id
- platform = targetPlatform dflags
+ platform = profilePlatform profile
srt_n_info = mkSRTInfoLabel (length refs)
fields =
- mkStaticClosure dflags srt_n_info dontCareCCS
+ mkStaticClosure profile srt_n_info dontCareCCS
[ CmmLabel lbl | SRTEntry lbl <- refs ]
[] -- no padding
[mkIntCLit platform 0] -- link field
@@ -1130,7 +1134,7 @@ buildSRT dflags refs = do
-- | Update info tables with references to their SRTs. Also generate
-- static closures, splicing in SRT fields as necessary.
updInfoSRTs
- :: DynFlags
+ :: Profile
-> LabelMap CLabel -- SRT labels for each block
-> LabelMap [SRTEntry] -- SRTs to merge into FUN_STATIC closures
-> Bool -- Whether the CmmDecl's group has CAF references
@@ -1140,13 +1144,13 @@ updInfoSRTs
updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics))
= [CmmData s (CmmStaticsRaw lbl statics)]
-updInfoSRTs dflags _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))
+updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))
= [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))]
where
caf_info = if caffy then MayHaveCafRefs else NoCafRefs
- field_lits = mkStaticClosureFields dflags itbl ccs caf_info payload
+ field_lits = mkStaticClosureFields profile itbl ccs caf_info payload
-updInfoSRTs dflags srt_env funSRTEnv caffy (CmmProc top_info top_l live g)
+updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)
| Just (_,closure) <- maybeStaticClosure = [ proc, closure ]
| otherwise = [ proc ]
where
@@ -1175,7 +1179,7 @@ updInfoSRTs dflags srt_env funSRTEnv caffy (CmmProc top_info top_l live g)
Just srtEntries -> srtTrace "maybeStaticFun" (ppr res)
(info_tbl { cit_rep = new_rep }, res)
where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]
- fields = mkStaticClosureFields dflags info_tbl ccs caf_info srtEntries
+ fields = mkStaticClosureFields profile info_tbl ccs caf_info srtEntries
new_rep = case cit_rep of
HeapRep sta ptrs nptrs ty ->
HeapRep sta (ptrs + length srtEntries) nptrs ty
diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs
index 689e5a0e46..f1137cf4fe 100644
--- a/compiler/GHC/Cmm/LayoutStack.hs
+++ b/compiler/GHC/Cmm/LayoutStack.hs
@@ -5,6 +5,9 @@ module GHC.Cmm.LayoutStack (
import GHC.Prelude hiding ((<*>))
+import GHC.Platform
+import GHC.Platform.Profile
+
import GHC.StgToCmm.Utils ( callerSaveVolatileRegs, newTemp ) -- XXX layering violation
import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState ) -- XXX layering violation
@@ -29,7 +32,6 @@ import GHC.Data.Maybe
import GHC.Types.Unique.FM
import GHC.Utils.Misc
-import GHC.Platform
import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Utils.Outputable hiding ( isEmpty )
@@ -245,6 +247,7 @@ cmmLayoutStack dflags procpoints entry_args
-- by the sinking pass.
let liveness = cmmLocalLiveness dflags graph
blocks = revPostorder graph
+ profile = targetProfile dflags
(final_stackmaps, _final_high_sp, new_blocks) <-
mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
@@ -253,7 +256,7 @@ cmmLayoutStack dflags procpoints entry_args
blocks_with_reloads <-
insertReloadsAsNeeded dflags procpoints final_stackmaps entry new_blocks
- new_blocks' <- mapM (lowerSafeForeignCall dflags) blocks_with_reloads
+ new_blocks' <- mapM (lowerSafeForeignCall profile) blocks_with_reloads
return (ofBlockList entry new_blocks', final_stackmaps)
-- -----------------------------------------------------------------------------
@@ -1131,18 +1134,18 @@ expecting them (see Note [safe foreign call convention]). Note also
that safe foreign call is replace by an unsafe one in the Cmm graph.
-}
-lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
-lowerSafeForeignCall dflags block
+lowerSafeForeignCall :: Profile -> CmmBlock -> UniqSM CmmBlock
+lowerSafeForeignCall profile block
| (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block
= do
- let platform = targetPlatform dflags
+ let platform = profilePlatform profile
-- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS-only objects and are not subject to garbage collection
id <- newTemp (bWord platform)
new_base <- newTemp (cmmRegType platform baseReg)
- let (caller_save, caller_load) = callerSaveVolatileRegs dflags
- save_state_code <- saveThreadState dflags
- load_state_code <- loadThreadState dflags
+ let (caller_save, caller_load) = callerSaveVolatileRegs platform
+ save_state_code <- saveThreadState profile
+ load_state_code <- loadThreadState profile
let suspend = save_state_code <*>
caller_save <*>
mkMiddle (callSuspendThread platform id intrbl)
@@ -1155,7 +1158,7 @@ lowerSafeForeignCall dflags block
load_state_code
(_, regs, copyout) =
- copyOutOflow dflags NativeReturn Jump (Young succ)
+ copyOutOflow profile NativeReturn Jump (Young succ)
(map (CmmReg . CmmLocal) res)
ret_off []
diff --git a/compiler/GHC/Cmm/Monad.hs b/compiler/GHC/Cmm/Monad.hs
index 310b316e02..edb4c5f9d6 100644
--- a/compiler/GHC/Cmm/Monad.hs
+++ b/compiler/GHC/Cmm/Monad.hs
@@ -11,10 +11,17 @@ module GHC.Cmm.Monad (
PD(..)
, liftP
, failMsgPD
+ , getProfile
+ , getPlatform
+ , getPtrOpts
) where
import GHC.Prelude
+import GHC.Platform
+import GHC.Platform.Profile
+import GHC.Cmm.Info
+
import Control.Monad
import GHC.Driver.Session
@@ -49,3 +56,18 @@ thenPD :: PD a -> (a -> PD b) -> PD b
instance HasDynFlags PD where
getDynFlags = PD $ \d s -> POk s d
+
+getProfile :: PD Profile
+getProfile = targetProfile <$> getDynFlags
+
+getPlatform :: PD Platform
+getPlatform = profilePlatform <$> getProfile
+
+getPtrOpts :: PD PtrOpts
+getPtrOpts = do
+ dflags <- getDynFlags
+ profile <- getProfile
+ pure $ PtrOpts
+ { po_profile = profile
+ , po_align_check = gopt Opt_AlignmentSanitisation dflags
+ }
diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y
index eeab41df7b..f03383833c 100644
--- a/compiler/GHC/Cmm/Parser.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -204,13 +204,15 @@ module GHC.Cmm.Parser ( parseCmmFile ) where
import GHC.Prelude
+import GHC.Platform
+import GHC.Platform.Profile
+
import GHC.StgToCmm.ExtCode
-import GHC.Cmm.CallConv
import GHC.StgToCmm.Prof
import GHC.StgToCmm.Heap
import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit
- , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff
- , getUpdFrameOff )
+ , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff
+ , getUpdFrameOff, getProfile, getPlatform, getPtrOpts )
import qualified GHC.StgToCmm.Monad as F
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Foreign
@@ -219,6 +221,7 @@ import GHC.StgToCmm.Closure
import GHC.StgToCmm.Layout hiding (ArgRep(..))
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame )
+
import GHC.Core ( Tickish(SourceNote) )
import GHC.Cmm.Opt
@@ -230,14 +233,15 @@ import GHC.Cmm.Info
import GHC.Cmm.BlockId
import GHC.Cmm.Lexer
import GHC.Cmm.CLabel
-import GHC.Cmm.Monad
+import GHC.Cmm.Monad hiding (getPlatform, getProfile, getPtrOpts)
+import qualified GHC.Cmm.Monad as PD
+import GHC.Cmm.CallConv
import GHC.Runtime.Heap.Layout
import GHC.Parser.Lexer
import GHC.Types.CostCentre
import GHC.Types.ForeignCall
import GHC.Unit.Module
-import GHC.Platform
import GHC.Types.Literal
import GHC.Types.Unique
import GHC.Types.Unique.FM
@@ -418,9 +422,9 @@ static :: { CmmParse [CmmStatic] }
fromIntegral $3)] }
| 'CLOSURE' '(' NAME lits ')'
{ do { lits <- sequence $4
- ; dflags <- getDynFlags
+ ; profile <- getProfile
; return $ map CmmStaticLit $
- mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
+ mkStaticClosure profile (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
-- mkForeignLabel because these are only used
-- for CHARLIKE and INTLIKE closures in the RTS.
dontCareCCS (map getLit lits) [] [] [] } }
@@ -463,10 +467,10 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, closure type, description, type
{% liftP . withHomeUnitId $ \pkg ->
- do dflags <- getDynFlags
- let prof = profilingInfo dflags $11 $13
+ do profile <- getProfile
+ let prof = profilingInfo profile $11 $13
rep = mkRTSRep (fromIntegral $9) $
- mkHeapRep dflags False (fromIntegral $5)
+ mkHeapRep profile False (fromIntegral $5)
(fromIntegral $7) Thunk
-- not really Thunk, but that makes the info table
-- we want.
@@ -479,12 +483,12 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type
{% liftP . withHomeUnitId $ \pkg ->
- do dflags <- getDynFlags
- let prof = profilingInfo dflags $11 $13
+ do profile <- getProfile
+ let prof = profilingInfo profile $11 $13
ty = Fun 0 (ArgSpec (fromIntegral $15))
-- Arity zero, arg_type $15
rep = mkRTSRep (fromIntegral $9) $
- mkHeapRep dflags False (fromIntegral $5)
+ mkHeapRep profile False (fromIntegral $5)
(fromIntegral $7) ty
return (mkCmmEntryLabel pkg $3,
Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
@@ -497,12 +501,12 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, tag, closure type, description, type
{% liftP . withHomeUnitId $ \pkg ->
- do dflags <- getDynFlags
- let prof = profilingInfo dflags $13 $15
+ do profile <- getProfile
+ let prof = profilingInfo profile $13 $15
ty = Constr (fromIntegral $9) -- Tag
(BS8.pack $13)
rep = mkRTSRep (fromIntegral $11) $
- mkHeapRep dflags False (fromIntegral $5)
+ mkHeapRep profile False (fromIntegral $5)
(fromIntegral $7) ty
return (mkCmmEntryLabel pkg $3,
Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
@@ -516,11 +520,11 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type
{% liftP . withHomeUnitId $ \pkg ->
- do dflags <- getDynFlags
- let prof = profilingInfo dflags $9 $11
+ do profile <- getProfile
+ let prof = profilingInfo profile $9 $11
ty = ThunkSelector (fromIntegral $5)
rep = mkRTSRep (fromIntegral $7) $
- mkHeapRep dflags False 0 0 ty
+ mkHeapRep profile False 0 0 ty
return (mkCmmEntryLabel pkg $3,
Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep
@@ -541,8 +545,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
-- closure type, live regs
{% liftP . withHomeUnitId $ \pkg ->
- do dflags <- getDynFlags
- let platform = targetPlatform dflags
+ do platform <- getPlatform
live <- sequence $7
let prof = NoProfilingInfo
-- drop one for the info pointer
@@ -686,8 +689,8 @@ safety :: { Safety }
vols :: { [GlobalReg] }
: '[' ']' { [] }
- | '[' '*' ']' {% do df <- getDynFlags
- ; return (realArgRegsCover df) }
+ | '[' '*' ']' {% do platform <- PD.getPlatform
+ ; return (realArgRegsCover platform) }
-- All of them. See comment attached
-- to realArgRegsCover
| '[' globals ']' { $2 }
@@ -771,7 +774,7 @@ expr0 :: { CmmParse CmmExpr }
-- leaving out the type of a literal gives you the native word size in C--
maybe_ty :: { CmmType }
- : {- empty -} {% do dflags <- getDynFlags; return $ bWord (targetPlatform dflags) }
+ : {- empty -} {% do platform <- PD.getPlatform; return $ bWord platform }
| '::' type { $2 }
cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
@@ -860,7 +863,7 @@ typenot8 :: { CmmType }
| 'bits512' { b512 }
| 'float32' { f32 }
| 'float64' { f64 }
- | 'gcptr' {% do dflags <- getDynFlags; return $ gcWord (targetPlatform dflags) }
+ | 'gcptr' {% do platform <- PD.getPlatform; return $ gcWord platform }
{
section :: String -> SectionType
@@ -880,8 +883,7 @@ mkString s = CmmString (BS8.pack s)
-- the op.
mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
mkMachOp fn args = do
- dflags <- getDynFlags
- let platform = targetPlatform dflags
+ platform <- getPlatform
arg_exprs <- sequence args
return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs)
@@ -898,8 +900,8 @@ nameToMachOp name =
exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
exprOp name args_code = do
- dflags <- getDynFlags
- case lookupUFM (exprMacros dflags) name of
+ ptr_opts <- PD.getPtrOpts
+ case lookupUFM (exprMacros ptr_opts) name of
Just f -> return $ do
args <- sequence args_code
return (f args)
@@ -907,20 +909,22 @@ exprOp name args_code = do
mo <- nameToMachOp name
return $ mkMachOp mo args_code
-exprMacros :: DynFlags -> UniqFM FastString ([CmmExpr] -> CmmExpr)
-exprMacros dflags = listToUFM [
+exprMacros :: PtrOpts -> UniqFM FastString ([CmmExpr] -> CmmExpr)
+exprMacros ptr_opts = listToUFM [
( fsLit "ENTRY_CODE", \ [x] -> entryCode platform x ),
- ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ),
- ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ),
- ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ),
- ( fsLit "GET_ENTRY", \ [x] -> entryCode platform (closureInfoPtr dflags x) ),
- ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),
- ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),
- ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ),
- ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ),
- ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x )
+ ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr ptr_opts x ),
+ ( fsLit "STD_INFO", \ [x] -> infoTable profile x ),
+ ( fsLit "FUN_INFO", \ [x] -> funInfoTable profile x ),
+ ( fsLit "GET_ENTRY", \ [x] -> entryCode platform (closureInfoPtr ptr_opts x) ),
+ ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile (closureInfoPtr ptr_opts x) ),
+ ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr ptr_opts x) ),
+ ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType profile x ),
+ ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs profile x ),
+ ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs profile x )
]
- where platform = targetPlatform dflags
+ where
+ profile = po_profile ptr_opts
+ platform = profilePlatform profile
-- we understand a subset of C-- primitives:
machOps = listToUFM $
@@ -1135,15 +1139,14 @@ stmtMacros = listToUFM [
emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
emitPushUpdateFrame sp e = do
- dflags <- getDynFlags
- emitUpdateFrame dflags sp mkUpdInfoLabel e
+ emitUpdateFrame sp mkUpdInfoLabel e
pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()
pushStackFrame fields body = do
- dflags <- getDynFlags
+ profile <- getProfile
exprs <- sequence fields
updfr_off <- getUpdFrameOff
- let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old
+ let (new_updfr_off, _, g) = copyOutOflow profile NativeReturn Ret Old
[] updfr_off exprs
emit g
withUpdFrameOff new_updfr_off body
@@ -1154,8 +1157,7 @@ reserveStackFrame
-> CmmParse ()
-> CmmParse ()
reserveStackFrame psize preg body = do
- dflags <- getDynFlags
- let platform = targetPlatform dflags
+ platform <- getPlatform
old_updfr_off <- getUpdFrameOff
reg <- preg
esize <- psize
@@ -1167,15 +1169,15 @@ reserveStackFrame psize preg body = do
emitAssign reg (CmmStackSlot Old frame)
withUpdFrameOff frame body
-profilingInfo dflags desc_str ty_str
- = if not (sccProfilingEnabled dflags)
+profilingInfo profile desc_str ty_str
+ = if not (profileIsProfiling profile)
then NoProfilingInfo
else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)
staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure pkg cl_label info payload
- = do dflags <- getDynFlags
- let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
+ = do profile <- getProfile
+ let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits
foreignCall
@@ -1192,12 +1194,11 @@ foreignCall conv_string results_code expr_code args_code safety ret
"stdcall" -> return StdCallConv
_ -> failMsgPD ("unknown calling convention: " ++ conv_string)
return $ do
- dflags <- getDynFlags
+ platform <- getPlatform
results <- sequence results_code
expr <- expr_code
args <- sequence args_code
let
- platform = targetPlatform dflags
expr' = adjCallTarget platform conv expr args
(arg_exprs, arg_hints) = unzip args
(res_regs, res_hints) = unzip results
@@ -1209,34 +1210,34 @@ foreignCall conv_string results_code expr_code args_code safety ret
doReturn :: [CmmParse CmmExpr] -> CmmParse ()
doReturn exprs_code = do
- dflags <- getDynFlags
+ profile <- getProfile
exprs <- sequence exprs_code
updfr_off <- getUpdFrameOff
- emit (mkReturnSimple dflags exprs updfr_off)
+ emit (mkReturnSimple profile exprs updfr_off)
-mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
-mkReturnSimple dflags actuals updfr_off =
- mkReturn dflags e actuals updfr_off
+mkReturnSimple :: Profile -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
+mkReturnSimple profile actuals updfr_off =
+ mkReturn profile e actuals updfr_off
where e = entryCode platform (CmmLoad (CmmStackSlot Old updfr_off)
(gcWord platform))
- platform = targetPlatform dflags
+ platform = profilePlatform profile
doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
doRawJump expr_code vols = do
- dflags <- getDynFlags
+ profile <- getProfile
expr <- expr_code
updfr_off <- getUpdFrameOff
- emit (mkRawJump dflags expr updfr_off vols)
+ emit (mkRawJump profile expr updfr_off vols)
doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
-> [CmmParse CmmExpr] -> CmmParse ()
doJumpWithStack expr_code stk_code args_code = do
- dflags <- getDynFlags
+ profile <- getProfile
expr <- expr_code
stk_args <- sequence stk_code
args <- sequence args_code
updfr_off <- getUpdFrameOff
- emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)
+ emit (mkJumpExtra profile NativeNodeCall expr args updfr_off stk_args)
doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
-> CmmParse ()
@@ -1276,7 +1277,7 @@ primCall results_code name args_code
doStore :: CmmType -> CmmParse CmmExpr -> CmmParse CmmExpr -> CmmParse ()
doStore rep addr_code val_code
- = do dflags <- getDynFlags
+ = do platform <- getPlatform
addr <- addr_code
val <- val_code
-- if the specified store type does not match the type of the expr
@@ -1286,7 +1287,6 @@ doStore rep addr_code val_code
-- be noticed.
let val_width = typeWidth (cmmExprType platform val)
rep_width = typeWidth rep
- platform = targetPlatform dflags
let coerce_val
| val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
| otherwise = val
@@ -1388,8 +1388,7 @@ doSwitch mb_range scrut arms deflt
table_entries <- mapM emitArm arms
let table = M.fromList (concat table_entries)
- dflags <- getDynFlags
- let platform = targetPlatform dflags
+ platform <- getPlatform
let range = fromMaybe (0, platformMaxWord platform) mb_range
expr <- scrut
@@ -1414,14 +1413,14 @@ forkLabelledCode p = do
-- The initial environment: we define some constants that the compiler
-- knows about here.
-initEnv :: DynFlags -> Env
-initEnv dflags = listToUFM [
+initEnv :: Profile -> Env
+initEnv profile = listToUFM [
( fsLit "SIZEOF_StgHeader",
- VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth platform)) )),
+ VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize profile)) (wordWidth platform)) )),
( fsLit "SIZEOF_StgInfoTable",
- VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth platform)) ))
+ VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB profile)) (wordWidth platform)) ))
]
- where platform = targetPlatform dflags
+ where platform = profilePlatform profile
parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
@@ -1436,7 +1435,7 @@ parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (te
return (getMessages pst dflags, Nothing)
POk pst code -> do
st <- initC
- let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
+ let fcode = getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()
(cmm,_) = runC dflags no_module st fcode
let ms = getMessages pst dflags
if (errorsFound dflags ms)
diff --git a/compiler/GHC/Cmm/Type.hs b/compiler/GHC/Cmm/Type.hs
index 0f2971dba2..0e7601cf3a 100644
--- a/compiler/GHC/Cmm/Type.hs
+++ b/compiler/GHC/Cmm/Type.hs
@@ -32,7 +32,6 @@ where
import GHC.Prelude
import GHC.Platform
-import GHC.Driver.Session
import GHC.Data.FastString
import GHC.Utils.Outputable
@@ -130,8 +129,8 @@ bHalfWord platform = cmmBits (halfWordWidth platform)
gcWord :: Platform -> CmmType
gcWord platform = CmmType GcPtrCat (wordWidth platform)
-cInt :: DynFlags -> CmmType
-cInt dflags = cmmBits (cIntWidth dflags)
+cInt :: Platform -> CmmType
+cInt platform = cmmBits (cIntWidth platform)
------------ Predicates ----------------
isFloatType, isGcPtrType, isBitsType :: CmmType -> Bool
@@ -196,8 +195,8 @@ halfWordMask platform = case platformWordSize platform of
PW8 -> 0xFFFFFFFF
-- cIntRep is the Width for a C-language 'int'
-cIntWidth :: DynFlags -> Width
-cIntWidth dflags = case cINT_SIZE dflags of
+cIntWidth :: Platform -> Width
+cIntWidth platform = case pc_CINT_SIZE (platformConstants platform) of
4 -> W32
8 -> W64
s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s)
@@ -323,25 +322,25 @@ data ForeignHint
-- These don't really belong here, but I don't know where is best to
-- put them.
-rEP_CostCentreStack_mem_alloc :: DynFlags -> CmmType
-rEP_CostCentreStack_mem_alloc dflags
+rEP_CostCentreStack_mem_alloc :: Platform -> CmmType
+rEP_CostCentreStack_mem_alloc platform
= cmmBits (widthFromBytes (pc_REP_CostCentreStack_mem_alloc pc))
- where pc = platformConstants (targetPlatform dflags)
+ where pc = platformConstants platform
-rEP_CostCentreStack_scc_count :: DynFlags -> CmmType
-rEP_CostCentreStack_scc_count dflags
+rEP_CostCentreStack_scc_count :: Platform -> CmmType
+rEP_CostCentreStack_scc_count platform
= cmmBits (widthFromBytes (pc_REP_CostCentreStack_scc_count pc))
- where pc = platformConstants (targetPlatform dflags)
+ where pc = platformConstants platform
-rEP_StgEntCounter_allocs :: DynFlags -> CmmType
-rEP_StgEntCounter_allocs dflags
+rEP_StgEntCounter_allocs :: Platform -> CmmType
+rEP_StgEntCounter_allocs platform
= cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocs pc))
- where pc = platformConstants (targetPlatform dflags)
+ where pc = platformConstants platform
-rEP_StgEntCounter_allocd :: DynFlags -> CmmType
-rEP_StgEntCounter_allocd dflags
+rEP_StgEntCounter_allocd :: Platform -> CmmType
+rEP_StgEntCounter_allocd platform
= cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd pc))
- where pc = platformConstants (targetPlatform dflags)
+ where pc = platformConstants platform
-------------------------------------------------------------------------
{- Note [Signed vs unsigned]
diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs
index 2581056fc6..d762f0d9b0 100644
--- a/compiler/GHC/Cmm/Utils.hs
+++ b/compiler/GHC/Cmm/Utils.hs
@@ -48,7 +48,7 @@ module GHC.Cmm.Utils(
-- Tagging
cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,
- cmmConstrTag1,
+ cmmConstrTag1, mAX_PTR_TAG, tAG_MASK,
-- Overlap and usage
regsOverlap, regUsedIn,
@@ -79,7 +79,6 @@ import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Utils.Outputable
-import GHC.Driver.Session
import GHC.Types.Unique
import GHC.Platform.Regs
@@ -428,26 +427,29 @@ isComparisonExpr _ = False
--
---------------------------------------------------
+tAG_MASK :: Platform -> Int
+tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1
+
+mAX_PTR_TAG :: Platform -> Int
+mAX_PTR_TAG = tAG_MASK
+
-- Tag bits mask
-cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
-cmmTagMask dflags = mkIntExpr (targetPlatform dflags) (tAG_MASK dflags)
-cmmPointerMask dflags = mkIntExpr (targetPlatform dflags) (complement (tAG_MASK dflags))
+cmmTagMask, cmmPointerMask :: Platform -> CmmExpr
+cmmTagMask platform = mkIntExpr platform (tAG_MASK platform)
+cmmPointerMask platform = mkIntExpr platform (complement (tAG_MASK platform))
-- Used to untag a possibly tagged pointer
-- A static label need not be untagged
-cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
+cmmUntag, cmmIsTagged, cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr
cmmUntag _ e@(CmmLit (CmmLabel _)) = e
-- Default case
-cmmUntag dflags e = cmmAndWord platform e (cmmPointerMask dflags)
- where platform = targetPlatform dflags
+cmmUntag platform e = cmmAndWord platform e (cmmPointerMask platform)
-- Test if a closure pointer is untagged
-cmmIsTagged dflags e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask dflags)) (zeroExpr platform)
- where platform = targetPlatform dflags
+cmmIsTagged platform e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform)
-- Get constructor tag, but one based.
-cmmConstrTag1 dflags e = cmmAndWord platform e (cmmTagMask dflags)
- where platform = targetPlatform dflags
+cmmConstrTag1 platform e = cmmAndWord platform e (cmmTagMask platform)
-----------------------------------------------------------------------------
View Lorry Controller Status