Commit 9dfeca6c authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

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
parent 6333d739
......@@ -12,6 +12,8 @@ module GHC.ByteCode.InfoTable ( mkITbls ) where
import GHC.Prelude
import GHC.Platform
import GHC.Platform.Profile
import GHC.ByteCode.Types
import GHC.Runtime.Interpreter
import GHC.Driver.Session
......@@ -54,7 +56,7 @@ make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv
make_constr_itbls hsc_env cons =
mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])
where
dflags = hsc_dflags hsc_env
profile = targetProfile (hsc_dflags hsc_env)
mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)
mk_itbl dcon conNo = do
......@@ -63,19 +65,20 @@ make_constr_itbls hsc_env cons =
, prim_rep <- typePrimRep (scaledThing arg) ]
(tot_wds, ptr_wds) =
mkVirtConstrSizes dflags rep_args
mkVirtConstrSizes profile rep_args
ptrs' = ptr_wds
nptrs' = tot_wds - ptr_wds
nptrs_really
| ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs'
| otherwise = mIN_PAYLOAD_SIZE dflags - ptrs'
| ptrs' + nptrs' >= pc_MIN_PAYLOAD_SIZE constants = nptrs'
| otherwise = pc_MIN_PAYLOAD_SIZE constants - ptrs'
descr = dataConIdentity dcon
platform = targetPlatform dflags
platform = profilePlatform profile
constants = platformConstants platform
tables_next_to_code = platformTablesNextToCode platform
r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really
conNo (tagForCon dflags dcon) descr)
conNo (tagForCon platform dcon) descr)
return (getName dcon, ItblPtr r)
......@@ -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)
......
......@@ -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
......@@ -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
......
......@@ -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)