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

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 ...@@ -12,6 +12,8 @@ module GHC.ByteCode.InfoTable ( mkITbls ) where
import GHC.Prelude import GHC.Prelude
import GHC.Platform import GHC.Platform
import GHC.Platform.Profile
import GHC.ByteCode.Types import GHC.ByteCode.Types
import GHC.Runtime.Interpreter import GHC.Runtime.Interpreter
import GHC.Driver.Session import GHC.Driver.Session
...@@ -54,7 +56,7 @@ make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv ...@@ -54,7 +56,7 @@ make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv
make_constr_itbls hsc_env cons = make_constr_itbls hsc_env cons =
mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..]) mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])
where where
dflags = hsc_dflags hsc_env profile = targetProfile (hsc_dflags hsc_env)
mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr) mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)
mk_itbl dcon conNo = do mk_itbl dcon conNo = do
...@@ -63,19 +65,20 @@ make_constr_itbls hsc_env cons = ...@@ -63,19 +65,20 @@ make_constr_itbls hsc_env cons =
, prim_rep <- typePrimRep (scaledThing arg) ] , prim_rep <- typePrimRep (scaledThing arg) ]
(tot_wds, ptr_wds) = (tot_wds, ptr_wds) =
mkVirtConstrSizes dflags rep_args mkVirtConstrSizes profile rep_args
ptrs' = ptr_wds ptrs' = ptr_wds
nptrs' = tot_wds - ptr_wds nptrs' = tot_wds - ptr_wds
nptrs_really nptrs_really
| ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs' | ptrs' + nptrs' >= pc_MIN_PAYLOAD_SIZE constants = nptrs'
| otherwise = mIN_PAYLOAD_SIZE dflags - ptrs' | otherwise = pc_MIN_PAYLOAD_SIZE constants - ptrs'
descr = dataConIdentity dcon descr = dataConIdentity dcon
platform = targetPlatform dflags platform = profilePlatform profile
constants = platformConstants platform
tables_next_to_code = platformTablesNextToCode platform tables_next_to_code = platformTablesNextToCode platform
r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really 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) return (getName dcon, ItblPtr r)
...@@ -599,24 +599,24 @@ mkLocalBlockLabel u = LocalBlockLabel u ...@@ -599,24 +599,24 @@ mkLocalBlockLabel u = LocalBlockLabel u
mkRtsPrimOpLabel :: PrimOp -> CLabel mkRtsPrimOpLabel :: PrimOp -> CLabel
mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop)
mkSelectorInfoLabel :: DynFlags -> Bool -> Int -> CLabel mkSelectorInfoLabel :: Platform -> Bool -> Int -> CLabel
mkSelectorInfoLabel dflags upd offset = mkSelectorInfoLabel platform upd offset =
ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags) ASSERT(offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform))
RtsLabel (RtsSelectorInfoTable upd offset) RtsLabel (RtsSelectorInfoTable upd offset)
mkSelectorEntryLabel :: DynFlags -> Bool -> Int -> CLabel mkSelectorEntryLabel :: Platform -> Bool -> Int -> CLabel
mkSelectorEntryLabel dflags upd offset = mkSelectorEntryLabel platform upd offset =
ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags) ASSERT(offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform))
RtsLabel (RtsSelectorEntry upd offset) RtsLabel (RtsSelectorEntry upd offset)
mkApInfoTableLabel :: DynFlags -> Bool -> Int -> CLabel mkApInfoTableLabel :: Platform -> Bool -> Int -> CLabel
mkApInfoTableLabel dflags upd arity = mkApInfoTableLabel platform upd arity =
ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags) ASSERT(arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform))
RtsLabel (RtsApInfoTable upd arity) RtsLabel (RtsApInfoTable upd arity)
mkApEntryLabel :: DynFlags -> Bool -> Int -> CLabel mkApEntryLabel :: Platform -> Bool -> Int -> CLabel
mkApEntryLabel dflags upd arity = mkApEntryLabel platform upd arity =
ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags) ASSERT(arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform))
RtsLabel (RtsApEntry upd arity) RtsLabel (RtsApEntry upd arity)
......
...@@ -14,6 +14,7 @@ import GHC.Cmm.Ppr () -- For Outputable instances ...@@ -14,6 +14,7 @@ import GHC.Cmm.Ppr () -- For Outputable instances
import GHC.Driver.Session import GHC.Driver.Session
import GHC.Platform import GHC.Platform
import GHC.Platform.Profile
import GHC.Utils.Outputable import GHC.Utils.Outputable
-- Calculate the 'GlobalReg' or stack locations for function call -- Calculate the 'GlobalReg' or stack locations for function call
...@@ -31,7 +32,7 @@ instance Outputable ParamLocation where ...@@ -31,7 +32,7 @@ instance Outputable ParamLocation where
-- Given a list of arguments, and a function that tells their types, -- Given a list of arguments, and a function that tells their types,
-- return a list showing where each argument is passed -- return a list showing where each argument is passed
-- --
assignArgumentsPos :: DynFlags assignArgumentsPos :: Profile
-> ByteOff -- stack offset to start with -> ByteOff -- stack offset to start with
-> Convention -> Convention
-> (a -> CmmType) -- how to get a type from an arg -> (a -> CmmType) -- how to get a type from an arg
...@@ -41,16 +42,16 @@ assignArgumentsPos :: DynFlags ...@@ -41,16 +42,16 @@ assignArgumentsPos :: DynFlags
, [(a, ParamLocation)] -- args and locations , [(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 where
platform = targetPlatform dflags platform = profilePlatform profile
regs = case (reps, conv) of regs = case (reps, conv) of
(_, NativeNodeCall) -> getRegsWithNode dflags (_, NativeNodeCall) -> getRegsWithNode platform
(_, NativeDirectCall) -> getRegsWithoutNode dflags (_, NativeDirectCall) -> getRegsWithoutNode platform
([_], NativeReturn) -> allRegs dflags ([_], NativeReturn) -> allRegs platform
(_, NativeReturn) -> getRegsWithNode dflags (_, NativeReturn) -> getRegsWithNode platform
-- GC calling convention *must* put values in registers -- GC calling convention *must* put values in registers
(_, GC) -> allRegs dflags (_, GC) -> allRegs platform
(_, Slow) -> nodeOnly (_, Slow) -> nodeOnly
-- The calling conventions first assign arguments to registers, -- The calling conventions first assign arguments to registers,
-- then switch to the stack when we first run out of 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) ...@@ -67,11 +68,11 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
| otherwise = int | otherwise = int
where vec = case (w, regs) of where vec = case (w, regs) of
(W128, (vs, fs, ds, ls, s:ss)) (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)) (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)) (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)) _ -> (assts, (r:rs))
float = case (w, regs) of float = case (w, regs) of
(W32, (vs, fs, ds, ls, s:ss)) (W32, (vs, fs, ds, ls, s:ss))
...@@ -107,7 +108,7 @@ passFloatArgsInXmm platform = case platformArch platform of ...@@ -107,7 +108,7 @@ passFloatArgsInXmm platform = case platformArch platform of
-- support vector registers in its calling convention. However, this has now -- support vector registers in its calling convention. However, this has now
-- been fixed. This function remains only as a convenient way to re-enable -- been fixed. This function remains only as a convenient way to re-enable
-- spilling when debugging code generation. -- spilling when debugging code generation.
passVectorInReg :: Width -> DynFlags -> Bool passVectorInReg :: Width -> Profile -> Bool
passVectorInReg _ _ = True passVectorInReg _ _ = True
assignStack :: Platform -> ByteOff -> (a -> CmmType) -> [a] assignStack :: Platform -> ByteOff -> (a -> CmmType) -> [a]
...@@ -142,56 +143,57 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. ...@@ -142,56 +143,57 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
-- We take these register supplies from the *real* registers, i.e. those -- We take these register supplies from the *real* registers, i.e. those
-- that are guaranteed to map to machine registers. -- that are guaranteed to map to machine registers.
getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs getRegsWithoutNode, getRegsWithNode :: Platform -> AvailRegs
getRegsWithoutNode dflags = getRegsWithoutNode platform =
( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags) ( filter (\r -> r VGcPtr /= node) (realVanillaRegs platform)
, realFloatRegs dflags , realFloatRegs platform
, realDoubleRegs dflags , realDoubleRegs platform
, realLongRegs dflags , realLongRegs platform
, realXmmRegNos dflags) , realXmmRegNos platform)
-- getRegsWithNode uses R1/node even if it isn't a register -- getRegsWithNode uses R1/node even if it isn't a register
getRegsWithNode dflags = getRegsWithNode platform =
( if null (realVanillaRegs dflags) ( if null (realVanillaRegs platform)
then [VanillaReg 1] then [VanillaReg 1]
else realVanillaRegs dflags else realVanillaRegs platform
, realFloatRegs dflags , realFloatRegs platform
, realDoubleRegs dflags , realDoubleRegs platform
, realLongRegs dflags , realLongRegs platform
, realXmmRegNos dflags) , realXmmRegNos platform)
allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg] allFloatRegs, allDoubleRegs, allLongRegs :: Platform -> [GlobalReg]
allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] allVanillaRegs :: Platform -> [VGcPtr -> GlobalReg]
allXmmRegs :: DynFlags -> [Int] allXmmRegs :: Platform -> [Int]
allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags) allVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Vanilla_REG (platformConstants platform))
allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags) allFloatRegs platform = map FloatReg $ regList (pc_MAX_Float_REG (platformConstants platform))
allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags) allDoubleRegs platform = map DoubleReg $ regList (pc_MAX_Double_REG (platformConstants platform))
allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags) allLongRegs platform = map LongReg $ regList (pc_MAX_Long_REG (platformConstants platform))
allXmmRegs dflags = regList (mAX_XMM_REG dflags) allXmmRegs platform = regList (pc_MAX_XMM_REG (platformConstants platform))
realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg] realFloatRegs, realDoubleRegs, realLongRegs :: Platform -> [GlobalReg]
realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg] realVanillaRegs :: Platform -> [VGcPtr -> GlobalReg]
realXmmRegNos :: DynFlags -> [Int]
realVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Real_Vanilla_REG (platformConstants platform))
realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags) realFloatRegs platform = map FloatReg $ regList (pc_MAX_Real_Float_REG (platformConstants platform))
realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags) realDoubleRegs platform = map DoubleReg $ regList (pc_MAX_Real_Double_REG (platformConstants platform))
realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags) realLongRegs platform = map LongReg $ regList (pc_MAX_Real_Long_REG (platformConstants platform))
realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags)
realXmmRegNos :: Platform -> [Int]
realXmmRegNos dflags realXmmRegNos platform
| isSse2Enabled dflags = regList (mAX_Real_XMM_REG dflags) | isSse2Enabled platform = regList (pc_MAX_Real_XMM_REG (platformConstants platform))
| otherwise = [] | otherwise = []
regList :: Int -> [Int] regList :: Int -> [Int]
regList n = [1 .. n] regList n = [1 .. n]
allRegs :: DynFlags -> AvailRegs allRegs :: Platform -> AvailRegs
allRegs dflags = (allVanillaRegs dflags, allRegs platform = ( allVanillaRegs platform
allFloatRegs dflags, , allFloatRegs platform
allDoubleRegs dflags, , allDoubleRegs platform
allLongRegs dflags, , allLongRegs platform
allXmmRegs dflags) , allXmmRegs platform
)
nodeOnly :: AvailRegs nodeOnly :: AvailRegs
nodeOnly = ([VanillaReg 1], [], [], [], []) nodeOnly = ([VanillaReg 1], [], [], [], [])
...@@ -201,18 +203,18 @@ nodeOnly = ([VanillaReg 1], [], [], [], []) ...@@ -201,18 +203,18 @@ nodeOnly = ([VanillaReg 1], [], [], [], [])
-- now just x86-64, where Float and Double registers overlap---passing this set -- 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 -- 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. -- only use this functionality in hand-written C-- code in the RTS.
realArgRegsCover :: DynFlags -> [GlobalReg] realArgRegsCover :: Platform -> [GlobalReg]
realArgRegsCover dflags realArgRegsCover platform
| passFloatArgsInXmm (targetPlatform dflags) | passFloatArgsInXmm platform
= map ($VGcPtr) (realVanillaRegs dflags) ++ = map ($VGcPtr) (realVanillaRegs platform) ++
realLongRegs dflags ++ realLongRegs platform ++
realDoubleRegs dflags -- we only need to save the low Double part of XMM registers. realDoubleRegs platform -- we only need to save the low Double part of XMM registers.
-- Moreover, the NCG can't load/store full XMM -- Moreover, the NCG can't load/store full XMM
-- registers for now... -- registers for now...
| otherwise | otherwise
= map ($VGcPtr) (realVanillaRegs dflags) ++ = map ($VGcPtr) (realVanillaRegs platform) ++
realFloatRegs dflags ++ realFloatRegs platform ++
realDoubleRegs dflags ++ realDoubleRegs platform ++
realLongRegs dflags realLongRegs platform
-- we don't save XMM registers if they are not used for parameter passing -- we don't save XMM registers if they are not used for parameter passing
...@@ -23,6 +23,8 @@ where ...@@ -23,6 +23,8 @@ where
import GHC.Prelude hiding ( (<*>) ) -- avoid importing (<*>) import GHC.Prelude hiding ( (<*>) ) -- avoid importing (<*>)
import GHC.Platform.Profile
import GHC.Cmm.BlockId import GHC.Cmm.BlockId
import GHC.Cmm import GHC.Cmm
import GHC.Cmm.CallConv import GHC.Cmm.CallConv
...@@ -31,7 +33,6 @@ import GHC.Cmm.Switch (SwitchTargets) ...@@ -31,7 +33,6 @@ import GHC.Cmm.Switch (SwitchTargets)
import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Label
import GHC.Driver.Session
import GHC.Data.FastString import GHC.Data.FastString
import GHC.Types.ForeignCall import GHC.Types.ForeignCall
import GHC.Data.OrdList import GHC.Data.OrdList
...@@ -196,28 +197,28 @@ mkStore :: CmmExpr -> CmmExpr -> CmmAGraph ...@@ -196,28 +197,28 @@ mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore l r = mkMiddle $ CmmStore l r mkStore l r = mkMiddle $ CmmStore l r
---------- Control transfer ---------- Control transfer
mkJump :: DynFlags -> Convention -> CmmExpr mkJump :: Profile -> Convention -> CmmExpr
-> [CmmExpr] -> [CmmExpr]
-> UpdFrameOffset -> UpdFrameOffset
-> CmmAGraph -> CmmAGraph
mkJump dflags conv e actuals updfr_off = mkJump profile conv e actuals updfr_off =
lastWithArgs dflags Jump Old conv actuals updfr_off $ lastWithArgs profile Jump Old conv actuals updfr_off $
toCall e Nothing updfr_off 0 toCall e Nothing updfr_off 0
-- | A jump where the caller says what the live GlobalRegs are. Used -- | A jump where the caller says what the live GlobalRegs are. Used
-- for low-level hand-written Cmm. -- for low-level hand-written Cmm.
mkRawJump :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg] mkRawJump :: Profile -> CmmExpr -> UpdFrameOffset -> [GlobalReg]
-> CmmAGraph -> CmmAGraph
mkRawJump dflags e updfr_off vols = mkRawJump profile e updfr_off vols =
lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $ lastWithArgs profile Jump Old NativeNodeCall [] updfr_off $
\arg_space _ -> toCall e Nothing updfr_off 0 arg_space vols \arg_space _ -> toCall e Nothing updfr_off 0 arg_space vols
mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr] mkJumpExtra :: Profile -> Convention -> CmmExpr -> [CmmExpr]
-> UpdFrameOffset -> [CmmExpr] -> UpdFrameOffset -> [CmmExpr]
-> CmmAGraph -> CmmAGraph
mkJumpExtra dflags conv e actuals updfr_off extra_stack = mkJumpExtra profile conv e actuals updfr_off extra_stack =
lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $ lastWithArgsAndExtraStack profile Jump Old conv actuals updfr_off extra_stack $
toCall e Nothing updfr_off 0 toCall e Nothing updfr_off 0
mkCbranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph mkCbranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
...@@ -227,42 +228,42 @@ mkCbranch pred ifso ifnot likely = ...@@ -227,42 +228,42 @@ mkCbranch pred ifso ifnot likely =
mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph
mkSwitch e tbl = mkLast $ CmmSwitch e tbl mkSwitch e tbl = mkLast $ CmmSwitch e tbl
mkReturn :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset mkReturn :: Profile -> CmmExpr -> [CmmExpr] -> UpdFrameOffset
-> CmmAGraph -> CmmAGraph
mkReturn dflags e actuals updfr_off = mkReturn profile e actuals updfr_off =
lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $ lastWithArgs profile Ret Old NativeReturn actuals updfr_off $
toCall e Nothing updfr_off 0 toCall e Nothing updfr_off 0
mkBranch :: BlockId -> CmmAGraph mkBranch :: BlockId -> CmmAGraph
mkBranch bid = mkLast (CmmBranch bid) mkBranch bid = mkLast (CmmBranch bid)
mkFinalCall :: DynFlags mkFinalCall :: Profile
-> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset
-> CmmAGraph -> CmmAGraph
mkFinalCall dflags f _ actuals updfr_off = mkFinalCall profile f _ actuals updfr_off =
lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $ lastWithArgs profile Call Old NativeDirectCall actuals updfr_off $
toCall f Nothing updfr_off 0 toCall f Nothing updfr_off 0
mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr] mkCallReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]
-> BlockId -> BlockId
-> ByteOff -> ByteOff
-> UpdFrameOffset -> UpdFrameOffset
-> [CmmExpr] -> [CmmExpr]
-> CmmAGraph -> CmmAGraph
mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do mkCallReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals lastWithArgsAndExtraStack profile Call (Young ret_lbl) callConv actuals
updfr_off extra_stack $ updfr_off extra_stack $
toCall f (Just ret_lbl) updfr_off ret_off toCall f (Just ret_lbl) updfr_off ret_off
-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be -- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
-- already on the stack). -- already on the stack).
mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr] mkJumpReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]
-> BlockId -> BlockId
-> ByteOff -> ByteOff
-> UpdFrameOffset -> UpdFrameOffset
-> CmmAGraph -> CmmAGraph
mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off = do mkJumpReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off = do
lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $ lastWithArgs profile JumpRet (Young ret_lbl) callConv actuals updfr_off $
toCall f (Just ret_lbl) updfr_off ret_off toCall f (Just ret_lbl) updfr_off ret_off
mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
...@@ -292,25 +293,25 @@ stackStubExpr w = CmmLit (CmmInt 0 w) ...@@ -292,25 +293,25 @@ stackStubExpr w = CmmLit (CmmInt 0 w)
-- variables in their spill slots. Therefore, for copying arguments -- variables in their spill slots. Therefore, for copying arguments
-- and results, we provide different functions to pass the arguments -- and results, we provide different functions to pass the arguments
-- in an overflow area and to pass them in spill slots. -- in an overflow area and to pass them in spill slots.
copyInOflow :: DynFlags -> Convention -> Area copyInOflow :: Profile -> Convention -> Area
-> [CmmFormal] -> [CmmFormal]
-> [CmmFormal] -> [CmmFormal]
-> (Int, [GlobalReg], CmmAGraph) -> (Int, [GlobalReg], CmmAGraph)
copyInOflow dflags conv area formals extra_stk copyInOflow profile conv area formals extra_stk
= (offset, gregs, catAGraphs $ map mkMiddle nodes) = (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 -- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments. -- instructions to copy the arguments.
copyIn :: DynFlags -> Convention -> Area copyIn :: Profile -> Convention -> Area
-> [CmmFormal] -> [CmmFormal]
-> [CmmFormal] -> [CmmFormal]
-> (ByteOff, [GlobalReg], [CmmNode O O]) -> (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)) = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
where where
platform = targetPlatform dflags platform = profilePlatform profile
-- See Note [Width of parameters] -- See Note [Width of parameters]
ci (reg, RegisterParam r@(VanillaReg {})) = ci (reg, RegisterParam r@(VanillaReg {})) =
let local = CmmLocal reg let local = CmmLocal reg
...@@ -346,7 +347,7 @@ copyIn dflags conv area formals extra_stk ...@@ -346,7 +347,7 @@ copyIn dflags conv area formals extra_stk
(stk_off, stk_args) = assignStack platform init_offset localRegType 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 localRegType formals
-- Factoring out the common parts of the copyout functions yielded something -- Factoring out the common parts of the copyout functions yielded something
...@@ -354,7 +355,7 @@ copyIn dflags conv area formals extra_stk ...@@ -354,7 +355,7 @@ copyIn dflags conv area formals extra_stk
data Transfer = Call | JumpRet | Jump | Ret deriving Eq data Transfer = Call | JumpRet | Jump | Ret deriving Eq
copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr] copyOutOflow :: Profile -> Convention -> Transfer -> Area -> [CmmExpr]
-> UpdFrameOffset -> UpdFrameOffset
-> [CmmExpr] -- extra stack args -> [CmmExpr] -- extra stack args
-> (Int, [GlobalReg], CmmAGraph) -> (Int, [GlobalReg], CmmAGraph)
...@@ -368,10 +369,10 @@ copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr] ...@@ -368,10 +369,10 @@ copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]
-- the info table for return and adjust the offsets of the other -- the info table for return and adjust the offsets of the other
-- parameters. If this is a call instruction, we adjust the offsets -- parameters. If this is a call instruction, we adjust the offsets
-- of the other parameters. -- 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) = (stk_size, regs, graph)
where where
platform = targetPlatform dflags platform = profilePlatform profile
(regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params) (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
-- See Note [Width of parameters] -- See Note [Width of parameters]
...@@ -419,7 +420,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff ...@@ -419,7 +420,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
assignStack platform init_offset (cmmExprType platform) extra_stack_stuff assignStack platform init_offset (cmmExprType platform) extra_stack_stuff
args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it 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
(