diff options
| author | Sylvain Henry <sylvain@haskus.fr> | 2020-07-07 18:48:31 +0200 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-07-25 00:45:08 -0400 |
| commit | 9dfeca6c2019fdb46613a68ccd6e650e40c7baac (patch) | |
| tree | 29a2cda3faddedc7024be259011f4406b6473f45 | |
| parent | 6333d7391068d8029eed3e8eff019b9e2c104c7b (diff) | |
| download | haskell-9dfeca6c2019fdb46613a68ccd6e650e40c7baac.tar.gz | |
Remove platform constant wrappers
Platform constant wrappers took a DynFlags parameter, hence implicitly
used the target platform constants. We removed them to allow support
for several platforms at once (#14335) and to avoid having to pass
the full DynFlags to every function (#17957).
Metric Decrease:
T4801
41 files changed, 1392 insertions, 1289 deletions
diff --git a/compiler/GHC/ByteCode/InfoTable.hs b/compiler/GHC/ByteCode/InfoTable.hs index 84f4ed3ef0..02b2e236b9 100644 --- a/compiler/GHC/ByteCode/InfoTable.hs +++ b/compiler/GHC/ByteCode/InfoTable.hs @@ -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) 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) ----------------------------------------------------------------------------- diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index 90b0305308..eaab3868c5 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -559,7 +559,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count -- rewrite assignments to global regs let fixed_cmm = {-# SCC "fixStgRegisters" #-} - fixStgRegisters dflags cmm + fixStgRegisters platform cmm -- cmm to cmm optimisations let (opt_cmm, imports) = diff --git a/compiler/GHC/CmmToAsm/Config.hs b/compiler/GHC/CmmToAsm/Config.hs index 6be6f17342..e6b5489b9e 100644 --- a/compiler/GHC/CmmToAsm/Config.hs +++ b/compiler/GHC/CmmToAsm/Config.hs @@ -2,6 +2,7 @@ module GHC.CmmToAsm.Config ( NCGConfig(..) , ncgWordWidth + , ncgSpillPreallocSize , platformWordWidth ) where @@ -20,7 +21,6 @@ data NCGConfig = NCGConfig , ncgInlineThresholdMemcpy :: !Word -- ^ If inlining `memcpy` produces less than this threshold (in pseudo-instruction unit), do it , ncgInlineThresholdMemset :: !Word -- ^ Ditto for `memset` , ncgSplitSections :: !Bool -- ^ Split sections - , ncgSpillPreallocSize :: !Int -- ^ Size in bytes of the pre-allocated spill space on the C stack , ncgRegsIterative :: !Bool , ncgAsmLinting :: !Bool -- ^ Perform ASM linting pass , ncgDoConstantFolding :: !Bool -- ^ Perform CMM constant folding @@ -35,6 +35,10 @@ data NCGConfig = NCGConfig ncgWordWidth :: NCGConfig -> Width ncgWordWidth config = platformWordWidth (ncgPlatform config) +-- | Size in bytes of the pre-allocated spill space on the C stack +ncgSpillPreallocSize :: NCGConfig -> Int +ncgSpillPreallocSize config = pc_RESERVED_C_STACK_BYTES (platformConstants (ncgPlatform config)) + -- | Return Word size platformWordWidth :: Platform -> Width platformWordWidth platform = case platformWordSize platform of diff --git a/compiler/GHC/CmmToAsm/Monad.hs b/compiler/GHC/CmmToAsm/Monad.hs index 2827e7026c..68bb46acd0 100644 --- a/compiler/GHC/CmmToAsm/Monad.hs +++ b/compiler/GHC/CmmToAsm/Monad.hs @@ -156,7 +156,6 @@ initConfig dflags = NCGConfig , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags , ncgSplitSections = gopt Opt_SplitSections dflags - , ncgSpillPreallocSize = rESERVED_C_STACK_BYTES dflags , ncgRegsIterative = gopt Opt_RegsIterative dflags , ncgAsmLinting = gopt Opt_DoAsmLinting dflags @@ -189,7 +188,6 @@ initConfig dflags = NCGConfig _ -> Nothing } - initNat :: NatM_State -> NatM a -> (a, NatM_State) initNat init_st m = case unNat m init_st of { (r,st) -> (r,st) } diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index bcead719a9..54b50577c8 100644 --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -19,9 +19,10 @@ -- ----------------------------------------------------------------------------- -module GHC.CmmToC ( - writeC - ) where +module GHC.CmmToC + ( cmmToC + ) +where #include "HsVersions.h" @@ -59,45 +60,38 @@ import Data.Char import Data.List (intersperse) import Data.Map (Map) import Data.Word -import System.IO import qualified Data.Map as Map import Control.Monad (ap) import qualified Data.Array.Unsafe as U ( castSTUArray ) import Data.Array.ST -- -------------------------------------------------------------------------- --- Top level - -writeC :: DynFlags -> Handle -> RawCmmGroup -> IO () -writeC dflags handle cmm = printForC dflags handle (pprC dflags cmm $$ blankLine) - --- -------------------------------------------------------------------------- -- Now do some real work -- -- for fun, we could call cmmToCmm over the tops... -- -pprC :: DynFlags -> RawCmmGroup -> SDoc -pprC dflags tops = vcat $ intersperse blankLine $ map (pprTop dflags) tops +cmmToC :: Platform -> RawCmmGroup -> SDoc +cmmToC platform tops = (vcat $ intersperse blankLine $ map (pprTop platform) tops) $$ blankLine -- -- top level procs -- -pprTop :: DynFlags -> RawCmmDecl -> SDoc -pprTop dflags = \case +pprTop :: Platform -> RawCmmDecl -> SDoc +pprTop platform = \case (CmmProc infos clbl _in_live_regs graph) -> (case mapLookup (g_entry graph) infos of Nothing -> empty Just (CmmStaticsRaw info_clbl info_dat) -> pprDataExterns platform info_dat $$ - pprWordArray dflags info_is_in_rodata info_clbl info_dat) $$ + pprWordArray platform info_is_in_rodata info_clbl info_dat) $$ (vcat [ blankLine, extern_decls, (if (externallyVisibleCLabel clbl) then mkFN_ else mkIF_) (ppr clbl) <+> lbrace, nest 8 temp_decls, - vcat (map (pprBBlock dflags) blocks), + vcat (map (pprBBlock platform) blocks), rbrace ] ) where @@ -127,13 +121,12 @@ pprTop dflags = \case (CmmData section (CmmStaticsRaw lbl lits)) -> pprDataExterns platform lits $$ - pprWordArray dflags (isSecConstant section) lbl lits + pprWordArray platform (isSecConstant section) lbl lits where isSecConstant section = case sectionProtection section of ReadOnlySection -> True WriteProtectedSection -> True _ -> False - platform = targetPlatform dflags -- -------------------------------------------------------------------------- -- BasicBlocks are self-contained entities: they always end in a jump. @@ -142,10 +135,10 @@ pprTop dflags = \case -- as many jumps as possible into fall throughs. -- -pprBBlock :: DynFlags -> CmmBlock -> SDoc -pprBBlock dflags block = +pprBBlock :: Platform -> CmmBlock -> SDoc +pprBBlock platform block = nest 4 (pprBlockId (entryLabel block) <> colon) $$ - nest 8 (vcat (map (pprStmt dflags) (blockToList nodes)) $$ pprStmt dflags last) + nest 8 (vcat (map (pprStmt platform) (blockToList nodes)) $$ pprStmt platform last) where (_, nodes, last) = blockSplit block @@ -153,8 +146,8 @@ pprBBlock dflags block = -- Info tables. Just arrays of words. -- See codeGen/ClosureInfo, and nativeGen/PprMach -pprWordArray :: DynFlags -> Bool -> CLabel -> [CmmStatic] -> SDoc -pprWordArray dflags is_ro lbl ds +pprWordArray :: Platform -> Bool -> CLabel -> [CmmStatic] -> SDoc +pprWordArray platform is_ro lbl ds = -- TODO: align closures only pprExternDecl platform lbl $$ hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord" @@ -162,10 +155,8 @@ pprWordArray dflags is_ro lbl ds -- See Note [StgWord alignment] , pprAlignment (wordWidth platform) , text "= {" ] - $$ nest 8 (commafy (pprStatics dflags ds)) + $$ nest 8 (commafy (pprStatics platform ds)) $$ text "};" - where - platform = targetPlatform dflags pprAlignment :: Width -> SDoc pprAlignment words = @@ -203,9 +194,8 @@ pprConstness is_ro | is_ro = text "const " -- Statements. -- -pprStmt :: DynFlags -> CmmNode e x -> SDoc - -pprStmt dflags stmt = +pprStmt :: Platform -> CmmNode e x -> SDoc +pprStmt platform stmt = case stmt of CmmEntry{} -> empty CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/") @@ -217,19 +207,18 @@ pprStmt dflags stmt = CmmTick _ -> empty CmmUnwind{} -> empty - CmmAssign dest src -> pprAssign dflags dest src + CmmAssign dest src -> pprAssign platform dest src CmmStore dest src | typeWidth rep == W64 && wordWidth platform /= W64 -> (if isFloatType rep then text "ASSIGN_DBL" else ptext (sLit ("ASSIGN_Word64"))) <> - parens (mkP_ <> pprExpr1 dflags dest <> comma <> pprExpr dflags src) <> semi + parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi | otherwise - -> hsep [ pprExpr dflags (CmmLoad dest rep), equals, pprExpr dflags src <> semi ] + -> hsep [ pprExpr platform (CmmLoad dest rep), equals, pprExpr platform src <> semi ] where rep = cmmExprType platform src - platform = targetPlatform dflags CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args -> fnCall @@ -237,29 +226,28 @@ pprStmt dflags stmt = (res_hints, arg_hints) = foreignTargetHints target hresults = zip results res_hints hargs = zip args arg_hints - platform = targetPlatform dflags ForeignConvention cconv _ _ ret = conv - cast_fn = parens (cCast dflags (pprCFunType platform (char '*') cconv hresults hargs) fn) + cast_fn = parens (cCast platform (pprCFunType platform (char '*') cconv hresults hargs) fn) -- See wiki:commentary/compiler/backends/ppr-c#prototypes fnCall = case fn of CmmLit (CmmLabel lbl) | StdCallConv <- cconv -> - pprCall dflags (ppr lbl) cconv hresults hargs + pprCall platform (ppr lbl) cconv hresults hargs -- stdcall functions must be declared with -- a function type, otherwise the C compiler -- doesn't add the @n suffix to the label. We -- can't add the @n suffix ourselves, because -- it isn't valid C. | CmmNeverReturns <- ret -> - pprCall dflags cast_fn cconv hresults hargs <> semi + pprCall platform cast_fn cconv hresults hargs <> semi | not (isMathFun lbl) -> - pprForeignCall dflags (ppr lbl) cconv hresults hargs + pprForeignCall platform (ppr lbl) cconv hresults hargs _ -> - pprCall dflags cast_fn cconv hresults hargs <> semi + pprCall platform cast_fn cconv hresults hargs <> semi -- for a dynamic call, no declaration is necessary. CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty @@ -282,28 +270,27 @@ pprStmt dflags stmt = -- builtins (see bug #5967). | Just _align <- machOpMemcpyishAlign op = (text ";EFF_(" <> fn <> char ')' <> semi) $$ - pprForeignCall dflags fn cconv hresults hargs + pprForeignCall platform fn cconv hresults hargs | otherwise - = pprCall dflags fn cconv hresults hargs + = pprCall platform fn cconv hresults hargs CmmBranch ident -> pprBranch ident - CmmCondBranch expr yes no _ -> pprCondBranch dflags expr yes no - CmmCall { cml_target = expr } -> mkJMP_ (pprExpr dflags expr) <> semi - CmmSwitch arg ids -> pprSwitch dflags arg ids + CmmCondBranch expr yes no _ -> pprCondBranch platform expr yes no + CmmCall { cml_target = expr } -> mkJMP_ (pprExpr platform expr) <> semi + CmmSwitch arg ids -> pprSwitch platform arg ids _other -> pprPanic "PprC.pprStmt" (ppr stmt) type Hinted a = (a, ForeignHint) -pprForeignCall :: DynFlags -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] +pprForeignCall :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc -pprForeignCall dflags fn cconv results args = fn_call +pprForeignCall platform fn cconv results args = fn_call where - platform = targetPlatform dflags fn_call = braces ( pprCFunType platform (char '*' <> text "ghcFunPtr") cconv results args <> semi $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi - $$ pprCall dflags (text "ghcFunPtr") cconv results args <> semi + $$ pprCall platform (text "ghcFunPtr") cconv results args <> semi ) cast_fn = parens (parens (pprCFunType platform (char '*') cconv results args) <> fn) @@ -326,9 +313,9 @@ pprBranch ident = text "goto" <+> pprBlockId ident <> semi -- --------------------------------------------------------------------- -- conditional branches to local labels -pprCondBranch :: DynFlags -> CmmExpr -> BlockId -> BlockId -> SDoc -pprCondBranch dflags expr yes no - = hsep [ text "if" , parens(pprExpr dflags expr) , +pprCondBranch :: Platform -> CmmExpr -> BlockId -> BlockId -> SDoc +pprCondBranch platform expr yes no + = hsep [ text "if" , parens (pprExpr platform expr) , text "goto", pprBlockId yes <> semi, text "else goto", pprBlockId no <> semi ] @@ -337,23 +324,22 @@ pprCondBranch dflags expr yes no -- -- we find the fall-through cases -- -pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc -pprSwitch dflags e ids - = (hang (text "switch" <+> parens ( pprExpr dflags e ) <+> lbrace) +pprSwitch :: Platform -> CmmExpr -> SwitchTargets -> SDoc +pprSwitch platform e ids + = (hang (text "switch" <+> parens ( pprExpr platform e ) <+> lbrace) 4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace where (pairs, mbdef) = switchTargetsFallThrough ids - platform = targetPlatform dflags -- fall through case caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix where do_fallthrough ix = - hsep [ text "case" , pprHexVal dflags ix (wordWidth platform) <> colon , + hsep [ text "case" , pprHexVal platform ix (wordWidth platform) <> colon , text "/* fall through */" ] final_branch ix = - hsep [ text "case" , pprHexVal dflags ix (wordWidth platform) <> colon , + hsep [ text "case" , pprHexVal platform ix (wordWidth platform) <> colon , text "goto" , (pprBlockId ident) <> semi ] caseify (_ , _ ) = panic "pprSwitch: switch with no cases!" @@ -375,30 +361,28 @@ pprSwitch dflags e ids -- -- (similar invariants apply to the rest of the pretty printer). -pprExpr :: DynFlags -> CmmExpr -> SDoc -pprExpr dflags e = case e of - CmmLit lit -> pprLit dflags lit - CmmLoad e ty -> pprLoad dflags e ty +pprExpr :: Platform -> CmmExpr -> SDoc +pprExpr platform e = case e of + CmmLit lit -> pprLit platform lit + CmmLoad e ty -> pprLoad platform e ty CmmReg reg -> pprCastReg reg CmmRegOff reg 0 -> pprCastReg reg -- CmmRegOff is an alias of MO_Add CmmRegOff reg i -> pprCastReg reg <> char '+' <> - pprHexVal dflags (fromIntegral i) (wordWidth platform) + pprHexVal platform (fromIntegral i) (wordWidth platform) - CmmMachOp mop args -> pprMachOpApp dflags mop args + CmmMachOp mop args -> pprMachOpApp platform mop args CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!" - where - platform = targetPlatform dflags -pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc -pprLoad dflags e ty +pprLoad :: Platform -> CmmExpr -> CmmType -> SDoc +pprLoad platform e ty | width == W64, wordWidth platform /= W64 = (if isFloatType ty then text "PK_DBL" else text "PK_Word64") - <> parens (mkP_ <> pprExpr1 dflags e) + <> parens (mkP_ <> pprExpr1 platform e) | otherwise = case e of @@ -414,34 +398,33 @@ pprLoad dflags e ty -- (For tagging to work, I had to avoid unaligned loads. --ARY) -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift platform)) - _other -> cLoad dflags e ty + _other -> cLoad platform e ty where width = typeWidth ty - platform = targetPlatform dflags -pprExpr1 :: DynFlags -> CmmExpr -> SDoc -pprExpr1 dflags e = case e of - CmmLit lit -> pprLit1 dflags lit - CmmReg _reg -> pprExpr dflags e - _ -> parens (pprExpr dflags e) +pprExpr1 :: Platform -> CmmExpr -> SDoc +pprExpr1 platform e = case e of + CmmLit lit -> pprLit1 platform lit + CmmReg _reg -> pprExpr platform e + _ -> parens (pprExpr platform e) -- -------------------------------------------------------------------------- -- MachOp applications -pprMachOpApp :: DynFlags -> MachOp -> [CmmExpr] -> SDoc +pprMachOpApp :: Platform -> MachOp -> [CmmExpr] -> SDoc -pprMachOpApp dflags op args +pprMachOpApp platform op args | isMulMayOfloOp op - = text "mulIntMayOflo" <> parens (commafy (map (pprExpr dflags) args)) + = text "mulIntMayOflo" <> parens (commafy (map (pprExpr platform) args)) where isMulMayOfloOp (MO_U_MulMayOflo _) = True isMulMayOfloOp (MO_S_MulMayOflo _) = True isMulMayOfloOp _ = False -pprMachOpApp dflags mop args +pprMachOpApp platform mop args | Just ty <- machOpNeedsCast mop - = ty <> parens (pprMachOpApp' dflags mop args) + = ty <> parens (pprMachOpApp' platform mop args) | otherwise - = pprMachOpApp' dflags mop args + = pprMachOpApp' platform mop args -- Comparisons in C have type 'int', but we want type W_ (this is what -- resultRepOfMachOp says). The other C operations inherit their type @@ -451,8 +434,8 @@ machOpNeedsCast mop | isComparisonMachOp mop = Just mkW_ | otherwise = Nothing -pprMachOpApp' :: DynFlags -> MachOp -> [CmmExpr] -> SDoc -pprMachOpApp' dflags mop args +pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc +pprMachOpApp' platform mop args = case args of -- dyadic [x,y] -> pprArg x <+> pprMachOp_for_C platform mop <+> pprArg y @@ -463,11 +446,10 @@ pprMachOpApp' dflags mop args _ -> panic "PprC.pprMachOp : machop with wrong number of args" where - platform = targetPlatform dflags -- Cast needed for signed integer ops - pprArg e | signedOp mop = cCast dflags (machRep_S_CType platform (typeWidth (cmmExprType platform e))) e - | needsFCasts mop = cCast dflags (machRep_F_CType (typeWidth (cmmExprType platform e))) e - | otherwise = pprExpr1 dflags e + pprArg e | signedOp mop = cCast platform (machRep_S_CType platform (typeWidth (cmmExprType platform e))) e + | needsFCasts mop = cCast platform (machRep_F_CType (typeWidth (cmmExprType platform e))) e + | otherwise = pprExpr1 platform e needsFCasts (MO_F_Eq _) = False needsFCasts (MO_F_Ne _) = False needsFCasts (MO_F_Neg _) = True @@ -477,9 +459,9 @@ pprMachOpApp' dflags mop args -- -------------------------------------------------------------------------- -- Literals -pprLit :: DynFlags -> CmmLit -> SDoc -pprLit dflags lit = case lit of - CmmInt i rep -> pprHexVal dflags i rep +pprLit :: Platform -> CmmLit -> SDoc +pprLit platform lit = case lit of + CmmInt i rep -> pprHexVal platform i rep CmmFloat f w -> parens (machRep_F_CType w) <> str where d = fromRational f :: Double @@ -505,38 +487,37 @@ pprLit dflags lit = case lit of where pprCLabelAddr lbl = char '&' <> ppr lbl -pprLit1 :: DynFlags -> CmmLit -> SDoc -pprLit1 dflags lit = case lit of - (CmmLabelOff _ _) -> parens (pprLit dflags lit) - (CmmLabelDiffOff _ _ _ _) -> parens (pprLit dflags lit) - (CmmFloat _ _) -> parens (pprLit dflags lit) - _ -> pprLit dflags lit +pprLit1 :: Platform -> CmmLit -> SDoc +pprLit1 platform lit = case lit of + (CmmLabelOff _ _) -> parens (pprLit platform lit) + (CmmLabelDiffOff _ _ _ _) -> parens (pprLit platform lit) + (CmmFloat _ _) -> parens (pprLit platform lit) + _ -> pprLit platform lit -- --------------------------------------------------------------------------- -- Static data -pprStatics :: DynFlags -> [CmmStatic] -> [SDoc] -pprStatics dflags = pprStatics' +pprStatics :: Platform -> [CmmStatic] -> [SDoc] +pprStatics platform = pprStatics' where - platform = targetPlatform dflags pprStatics' = \case [] -> [] (CmmStaticLit (CmmFloat f W32) : rest) -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding | wordWidth platform == W64, CmmStaticLit (CmmInt 0 W32) : rest' <- rest - -> pprLit1 dflags (floatToWord platform f) : pprStatics' rest' + -> pprLit1 platform (floatToWord platform f) : pprStatics' rest' -- adjacent floats aren't padded but combined into a single word | wordWidth platform == W64, CmmStaticLit (CmmFloat g W32) : rest' <- rest - -> pprLit1 dflags (floatPairToWord platform f g) : pprStatics' rest' + -> pprLit1 platform (floatPairToWord platform f g) : pprStatics' rest' | wordWidth platform == W32 - -> pprLit1 dflags (floatToWord platform f) : pprStatics' rest + -> pprLit1 platform (floatToWord platform f) : pprStatics' rest | otherwise -> pprPanic "pprStatics: float" (vcat (map ppr' rest)) where ppr' (CmmStaticLit l) = ppr (cmmLitType platform l) ppr' _other = text "bad static!" (CmmStaticLit (CmmFloat f W64) : rest) - -> map (pprLit1 dflags) (doubleToWords platform f) ++ pprStatics' rest + -> map (pprLit1 platform) (doubleToWords platform f) ++ pprStatics' rest (CmmStaticLit (CmmInt i W64) : rest) | wordWidth platform == W32 @@ -565,15 +546,15 @@ pprStatics dflags = pprStatics' -> pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w) (CmmStaticLit lit : rest) - -> pprLit1 dflags lit : pprStatics' rest + -> pprLit1 platform lit : pprStatics' rest (other : _) - -> pprPanic "pprStatics: other" (pprStatic dflags other) + -> pprPanic "pprStatics: other" (pprStatic platform other) -pprStatic :: DynFlags -> CmmStatic -> SDoc -pprStatic dflags s = case s of +pprStatic :: Platform -> CmmStatic -> SDoc +pprStatic platform s = case s of - CmmStaticLit lit -> nest 4 (pprLit dflags lit) + CmmStaticLit lit -> nest 4 (pprLit platform lit) CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i)) -- these should be inlined, like the old .hc @@ -881,7 +862,7 @@ mkP_ = text "(P_)" -- StgWord* -- -- Generating assignments is what we're all about, here -- -pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc +pprAssign :: Platform -> CmmReg -> CmmExpr -> SDoc -- dest is a reg, rhs is a reg pprAssign _ r1 (CmmReg r2) @@ -889,11 +870,10 @@ pprAssign _ r1 (CmmReg r2) = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ] -- dest is a reg, rhs is a CmmRegOff -pprAssign dflags r1 (CmmRegOff r2 off) +pprAssign platform r1 (CmmRegOff r2 off) | isPtrReg r1 && isPtrReg r2 && (off `rem` platformWordSizeInBytes platform == 0) = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ] where - platform = targetPlatform dflags off1 = off `shiftR` wordShift platform (op,off') | off >= 0 = (char '+', off1) @@ -902,10 +882,10 @@ pprAssign dflags r1 (CmmRegOff r2 off) -- dest is a reg, rhs is anything. -- We can't cast the lvalue, so we have to cast the rhs if necessary. Casting -- the lvalue elicits a warning from new GCC versions (3.4+). -pprAssign dflags r1 r2 - | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 dflags r2) - | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 dflags r2) - | otherwise = mkAssign (pprExpr dflags r2) +pprAssign platform r1 r2 + | isFixedPtrReg r1 = mkAssign (mkP_ <> pprExpr1 platform r2) + | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 platform r2) + | otherwise = mkAssign (pprExpr platform r2) where mkAssign x = if r1 == CmmGlobal BaseReg then text "ASSIGN_BaseReg" <> parens x <> semi else pprReg r1 <> text " = " <> x <> semi @@ -1004,8 +984,8 @@ pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq -- ----------------------------------------------------------------------------- -- Foreign Calls -pprCall :: DynFlags -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc -pprCall dflags ppr_fn cconv results args +pprCall :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc +pprCall platform ppr_fn cconv results args | not (is_cishCC cconv) = panic $ "pprCall: unknown calling convention" @@ -1013,8 +993,6 @@ pprCall dflags ppr_fn cconv results args = ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi where - platform = targetPlatform dflags - ppr_assign [] rhs = rhs ppr_assign [(one,hint)] rhs = pprLocalReg one <> text " = " @@ -1022,12 +1000,12 @@ pprCall dflags ppr_fn cconv results args ppr_assign _other _rhs = panic "pprCall: multiple results" pprArg (expr, AddrHint) - = cCast dflags (text "void *") expr + = cCast platform (text "void *") expr -- see comment by machRepHintCType below pprArg (expr, SignedHint) - = cCast dflags (machRep_S_CType platform $ typeWidth $ cmmExprType platform expr) expr + = cCast platform (machRep_S_CType platform $ typeWidth $ cmmExprType platform expr) expr pprArg (expr, _other) - = pprExpr dflags expr + = pprExpr platform expr pprUnHint AddrHint rep = parens (machRepCType platform rep) pprUnHint SignedHint rep = parens (machRepCType platform rep) @@ -1159,18 +1137,18 @@ te_Reg _ = return () -- --------------------------------------------------------------------- -- C types for MachReps -cCast :: DynFlags -> SDoc -> CmmExpr -> SDoc -cCast dflags ty expr = parens ty <> pprExpr1 dflags expr +cCast :: Platform -> SDoc -> CmmExpr -> SDoc +cCast platform ty expr = parens ty <> pprExpr1 platform expr -cLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc -cLoad dflags expr rep +cLoad :: Platform -> CmmExpr -> CmmType -> SDoc +cLoad platform expr rep = if bewareLoadStoreAlignment (platformArch platform) then let decl = machRepCType platform rep <+> text "x" <> semi struct = text "struct" <+> braces (decl) packed_attr = text "__attribute__((packed))" cast = parens (struct <+> packed_attr <> char '*') - in parens (cast <+> pprExpr1 dflags expr) <> text "->x" - else char '*' <> parens (cCast dflags (machRepPtrCType platform rep) expr) + in parens (cast <+> pprExpr1 platform expr) <> text "->x" + else char '*' <> parens (cCast platform (machRepPtrCType platform rep) expr) where -- On these platforms, unaligned loads are known to cause problems bewareLoadStoreAlignment ArchAlpha = True bewareLoadStoreAlignment ArchMipseb = True @@ -1183,7 +1161,6 @@ cLoad dflags expr rep -- on unknown arches bewareLoadStoreAlignment ArchUnknown = True bewareLoadStoreAlignment _ = False - platform = targetPlatform dflags isCmmWordType :: Platform -> CmmType -> Bool -- True of GcPtrReg/NonGcReg of native word size @@ -1345,8 +1322,8 @@ commafy :: [SDoc] -> SDoc commafy xs = hsep $ punctuate comma xs -- Print in C hex format: 0x13fa -pprHexVal :: DynFlags -> Integer -> Width -> SDoc -pprHexVal dflags w rep +pprHexVal :: Platform -> Integer -> Width -> SDoc +pprHexVal platform w rep | w < 0 = parens (char '-' <> text "0x" <> intToDoc (-w) <> repsuffix rep) | otherwise = text "0x" <> intToDoc w <> repsuffix rep @@ -1357,10 +1334,12 @@ pprHexVal dflags w rep -- times values are unsigned. This also helps eliminate occasional -- warnings about integer overflow from gcc. + constants = platformConstants platform + repsuffix W64 = - if cINT_SIZE dflags == 8 then char 'U' - else if cLONG_SIZE dflags == 8 then text "UL" - else if cLONG_LONG_SIZE dflags == 8 then text "ULL" + if pc_CINT_SIZE constants == 8 then char 'U' + else if pc_CLONG_SIZE constants == 8 then text "UL" + else if pc_CLONG_LONG_SIZE constants == 8 then text "ULL" else panic "pprHexVal: Can't find a 64-bit type" repsuffix _ = char 'U' diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs index ac8e9718e4..13a557dcd9 100644 --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -159,8 +159,8 @@ cmmLlvmGen ::RawCmmDecl -> LlvmM () cmmLlvmGen cmm@CmmProc{} = do -- rewrite assignments to global regs - dflags <- getDynFlags - let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters dflags cmm + platform <- getPlatform + let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters platform cmm dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM (pprCmmGroup [fixed_cmm]) diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index 40866f7f8b..8ba378521d 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -19,13 +19,15 @@ import GHC.ByteCode.Instr import GHC.ByteCode.Asm import GHC.ByteCode.Types +import GHC.Platform +import GHC.Platform.Profile + import GHC.Runtime.Interpreter import GHCi.FFI import GHCi.RemoteTypes import GHC.Types.Basic import GHC.Driver.Session import GHC.Utils.Outputable -import GHC.Platform import GHC.Types.Name import GHC.Types.Id.Make import GHC.Types.Id @@ -241,7 +243,7 @@ ppBCEnv p -- Create a BCO and do a spot of peephole optimisation on the insns -- at the same time. mkProtoBCO - :: DynFlags + :: Platform -> name -> BCInstrList -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet) @@ -252,7 +254,7 @@ mkProtoBCO -> Bool -- True <=> is a return point, rather than a function -> [FFIInfo] -> ProtoBCO name -mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis +mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis = ProtoBCO { protoBCOName = nm, protoBCOInstrs = maybe_with_stack_check, @@ -271,7 +273,7 @@ mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis -- (hopefully rare) cases when the (overestimated) stack use -- exceeds iNTERP_STACK_CHECK_THRESH. maybe_with_stack_check - | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d + | is_ret && stack_usage < fromIntegral (pc_AP_STACK_SPLIM (platformConstants platform)) = peep_d -- don't do stack checks at return points, -- everything is aggregated up to the top BCO -- (which must be a function). @@ -312,7 +314,7 @@ schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name) schemeTopBind (id, rhs) | Just data_con <- isDataConWorkId_maybe id, isNullaryRepDataCon data_con = do - dflags <- getDynFlags + platform <- profilePlatform <$> getProfile -- Special case for the worker of a nullary data con. -- It'll look like this: Nil = /\a -> Nil a -- If we feed it into schemeR, we'll get @@ -321,7 +323,7 @@ schemeTopBind (id, rhs) -- by just re-using the single top-level definition. So -- for the worker itself, we must allocate it directly. -- ioToBc (putStrLn $ "top level BCO") - emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER]) + emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, ENTER]) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) | otherwise @@ -380,9 +382,9 @@ schemeR_wrk -> BcM (ProtoBCO Name) schemeR_wrk fvs nm original_body (args, body) = do - dflags <- getDynFlags + profile <- getProfile let - platform = targetPlatform dflags + platform = profilePlatform profile all_args = reverse args ++ fvs arity = length all_args -- all_args are the args in reverse order. We're compiling a function @@ -401,7 +403,7 @@ schemeR_wrk fvs nm original_body (args, body) bitmap = mkBitmap platform bits body_code <- schemeER_wrk sum_szsb_args p_init body - emitBc (mkProtoBCO dflags nm body_code (Right original_body) + emitBc (mkProtoBCO platform nm body_code (Right original_body) arity bitmap_size bitmap False{-not alts-}) -- introduce break instructions for ticked expressions @@ -411,8 +413,7 @@ schemeER_wrk d p rhs = do code <- schemeE d 0 p newRhs cc_arr <- getCCArray this_mod <- moduleName <$> getCurrentModule - dflags <- getDynFlags - let platform = targetPlatform dflags + platform <- profilePlatform <$> getProfile let idOffSets = getVarOffSets platform d p fvs let breakInfo = CgBreakInfo { cgb_vars = idOffSets @@ -879,8 +880,8 @@ mkConAppCode orig_d _ p con args_r_to_l = ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code where app_code = do - dflags <- getDynFlags - let platform = targetPlatform dflags + profile <- getProfile + let platform = profilePlatform profile -- The args are initially in reverse order, but mkVirtHeapOffsets -- expects them to be left-to-right. @@ -891,7 +892,7 @@ mkConAppCode orig_d _ p con args_r_to_l = , not (isVoidRep prim_rep) ] (_, _, args_offsets) = - mkVirtHeapOffsetsWithPadding dflags StdHeader non_voids + mkVirtHeapOffsetsWithPadding profile StdHeader non_voids do_pushery !d (arg : args) = do (push, arg_bytes) <- case arg of @@ -1000,10 +1001,11 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple | otherwise = do - dflags <- getDynFlags + profile <- getProfile hsc_env <- getHscEnv let - platform = targetPlatform dflags + platform = profilePlatform profile + profiling | Just interp <- hsc_interp hsc_env = interpreterProfiled interp @@ -1064,7 +1066,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple -- algebraic alt with some binders | otherwise = let (tot_wds, _ptrs_wds, args_offsets) = - mkVirtHeapOffsets dflags NoHeader + mkVirtHeapOffsets profile NoHeader [ NonVoid (bcIdPrimRep id, id) | NonVoid id <- nonVoidIds real_bndrs ] @@ -1139,7 +1141,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple let alt_bco_name = getName bndr - alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts) + alt_bco = mkProtoBCO platform alt_bco_name alt_final (Left alts) 0{-no arity-} bitmap_size bitmap True{-is alts-} -- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++ -- "\n bitmap = " ++ show bitmap) $ do @@ -1173,10 +1175,10 @@ generateCCall -> BcM BCInstrList generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l = do - dflags <- getDynFlags + profile <- getProfile let - platform = targetPlatform dflags + platform = profilePlatform profile -- useful constants addr_size_b :: ByteOff addr_size_b = wordSize platform @@ -1198,17 +1200,17 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l Just t | t == arrayPrimTyCon || t == mutableArrayPrimTyCon -> do rest <- pargs (d + addr_size_b) az - code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a + code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize profile)) d p a return ((code,AddrRep):rest) | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon -> do rest <- pargs (d + addr_size_b) az - code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a + code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize profile)) d p a return ((code,AddrRep):rest) | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon -> do rest <- pargs (d + addr_size_b) az - code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a + code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize profile)) d p a return ((code,AddrRep):rest) -- Default case: push taggedly, but otherwise intact. @@ -2016,6 +2018,9 @@ instance HasDynFlags BcM where getHscEnv :: BcM HscEnv getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st) +getProfile :: BcM Profile +getProfile = targetProfile <$> getDynFlags + emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name) emitBc bco = BcM $ \st -> return (st{ffis=[]}, bco (ffis st)) diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index 5cc502a715..e4157eee8a 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -24,7 +24,7 @@ import GHC.Types.Unique.Supply ( mkSplitUniqSupply ) import GHC.Driver.Finder ( mkStubPaths ) import GHC.Driver.Backend -import GHC.CmmToC ( writeC ) +import GHC.CmmToC ( cmmToC ) import GHC.Cmm.Lint ( cmmLint ) import GHC.Cmm ( RawCmmGroup ) import GHC.Cmm.CLabel @@ -146,7 +146,9 @@ outputC dflags filenm cmm_stream packages doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") hPutStr h cc_injects - Stream.consume cmm_stream (writeC dflags h) + let platform = targetPlatform dflags + writeC = printForC dflags h . cmmToC platform + Stream.consume cmm_stream writeC {- ************************************************************************ diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index ccbd524e55..1603c38e71 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -894,16 +894,18 @@ llvmOptions dflags = | WayDyn `elem` ways dflags = "dynamic-no-pic" | otherwise = "static" + platform = targetPlatform dflags + align :: Int - align = case platformArch (targetPlatform dflags) of + align = case platformArch platform of ArchX86_64 | isAvxEnabled dflags -> 32 _ -> 0 attrs :: String attrs = intercalate "," $ mattr ++ ["+sse42" | isSse4_2Enabled dflags ] - ++ ["+sse2" | isSse2Enabled dflags ] - ++ ["+sse" | isSseEnabled dflags ] + ++ ["+sse2" | isSse2Enabled platform ] + ++ ["+sse" | isSseEnabled platform ] ++ ["+avx512f" | isAvx512fEnabled dflags ] ++ ["+avx2" | isAvx2Enabled dflags ] ++ ["+avx" | isAvxEnabled dflags ] @@ -1977,9 +1979,10 @@ doCpp dflags raw input_fn output_fn = do let cpp_prog args | raw = GHC.SysTools.runCpp dflags args | otherwise = GHC.SysTools.runCc Nothing dflags (GHC.SysTools.Option "-E" : args) - let targetArch = stringEncodeArch $ platformArch $ targetPlatform dflags - targetOS = stringEncodeOS $ platformOS $ targetPlatform dflags - isWindows = (platformOS $ targetPlatform dflags) == OSMinGW32 + let platform = targetPlatform dflags + targetArch = stringEncodeArch $ platformArch platform + targetOS = stringEncodeOS $ platformOS platform + isWindows = platformOS platform == OSMinGW32 let target_defs = [ "-D" ++ HOST_OS ++ "_BUILD_OS", "-D" ++ HOST_ARCH ++ "_BUILD_ARCH", @@ -1993,8 +1996,8 @@ doCpp dflags raw input_fn output_fn = do [ "-D__IO_MANAGER_MIO__=1" ] let sse_defs = - [ "-D__SSE__" | isSseEnabled dflags ] ++ - [ "-D__SSE2__" | isSse2Enabled dflags ] ++ + [ "-D__SSE__" | isSseEnabled platform ] ++ + [ "-D__SSE2__" | isSse2Enabled platform ] ++ [ "-D__SSE4_2__" | isSse4_2Enabled dflags ] let avx_defs = diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs index 9cbe60a36a..6d6a976856 100644 --- a/compiler/GHC/Driver/Plugins.hs +++ b/compiler/GHC/Driver/Plugins.hs @@ -49,7 +49,7 @@ module GHC.Driver.Plugins ( import GHC.Prelude -import {-# SOURCE #-} GHC.Core.Opt.Monad ( CoreToDo, CoreM ) +import GHC.Core.Opt.Monad ( CoreToDo, CoreM ) import qualified GHC.Tc.Types import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports ) import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR ) diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 8c41a4ca4f..2c2c3db7c2 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -197,11 +197,7 @@ module GHC.Driver.Session ( -- * Compiler configuration suitable for display to the user compilerInfo, -#include "GHCConstantsHaskellExports.hs" - bLOCK_SIZE_W, wordAlignment, - tAG_MASK, - mAX_PTR_TAG, unsafeGlobalDynFlags, setUnsafeGlobalDynFlags, @@ -240,6 +236,8 @@ module GHC.Driver.Session ( import GHC.Prelude import GHC.Platform +import GHC.Platform.Ways +import GHC.Platform.Profile import GHC.UniqueSubdir (uniqueSubdir) import GHC.Unit.Types import GHC.Unit.Parser @@ -250,7 +248,6 @@ import GHC.Builtin.Names ( mAIN ) import {-# SOURCE #-} GHC.Unit.State (UnitState, emptyUnitState, UnitDatabase, updateIndefUnitId) import GHC.Driver.Phases ( Phase(..), phaseInputExt ) import GHC.Driver.Flags -import GHC.Platform.Ways import GHC.Driver.Backend import GHC.Settings.Config import GHC.Utils.CliOption @@ -288,7 +285,6 @@ import Control.Monad.Trans.Reader import Control.Monad.Trans.Except import Data.Ord -import Data.Bits import Data.Char import Data.List import Data.Map (Map) @@ -4837,7 +4833,7 @@ compilerInfo dflags -- Whether or not we support the @-this-unit-id@ flag ("Uses unit IDs", "YES"), -- Whether or not GHC compiles libraries as dynamic by default - ("Dynamic by default", showBool $ dYNAMIC_BY_DEFAULT dflags), + ("Dynamic by default", showBool $ pc_DYNAMIC_BY_DEFAULT constants), -- Whether or not GHC was compiled using -dynamic ("GHC Dynamic", showBool hostIsDynamic), -- Whether or not GHC was compiled using -prof @@ -4850,16 +4846,12 @@ compilerInfo dflags where showBool True = "YES" showBool False = "NO" - isWindows = platformOS (targetPlatform dflags) == OSMinGW32 + platform = targetPlatform dflags + constants = platformConstants platform + isWindows = platformOS platform == OSMinGW32 expandDirectories :: FilePath -> Maybe FilePath -> String -> String expandDirectories topd mtoold = expandToolDir mtoold . expandTopDir topd --- Produced by deriveConstants -#include "GHCConstantsHaskellWrappers.hs" - -bLOCK_SIZE_W :: DynFlags -> Int -bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` platformWordSizeInBytes platform - where platform = targetPlatform dflags wordAlignment :: Platform -> Alignment wordAlignment platform = alignmentOf (platformWordSizeInBytes platform) @@ -4868,12 +4860,6 @@ wordAlignment platform = alignmentOf (platformWordSizeInBytes platform) targetProfile :: DynFlags -> Profile targetProfile dflags = Profile (targetPlatform dflags) (ways dflags) -tAG_MASK :: DynFlags -> Int -tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 - -mAX_PTR_TAG :: DynFlags -> Int -mAX_PTR_TAG = tAG_MASK - {- ----------------------------------------------------------------------------- Note [DynFlags consistency] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -5014,14 +5000,14 @@ setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags -- check if SSE is enabled, we might have x86-64 imply the -msse2 -- flag. -isSseEnabled :: DynFlags -> Bool -isSseEnabled dflags = case platformArch (targetPlatform dflags) of +isSseEnabled :: Platform -> Bool +isSseEnabled platform = case platformArch platform of ArchX86_64 -> True ArchX86 -> True _ -> False -isSse2Enabled :: DynFlags -> Bool -isSse2Enabled dflags = case platformArch (targetPlatform dflags) of +isSse2Enabled :: Platform -> Bool +isSse2Enabled platform = case platformArch platform of -- We Assume SSE1 and SSE2 operations are available on both -- x86 and x86_64. Historically we didn't default to SSE2 and -- SSE1 on x86, which results in defacto nondeterminism for how @@ -5073,7 +5059,7 @@ isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of -- | Indicate if cost-centre profiling is enabled sccProfilingEnabled :: DynFlags -> Bool -sccProfilingEnabled dflags = ways dflags `hasWay` WayProf +sccProfilingEnabled dflags = profileIsProfiling (targetProfile dflags) -- ----------------------------------------------------------------------------- -- Linker/compiler information diff --git a/compiler/GHC/Platform/Profile.hs b/compiler/GHC/Platform/Profile.hs index d484a1ebc4..5875e5d56d 100644 --- a/compiler/GHC/Platform/Profile.hs +++ b/compiler/GHC/Platform/Profile.hs @@ -2,6 +2,9 @@ module GHC.Platform.Profile ( Profile (..) , profileBuildTag + , profileConstants + , profileIsProfiling + , profileWordSizeInBytes ) where @@ -23,6 +26,21 @@ data Profile = Profile , profileWays :: !(Set Way) -- ^ Ways } +-- | Get platform constants +profileConstants :: Profile -> PlatformConstants +{-# INLINE profileConstants #-} +profileConstants profile = platformConstants (profilePlatform profile) + +-- | Is profiling enabled +profileIsProfiling :: Profile -> Bool +{-# INLINE profileIsProfiling #-} +profileIsProfiling profile = profileWays profile `hasWay` WayProf + +-- | Word size in bytes +profileWordSizeInBytes :: Profile -> Int +{-# INLINE profileWordSizeInBytes #-} +profileWordSizeInBytes profile = platformWordSizeInBytes (profilePlatform profile) + -- | Unique build tag for the profile profileBuildTag :: Profile -> String profileBuildTag profile diff --git a/compiler/GHC/Runtime/Heap/Layout.hs b/compiler/GHC/Runtime/Heap/Layout.hs index a092b04a22..cd09ad0163 100644 --- a/compiler/GHC/Runtime/Heap/Layout.hs +++ b/compiler/GHC/Runtime/Heap/Layout.hs @@ -50,6 +50,7 @@ import GHC.Types.Basic( ConTagZ ) import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Platform +import GHC.Platform.Profile import GHC.Data.FastString import GHC.StgToCmm.Types @@ -197,9 +198,9 @@ type SelectorOffset = Int ----------------------------------------------------------------------------- -- Construction -mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo +mkHeapRep :: Profile -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo -> SMRep -mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info +mkHeapRep profile is_static ptr_wds nonptr_wds cl_type_info = HeapRep is_static ptr_wds (nonptr_wds + slop_wds) @@ -207,9 +208,9 @@ mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info where slop_wds | is_static = 0 - | otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size)) + | otherwise = max 0 (minClosureSize profile - (hdr_size + payload_size)) - hdr_size = closureTypeHdrSize dflags cl_type_info + hdr_size = closureTypeHdrSize profile cl_type_info payload_size = ptr_wds + nonptr_wds mkRTSRep :: Int -> SMRep -> SMRep @@ -224,8 +225,8 @@ blackHoleRep = HeapRep False 0 0 BlackHole indStaticRep :: SMRep indStaticRep = HeapRep True 1 0 IndStatic -arrPtrsRep :: DynFlags -> WordOff -> SMRep -arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems) +arrPtrsRep :: Platform -> WordOff -> SMRep +arrPtrsRep platform elems = ArrayPtrsRep elems (cardTableSizeW platform elems) smallArrPtrsRep :: WordOff -> SMRep smallArrPtrsRep elems = SmallArrayPtrsRep elems @@ -271,71 +272,79 @@ isStaticNoCafCon _ = False ----------------------------------------------------------------------------- -- Size-related things -fixedHdrSize :: DynFlags -> ByteOff -fixedHdrSize dflags = wordsToBytes (targetPlatform dflags) (fixedHdrSizeW dflags) +fixedHdrSize :: Profile -> ByteOff +fixedHdrSize profile = wordsToBytes (profilePlatform profile) (fixedHdrSizeW profile) -- | Size of a closure header (StgHeader in includes\/rts\/storage\/Closures.h) -fixedHdrSizeW :: DynFlags -> WordOff -fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags +fixedHdrSizeW :: Profile -> WordOff +fixedHdrSizeW profile = pc_STD_HDR_SIZE (profileConstants profile) + profHdrSize profile -- | Size of the profiling part of a closure header -- (StgProfHeader in includes\/rts\/storage\/Closures.h) -profHdrSize :: DynFlags -> WordOff -profHdrSize dflags - | sccProfilingEnabled dflags = pROF_HDR_SIZE dflags - | otherwise = 0 +profHdrSize :: Profile -> WordOff +profHdrSize profile = + if profileIsProfiling profile + then pc_PROF_HDR_SIZE (profileConstants profile) + else 0 -- | The garbage collector requires that every closure is at least as -- big as this. -minClosureSize :: DynFlags -> WordOff -minClosureSize dflags = fixedHdrSizeW dflags + mIN_PAYLOAD_SIZE dflags - -arrWordsHdrSize :: DynFlags -> ByteOff -arrWordsHdrSize dflags - = fixedHdrSize dflags + sIZEOF_StgArrBytes_NoHdr dflags - -arrWordsHdrSizeW :: DynFlags -> WordOff -arrWordsHdrSizeW dflags = - fixedHdrSizeW dflags + - (sIZEOF_StgArrBytes_NoHdr dflags `quot` - platformWordSizeInBytes (targetPlatform dflags)) - -arrPtrsHdrSize :: DynFlags -> ByteOff -arrPtrsHdrSize dflags - = fixedHdrSize dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags - -arrPtrsHdrSizeW :: DynFlags -> WordOff -arrPtrsHdrSizeW dflags = - fixedHdrSizeW dflags + - (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` - platformWordSizeInBytes (targetPlatform dflags)) - -smallArrPtrsHdrSize :: DynFlags -> ByteOff -smallArrPtrsHdrSize dflags - = fixedHdrSize dflags + sIZEOF_StgSmallMutArrPtrs_NoHdr dflags - -smallArrPtrsHdrSizeW :: DynFlags -> WordOff -smallArrPtrsHdrSizeW dflags = - fixedHdrSizeW dflags + - (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` - platformWordSizeInBytes (targetPlatform dflags)) +minClosureSize :: Profile -> WordOff +minClosureSize profile + = fixedHdrSizeW profile + + pc_MIN_PAYLOAD_SIZE (profileConstants profile) + +arrWordsHdrSize :: Profile -> ByteOff +arrWordsHdrSize profile + = fixedHdrSize profile + + pc_SIZEOF_StgArrBytes_NoHdr (profileConstants profile) + +arrWordsHdrSizeW :: Profile -> WordOff +arrWordsHdrSizeW profile + = fixedHdrSizeW profile + + (pc_SIZEOF_StgArrBytes_NoHdr (profileConstants profile) `quot` + platformWordSizeInBytes (profilePlatform profile)) + +arrPtrsHdrSize :: Profile -> ByteOff +arrPtrsHdrSize profile + = fixedHdrSize profile + + pc_SIZEOF_StgMutArrPtrs_NoHdr (profileConstants profile) + +arrPtrsHdrSizeW :: Profile -> WordOff +arrPtrsHdrSizeW profile + = fixedHdrSizeW profile + + (pc_SIZEOF_StgMutArrPtrs_NoHdr (profileConstants profile) `quot` + platformWordSizeInBytes (profilePlatform profile)) + +smallArrPtrsHdrSize :: Profile -> ByteOff +smallArrPtrsHdrSize profile + = fixedHdrSize profile + + pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (profileConstants profile) + +smallArrPtrsHdrSizeW :: Profile -> WordOff +smallArrPtrsHdrSizeW profile + = fixedHdrSizeW profile + + (pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (profileConstants profile) `quot` + platformWordSizeInBytes (profilePlatform profile)) -- Thunks have an extra header word on SMP, so the update doesn't -- splat the payload. -thunkHdrSize :: DynFlags -> WordOff -thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr - where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` - platformWordSizeInBytes (targetPlatform dflags) - -hdrSize :: DynFlags -> SMRep -> ByteOff -hdrSize dflags rep = wordsToBytes (targetPlatform dflags) (hdrSizeW dflags rep) - -hdrSizeW :: DynFlags -> SMRep -> WordOff -hdrSizeW dflags (HeapRep _ _ _ ty) = closureTypeHdrSize dflags ty -hdrSizeW dflags (ArrayPtrsRep _ _) = arrPtrsHdrSizeW dflags -hdrSizeW dflags (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW dflags -hdrSizeW dflags (ArrayWordsRep _) = arrWordsHdrSizeW dflags -hdrSizeW _ _ = panic "SMRep.hdrSizeW" +thunkHdrSize :: Profile -> WordOff +thunkHdrSize profile = fixedHdrSizeW profile + smp_hdr + where + platform = profilePlatform profile + smp_hdr = pc_SIZEOF_StgSMPThunkHeader (platformConstants platform) `quot` + platformWordSizeInBytes platform + +hdrSize :: Profile -> SMRep -> ByteOff +hdrSize profile rep = wordsToBytes (profilePlatform profile) (hdrSizeW profile rep) + +hdrSizeW :: Profile -> SMRep -> WordOff +hdrSizeW profile (HeapRep _ _ _ ty) = closureTypeHdrSize profile ty +hdrSizeW profile (ArrayPtrsRep _ _) = arrPtrsHdrSizeW profile +hdrSizeW profile (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW profile +hdrSizeW profile (ArrayWordsRep _) = arrWordsHdrSizeW profile +hdrSizeW _ _ = panic "GHC.Runtime.Heap.Layout.hdrSizeW" nonHdrSize :: Platform -> SMRep -> ByteOff nonHdrSize platform rep = wordsToBytes platform (nonHdrSizeW rep) @@ -349,24 +358,21 @@ nonHdrSizeW (StackRep bs) = length bs nonHdrSizeW (RTSRep _ rep) = nonHdrSizeW rep -- | The total size of the closure, in words. -heapClosureSizeW :: DynFlags -> SMRep -> WordOff -heapClosureSizeW dflags (HeapRep _ p np ty) - = closureTypeHdrSize dflags ty + p + np -heapClosureSizeW dflags (ArrayPtrsRep elems ct) - = arrPtrsHdrSizeW dflags + elems + ct -heapClosureSizeW dflags (SmallArrayPtrsRep elems) - = smallArrPtrsHdrSizeW dflags + elems -heapClosureSizeW dflags (ArrayWordsRep words) - = arrWordsHdrSizeW dflags + words -heapClosureSizeW _ _ = panic "SMRep.heapClosureSize" - -closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff -closureTypeHdrSize dflags ty = case ty of - Thunk -> thunkHdrSize dflags - ThunkSelector{} -> thunkHdrSize dflags - BlackHole -> thunkHdrSize dflags - IndStatic -> thunkHdrSize dflags - _ -> fixedHdrSizeW dflags +heapClosureSizeW :: Profile -> SMRep -> WordOff +heapClosureSizeW profile rep = case rep of + HeapRep _ p np ty -> closureTypeHdrSize profile ty + p + np + ArrayPtrsRep elems ct -> arrPtrsHdrSizeW profile + elems + ct + SmallArrayPtrsRep elems -> smallArrPtrsHdrSizeW profile + elems + ArrayWordsRep words -> arrWordsHdrSizeW profile + words + _ -> panic "GHC.Runtime.Heap.Layout.heapClosureSize" + +closureTypeHdrSize :: Profile -> ClosureTypeInfo -> WordOff +closureTypeHdrSize profile ty = case ty of + Thunk -> thunkHdrSize profile + ThunkSelector{} -> thunkHdrSize profile + BlackHole -> thunkHdrSize profile + IndStatic -> thunkHdrSize profile + _ -> fixedHdrSizeW profile -- All thunks use thunkHdrSize, even if they are non-updatable. -- this is because we don't have separate closure types for -- updatable vs. non-updatable thunks, so the GC can't tell the @@ -377,23 +383,22 @@ closureTypeHdrSize dflags ty = case ty of -- Arrays -- | The byte offset into the card table of the card for a given element -card :: DynFlags -> Int -> Int -card dflags i = i `shiftR` mUT_ARR_PTRS_CARD_BITS dflags +card :: Platform -> Int -> Int +card platform i = i `shiftR` pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform) -- | Convert a number of elements to a number of cards, rounding up -cardRoundUp :: DynFlags -> Int -> Int -cardRoundUp dflags i = - card dflags (i + ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1)) +cardRoundUp :: Platform -> Int -> Int +cardRoundUp platform i = + card platform (i + ((1 `shiftL` pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform)) - 1)) -- | The size of a card table, in bytes -cardTableSizeB :: DynFlags -> Int -> ByteOff -cardTableSizeB dflags elems = cardRoundUp dflags elems +cardTableSizeB :: Platform -> Int -> ByteOff +cardTableSizeB platform elems = cardRoundUp platform elems -- | The size of a card table, in words -cardTableSizeW :: DynFlags -> Int -> WordOff -cardTableSizeW dflags elems = - bytesToWordsRoundUp (targetPlatform dflags) - (cardTableSizeB dflags elems) +cardTableSizeW :: Platform -> Int -> WordOff +cardTableSizeW platform elems = + bytesToWordsRoundUp platform (cardTableSizeB platform elems) ----------------------------------------------------------------------------- -- deriving the RTS closure type from an SMRep diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs index 3eea75b21e..80883b9312 100644 --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -21,7 +21,9 @@ module GHC.Stg.Lift.Analysis ( ) where import GHC.Prelude + import GHC.Platform +import GHC.Platform.Profile import GHC.Types.Basic import GHC.Types.Demand @@ -375,7 +377,8 @@ goodToLift dflags top_lvl rec_flag expander pairs scope = decide , ("args spill on stack", args_spill_on_stack) , ("increases allocation", inc_allocs) ] where - platform = targetPlatform dflags + profile = targetProfile dflags + platform = profilePlatform profile decide deciders | not (fancy_or deciders) = llTrace "stgLiftLams:lifting" @@ -472,7 +475,7 @@ goodToLift dflags top_lvl rec_flag expander pairs scope = decide -- GHC does not currently share closure environments, and we either lift -- the entire recursive binding group or none of it. closuresSize = sum $ flip map rhss $ \rhs -> - closureSize dflags + closureSize profile . dVarSetElems . expander . flip dVarSetMinusVarSet bndrs_set @@ -485,14 +488,14 @@ rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _) = map binderInfoBndr bndrs -- | The size in words of a function closure closing over the given 'Id's, -- including the header. -closureSize :: DynFlags -> [Id] -> WordOff -closureSize dflags ids = words + sTD_HDR_SIZE dflags +closureSize :: Profile -> [Id] -> WordOff +closureSize profile ids = words + pc_STD_HDR_SIZE (platformConstants (profilePlatform profile)) -- We go through sTD_HDR_SIZE rather than fixedHdrSizeW so that we don't -- optimise differently when profiling is enabled. where (words, _, _) -- Functions have a StdHeader (as opposed to ThunkHeader). - = StgToCmm.Layout.mkVirtHeapOffsets dflags StgToCmm.Layout.StdHeader + = StgToCmm.Layout.mkVirtHeapOffsets profile StgToCmm.Layout.StdHeader . StgToCmm.Closure.addIdReps . StgToCmm.Closure.nonVoidIds $ ids diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index 40a43b3e06..268a1a6a16 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -177,7 +177,7 @@ cgTopBinding dflags (StgTopStringLit id str) = do BS.writeFile bFile str return bFile emitDecl decl - addBindC (litIdInfo dflags id mkLFStringLit lit) + addBindC (litIdInfo (targetPlatform dflags) id mkLFStringLit lit) cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ()) @@ -190,7 +190,7 @@ cgTopRhs dflags _rec bndr (StgRhsCon _cc con args) cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body) = ASSERT(isEmptyDVarSet fvs) -- There should be no free variables - cgTopRhsClosure dflags rec bndr cc upd_flag args body + cgTopRhsClosure (targetPlatform dflags) rec bndr cc upd_flag args body --------------------------------------------------------------- @@ -216,28 +216,28 @@ mkModuleInit cost_centre_info this_mod hpc_info cgEnumerationTyCon :: TyCon -> FCode () cgEnumerationTyCon tycon - = do dflags <- getDynFlags + = do platform <- getPlatform emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs) [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) - (tagForCon dflags con) + (tagForCon platform con) | con <- tyConDataCons tycon] -cgDataCon :: DataCon -> FCode () --- Generate the entry code, info tables, and (for niladic constructor) +-- | Generate the entry code, info tables, and (for niladic constructor) -- the static closure, for a constructor. +cgDataCon :: DataCon -> FCode () cgDataCon data_con - = do { dflags <- getDynFlags + = do { profile <- getProfile ; platform <- getPlatform ; let (tot_wds, -- #ptr_wds + #nonptr_wds ptr_wds) -- #ptr_wds - = mkVirtConstrSizes dflags arg_reps + = mkVirtConstrSizes profile arg_reps nonptr_wds = tot_wds - ptr_wds dyn_info_tbl = - mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds + mkDataConInfoTable profile data_con False ptr_wds nonptr_wds -- We're generating info tables, so we don't know and care about -- what the actual arguments are. Using () here as the place holder. @@ -257,7 +257,7 @@ cgDataCon data_con do { tickyEnterDynCon ; ldvEnter (CmmReg nodeReg) ; tickyReturnOldCon (length arg_reps) - ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon dflags data_con)] + ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon platform data_con)] } -- The case continuation code expects a tagged pointer } diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs index c83bca2217..4fbdc4a153 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -14,7 +14,9 @@ module GHC.StgToCmm.Bind ( ) where import GHC.Prelude hiding ((<*>)) + import GHC.Platform +import GHC.Platform.Profile import GHC.StgToCmm.Expr import GHC.StgToCmm.Monad @@ -60,7 +62,7 @@ import Control.Monad -- For closures bound at top level, allocate in static space. -- They should have no free variables. -cgTopRhsClosure :: DynFlags +cgTopRhsClosure :: Platform -> RecFlag -- member of a recursive group? -> Id -> CostCentreStack -- Optional cost centre annotation @@ -69,12 +71,11 @@ cgTopRhsClosure :: DynFlags -> CgStgExpr -> (CgIdInfo, FCode ()) -cgTopRhsClosure dflags rec id ccs upd_flag args body = - let platform = targetPlatform dflags - closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) - cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) +cgTopRhsClosure platform rec id ccs upd_flag args body = + let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) + cg_id_info = litIdInfo platform id lf_info (CmmLabel closure_label) lf_info = mkClosureLFInfo platform id TopLevel [] upd_flag args - in (cg_id_info, gen_code dflags lf_info closure_label) + in (cg_id_info, gen_code lf_info closure_label) where -- special case for a indirection (f = g). We create an IND_STATIC -- closure pointing directly to the indirectee. This is exactly @@ -89,17 +90,19 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body = -- hole detection from working in that case. Test -- concurrent/should_run/4030 fails, for instance. -- - gen_code _ _ closure_label + gen_code _ closure_label | StgApp f [] <- body, null args, isNonRec rec = do cg_info <- getCgIdInfo f emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)] - gen_code dflags lf_info _closure_label - = do { let name = idName id + gen_code lf_info _closure_label + = do { profile <- getProfile + ; dflags <- getDynFlags + ; let name = idName id ; mod_name <- getModuleName ; let descr = closureDescription dflags mod_name name - closure_info = mkClosureInfo dflags True id lf_info 0 0 descr + closure_info = mkClosureInfo profile True id lf_info 0 0 descr -- We don't generate the static closure here, because we might -- want to add references to static closures to it later. The @@ -108,7 +111,7 @@ cgTopRhsClosure dflags rec id ccs upd_flag args body = ; let fv_details :: [(NonVoid Id, ByteOff)] header = if isLFThunk lf_info then ThunkHeader else StdHeader - (_, _, fv_details) = mkVirtHeapOffsets dflags header [] + (_, _, fv_details) = mkVirtHeapOffsets profile header [] -- Don't drop the non-void args until the closure info has been made ; forkClosureBody (closureCodeBody True id closure_info ccs args body fv_details) @@ -208,14 +211,14 @@ cgRhs id (StgRhsCon cc con args) {- See Note [GC recovery] in "GHC.StgToCmm.Closure" -} cgRhs id (StgRhsClosure fvs cc upd_flag args body) - = do dflags <- getDynFlags - mkRhsClosure dflags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body + = do profile <- getProfile + mkRhsClosure profile id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body ------------------------------------------------------------------------ -- Non-constructor right hand sides ------------------------------------------------------------------------ -mkRhsClosure :: DynFlags -> Id -> CostCentreStack +mkRhsClosure :: Profile -> Id -> CostCentreStack -> [NonVoid Id] -- Free vars -> UpdateFlag -> [Id] -- Args @@ -258,7 +261,7 @@ for semi-obvious reasons. -} ---------- Note [Selectors] ------------------ -mkRhsClosure dflags bndr _cc +mkRhsClosure profile bndr _cc [NonVoid the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk @@ -271,14 +274,14 @@ mkRhsClosure dflags bndr _cc , StgApp selectee [{-no args-}] <- strip sel_expr , the_fv == scrutinee -- Scrutinee is the only free variable - , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params)) + , let (_, _, params_w_offsets) = mkVirtConstrOffsets profile (addIdReps (assertNonVoidIds params)) -- pattern binders are always non-void, -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee) - , let offset_into_int = bytesToWordsRoundUp (targetPlatform dflags) the_offset - - fixedHdrSizeW dflags - , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough + , let offset_into_int = bytesToWordsRoundUp (profilePlatform profile) the_offset + - fixedHdrSizeW profile + , offset_into_int <= pc_MAX_SPEC_SELECTEE_SIZE (profileConstants profile) -- Offset is small enough = -- NOT TRUE: ASSERT(is_single_constructor) -- The simplifier may have statically determined that the single alternative -- is the only possible case and eliminated the others, even if there are @@ -291,7 +294,7 @@ mkRhsClosure dflags bndr _cc in cgRhsStdThunk bndr lf_info [StgVarArg the_fv] ---------- Note [Ap thunks] ------------------ -mkRhsClosure dflags bndr _cc +mkRhsClosure profile bndr _cc fvs upd_flag [] -- No args; a thunk @@ -306,8 +309,8 @@ mkRhsClosure dflags bndr _cc -- Missed opportunity: (f x x) is not detected , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs , isUpdatable upd_flag - , n_fvs <= mAX_SPEC_AP_SIZE dflags - , not (sccProfilingEnabled dflags) + , n_fvs <= pc_MAX_SPEC_AP_SIZE (profileConstants profile) + , not (profileIsProfiling profile) -- not when profiling: we don't want to -- lose information about this particular -- thunk (e.g. its type) (#949) @@ -324,12 +327,11 @@ mkRhsClosure dflags bndr _cc payload = StgVarArg fun_id : args ---------- Default case ------------------ -mkRhsClosure dflags bndr cc fvs upd_flag args body - = do { let lf_info = mkClosureLFInfo platform bndr NotTopLevel fvs upd_flag args +mkRhsClosure profile bndr cc fvs upd_flag args body + = do { let lf_info = mkClosureLFInfo (profilePlatform profile) bndr NotTopLevel fvs upd_flag args ; (id_info, reg) <- rhsIdInfo bndr lf_info ; return (id_info, gen_code lf_info reg) } where - platform = targetPlatform dflags gen_code lf_info reg = do { -- LAY OUT THE OBJECT -- If the binder is itself a free variable, then don't store @@ -341,15 +343,19 @@ mkRhsClosure dflags bndr cc fvs upd_flag args body -- Node points to it... ; let reduced_fvs = filter (NonVoid bndr /=) fvs + ; profile <- getProfile + ; let platform = profilePlatform profile + -- MAKE CLOSURE INFO FOR THIS CLOSURE ; mod_name <- getModuleName + ; dflags <- getDynFlags ; let name = idName bndr descr = closureDescription dflags mod_name name fv_details :: [(NonVoid Id, ByteOff)] header = if isLFThunk lf_info then ThunkHeader else StdHeader (tot_wds, ptr_wds, fv_details) - = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs) - closure_info = mkClosureInfo dflags False -- Not static + = mkVirtHeapOffsets profile header (addIdReps reduced_fvs) + closure_info = mkClosureInfo profile False -- Not static bndr lf_info tot_wds ptr_wds descr @@ -371,7 +377,7 @@ mkRhsClosure dflags bndr cc fvs upd_flag args body (map toVarArg fv_details) -- RETURN - ; return (mkRhsInit dflags reg lf_info hp_plus_n) } + ; return (mkRhsInit platform reg lf_info hp_plus_n) } ------------------------- cgRhsStdThunk @@ -391,13 +397,15 @@ cgRhsStdThunk bndr lf_info payload { -- LAY OUT THE OBJECT mod_name <- getModuleName ; dflags <- getDynFlags - ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader + ; profile <- getProfile + ; let platform = profilePlatform profile + header = if isLFThunk lf_info then ThunkHeader else StdHeader (tot_wds, ptr_wds, payload_w_offsets) - = mkVirtHeapOffsets dflags header + = mkVirtHeapOffsets profile header (addArgReps (nonVoidStgArgs payload)) descr = closureDescription dflags mod_name (idName bndr) - closure_info = mkClosureInfo dflags False -- Not static + closure_info = mkClosureInfo profile False -- Not static bndr lf_info tot_wds ptr_wds descr @@ -411,7 +419,7 @@ cgRhsStdThunk bndr lf_info payload use_cc blame_cc payload_w_offsets -- RETURN - ; return (mkRhsInit dflags reg lf_info hp_plus_n) } + ; return (mkRhsInit platform reg lf_info hp_plus_n) } mkClosureLFInfo :: Platform @@ -480,9 +488,9 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details \(_offset, node, arg_regs) -> do -- Emit slow-entry code (for entering a closure through a PAP) { mkSlowEntryCode bndr cl_info arg_regs - ; dflags <- getDynFlags + ; profile <- getProfile ; platform <- getPlatform - ; let node_points = nodeMustPointToIt dflags lf_info + ; let node_points = nodeMustPointToIt profile lf_info node' = if node_points then Just node else Nothing ; loop_header_id <- newBlockId -- Extend reader monad with information that @@ -499,7 +507,7 @@ closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details ; enterCostCentreFun cc (CmmMachOp (mo_wordSub platform) [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification] - , mkIntExpr platform (funTag dflags cl_info) ]) + , mkIntExpr platform (funTag platform cl_info) ]) ; fv_bindings <- mapM bind_fv fv_details -- Load free vars out of closure *after* -- heap check, to reduce live vars over check @@ -528,9 +536,8 @@ bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) } load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode () load_fvs node lf_info = mapM_ (\ (reg, off) -> - do dflags <- getDynFlags - platform <- getPlatform - let tag = lfDynTag dflags lf_info + do platform <- getPlatform + let tag = lfDynTag platform lf_info emit $ mkTaggedObjectLoad platform reg node off tag) ----------------------------------------- @@ -548,13 +555,13 @@ mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode () -- Here, we emit the slow-entry code. mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node' | Just (_, ArgGen _) <- closureFunInfo cl_info - = do dflags <- getDynFlags + = do profile <- getProfile platform <- getPlatform let node = idToReg platform (NonVoid bndr) slow_lbl = closureSlowEntryLabel cl_info fast_lbl = closureLocalEntryLabel platform cl_info -- mkDirectJump does not clobber `Node' containing function closure - jump = mkJump dflags NativeNodeCall + jump = mkJump profile NativeNodeCall (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) (node : arg_regs)) (initUpdFrameOff platform) @@ -567,8 +574,8 @@ mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node' thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack -> LocalReg -> CgStgExpr -> FCode () thunkCode cl_info fv_details _cc node body - = do { dflags <- getDynFlags - ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info) + = do { profile <- getProfile + ; let node_points = nodeMustPointToIt profile (closureLFInfo cl_info) node' = if node_points then Just node else Nothing ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling @@ -606,7 +613,8 @@ blackHoleIt node_reg emitBlackHoleCode :: CmmExpr -> FCode () emitBlackHoleCode node = do dflags <- getDynFlags - let platform = targetPlatform dflags + profile <- getProfile + let platform = profilePlatform profile -- Eager blackholing is normally disabled, but can be turned on with -- -feager-blackholing. When it is on, we replace the info pointer @@ -626,7 +634,7 @@ emitBlackHoleCode node = do -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, -- because emitBlackHoleCode is called from GHC.Cmm.Parser. - let eager_blackholing = not (sccProfilingEnabled dflags) + let eager_blackholing = not (profileIsProfiling profile) && gopt Opt_EagerBlackHoling dflags -- Profiling needs slop filling (to support LDV -- profiling), so currently eager blackholing doesn't @@ -634,7 +642,7 @@ emitBlackHoleCode node = do when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node - emitStore (cmmOffsetW platform node (fixedHdrSizeW dflags)) currentTSOExpr + emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) currentTSOExpr -- See Note [Heap memory barriers] in SMP.h. emitPrimCall [] MO_WriteBarrier [] emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo)) @@ -684,20 +692,21 @@ pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode () pushUpdateFrame lbl updatee body = do updfr <- getUpdFrameOff - dflags <- getDynFlags + profile <- getProfile let - hdr = fixedHdrSize dflags - frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags + hdr = fixedHdrSize profile + frame = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile) -- - emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee + emitUpdateFrame (CmmStackSlot Old frame) lbl updatee withUpdFrameOff frame body -emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode () -emitUpdateFrame dflags frame lbl updatee = do +emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode () +emitUpdateFrame frame lbl updatee = do + profile <- getProfile let - hdr = fixedHdrSize dflags - off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags - platform = targetPlatform dflags + hdr = fixedHdrSize profile + off_updatee = hdr + pc_OFFSET_StgUpdateFrame_updatee (platformConstants platform) + platform = profilePlatform profile -- emitStore frame (mkLblExpr lbl) emitStore (cmmOffset platform frame off_updatee) updatee @@ -713,12 +722,12 @@ link_caf :: LocalReg -- pointer to the closure -- This function returns the address of the black hole, so it can be -- updated with the new value when available. link_caf node = do - { dflags <- getDynFlags + { profile <- getProfile -- Call the RTS function newCAF, returning the newly-allocated -- blackhole indirection closure ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing ForeignLabelInExternalPackage IsFunction - ; let platform = targetPlatform dflags + ; let platform = profilePlatform profile ; bh <- newTemp (bWord platform) ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl [ (baseExpr, AddrHint), @@ -727,11 +736,12 @@ link_caf node = do -- see Note [atomic CAF entry] in rts/sm/Storage.c ; updfr <- getUpdFrameOff - ; let target = entryCode platform (closureInfoPtr dflags (CmmReg (CmmLocal node))) + ; ptr_opts <- getPtrOpts + ; let target = entryCode platform (closureInfoPtr ptr_opts (CmmReg (CmmLocal node))) ; emit =<< mkCmmIfThen (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform)) -- re-enter the CAF - (mkJump dflags NativeNodeCall target [] updfr) + (mkJump profile NativeNodeCall target [] updfr) ; return (CmmReg (CmmLocal bh)) } diff --git a/compiler/GHC/StgToCmm/CgUtils.hs b/compiler/GHC/StgToCmm/CgUtils.hs index 25cd5e04c1..36ba21cb15 100644 --- a/compiler/GHC/StgToCmm/CgUtils.hs +++ b/compiler/GHC/StgToCmm/CgUtils.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-} +{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- @@ -19,82 +20,84 @@ module GHC.StgToCmm.CgUtils ( import GHC.Prelude import GHC.Platform.Regs +import GHC.Platform import GHC.Cmm import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Utils import GHC.Cmm.CLabel -import GHC.Driver.Session import GHC.Utils.Outputable -- ----------------------------------------------------------------------------- -- Information about global registers -baseRegOffset :: DynFlags -> GlobalReg -> Int - -baseRegOffset dflags (VanillaReg 1 _) = oFFSET_StgRegTable_rR1 dflags -baseRegOffset dflags (VanillaReg 2 _) = oFFSET_StgRegTable_rR2 dflags -baseRegOffset dflags (VanillaReg 3 _) = oFFSET_StgRegTable_rR3 dflags -baseRegOffset dflags (VanillaReg 4 _) = oFFSET_StgRegTable_rR4 dflags -baseRegOffset dflags (VanillaReg 5 _) = oFFSET_StgRegTable_rR5 dflags -baseRegOffset dflags (VanillaReg 6 _) = oFFSET_StgRegTable_rR6 dflags -baseRegOffset dflags (VanillaReg 7 _) = oFFSET_StgRegTable_rR7 dflags -baseRegOffset dflags (VanillaReg 8 _) = oFFSET_StgRegTable_rR8 dflags -baseRegOffset dflags (VanillaReg 9 _) = oFFSET_StgRegTable_rR9 dflags -baseRegOffset dflags (VanillaReg 10 _) = oFFSET_StgRegTable_rR10 dflags -baseRegOffset _ (VanillaReg n _) = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") -baseRegOffset dflags (FloatReg 1) = oFFSET_StgRegTable_rF1 dflags -baseRegOffset dflags (FloatReg 2) = oFFSET_StgRegTable_rF2 dflags -baseRegOffset dflags (FloatReg 3) = oFFSET_StgRegTable_rF3 dflags -baseRegOffset dflags (FloatReg 4) = oFFSET_StgRegTable_rF4 dflags -baseRegOffset dflags (FloatReg 5) = oFFSET_StgRegTable_rF5 dflags -baseRegOffset dflags (FloatReg 6) = oFFSET_StgRegTable_rF6 dflags -baseRegOffset _ (FloatReg n) = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")") -baseRegOffset dflags (DoubleReg 1) = oFFSET_StgRegTable_rD1 dflags -baseRegOffset dflags (DoubleReg 2) = oFFSET_StgRegTable_rD2 dflags -baseRegOffset dflags (DoubleReg 3) = oFFSET_StgRegTable_rD3 dflags -baseRegOffset dflags (DoubleReg 4) = oFFSET_StgRegTable_rD4 dflags -baseRegOffset dflags (DoubleReg 5) = oFFSET_StgRegTable_rD5 dflags -baseRegOffset dflags (DoubleReg 6) = oFFSET_StgRegTable_rD6 dflags -baseRegOffset _ (DoubleReg n) = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")") -baseRegOffset dflags (XmmReg 1) = oFFSET_StgRegTable_rXMM1 dflags -baseRegOffset dflags (XmmReg 2) = oFFSET_StgRegTable_rXMM2 dflags -baseRegOffset dflags (XmmReg 3) = oFFSET_StgRegTable_rXMM3 dflags -baseRegOffset dflags (XmmReg 4) = oFFSET_StgRegTable_rXMM4 dflags -baseRegOffset dflags (XmmReg 5) = oFFSET_StgRegTable_rXMM5 dflags -baseRegOffset dflags (XmmReg 6) = oFFSET_StgRegTable_rXMM6 dflags -baseRegOffset _ (XmmReg n) = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")") -baseRegOffset dflags (YmmReg 1) = oFFSET_StgRegTable_rYMM1 dflags -baseRegOffset dflags (YmmReg 2) = oFFSET_StgRegTable_rYMM2 dflags -baseRegOffset dflags (YmmReg 3) = oFFSET_StgRegTable_rYMM3 dflags -baseRegOffset dflags (YmmReg 4) = oFFSET_StgRegTable_rYMM4 dflags -baseRegOffset dflags (YmmReg 5) = oFFSET_StgRegTable_rYMM5 dflags -baseRegOffset dflags (YmmReg 6) = oFFSET_StgRegTable_rYMM6 dflags -baseRegOffset _ (YmmReg n) = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")") -baseRegOffset dflags (ZmmReg 1) = oFFSET_StgRegTable_rZMM1 dflags -baseRegOffset dflags (ZmmReg 2) = oFFSET_StgRegTable_rZMM2 dflags -baseRegOffset dflags (ZmmReg 3) = oFFSET_StgRegTable_rZMM3 dflags -baseRegOffset dflags (ZmmReg 4) = oFFSET_StgRegTable_rZMM4 dflags -baseRegOffset dflags (ZmmReg 5) = oFFSET_StgRegTable_rZMM5 dflags -baseRegOffset dflags (ZmmReg 6) = oFFSET_StgRegTable_rZMM6 dflags -baseRegOffset _ (ZmmReg n) = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")") -baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags -baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags -baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags -baseRegOffset _ (LongReg n) = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")") -baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags -baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags -baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags -baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags -baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags -baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags -baseRegOffset dflags EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo dflags -baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags -baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags -baseRegOffset _ BaseReg = panic "CgUtils.baseRegOffset:BaseReg" -baseRegOffset _ PicBaseReg = panic "CgUtils.baseRegOffset:PicBaseReg" -baseRegOffset _ MachSp = panic "CgUtils.baseRegOffset:MachSp" -baseRegOffset _ UnwindReturnReg = panic "CgUtils.baseRegOffset:UnwindReturnReg" +baseRegOffset :: Platform -> GlobalReg -> Int +baseRegOffset platform reg = case reg of + VanillaReg 1 _ -> pc_OFFSET_StgRegTable_rR1 constants + VanillaReg 2 _ -> pc_OFFSET_StgRegTable_rR2 constants + VanillaReg 3 _ -> pc_OFFSET_StgRegTable_rR3 constants + VanillaReg 4 _ -> pc_OFFSET_StgRegTable_rR4 constants + VanillaReg 5 _ -> pc_OFFSET_StgRegTable_rR5 constants + VanillaReg 6 _ -> pc_OFFSET_StgRegTable_rR6 constants + VanillaReg 7 _ -> pc_OFFSET_StgRegTable_rR7 constants + VanillaReg 8 _ -> pc_OFFSET_StgRegTable_rR8 constants + VanillaReg 9 _ -> pc_OFFSET_StgRegTable_rR9 constants + VanillaReg 10 _ -> pc_OFFSET_StgRegTable_rR10 constants + VanillaReg n _ -> panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")") + FloatReg 1 -> pc_OFFSET_StgRegTable_rF1 constants + FloatReg 2 -> pc_OFFSET_StgRegTable_rF2 constants + FloatReg 3 -> pc_OFFSET_StgRegTable_rF3 constants + FloatReg 4 -> pc_OFFSET_StgRegTable_rF4 constants + FloatReg 5 -> pc_OFFSET_StgRegTable_rF5 constants + FloatReg 6 -> pc_OFFSET_StgRegTable_rF6 constants + FloatReg n -> panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")") + DoubleReg 1 -> pc_OFFSET_StgRegTable_rD1 constants + DoubleReg 2 -> pc_OFFSET_StgRegTable_rD2 constants + DoubleReg 3 -> pc_OFFSET_StgRegTable_rD3 constants + DoubleReg 4 -> pc_OFFSET_StgRegTable_rD4 constants + DoubleReg 5 -> pc_OFFSET_StgRegTable_rD5 constants + DoubleReg 6 -> pc_OFFSET_StgRegTable_rD6 constants + DoubleReg n -> panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")") + XmmReg 1 -> pc_OFFSET_StgRegTable_rXMM1 constants + XmmReg 2 -> pc_OFFSET_StgRegTable_rXMM2 constants + XmmReg 3 -> pc_OFFSET_StgRegTable_rXMM3 constants + XmmReg 4 -> pc_OFFSET_StgRegTable_rXMM4 constants + XmmReg 5 -> pc_OFFSET_StgRegTable_rXMM5 constants + XmmReg 6 -> pc_OFFSET_StgRegTable_rXMM6 constants + XmmReg n -> panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")") + YmmReg 1 -> pc_OFFSET_StgRegTable_rYMM1 constants + YmmReg 2 -> pc_OFFSET_StgRegTable_rYMM2 constants + YmmReg 3 -> pc_OFFSET_StgRegTable_rYMM3 constants + YmmReg 4 -> pc_OFFSET_StgRegTable_rYMM4 constants + YmmReg 5 -> pc_OFFSET_StgRegTable_rYMM5 constants + YmmReg 6 -> pc_OFFSET_StgRegTable_rYMM6 constants + YmmReg n -> panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")") + ZmmReg 1 -> pc_OFFSET_StgRegTable_rZMM1 constants + ZmmReg 2 -> pc_OFFSET_StgRegTable_rZMM2 constants + ZmmReg 3 -> pc_OFFSET_StgRegTable_rZMM3 constants + ZmmReg 4 -> pc_OFFSET_StgRegTable_rZMM4 constants + ZmmReg 5 -> pc_OFFSET_StgRegTable_rZMM5 constants + ZmmReg 6 -> pc_OFFSET_StgRegTable_rZMM6 constants + ZmmReg n -> panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")") + Sp -> pc_OFFSET_StgRegTable_rSp constants + SpLim -> pc_OFFSET_StgRegTable_rSpLim constants + LongReg 1 -> pc_OFFSET_StgRegTable_rL1 constants + LongReg n -> panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")") + Hp -> pc_OFFSET_StgRegTable_rHp constants + HpLim -> pc_OFFSET_StgRegTable_rHpLim constants + CCCS -> pc_OFFSET_StgRegTable_rCCCS constants + CurrentTSO -> pc_OFFSET_StgRegTable_rCurrentTSO constants + CurrentNursery -> pc_OFFSET_StgRegTable_rCurrentNursery constants + HpAlloc -> pc_OFFSET_StgRegTable_rHpAlloc constants + EagerBlackholeInfo -> pc_OFFSET_stgEagerBlackholeInfo constants + GCEnter1 -> pc_OFFSET_stgGCEnter1 constants + GCFun -> pc_OFFSET_stgGCFun constants + BaseReg -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:BaseReg" + PicBaseReg -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:PicBaseReg" + MachSp -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:MachSp" + UnwindReturnReg -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:UnwindReturnReg" + where + !constants = platformConstants platform -- ----------------------------------------------------------------------------- @@ -107,40 +110,38 @@ baseRegOffset _ UnwindReturnReg = panic "CgUtils.baseRegOffset:UnwindRe -- to real machine registers or stored as offsets from BaseReg. Given -- a GlobalReg, get_GlobalReg_addr always produces the -- register table address for it. -get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr -get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0 -get_GlobalReg_addr dflags mid - = get_Regtable_addr_from_offset dflags (baseRegOffset dflags mid) +get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr +get_GlobalReg_addr platform BaseReg = regTableOffset platform 0 +get_GlobalReg_addr platform mid + = get_Regtable_addr_from_offset platform (baseRegOffset platform mid) -- Calculate a literal representing an offset into the register table. -- Used when we don't have an actual BaseReg to offset from. -regTableOffset :: DynFlags -> Int -> CmmExpr -regTableOffset dflags n = - CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n)) +regTableOffset :: Platform -> Int -> CmmExpr +regTableOffset platform n = + CmmLit (CmmLabelOff mkMainCapabilityLabel (pc_OFFSET_Capability_r (platformConstants platform) + n)) -get_Regtable_addr_from_offset :: DynFlags -> Int -> CmmExpr -get_Regtable_addr_from_offset dflags offset = - if haveRegBase (targetPlatform dflags) +get_Regtable_addr_from_offset :: Platform -> Int -> CmmExpr +get_Regtable_addr_from_offset platform offset = + if haveRegBase platform then cmmRegOff baseReg offset - else regTableOffset dflags offset + else regTableOffset platform offset -- | Fixup global registers so that they assign to locations within the -- RegTable if they aren't pinned for the current target. -fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl +fixStgRegisters :: Platform -> RawCmmDecl -> RawCmmDecl fixStgRegisters _ top@(CmmData _ _) = top -fixStgRegisters dflags (CmmProc info lbl live graph) = - let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph +fixStgRegisters platform (CmmProc info lbl live graph) = + let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock platform)) graph in CmmProc info lbl live graph' -fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x -fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block +fixStgRegBlock :: Platform -> Block CmmNode e x -> Block CmmNode e x +fixStgRegBlock platform block = mapBlock (fixStgRegStmt platform) block -fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x -fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt +fixStgRegStmt :: Platform -> CmmNode e x -> CmmNode e x +fixStgRegStmt platform stmt = fixAssign $ mapExpDeep fixExpr stmt where - platform = targetPlatform dflags - fixAssign stmt = case stmt of CmmAssign (CmmGlobal reg) src @@ -148,7 +149,7 @@ fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt -- information | reg == MachSp -> stmt | otherwise -> - let baseAddr = get_GlobalReg_addr dflags reg + let baseAddr = get_GlobalReg_addr platform reg in case reg `elem` activeStgRegs platform of True -> CmmAssign (CmmGlobal reg) src False -> CmmStore baseAddr src @@ -167,7 +168,7 @@ fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt case reg `elem` activeStgRegs platform of True -> expr False -> - let baseAddr = get_GlobalReg_addr dflags reg + let baseAddr = get_GlobalReg_addr platform reg in case reg of BaseReg -> baseAddr _other -> CmmLoad baseAddr (globalRegType platform reg) diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index a21be98ceb..98a15f0ef5 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -31,7 +31,8 @@ module GHC.StgToCmm.Closure ( -- * Used by other modules CgLoc(..), SelfLoopInfo, CallMethod(..), - nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod, + nodeMustPointToIt, isKnownFun, funTag, tagForArity, + CallOpts(..), getCallMethod, -- * ClosureInfo ClosureInfo, @@ -66,10 +67,12 @@ module GHC.StgToCmm.Closure ( import GHC.Prelude import GHC.Platform +import GHC.Platform.Profile import GHC.Stg.Syntax import GHC.Runtime.Heap.Layout import GHC.Cmm +import GHC.Cmm.Utils import GHC.Cmm.Ppr.Expr() -- For Outputable instances import GHC.StgToCmm.Types @@ -87,7 +90,6 @@ import GHC.Core.TyCon import GHC.Types.RepType import GHC.Types.Basic import GHC.Utils.Outputable -import GHC.Driver.Session import GHC.Utils.Misc import Data.Coerce (coerce) @@ -308,24 +310,25 @@ type DynTag = Int -- The tag on a *pointer* -- -- Also see Note [Tagging big families] in GHC.StgToCmm.Expr -isSmallFamily :: DynFlags -> Int -> Bool -isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags +isSmallFamily :: Platform -> Int -> Bool +isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform -tagForCon :: DynFlags -> DataCon -> DynTag -tagForCon dflags con = min (dataConTag con) (mAX_PTR_TAG dflags) +tagForCon :: Platform -> DataCon -> DynTag +tagForCon platform con = min (dataConTag con) (mAX_PTR_TAG platform) -- NB: 1-indexed -tagForArity :: DynFlags -> RepArity -> DynTag -tagForArity dflags arity - | isSmallFamily dflags arity = arity - | otherwise = 0 +tagForArity :: Platform -> RepArity -> DynTag +tagForArity platform arity + | isSmallFamily platform arity = arity + | otherwise = 0 -lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag --- Return the tag in the low order bits of a variable bound +-- | Return the tag in the low order bits of a variable bound -- to this LambdaForm -lfDynTag dflags (LFCon con) = tagForCon dflags con -lfDynTag dflags (LFReEntrant _ arity _ _) = tagForArity dflags arity -lfDynTag _ _other = 0 +lfDynTag :: Platform -> LambdaFormInfo -> DynTag +lfDynTag platform lf = case lf of + LFCon con -> tagForCon platform con + LFReEntrant _ arity _ _ -> tagForArity platform arity + _other -> 0 ----------------------------------------------------------------------------- @@ -365,7 +368,7 @@ thunkClosureType _ = Thunk -- nodeMustPointToIt ----------------------------------------------------------------------------- -nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool +nodeMustPointToIt :: Profile -> LambdaFormInfo -> Bool -- If nodeMustPointToIt is true, then the entry convention for -- this closure has R1 (the "Node" register) pointing to the -- closure itself --- the "self" argument @@ -377,11 +380,11 @@ nodeMustPointToIt _ (LFReEntrant top _ no_fvs _) -- non-inherited (i.e. non-top-level) function. -- The isNotTopLevel test above ensures this is ok. -nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _) +nodeMustPointToIt profile (LFThunk top no_fvs updatable NonStandardThunk _) = not no_fvs -- Self parameter || isNotTopLevel top -- Note [GC recovery] || updatable -- Need to push update frame - || sccProfilingEnabled dflags + || profileIsProfiling profile -- For the non-updatable (single-entry case): -- -- True if has fvs (in which case we need access to them, and we @@ -476,7 +479,13 @@ data CallMethod CLabel -- The code label RepArity -- Its arity -getCallMethod :: DynFlags +data CallOpts = CallOpts + { co_profile :: !Profile -- ^ Platform profile + , co_loopification :: !Bool -- ^ Loopification enabled (cf @-floopification@) + , co_ticky :: !Bool -- ^ Ticky profiling enabled (cf @-ticky@) + } + +getCallMethod :: CallOpts -> Name -- Function being applied -> Id -- Function Id used to chech if it can refer to -- CAF's and whether the function is tail-calling @@ -492,9 +501,9 @@ getCallMethod :: DynFlags -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call? -> CallMethod -getCallMethod dflags _ id _ n_args v_args _cg_loc +getCallMethod opts _ id _ n_args v_args _cg_loc (Just (self_loop_id, block_id, args)) - | gopt Opt_Loopification dflags + | co_loopification opts , id == self_loop_id , args `lengthIs` (n_args - v_args) -- If these patterns match then we know that: @@ -505,14 +514,14 @@ getCallMethod dflags _ id _ n_args v_args _cg_loc -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details = JumpToIt block_id args -getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc +getCallMethod opts name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info | n_args == 0 -- No args at all - && not (sccProfilingEnabled dflags) + && not (profileIsProfiling (co_profile opts)) -- See Note [Evaluating functions with profiling] in rts/Apply.cmm = ASSERT( arity /= 0 ) ReturnIt | n_args < arity = SlowCall -- Not enough args - | otherwise = DirectEntry (enterIdLabel (targetPlatform dflags) name (idCafInfo id)) arity + | otherwise = DirectEntry (enterIdLabel (profilePlatform (co_profile opts)) name (idCafInfo id)) arity getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info = ASSERT( n_args == 0 ) ReturnIt @@ -522,14 +531,14 @@ getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info -- n_args=0 because it'd be ill-typed to apply a saturated -- constructor application to anything -getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun) +getCallMethod opts name id (LFThunk _ _ updatable std_form_info is_fun) n_args _v_args _cg_loc _self_loop_info | is_fun -- it *might* be a function, so we must "call" it (which is always safe) = SlowCall -- We cannot just enter it [in eval/apply, the entry code -- is the fast-entry code] -- Since is_fun is False, we are *definitely* looking at a data value - | updatable || gopt Opt_Ticky dflags -- to catch double entry + | updatable || co_ticky opts -- to catch double entry {- OLD: || opt_SMP I decided to remove this, because in SMP mode it doesn't matter if we enter the same thunk multiple times, so the optimisation @@ -551,7 +560,7 @@ getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun) | otherwise -- Jump direct to code for single-entry thunks = ASSERT( n_args == 0 ) - DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info + DirectEntry (thunkEntryLabel (profilePlatform (co_profile opts)) name (idCafInfo id) std_form_info updatable) 0 getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info @@ -619,14 +628,14 @@ mkCmmInfo ClosureInfo {..} id ccs -- Building ClosureInfos -------------------------------------- -mkClosureInfo :: DynFlags +mkClosureInfo :: Profile -> Bool -- Is static -> Id -> LambdaFormInfo -> Int -> Int -- Total and pointer words -> String -- String descriptor -> ClosureInfo -mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr +mkClosureInfo profile is_static id lf_info tot_wds ptr_wds val_descr = ClosureInfo { closureName = name , closureLFInfo = lf_info , closureInfoLabel = info_lbl -- These three fields are @@ -634,11 +643,11 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr , closureProf = prof } -- (we don't have an SRT yet) where name = idName id - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info) - prof = mkProfilingInfo dflags id val_descr + sm_rep = mkHeapRep profile is_static ptr_wds nonptr_wds (lfClosureType lf_info) + prof = mkProfilingInfo profile id val_descr nonptr_wds = tot_wds - ptr_wds - info_lbl = mkClosureInfoTableLabel dflags id lf_info + info_lbl = mkClosureInfoTableLabel (profilePlatform profile) id lf_info -------------------------------------- -- Other functions over ClosureInfo @@ -761,9 +770,9 @@ lfFunInfo :: LambdaFormInfo -> Maybe (RepArity, ArgDescr) lfFunInfo (LFReEntrant _ arity _ arg_desc) = Just (arity, arg_desc) lfFunInfo _ = Nothing -funTag :: DynFlags -> ClosureInfo -> DynTag -funTag dflags (ClosureInfo { closureLFInfo = lf_info }) - = lfDynTag dflags lf_info +funTag :: Platform -> ClosureInfo -> DynTag +funTag platform (ClosureInfo { closureLFInfo = lf_info }) + = lfDynTag platform lf_info isToplevClosure :: ClosureInfo -> Bool isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) @@ -787,14 +796,14 @@ closureLocalEntryLabel platform | platformTablesNextToCode platform = toInfoLbl . closureInfoLabel | otherwise = toEntryLbl . closureInfoLabel -mkClosureInfoTableLabel :: DynFlags -> Id -> LambdaFormInfo -> CLabel -mkClosureInfoTableLabel dflags id lf_info +mkClosureInfoTableLabel :: Platform -> Id -> LambdaFormInfo -> CLabel +mkClosureInfoTableLabel platform id lf_info = case lf_info of LFThunk _ _ upd_flag (SelectorThunk offset) _ - -> mkSelectorInfoLabel dflags upd_flag offset + -> mkSelectorInfoLabel platform upd_flag offset LFThunk _ _ upd_flag (ApThunk arity) _ - -> mkApInfoTableLabel dflags upd_flag arity + -> mkApInfoTableLabel platform upd_flag arity LFThunk{} -> std_mk_lbl name cafs LFReEntrant{} -> std_mk_lbl name cafs @@ -814,29 +823,23 @@ mkClosureInfoTableLabel dflags id lf_info -- invariants in "GHC.CoreToStg.Prep" anything else gets eta expanded. -thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel --- thunkEntryLabel is a local help function, not exported. It's used from +-- | thunkEntryLabel is a local help function, not exported. It's used from -- getCallMethod. -thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag - = enterApLabel dflags upd_flag arity -thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag - = enterSelectorLabel dflags upd_flag offset -thunkEntryLabel dflags thunk_id c _ _ - = enterIdLabel (targetPlatform dflags) thunk_id c - -enterApLabel :: DynFlags -> Bool -> Arity -> CLabel -enterApLabel dflags is_updatable arity - | platformTablesNextToCode platform = mkApInfoTableLabel dflags is_updatable arity - | otherwise = mkApEntryLabel dflags is_updatable arity - where - platform = targetPlatform dflags - -enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel -enterSelectorLabel dflags upd_flag offset - | platformTablesNextToCode platform = mkSelectorInfoLabel dflags upd_flag offset - | otherwise = mkSelectorEntryLabel dflags upd_flag offset - where - platform = targetPlatform dflags +thunkEntryLabel :: Platform -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel +thunkEntryLabel platform thunk_id caf_info sfi upd_flag = case sfi of + ApThunk arity -> enterApLabel platform upd_flag arity + SelectorThunk offset -> enterSelectorLabel platform upd_flag offset + _ -> enterIdLabel platform thunk_id caf_info + +enterApLabel :: Platform -> Bool -> Arity -> CLabel +enterApLabel platform is_updatable arity + | platformTablesNextToCode platform = mkApInfoTableLabel platform is_updatable arity + | otherwise = mkApEntryLabel platform is_updatable arity + +enterSelectorLabel :: Platform -> Bool -> WordOff -> CLabel +enterSelectorLabel platform upd_flag offset + | platformTablesNextToCode platform = mkSelectorInfoLabel platform upd_flag offset + | otherwise = mkSelectorEntryLabel platform upd_flag offset enterIdLabel :: Platform -> Name -> CafInfo -> CLabel enterIdLabel platform id c @@ -857,10 +860,10 @@ enterIdLabel platform id c -- The type is determined from the type information stored with the @Id@ -- in the closure info using @closureTypeDescr@. -mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo -mkProfilingInfo dflags id val_descr - | not (sccProfilingEnabled dflags) = NoProfilingInfo - | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr) +mkProfilingInfo :: Profile -> Id -> String -> ProfilingInfo +mkProfilingInfo profile id val_descr + | not (profileIsProfiling profile) = NoProfilingInfo + | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr) where ty_descr_w8 = BS8.pack (getTyDescription (idType id)) @@ -891,8 +894,8 @@ getTyLitDescription l = -- CmmInfoTable-related things -------------------------------------- -mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable -mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds +mkDataConInfoTable :: Profile -> DataCon -> Bool -> Int -> Int -> CmmInfoTable +mkDataConInfoTable profile data_con is_static ptr_wds nonptr_wds = CmmInfoTable { cit_lbl = info_lbl , cit_rep = sm_rep , cit_prof = prof @@ -901,12 +904,12 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds where name = dataConName data_con info_lbl = mkConInfoTableLabel name NoCafRefs - sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type + sm_rep = mkHeapRep profile is_static ptr_wds nonptr_wds cl_type cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con) -- We keep the *zero-indexed* tag in the srt_len field -- of the info table of a data constructor. - prof | not (sccProfilingEnabled dflags) = NoProfilingInfo + prof | not (profileIsProfiling profile) = NoProfilingInfo | otherwise = ProfilingInfo ty_descr val_descr ty_descr = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs index 30eeb25ab8..fdd4214b51 100644 --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -19,6 +19,9 @@ module GHC.StgToCmm.DataCon ( import GHC.Prelude +import GHC.Platform +import GHC.Platform.Profile + import GHC.Stg.Syntax import GHC.Core ( AltCon(..) ) @@ -46,7 +49,6 @@ import GHC.Types.RepType (countConRepArgs) import GHC.Types.Literal import GHC.Builtin.Utils import GHC.Utils.Outputable -import GHC.Platform import GHC.Utils.Misc import GHC.Utils.Monad (mapMaybeM) @@ -79,14 +81,16 @@ cgTopRhsCon dflags id con args = (id_Info, gen_code) where - id_Info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label) + platform = targetPlatform dflags + id_Info = litIdInfo platform id (mkConLFInfo con) (CmmLabel closure_label) name = idName id caffy = idCafInfo id -- any stgArgHasCafRefs args closure_label = mkClosureLabel name caffy gen_code = - do { this_mod <- getModuleName - ; when (platformOS (targetPlatform dflags) == OSMinGW32) $ + do { profile <- getProfile + ; this_mod <- getModuleName + ; when (platformOS platform == OSMinGW32) $ -- Windows DLLs have a problem with static cross-DLL refs. MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) ) ; ASSERT( args `lengthIs` countConRepArgs con ) return () @@ -96,7 +100,7 @@ cgTopRhsCon dflags id con args (tot_wds, -- #ptr_wds + #nonptr_wds ptr_wds, -- #ptr_wds nv_args_w_offsets) = - mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args) + mkVirtHeapOffsetsWithPadding profile StdHeader (addArgReps args) mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len)) mk_payload (FieldOff arg _) = do @@ -110,7 +114,7 @@ cgTopRhsCon dflags id con args -- we're not really going to emit an info table, so having -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields -- needs to poke around inside it. - info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds + info_tbl = mkDataConInfoTable profile con True ptr_wds nonptr_wds ; payload <- mapM mk_payload nv_args_w_offsets @@ -165,7 +169,7 @@ buildDynCon' dflags binder _ _cc con args = return (cgInfo, return mkNop) -------- buildDynCon': the general case ----------- -buildDynCon' dflags binder actually_bound ccs con args +buildDynCon' _ binder actually_bound ccs con args = do { (id_info, reg) <- rhsIdInfo binder lf_info ; return (id_info, gen_code reg) } @@ -173,17 +177,19 @@ buildDynCon' dflags binder actually_bound ccs con args lf_info = mkConLFInfo con gen_code reg - = do { let (tot_wds, ptr_wds, args_w_offsets) - = mkVirtConstrOffsets dflags (addArgReps args) + = do { profile <- getProfile + ; let platform = profilePlatform profile + (tot_wds, ptr_wds, args_w_offsets) + = mkVirtConstrOffsets profile (addArgReps args) nonptr_wds = tot_wds - ptr_wds - info_tbl = mkDataConInfoTable dflags con False + info_tbl = mkDataConInfoTable profile con False ptr_wds nonptr_wds ; let ticky_name | actually_bound = Just binder | otherwise = Nothing ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info use_cc blame_cc args_w_offsets - ; return (mkRhsInit dflags reg lf_info hp_plus_n) } + ; return (mkRhsInit platform reg lf_info hp_plus_n) } where use_cc -- cost-centre to stick in the object | isCurrentCCS ccs = cccsExpr @@ -293,7 +299,7 @@ precomputedStaticConInfo_maybe :: DynFlags -> Id -> DataCon -> [NonVoid StgArg] precomputedStaticConInfo_maybe dflags binder con [] -- Nullary constructors | isNullaryRepDataCon con - = Just $ litIdInfo dflags binder (mkConLFInfo con) + = Just $ litIdInfo (targetPlatform dflags) binder (mkConLFInfo con) (CmmLabel (mkClosureLabel (dataConName con) NoCafRefs)) precomputedStaticConInfo_maybe dflags binder con [arg] -- Int/Char values with existing closures in the RTS @@ -303,12 +309,13 @@ precomputedStaticConInfo_maybe dflags binder con [arg] , inRange val = let intlike_lbl = mkCmmClosureLabel rtsUnitId (fsLit label) val_int = fromIntegral val :: Int - offsetW = (val_int - (fromIntegral min_static_range)) * (fixedHdrSizeW dflags + 1) + offsetW = (val_int - (fromIntegral min_static_range)) * (fixedHdrSizeW profile + 1) -- INTLIKE/CHARLIKE closures consist of a header and one word payload static_amode = cmmLabelOffW platform intlike_lbl offsetW - in Just $ litIdInfo dflags binder (mkConLFInfo con) static_amode + in Just $ litIdInfo platform binder (mkConLFInfo con) static_amode where - platform = targetPlatform dflags + profile = targetProfile dflags + platform = profilePlatform profile intClosure = maybeIntLikeCon con charClosure = maybeCharLikeCon con getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val))) = Just val @@ -319,14 +326,16 @@ precomputedStaticConInfo_maybe dflags binder con [arg] inRange val = val >= min_static_range && val <= max_static_range + constants = platformConstants platform + min_static_range :: Integer min_static_range - | intClosure = fromIntegral (mIN_INTLIKE dflags) - | charClosure = fromIntegral (mIN_CHARLIKE dflags) + | intClosure = fromIntegral (pc_MIN_INTLIKE constants) + | charClosure = fromIntegral (pc_MIN_CHARLIKE constants) | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" max_static_range - | intClosure = fromIntegral (mAX_INTLIKE dflags) - | charClosure = fromIntegral (mAX_CHARLIKE dflags) + | intClosure = fromIntegral (pc_MAX_INTLIKE constants) + | charClosure = fromIntegral (pc_MAX_CHARLIKE constants) | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type" label | intClosure = "stg_INTLIKE" @@ -346,10 +355,10 @@ bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg] -- found a con bindConArgs (DataAlt con) base args = ASSERT(not (isUnboxedTupleCon con)) - do dflags <- getDynFlags + do profile <- getProfile platform <- getPlatform - let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args) - tag = tagForCon dflags con + let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args) + tag = tagForCon platform con -- The binding below forces the masking out of the tag bits -- when accessing the constructor field. diff --git a/compiler/GHC/StgToCmm/Env.hs b/compiler/GHC/StgToCmm/Env.hs index 9ee04c0617..e1a1e3c184 100644 --- a/compiler/GHC/StgToCmm/Env.hs +++ b/compiler/GHC/StgToCmm/Env.hs @@ -58,13 +58,12 @@ mkCgIdInfo id lf expr = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = CmmLoc expr } -litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo -litIdInfo dflags id lf lit +litIdInfo :: Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo +litIdInfo platform id lf lit = CgIdInfo { cg_id = id, cg_lf = lf , cg_loc = CmmLoc (addDynTag platform (CmmLit lit) tag) } where - tag = lfDynTag dflags lf - platform = targetPlatform dflags + tag = lfDynTag platform lf lneIdInfo :: Platform -> Id -> [NonVoid Id] -> CgIdInfo lneIdInfo platform id regs @@ -81,10 +80,9 @@ rhsIdInfo id lf_info reg <- newTemp (gcWord platform) return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) -mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph -mkRhsInit dflags reg lf_info expr - = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag dflags lf_info)) - where platform = targetPlatform dflags +mkRhsInit :: Platform -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph +mkRhsInit platform reg lf_info expr + = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag platform lf_info)) idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer @@ -124,7 +122,7 @@ addBindsC new_bindings = do getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id - = do { dflags <- getDynFlags + = do { platform <- targetPlatform <$> getDynFlags ; local_binds <- getBinds -- Try local bindings first ; case lookupVarEnv local_binds id of { Just info -> return info ; @@ -141,7 +139,7 @@ getCgIdInfo id mkBytesLabel name | otherwise = mkClosureLabel name $ idCafInfo id in return $ - litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl) + litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl) else cgLookupPanic id -- Bug }}} diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 6b4bddca33..61a4da571c 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -36,9 +36,9 @@ import GHC.Cmm.Graph import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info +import GHC.Cmm.Utils ( mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon -import GHC.Driver.Session ( mAX_PTR_TAG ) import GHC.Types.ForeignCall import GHC.Types.Id import GHC.Builtin.PrimOps @@ -71,13 +71,13 @@ cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = -- dataToTag# :: a -> Int# -- See Note [dataToTag#] in primops.txt.pp cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do - dflags <- getDynFlags platform <- getPlatform emitComment (mkFastString "dataToTag#") tmp <- newTemp (bWord platform) _ <- withSequel (AssignTo [tmp] False) (cgIdApp a []) -- TODO: For small types look at the tag bits instead of reading info table - emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))] + ptr_opts <- getPtrOpts + emitReturn [getConstrTag ptr_opts (cmmUntag platform (CmmReg (CmmLocal tmp)))] cgExpr (StgOpApp op args ty) = cgOpApp op args ty cgExpr (StgConApp con args _)= cgConApp con args @@ -564,18 +564,17 @@ cgAlts gc_plan bndr (PrimAlt _) alts ; return AssignedDirectly } cgAlts gc_plan bndr (AlgAlt tycon) alts - = do { dflags <- getDynFlags - ; platform <- getPlatform + = do { platform <- getPlatform ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts ; let !fam_sz = tyConFamilySize tycon !bndr_reg = CmmLocal (idToReg platform bndr) - !ptag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg) + !ptag_expr = cmmConstrTag1 platform (CmmReg bndr_reg) !branches' = first succ <$> branches - !maxpt = mAX_PTR_TAG dflags + !maxpt = mAX_PTR_TAG platform (!via_ptr, !via_info) = partition ((< maxpt) . fst) branches' - !small = isSmallFamily dflags fam_sz + !small = isSmallFamily platform fam_sz -- Is the constructor tag in the node reg? -- See Note [Tagging big families] @@ -587,8 +586,9 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts else -- No, the get exact tag from info table when mAX_PTR_TAG -- See Note [Double switching for big families] do - let !untagged_ptr = cmmUntag dflags (CmmReg bndr_reg) - !itag_expr = getConstrTag dflags untagged_ptr + ptr_opts <- getPtrOpts + let !untagged_ptr = cmmUntag platform (CmmReg bndr_reg) + !itag_expr = getConstrTag ptr_opts untagged_ptr !info0 = first pred <$> via_info if null via_ptr then emitSwitch itag_expr info0 mb_deflt 0 (fam_sz - 1) @@ -857,17 +857,17 @@ cgConApp con stg_args cgIdApp :: Id -> [StgArg] -> FCode ReturnKind cgIdApp fun_id args = do - dflags <- getDynFlags fun_info <- getCgIdInfo fun_id self_loop_info <- getSelfLoop + call_opts <- getCallOpts + profile <- getProfile let fun_arg = StgVarArg fun_id fun_name = idName fun_id fun = idInfoToAmode fun_info lf_info = cg_lf fun_info n_args = length args v_args = length $ filter (isVoidTy . stgArgType) args - node_points dflags = nodeMustPointToIt dflags lf_info - case getCallMethod dflags fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of + case getCallMethod call_opts fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of -- A value in WHNF, so we can just return it. ReturnIt | isVoidTy (idType fun_id) -> emitReturn [] @@ -885,7 +885,7 @@ cgIdApp fun_id args = do -- A direct function call (possibly with some left-over arguments) DirectEntry lbl arity -> do { tickyDirectCall arity args - ; if node_points dflags + ; if nodeMustPointToIt profile lf_info then directCall NativeNodeCall lbl arity (fun_arg:args) else directCall NativeDirectCall lbl arity args } @@ -1006,8 +1006,9 @@ cgIdApp fun_id args = do emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do - { dflags <- getDynFlags + { ptr_opts <- getPtrOpts ; platform <- getPlatform + ; profile <- getProfile ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff @@ -1021,9 +1022,9 @@ emitEnter fun = do -- Right now, we do what the old codegen did, and omit the tag -- test, just generating an enter. Return -> do - { let entry = entryCode platform $ closureInfoPtr dflags $ CmmReg nodeReg - ; emit $ mkJump dflags NativeNodeCall entry - [cmmUntag dflags fun] updfr_off + { let entry = entryCode platform $ closureInfoPtr ptr_opts $ CmmReg nodeReg + ; emit $ mkJump profile NativeNodeCall entry + [cmmUntag platform fun] updfr_off ; return AssignedDirectly } @@ -1054,21 +1055,21 @@ emitEnter fun = do -- AssignTo res_regs _ -> do { lret <- newBlockId - ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs [] + ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs [] ; lcall <- newBlockId ; updfr_off <- getUpdFrameOff ; let area = Young lret - ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area + ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area [fun] updfr_off [] -- refer to fun via nodeReg after the copyout, to avoid having -- both live simultaneously; this sometimes enables fun to be -- inlined in the RHS of the R1 assignment. - ; let entry = entryCode platform (closureInfoPtr dflags (CmmReg nodeReg)) + ; let entry = entryCode platform (closureInfoPtr ptr_opts (CmmReg nodeReg)) the_call = toCall entry (Just lret) updfr_off off outArgs regs ; tscope <- getTickScope ; emit $ copyout <*> - mkCbranch (cmmIsTagged dflags (CmmReg nodeReg)) + mkCbranch (cmmIsTagged platform (CmmReg nodeReg)) lret lcall Nothing <*> outOfLine lcall (the_call,tscope) <*> mkLabel lret tscope <*> diff --git a/compiler/GHC/StgToCmm/ExtCode.hs b/compiler/GHC/StgToCmm/ExtCode.hs index 05909d4bb5..380e4458e2 100644 --- a/compiler/GHC/StgToCmm/ExtCode.hs +++ b/compiler/GHC/StgToCmm/ExtCode.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TupleSections #-} -- | Our extended FCode monad. -- We add a mapping from names to CmmExpr, to support local variable names in @@ -32,19 +33,24 @@ module GHC.StgToCmm.ExtCode ( emit, emitLabel, emitAssign, emitStore, getCode, getCodeR, getCodeScoped, emitOutOfLine, - withUpdFrameOff, getUpdFrameOff + withUpdFrameOff, getUpdFrameOff, + getProfile, getPlatform, getPtrOpts ) where import GHC.Prelude +import GHC.Platform +import GHC.Platform.Profile + import qualified GHC.StgToCmm.Monad as F import GHC.StgToCmm.Monad (FCode, newUnique) import GHC.Cmm import GHC.Cmm.CLabel import GHC.Cmm.Graph +import GHC.Cmm.Info import GHC.Cmm.BlockId import GHC.Driver.Session @@ -98,9 +104,16 @@ instance MonadUnique CmmParse where return (decls, u) instance HasDynFlags CmmParse where - getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags - return (d, dflags)) + getDynFlags = EC (\_ _ d -> (d,) <$> getDynFlags) + +getProfile :: CmmParse Profile +getProfile = EC (\_ _ d -> (d,) <$> F.getProfile) + +getPlatform :: CmmParse Platform +getPlatform = EC (\_ _ d -> (d,) <$> F.getPlatform) +getPtrOpts :: CmmParse PtrOpts +getPtrOpts = EC (\_ _ d -> (d,) <$> F.getPtrOpts) -- | Takes the variable declarations and imports from the monad -- and makes an environment, which is looped back into the computation. diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs index aaffa17699..1f0939d344 100644 --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -22,6 +22,9 @@ module GHC.StgToCmm.Foreign ( import GHC.Prelude hiding( succ, (<*>) ) +import GHC.Platform +import GHC.Platform.Profile + import GHC.Stg.Syntax import GHC.StgToCmm.Prof (storeCurCCS, ccsType) import GHC.StgToCmm.Env @@ -40,8 +43,6 @@ import GHC.Types.RepType import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout import GHC.Types.ForeignCall -import GHC.Driver.Session -import GHC.Platform import GHC.Data.Maybe import GHC.Utils.Outputable import GHC.Types.Unique.Supply @@ -216,8 +217,8 @@ emitForeignCall -> FCode ReturnKind emitForeignCall safety results target args | not (playSafe safety) = do - dflags <- getDynFlags - let (caller_save, caller_load) = callerSaveVolatileRegs dflags + platform <- getPlatform + let (caller_save, caller_load) = callerSaveVolatileRegs platform emit caller_save target' <- load_target_into_temp target args' <- mapM maybe_assign_temp args @@ -226,13 +227,13 @@ emitForeignCall safety results target args return AssignedDirectly | otherwise = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform updfr_off <- getUpdFrameOff target' <- load_target_into_temp target args' <- mapM maybe_assign_temp args k <- newBlockId - let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results [] + let (off, _, copyout) = copyInOflow profile NativeReturn (Young k) results [] -- see Note [safe foreign call convention] tscope <- getTickScope emit $ @@ -283,32 +284,35 @@ maybe_assign_temp e = do emitSaveThreadState :: FCode () emitSaveThreadState = do - dflags <- getDynFlags - code <- saveThreadState dflags + profile <- getProfile + code <- saveThreadState profile emit code -- | Produce code to save the current thread state to @CurrentTSO@ -saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph -saveThreadState dflags = do - let platform = targetPlatform dflags +saveThreadState :: MonadUnique m => Profile -> m CmmAGraph +saveThreadState profile = do + let platform = profilePlatform profile tso <- newTemp (gcWord platform) - close_nursery <- closeNursery dflags tso - pure $ catAGraphs [ - -- tso = CurrentTSO; - mkAssign (CmmLocal tso) currentTSOExpr, - -- tso->stackobj->sp = Sp; - mkStore (cmmOffset platform - (CmmLoad (cmmOffset platform - (CmmReg (CmmLocal tso)) - (tso_stackobj dflags)) - (bWord platform)) - (stack_SP dflags)) - spExpr, - close_nursery, - -- and save the current cost centre stack in the TSO when profiling: - if sccProfilingEnabled dflags then - mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr - else mkNop + close_nursery <- closeNursery profile tso + pure $ catAGraphs + [ -- tso = CurrentTSO; + mkAssign (CmmLocal tso) currentTSOExpr + + , -- tso->stackobj->sp = Sp; + mkStore (cmmOffset platform + (CmmLoad (cmmOffset platform + (CmmReg (CmmLocal tso)) + (tso_stackobj profile)) + (bWord platform)) + (stack_SP profile)) + spExpr + + , close_nursery + + , -- and save the current cost centre stack in the TSO when profiling: + if profileIsProfiling profile + then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile)) cccsExpr + else mkNop ] @@ -323,26 +327,26 @@ saveThreadState dflags = do -- are live, we might have to save them all. emitSaveRegs :: FCode () emitSaveRegs = do - dflags <- getDynFlags - let regs = realArgRegsCover dflags - save = catAGraphs (map (callerSaveGlobalReg dflags) regs) + platform <- getPlatform + let regs = realArgRegsCover platform + save = catAGraphs (map (callerSaveGlobalReg platform) regs) emit save -- | Restore STG registers (see 'emitSaveRegs') emitRestoreRegs :: FCode () emitRestoreRegs = do - dflags <- getDynFlags - let regs = realArgRegsCover dflags - save = catAGraphs (map (callerRestoreGlobalReg dflags) regs) - emit save + platform <- getPlatform + let regs = realArgRegsCover platform + restore = catAGraphs (map (callerRestoreGlobalReg platform) regs) + emit restore emitCloseNursery :: FCode () emitCloseNursery = do - dflags <- getDynFlags - platform <- getPlatform + profile <- getProfile + let platform = profilePlatform profile tso <- newTemp (bWord platform) - code <- closeNursery dflags tso + code <- closeNursery profile tso emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code {- | @@ -366,24 +370,24 @@ Closing the nursery corresponds to the following code: cn->free = Hp + WDS(1); @ -} -closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph -closeNursery df tso = do - let tsoreg = CmmLocal tso - platform = targetPlatform df +closeNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph +closeNursery profile tso = do + let tsoreg = CmmLocal tso + platform = profilePlatform profile cnreg <- CmmLocal <$> newTemp (bWord platform) pure $ catAGraphs [ mkAssign cnreg currentNurseryExpr, -- CurrentNursery->free = Hp+1; - mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW platform hpExpr 1), + mkStore (nursery_bdescr_free platform cnreg) (cmmOffsetW platform hpExpr 1), let alloc = CmmMachOp (mo_wordSub platform) [ cmmOffsetW platform hpExpr 1 - , CmmLoad (nursery_bdescr_start df cnreg) (bWord platform) + , CmmLoad (nursery_bdescr_start platform cnreg) (bWord platform) ] - alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit df) + alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit profile) in -- tso->alloc_limit += alloc @@ -394,51 +398,51 @@ closeNursery df tso = do emitLoadThreadState :: FCode () emitLoadThreadState = do - dflags <- getDynFlags - code <- loadThreadState dflags + profile <- getProfile + code <- loadThreadState profile emit code -- | Produce code to load the current thread state from @CurrentTSO@ -loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph -loadThreadState dflags = do - let platform = targetPlatform dflags +loadThreadState :: MonadUnique m => Profile -> m CmmAGraph +loadThreadState profile = do + let platform = profilePlatform profile tso <- newTemp (gcWord platform) stack <- newTemp (gcWord platform) - open_nursery <- openNursery dflags tso + open_nursery <- openNursery profile tso pure $ catAGraphs [ -- tso = CurrentTSO; mkAssign (CmmLocal tso) currentTSOExpr, -- stack = tso->stackobj; - mkAssign (CmmLocal stack) (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord platform)), + mkAssign (CmmLocal stack) (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj profile)) (bWord platform)), -- Sp = stack->sp; - mkAssign spReg (CmmLoad (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord platform)), + mkAssign spReg (CmmLoad (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile)) (bWord platform)), -- SpLim = stack->stack + RESERVED_STACK_WORDS; - mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK dflags)) - (rESERVED_STACK_WORDS dflags)), + mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK profile)) + (pc_RESERVED_STACK_WORDS (platformConstants platform))), -- HpAlloc = 0; -- HpAlloc is assumed to be set to non-zero only by a failed -- a heap check, see HeapStackCheck.cmm:GC_GENERIC mkAssign hpAllocReg (zeroExpr platform), open_nursery, -- and load the current cost centre stack from the TSO when profiling: - if sccProfilingEnabled dflags + if profileIsProfiling profile then storeCurCCS (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) - (tso_CCCS dflags)) (ccsType platform)) + (tso_CCCS profile)) (ccsType platform)) else mkNop ] emitOpenNursery :: FCode () emitOpenNursery = do - dflags <- getDynFlags - platform <- getPlatform + profile <- getProfile + let platform = profilePlatform profile tso <- newTemp (bWord platform) - code <- openNursery dflags tso + code <- openNursery profile tso emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code {- | -@openNursery dflags tso@ produces code to open the nursery. A local register +@openNursery profile tso@ produces code to open the nursery. A local register holding the value of @CurrentTSO@ is expected for efficiency. Opening the nursery corresponds to the following code: @@ -465,10 +469,10 @@ Opening the nursery corresponds to the following code: HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1; @ -} -openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph -openNursery dflags tso = do - let tsoreg = CmmLocal tso - platform = targetPlatform dflags +openNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph +openNursery profile tso = do + let tsoreg = CmmLocal tso + platform = profilePlatform profile cnreg <- CmmLocal <$> newTemp (bWord platform) bdfreereg <- CmmLocal <$> newTemp (bWord platform) bdstartreg <- CmmLocal <$> newTemp (bWord platform) @@ -479,12 +483,12 @@ openNursery dflags tso = do -- stg_returnToStackTop in rts/StgStartup.cmm. pure $ catAGraphs [ mkAssign cnreg currentNurseryExpr, - mkAssign bdfreereg (CmmLoad (nursery_bdescr_free dflags cnreg) (bWord platform)), + mkAssign bdfreereg (CmmLoad (nursery_bdescr_free platform cnreg) (bWord platform)), -- Hp = CurrentNursery->free - 1; mkAssign hpReg (cmmOffsetW platform (CmmReg bdfreereg) (-1)), - mkAssign bdstartreg (CmmLoad (nursery_bdescr_start dflags cnreg) (bWord platform)), + mkAssign bdstartreg (CmmLoad (nursery_bdescr_start platform cnreg) (bWord platform)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; @@ -494,8 +498,8 @@ openNursery dflags tso = do (cmmOffset platform (CmmMachOp (mo_wordMul platform) [ CmmMachOp (MO_SS_Conv W32 (wordWidth platform)) - [CmmLoad (nursery_bdescr_blocks dflags cnreg) b32], - mkIntExpr platform (bLOCK_SIZE dflags) + [CmmLoad (nursery_bdescr_blocks platform cnreg) b32], + mkIntExpr platform (pc_BLOCK_SIZE (platformConstants platform)) ]) (-1) ) @@ -505,7 +509,7 @@ openNursery dflags tso = do let alloc = CmmMachOp (mo_wordSub platform) [CmmReg bdfreereg, CmmReg bdstartreg] - alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit dflags) + alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit profile) in -- tso->alloc_limit += alloc @@ -516,24 +520,24 @@ openNursery dflags tso = do ] nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks - :: DynFlags -> CmmReg -> CmmExpr -nursery_bdescr_free dflags cn = - cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_free dflags) -nursery_bdescr_start dflags cn = - cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_start dflags) -nursery_bdescr_blocks dflags cn = - cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_blocks dflags) + :: Platform -> CmmReg -> CmmExpr +nursery_bdescr_free platform cn = + cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_free (platformConstants platform)) +nursery_bdescr_start platform cn = + cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_start (platformConstants platform)) +nursery_bdescr_blocks platform cn = + cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_blocks (platformConstants platform)) -tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff -tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags) -tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags) -tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags) -stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags) -stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags) +tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: Profile -> ByteOff +tso_stackobj profile = closureField profile (pc_OFFSET_StgTSO_stackobj (profileConstants profile)) +tso_alloc_limit profile = closureField profile (pc_OFFSET_StgTSO_alloc_limit (profileConstants profile)) +tso_CCCS profile = closureField profile (pc_OFFSET_StgTSO_cccs (profileConstants profile)) +stack_STACK profile = closureField profile (pc_OFFSET_StgStack_stack (profileConstants profile)) +stack_SP profile = closureField profile (pc_OFFSET_StgStack_sp (profileConstants profile)) -closureField :: DynFlags -> ByteOff -> ByteOff -closureField dflags off = off + fixedHdrSize dflags +closureField :: Profile -> ByteOff -> ByteOff +closureField profile off = off + fixedHdrSize profile -- Note [Unlifted boxed arguments to foreign calls] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -601,8 +605,8 @@ getFCallArgs args typ = return Nothing | otherwise = do { cmm <- getArgAmode (NonVoid arg) - ; dflags <- getDynFlags - ; return (Just (add_shim dflags typ cmm, hint)) } + ; profile <- getProfile + ; return (Just (add_shim profile typ cmm, hint)) } where arg_ty = stgArgType arg arg_reps = typePrimRep arg_ty @@ -618,14 +622,14 @@ data StgFArgType | StgByteArrayType -- See Note [Unlifted boxed arguments to foreign calls] -add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr -add_shim dflags ty expr = case ty of - StgPlainType -> expr - StgArrayType -> cmmOffsetB platform expr (arrPtrsHdrSize dflags) - StgSmallArrayType -> cmmOffsetB platform expr (smallArrPtrsHdrSize dflags) - StgByteArrayType -> cmmOffsetB platform expr (arrWordsHdrSize dflags) +add_shim :: Profile -> StgFArgType -> CmmExpr -> CmmExpr +add_shim profile ty expr = case ty of + StgPlainType -> expr + StgArrayType -> cmmOffsetB platform expr (arrPtrsHdrSize profile) + StgSmallArrayType -> cmmOffsetB platform expr (smallArrPtrsHdrSize profile) + StgByteArrayType -> cmmOffsetB platform expr (arrWordsHdrSize profile) where - platform = targetPlatform dflags + platform = profilePlatform profile -- From a function, extract information needed to determine -- the offset of each argument when used as a C FFI argument. diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs index 1804193de4..2edbdbf6c8 100644 --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -47,6 +47,7 @@ import GHC.Types.Id ( Id ) import GHC.Unit import GHC.Driver.Session import GHC.Platform +import GHC.Platform.Profile import GHC.Data.FastString( mkFastString, fsLit ) import GHC.Utils.Panic( sorry ) @@ -135,20 +136,19 @@ allocHeapClosure rep info_ptr use_cc payload = do hpStore base payload -- Bump the virtual heap pointer - dflags <- getDynFlags - setVirtHp (virt_hp + heapClosureSizeW dflags rep) + profile <- getProfile + setVirtHp (virt_hp + heapClosureSizeW profile rep) return base emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitSetDynHdr base info_ptr ccs - = do dflags <- getDynFlags - let platform = targetPlatform dflags - hpStore base (zip (header dflags) [0, platformWordSizeInBytes platform ..]) + = do profile <- getProfile + hpStore base (zip (header profile) [0, profileWordSizeInBytes profile ..]) where - header :: DynFlags -> [CmmExpr] - header dflags = [info_ptr] ++ dynProfHdr dflags ccs + header :: Profile -> [CmmExpr] + header profile = [info_ptr] ++ dynProfHdr profile ccs -- ToDo: Parallel stuff -- No ticky header @@ -167,17 +167,17 @@ hpStore base vals = do -- and adding a static link field if necessary. mkStaticClosureFields - :: DynFlags + :: Profile -> CmmInfoTable -> CostCentreStack -> CafInfo -> [CmmLit] -- Payload -> [CmmLit] -- The full closure -mkStaticClosureFields dflags info_tbl ccs caf_refs payload - = mkStaticClosure dflags info_lbl ccs payload padding +mkStaticClosureFields profile info_tbl ccs caf_refs payload + = mkStaticClosure profile info_lbl ccs payload padding static_link_field saved_info_field where - platform = targetPlatform dflags + platform = profilePlatform profile info_lbl = cit_lbl info_tbl -- CAFs must have consistent layout, regardless of whether they @@ -219,11 +219,11 @@ mkStaticClosureFields dflags info_tbl ccs caf_refs payload -- See Note [STATIC_LINK fields] -- in rts/sm/Storage.h -mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] +mkStaticClosure :: Profile -> CLabel -> CostCentreStack -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field +mkStaticClosure profile info_lbl ccs payload padding static_link_field saved_info_field = [CmmLabel info_lbl] - ++ staticProfHdr dflags ccs + ++ staticProfHdr profile ccs ++ payload ++ padding ++ static_link_field @@ -352,7 +352,7 @@ entryHeapCheck' :: Bool -- is a known function pattern -> FCode () -> FCode () entryHeapCheck' is_fastf node arity args code - = do dflags <- getDynFlags + = do profile <- getProfile let is_thunk = arity == 0 args' = map (CmmReg . CmmLocal) args @@ -367,13 +367,13 @@ entryHeapCheck' is_fastf node arity args code -} gc_call upd | is_thunk - = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd + = mkJump profile NativeNodeCall stg_gc_enter1 [node] upd | is_fastf - = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd + = mkJump profile NativeNodeCall stg_gc_fun (node : args') upd | otherwise - = mkJump dflags Slow stg_gc_fun (node : args') upd + = mkJump profile Slow stg_gc_fun (node : args') upd updfr_sz <- getUpdFrameOff @@ -404,13 +404,13 @@ altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a altOrNoEscapeHeapCheck checkYield regs code = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform case cannedGCEntryPoint platform regs of Nothing -> genericGC checkYield code Just gc -> do lret <- newBlockId - let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs [] + let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) regs [] lcont <- newBlockId tscope <- getTickScope emitOutOfLine lret (copyin <*> mkBranch lcont, tscope) @@ -434,9 +434,9 @@ cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code - = do dflags <- getDynFlags + = do profile <- getProfile updfr_sz <- getUpdFrameOff - heapCheck False checkYield (gc_call dflags gc updfr_sz) code + heapCheck False checkYield (gc_call profile gc updfr_sz) code where reg_exprs = map (CmmReg . CmmLocal) regs -- Note [stg_gc arguments] @@ -445,11 +445,11 @@ cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code -- to the canned heap-check routines, because we are in a case -- alternative and hence the [LocalReg] was passed to us in the -- NativeReturn convention. - gc_call dflags label sp + gc_call profile label sp | cont_on_stack - = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp + = mkJumpReturnsTo profile label NativeReturn reg_exprs lret off sp | otherwise - = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp [] + = mkCallReturnsTo profile label NativeReturn reg_exprs lret off sp [] genericGC :: Bool -> FCode a -> FCode a genericGC checkYield code @@ -521,8 +521,7 @@ heapCheck checkStack checkYield do_gc code = getHeapUsage $ \ hpHw -> -- Emit heap checks, but be sure to do it lazily so -- that the conditionals on hpHw don't cause a black hole - do { dflags <- getDynFlags - ; platform <- getPlatform + do { platform <- getPlatform ; let mb_alloc_bytes | hpHw > mBLOCK_SIZE = sorry $ unlines [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.", @@ -533,7 +532,10 @@ heapCheck checkStack checkYield do_gc code "structures in code."] | hpHw > 0 = Just (mkIntExpr platform (hpHw * (platformWordSizeInBytes platform))) | otherwise = Nothing - where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags + where + constants = platformConstants platform + bLOCK_SIZE_W = pc_BLOCK_SIZE (platformConstants platform) `quot` platformWordSizeInBytes platform + mBLOCK_SIZE = pc_BLOCKS_PER_MBLOCK constants * bLOCK_SIZE_W stk_hwm | checkStack = Just (CmmLit CmmHighStackMark) | otherwise = Nothing ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs index 3ccc3c51ac..566e6666ad 100644 --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -54,6 +54,7 @@ import GHC.Core.TyCon ( PrimRep(..), primRepSizeB ) import GHC.Types.Basic ( RepArity ) import GHC.Driver.Session import GHC.Platform +import GHC.Platform.Profile import GHC.Unit import GHC.Utils.Misc @@ -78,7 +79,7 @@ import Control.Monad -- emitReturn :: [CmmExpr] -> FCode ReturnKind emitReturn results - = do { dflags <- getDynFlags + = do { profile <- getProfile ; platform <- getPlatform ; sequel <- getSequel ; updfr_off <- getUpdFrameOff @@ -86,7 +87,7 @@ emitReturn results Return -> do { adjustHpBackwards ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform) - ; emit (mkReturn dflags (entryCode platform e) results updfr_off) + ; emit (mkReturn profile (entryCode platform e) results updfr_off) } AssignTo regs adjust -> do { when adjust adjustHpBackwards @@ -113,19 +114,19 @@ emitCallWithExtraStack :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> [CmmExpr] -> FCode ReturnKind emitCallWithExtraStack (callConv, retConv) fun args extra_stack - = do { dflags <- getDynFlags + = do { profile <- getProfile ; adjustHpBackwards ; sequel <- getSequel ; updfr_off <- getUpdFrameOff ; case sequel of Return -> do - emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack + emit $ mkJumpExtra profile callConv fun args updfr_off extra_stack return AssignedDirectly AssignTo res_regs _ -> do k <- newBlockId let area = Young k - (off, _, copyin) = copyInOflow dflags retConv area res_regs [] - copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off + (off, _, copyin) = copyInOflow profile retConv area res_regs [] + copyout = mkCallReturnsTo profile fun callConv args k off updfr_off extra_stack tscope <- getTickScope emit (copyout <*> mkLabel k tscope <*> copyin) @@ -191,7 +192,8 @@ slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind -- (slowCall fun args) applies fun to args, returning the results to Sequel slowCall fun stg_args = do dflags <- getDynFlags - platform <- getPlatform + profile <- getProfile + let platform = profilePlatform profile argsreps <- getArgRepsAmodes stg_args let (rts_fun, arity) = slowCallPattern (map fst argsreps) @@ -207,9 +209,10 @@ slowCall fun stg_args let n_args = length stg_args if n_args > arity && optLevel dflags >= 2 then do + ptr_opts <- getPtrOpts funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun fun_iptr <- (CmmReg . CmmLocal) `fmap` - assignTemp (closureInfoPtr dflags (cmmUntag dflags funv)) + assignTemp (closureInfoPtr ptr_opts (cmmUntag platform funv)) -- ToDo: we could do slightly better here by reusing the -- continuation from the slow call, which we have in r. @@ -230,11 +233,11 @@ slowCall fun stg_args is_tagged_lbl <- newBlockId end_lbl <- newBlockId - let correct_arity = cmmEqWord platform (funInfoArity dflags fun_iptr) + let correct_arity = cmmEqWord platform (funInfoArity profile fun_iptr) (mkIntExpr platform n_args) tscope <- getTickScope - emit (mkCbranch (cmmIsTagged dflags funv) + emit (mkCbranch (cmmIsTagged platform funv) is_tagged_lbl slow_lbl (Just True) <*> mkLabel is_tagged_lbl tscope <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True) @@ -411,7 +414,7 @@ data ClosureHeader | ThunkHeader mkVirtHeapOffsetsWithPadding - :: DynFlags + :: Profile -> ClosureHeader -- What kind of header to account for -> [NonVoid (PrimRep, a)] -- Things to make offsets for -> ( WordOff -- Total number of words allocated @@ -426,18 +429,18 @@ mkVirtHeapOffsetsWithPadding -- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets -- than the unboxed things -mkVirtHeapOffsetsWithPadding dflags header things = +mkVirtHeapOffsetsWithPadding profile header things = ASSERT(not (any (isVoidRep . fst . fromNonVoid) things)) ( tot_wds , bytesToWordsRoundUp platform bytes_of_ptrs , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad ) where - platform = targetPlatform dflags + platform = profilePlatform profile hdr_words = case header of NoHeader -> 0 - StdHeader -> fixedHdrSizeW dflags - ThunkHeader -> thunkHdrSize dflags + StdHeader -> fixedHdrSizeW profile + ThunkHeader -> thunkHdrSize profile hdr_bytes = wordsToBytes platform hdr_words (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things @@ -485,36 +488,36 @@ mkVirtHeapOffsetsWithPadding dflags header things = mkVirtHeapOffsets - :: DynFlags + :: Profile -> ClosureHeader -- What kind of header to account for -> [NonVoid (PrimRep,a)] -- Things to make offsets for -> (WordOff, -- _Total_ number of words allocated WordOff, -- Number of words allocated for *pointers* [(NonVoid a, ByteOff)]) -mkVirtHeapOffsets dflags header things = +mkVirtHeapOffsets profile header things = ( tot_wds , ptr_wds , [ (field, offset) | (FieldOff field offset) <- things_offsets ] ) where (tot_wds, ptr_wds, things_offsets) = - mkVirtHeapOffsetsWithPadding dflags header things + mkVirtHeapOffsetsWithPadding profile header things -- | Just like mkVirtHeapOffsets, but for constructors mkVirtConstrOffsets - :: DynFlags -> [NonVoid (PrimRep, a)] + :: Profile -> [NonVoid (PrimRep, a)] -> (WordOff, WordOff, [(NonVoid a, ByteOff)]) -mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags StdHeader +mkVirtConstrOffsets profile = mkVirtHeapOffsets profile StdHeader -- | Just like mkVirtConstrOffsets, but used when we don't have the actual -- arguments. Useful when e.g. generating info tables; we just need to know -- sizes of pointer and non-pointer fields. -mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff) -mkVirtConstrSizes dflags field_reps +mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff) +mkVirtConstrSizes profile field_reps = (tot_wds, ptr_wds) where (tot_wds, ptr_wds, _) = - mkVirtConstrOffsets dflags + mkVirtConstrOffsets profile (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps) ------------------------------------------------------------------------- @@ -601,19 +604,19 @@ emitClosureProcAndInfoTable :: Bool -- top-level? -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body -> FCode () emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body - = do { dflags <- getDynFlags + = do { profile <- getProfile ; platform <- getPlatform -- Bind the binder itself, but only if it's not a top-level -- binding. We need non-top let-bindings to refer to the -- top-level binding, which this binding would incorrectly shadow. ; node <- if top_lvl then return $ idToReg platform (NonVoid bndr) else bindToReg (NonVoid bndr) lf_info - ; let node_points = nodeMustPointToIt dflags lf_info + ; let node_points = nodeMustPointToIt profile lf_info ; arg_regs <- bindArgsToRegs args ; let args' = if node_points then (node : arg_regs) else arg_regs - conv = if nodeMustPointToIt dflags lf_info then NativeNodeCall + conv = if nodeMustPointToIt profile lf_info then NativeNodeCall else NativeDirectCall - (offset, _, _) = mkCallEntry dflags conv args' [] + (offset, _, _) = mkCallEntry profile conv args' [] ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs) } diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs index 6beb08398b..802f3ae54d 100644 --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -22,8 +22,9 @@ module GHC.StgToCmm.Monad ( emitOutOfLine, emitAssign, emitStore, emitComment, emitTick, emitUnwind, - getCmm, aGraphToGraph, getPlatform, + getCmm, aGraphToGraph, getPlatform, getProfile, getCodeR, getCode, getCodeScoped, getHeapUsage, + getCallOpts, getPtrOpts, mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto, mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto', @@ -62,6 +63,7 @@ module GHC.StgToCmm.Monad ( import GHC.Prelude hiding( sequence, succ ) import GHC.Platform +import GHC.Platform.Profile import GHC.Cmm import GHC.StgToCmm.Closure import GHC.Driver.Session @@ -69,6 +71,7 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Graph as CmmGraph import GHC.Cmm.BlockId import GHC.Cmm.CLabel +import GHC.Cmm.Info import GHC.Runtime.Heap.Layout import GHC.Unit import GHC.Types.Id @@ -471,8 +474,31 @@ withSelfLoop self_loop code = do instance HasDynFlags FCode where getDynFlags = liftM cgd_dflags getInfoDown +getProfile :: FCode Profile +getProfile = targetProfile <$> getDynFlags + getPlatform :: FCode Platform -getPlatform = targetPlatform <$> getDynFlags +getPlatform = profilePlatform <$> getProfile + +getCallOpts :: FCode CallOpts +getCallOpts = do + dflags <- getDynFlags + profile <- getProfile + pure $ CallOpts + { co_profile = profile + , co_loopification = gopt Opt_Loopification dflags + , co_ticky = gopt Opt_Ticky dflags + } + +getPtrOpts :: FCode PtrOpts +getPtrOpts = do + dflags <- getDynFlags + profile <- getProfile + pure $ PtrOpts + { po_profile = profile + , po_align_check = gopt Opt_AlignmentSanitisation dflags + } + withInfoDown :: FCode a -> CgInfoDownwards -> FCode a withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state @@ -742,8 +768,8 @@ emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False } emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True -- do layout - = do { dflags <- getDynFlags - ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args + = do { profile <- getProfile + ; let (offset, live, entry) = mkCallEntry profile conv args stk_args graph' = entry CmmGraph.<*> graph ; emitProc mb_info lbl live (graph', tscope) offset True } @@ -837,12 +863,12 @@ mkCmmIfThen' e tbranch l = do mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do - dflags <- getDynFlags - k <- newBlockId - tscp <- getTickScope + profile <- getProfile + k <- newBlockId + tscp <- getTickScope let area = Young k - (off, _, copyin) = copyInOflow dflags retConv area results [] - copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack + (off, _, copyin) = copyInOflow profile retConv area results [] + copyout = mkCallReturnsTo profile f callConv actuals k off updfr_off extra_stack return $ catAGraphs [copyout, mkLabel k tscp, copyin] mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index c3a14f9b1c..374b5241fc 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -27,6 +27,9 @@ module GHC.StgToCmm.Prim ( import GHC.Prelude hiding ((<*>)) +import GHC.Platform +import GHC.Platform.Profile + import GHC.StgToCmm.Layout import GHC.StgToCmm.Foreign import GHC.StgToCmm.Env @@ -38,7 +41,6 @@ import GHC.StgToCmm.Prof ( costCentreFrom ) import GHC.Driver.Session import GHC.Driver.Backend -import GHC.Platform import GHC.Types.Basic import GHC.Cmm.BlockId import GHC.Cmm.Graph @@ -165,11 +167,11 @@ emitPrimOp dflags primop = case primop of NewArrayOp -> \case [(CmmLit (CmmInt n w)), init] | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) - -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel + -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel [ (mkIntExpr platform (fromInteger n), - fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags) - , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))), - fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags) + fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)) + , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep platform (fromInteger n))), + fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_size (platformConstants platform)) ] (fromInteger n) init _ -> PrimopCmmEmit_External @@ -224,7 +226,7 @@ emitPrimOp dflags primop = case primop of -> opIntoRegs $ \ [res] -> doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel [ (mkIntExpr platform (fromInteger n), - fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags) + fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)) ] (fromInteger n) init _ -> PrimopCmmEmit_External @@ -288,7 +290,7 @@ emitPrimOp dflags primop = case primop of GetCCSOfOp -> \[arg] -> opIntoRegs $ \[res] -> do let val - | sccProfilingEnabled dflags = costCentreFrom dflags (cmmUntag dflags arg) + | profileIsProfiling profile = costCentreFrom platform (cmmUntag platform arg) | otherwise = CmmLit (zeroCLit platform) emitAssign (CmmLocal res) val @@ -299,11 +301,11 @@ emitPrimOp dflags primop = case primop of emitAssign (CmmLocal res) currentTSOExpr ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] -> do - emitAssign (CmmLocal res) (cmmLoadIndexW platform mutv (fixedHdrSizeW dflags) (gcWord platform)) + emitAssign (CmmLocal res) (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform)) WriteMutVarOp -> \[mutv, var] -> opIntoRegs $ \res@[] -> do old_val <- CmmLocal <$> newTemp (cmmExprType platform var) - emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW dflags) (gcWord platform)) + emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform)) -- Without this write barrier, other CPUs may see this pointer before -- the writes for the closure it points to have occurred. @@ -311,7 +313,7 @@ emitPrimOp dflags primop = case primop of -- that the read of old_val comes before another core's write to the -- MutVar's value. emitPrimCall res MO_WriteBarrier [] - emitStore (cmmOffsetW platform mutv (fixedHdrSizeW dflags)) var + emitStore (cmmOffsetW platform mutv (fixedHdrSizeW profile)) var emitCCall [{-no results-}] (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) @@ -320,7 +322,7 @@ emitPrimOp dflags primop = case primop of -- #define sizzeofByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do - emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform)) + emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) -- #define sizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes @@ -329,7 +331,7 @@ emitPrimOp dflags primop = case primop of -- #define getSizzeofMutableByteArrayzh(r,a) \ -- r = ((StgArrBytes *)(a))->bytes GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do - emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform)) + emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) -- #define touchzh(o) /* nothing */ @@ -338,11 +340,11 @@ emitPrimOp dflags primop = case primop of -- #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a) ByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] -> do - emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize dflags)) + emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile)) -- #define stableNameToIntzh(r,s) (r = ((StgStableName *)s)->sn) StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] -> do - emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform)) + emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform)) ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] -> do emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2]) @@ -423,7 +425,7 @@ emitPrimOp dflags primop = case primop of SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg - (fixedHdrSizeW dflags + bytesToWordsRoundUp platform (oFFSET_StgMutArrPtrs_ptrs dflags)) + (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))) (bWord platform)) SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp @@ -431,7 +433,7 @@ emitPrimOp dflags primop = case primop of SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg - (fixedHdrSizeW dflags + bytesToWordsRoundUp platform (oFFSET_StgSmallMutArrPtrs_ptrs dflags)) + (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform))) (bWord platform)) SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp @@ -1518,7 +1520,8 @@ emitPrimOp dflags primop = case primop of SetThreadAllocationCounter -> alwaysExternal where - platform = targetPlatform dflags + profile = targetProfile dflags + platform = profilePlatform profile result_info = getPrimOpResultInfo primop opNop :: [CmmExpr] -> PrimopCmmEmit @@ -1963,8 +1966,8 @@ doIndexByteArrayOp :: Maybe MachOp -> [CmmExpr] -> FCode () doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx] - = do dflags <- getDynFlags - mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx + = do profile <- getProfile + mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx doIndexByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp" @@ -1975,8 +1978,8 @@ doIndexByteArrayOpAs :: Maybe MachOp -> [CmmExpr] -> FCode () doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx] - = do dflags <- getDynFlags - mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx + = do profile <- getProfile + mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx doIndexByteArrayOpAs _ _ _ _ _ = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs" @@ -1985,9 +1988,9 @@ doReadPtrArrayOp :: LocalReg -> CmmExpr -> FCode () doReadPtrArrayOp res addr idx - = do dflags <- getDynFlags + = do profile <- getProfile platform <- getPlatform - mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord platform) res addr (gcWord platform) idx + mkBasicIndexedRead (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx doWriteOffAddrOp :: Maybe MachOp -> CmmType @@ -2005,8 +2008,8 @@ doWriteByteArrayOp :: Maybe MachOp -> [CmmExpr] -> FCode () doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val] - = do dflags <- getDynFlags - mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val + = do profile <- getProfile + mkBasicIndexedWrite (arrWordsHdrSize profile) maybe_pre_write_cast addr idx_ty idx val doWriteByteArrayOp _ _ _ _ = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp" @@ -2015,10 +2018,10 @@ doWritePtrArrayOp :: CmmExpr -> CmmExpr -> FCode () doWritePtrArrayOp addr idx val - = do dflags <- getDynFlags + = do profile <- getProfile platform <- getPlatform let ty = cmmExprType platform val - hdr_size = arrPtrsHdrSize dflags + hdr_size = arrPtrsHdrSize profile -- Update remembered set for non-moving collector whenUpdRemSetEnabled $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform hdr_size ty addr ty idx) @@ -2033,15 +2036,15 @@ doWritePtrArrayOp addr idx val emit $ mkStore ( cmmOffsetExpr platform (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size) - (loadArrPtrsSize dflags addr)) + (loadArrPtrsSize profile addr)) (CmmMachOp (mo_wordUShr platform) [idx, - mkIntExpr platform (mUT_ARR_PTRS_CARD_BITS dflags)]) + mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))]) ) (CmmLit (CmmInt 1 W8)) -loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr -loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB platform addr off) (bWord platform) - where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags - platform = targetPlatform dflags +loadArrPtrsSize :: Profile -> CmmExpr -> CmmExpr +loadArrPtrsSize profile addr = CmmLoad (cmmOffsetB platform addr off) (bWord platform) + where off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (profileConstants profile) + platform = profilePlatform profile mkBasicIndexedRead :: ByteOff -- Initial offset in bytes -> Maybe MachOp -- Optional result cast @@ -2171,11 +2174,12 @@ checkVecCompatibility dflags vcat l w = do ,"Please use -fllvm."] check vecWidth vcat l w where + platform = targetPlatform dflags check :: Width -> PrimOpVecCat -> Length -> Width -> FCode () - check W128 FloatVec 4 W32 | not (isSseEnabled dflags) = + check W128 FloatVec 4 W32 | not (isSseEnabled platform) = sorry $ "128-bit wide single-precision floating point " ++ "SIMD vector instructions require at least -msse." - check W128 _ _ _ | not (isSse2Enabled dflags) = + check W128 _ _ _ | not (isSse2Enabled platform) = sorry $ "128-bit wide integer and double precision " ++ "SIMD vector instructions require at least -msse2." check W256 FloatVec _ _ | not (isAvxEnabled dflags) = @@ -2302,8 +2306,8 @@ doPrefetchByteArrayOp :: Int -> [CmmExpr] -> FCode () doPrefetchByteArrayOp locality [addr,idx] - = do dflags <- getDynFlags - mkBasicPrefetch locality (arrWordsHdrSize dflags) addr idx + = do profile <- getProfile + mkBasicPrefetch locality (arrWordsHdrSize profile) addr idx doPrefetchByteArrayOp _ _ = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" @@ -2312,8 +2316,8 @@ doPrefetchMutableByteArrayOp :: Int -> [CmmExpr] -> FCode () doPrefetchMutableByteArrayOp locality [addr,idx] - = do dflags <- getDynFlags - mkBasicPrefetch locality (arrWordsHdrSize dflags) addr idx + = do profile <- getProfile + mkBasicPrefetch locality (arrWordsHdrSize profile) addr idx doPrefetchMutableByteArrayOp _ _ = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp" @@ -2355,21 +2359,21 @@ mkBasicPrefetch locality off base idx -- 'MutableByteArray#'. doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode () doNewByteArrayOp res_r n = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let info_ptr = mkLblExpr mkArrWords_infoLabel rep = arrWordsRep platform n - tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize dflags)) + tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize profile)) (mkIntExpr platform (nonHdrSize platform rep)) (zeroExpr platform) - let hdr_size = fixedHdrSize dflags + let hdr_size = fixedHdrSize profile base <- allocHeapClosure rep info_ptr cccsExpr [ (mkIntExpr platform n, - hdr_size + oFFSET_StgArrBytes_bytes dflags) + hdr_size + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)) ] emit $ mkAssign (CmmLocal res_r) base @@ -2380,10 +2384,10 @@ doNewByteArrayOp res_r n = do doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform - ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize dflags)) ba1_off - ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize dflags)) ba2_off + ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off + ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off -- short-cut in case of equal pointers avoiding a costly -- subroutine call to the memcmp(3) routine; the Cmm logic below @@ -2469,14 +2473,14 @@ emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitCopyByteArray copy src src_off dst dst_off n = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let byteArrayAlignment = wordAlignment platform srcOffAlignment = cmmExprAlignment src_off dstOffAlignment = cmmExprAlignment dst_off align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment] - dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize dflags)) dst_off - src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize dflags)) src_off + dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off + src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off copy src dst dst_p src_p n align -- | Takes a source 'ByteArray#', an offset in the source array, a @@ -2485,9 +2489,9 @@ emitCopyByteArray copy src src_off dst dst_off n = do doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doCopyByteArrayToAddrOp src src_off dst_p bytes = do -- Use memcpy (we are allowed to assume the arrays aren't overlapping) - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform - src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize dflags)) src_off + src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off emitMemcpyCall dst_p src_p bytes (mkAlignment 1) -- | Takes a source 'MutableByteArray#', an offset in the source array, a @@ -2503,9 +2507,9 @@ doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doCopyAddrToByteArrayOp src_p dst dst_off bytes = do -- Use memcpy (we are allowed to assume the arrays aren't overlapping) - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform - dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize dflags)) dst_off + dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off emitMemcpyCall dst_p src_p bytes (mkAlignment 1) @@ -2518,14 +2522,14 @@ doCopyAddrToByteArrayOp src_p dst dst_off bytes = do doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () doSetByteArrayOp ba off len c = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap offsetAlignment = cmmExprAlignment off align = min byteArrayAlignment offsetAlignment - p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize dflags)) off + p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize profile)) off emitMemsetCall p c len align -- ---------------------------------------------------------------------------- @@ -2540,12 +2544,12 @@ doNewArrayOp :: CmmFormal -- ^ return register -> CmmExpr -- ^ initial element -> FCode () doNewArrayOp res_r rep info payload n init = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let info_ptr = mkLblExpr info - tickyAllocPrim (mkIntExpr platform (hdrSize dflags rep)) + tickyAllocPrim (mkIntExpr platform (hdrSize profile rep)) (mkIntExpr platform (nonHdrSize platform rep)) (zeroExpr platform) @@ -2555,7 +2559,7 @@ doNewArrayOp res_r rep info payload n init = do emit $ mkAssign arr base -- Initialise all elements of the array - let mkOff off = cmmOffsetW platform (CmmReg arr) (hdrSizeW dflags rep + off) + let mkOff off = cmmOffsetW platform (CmmReg arr) (hdrSizeW profile rep + off) initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ] emit (catAGraphs initialization) @@ -2624,7 +2628,7 @@ emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff -> FCode () emitCopyArray copy src0 src_off dst0 dst_off0 n = when (n /= 0) $ do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform -- Passed as arguments (be careful) @@ -2633,23 +2637,23 @@ emitCopyArray copy src0 src_off dst0 dst_off0 n = dst_off <- assignTempE dst_off0 -- Nonmoving collector write barrier - emitCopyUpdRemSetPush platform (arrPtrsHdrSizeW dflags) dst dst_off n + emitCopyUpdRemSetPush platform (arrPtrsHdrSizeW profile) dst dst_off n -- Set the dirty bit in the header. emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) dst_elems_p <- assignTempE $ cmmOffsetB platform dst - (arrPtrsHdrSize dflags) + (arrPtrsHdrSize profile) dst_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p dst_off src_p <- assignTempE $ cmmOffsetExprW platform - (cmmOffsetB platform src (arrPtrsHdrSize dflags)) src_off + (cmmOffsetB platform src (arrPtrsHdrSize profile)) src_off let bytes = wordsToBytes platform n copy src dst dst_p src_p bytes -- The base address of the destination card table dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p - (loadArrPtrsSize dflags dst) + (loadArrPtrsSize profile dst) emitSetCards dst_off dst_cards_p n @@ -2691,7 +2695,7 @@ emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff -> FCode () emitCopySmallArray copy src0 src_off dst0 dst_off n = when (n /= 0) $ do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform -- Passed as arguments (be careful) @@ -2699,15 +2703,15 @@ emitCopySmallArray copy src0 src_off dst0 dst_off n = dst <- assignTempE dst0 -- Nonmoving collector write barrier - emitCopyUpdRemSetPush platform (smallArrPtrsHdrSizeW dflags) dst dst_off n + emitCopyUpdRemSetPush platform (smallArrPtrsHdrSizeW profile) dst dst_off n -- Set the dirty bit in the header. emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) dst_p <- assignTempE $ cmmOffsetExprW platform - (cmmOffsetB platform dst (smallArrPtrsHdrSize dflags)) dst_off + (cmmOffsetB platform dst (smallArrPtrsHdrSize profile)) dst_off src_p <- assignTempE $ cmmOffsetExprW platform - (cmmOffsetB platform src (smallArrPtrsHdrSize dflags)) src_off + (cmmOffsetB platform src (smallArrPtrsHdrSize profile)) src_off let bytes = wordsToBytes platform n copy src dst dst_p src_p bytes @@ -2719,33 +2723,34 @@ emitCopySmallArray copy src0 src_off dst0 dst_off n = emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff -> FCode () emitCloneArray info_p res_r src src_off n = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let info_ptr = mkLblExpr info_p - rep = arrPtrsRep dflags n + rep = arrPtrsRep platform n - tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize dflags)) + tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize profile)) (mkIntExpr platform (nonHdrSize platform rep)) (zeroExpr platform) - let hdr_size = fixedHdrSize dflags + let hdr_size = fixedHdrSize profile + constants = platformConstants platform base <- allocHeapClosure rep info_ptr cccsExpr [ (mkIntExpr platform n, - hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags) + hdr_size + pc_OFFSET_StgMutArrPtrs_ptrs constants) , (mkIntExpr platform (nonHdrSizeW rep), - hdr_size + oFFSET_StgMutArrPtrs_size dflags) + hdr_size + pc_OFFSET_StgMutArrPtrs_size constants) ] arr <- CmmLocal `fmap` newTemp (bWord platform) emit $ mkAssign arr base dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr) - (arrPtrsHdrSize dflags) + (arrPtrsHdrSize profile) src_p <- assignTempE $ cmmOffsetExprW platform src (cmmAddWord platform - (mkIntExpr platform (arrPtrsHdrSizeW dflags)) src_off) + (mkIntExpr platform (arrPtrsHdrSizeW profile)) src_off) emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) (wordAlignment platform) @@ -2759,31 +2764,31 @@ emitCloneArray info_p res_r src src_off n = do emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff -> FCode () emitCloneSmallArray info_p res_r src src_off n = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let info_ptr = mkLblExpr info_p rep = smallArrPtrsRep n - tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize dflags)) + tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize profile)) (mkIntExpr platform (nonHdrSize platform rep)) (zeroExpr platform) - let hdr_size = fixedHdrSize dflags + let hdr_size = fixedHdrSize profile base <- allocHeapClosure rep info_ptr cccsExpr [ (mkIntExpr platform n, - hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags) + hdr_size + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)) ] arr <- CmmLocal `fmap` newTemp (bWord platform) emit $ mkAssign arr base dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr) - (smallArrPtrsHdrSize dflags) + (smallArrPtrsHdrSize profile) src_p <- assignTempE $ cmmOffsetExprW platform src (cmmAddWord platform - (mkIntExpr platform (smallArrPtrsHdrSizeW dflags)) src_off) + (mkIntExpr platform (smallArrPtrsHdrSizeW profile)) src_off) emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n)) (wordAlignment platform) @@ -2796,10 +2801,9 @@ emitCloneSmallArray info_p res_r src src_off n = do -- Marks the relevant cards as dirty. emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode () emitSetCards dst_start dst_cards_start n = do - dflags <- getDynFlags platform <- getPlatform - start_card <- assignTempE $ cardCmm dflags dst_start - let end_card = cardCmm dflags + start_card <- assignTempE $ cardCmm platform dst_start + let end_card = cardCmm platform (cmmSubWord platform (cmmAddWord platform dst_start (mkIntExpr platform n)) (mkIntExpr platform 1)) @@ -2809,10 +2813,9 @@ emitSetCards dst_start dst_cards_start n = do (mkAlignment 1) -- no alignment (1 byte) -- Convert an element index to a card index -cardCmm :: DynFlags -> CmmExpr -> CmmExpr -cardCmm dflags i = - cmmUShrWord platform i (mkIntExpr platform (mUT_ARR_PTRS_CARD_BITS dflags)) - where platform = targetPlatform dflags +cardCmm :: Platform -> CmmExpr -> CmmExpr +cardCmm platform i = + cmmUShrWord platform i (mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))) ------------------------------------------------------------------------------ -- SmallArray PrimOp implementations @@ -2822,9 +2825,9 @@ doReadSmallPtrArrayOp :: LocalReg -> CmmExpr -> FCode () doReadSmallPtrArrayOp res addr idx = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform - mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord platform) res addr + mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx doWriteSmallPtrArrayOp :: CmmExpr @@ -2832,17 +2835,17 @@ doWriteSmallPtrArrayOp :: CmmExpr -> CmmExpr -> FCode () doWriteSmallPtrArrayOp addr idx val = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let ty = cmmExprType platform val -- Update remembered set for non-moving collector tmp <- newTemp ty - mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing ty tmp addr ty idx + mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp)) emitPrimCall [] MO_WriteBarrier [] -- #12469 - mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val + mkBasicIndexedWrite (smallArrPtrsHdrSize profile) Nothing addr ty idx val emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel))) ------------------------------------------------------------------------------ @@ -2859,10 +2862,10 @@ doAtomicRMW :: LocalReg -- ^ Result reg -> CmmExpr -- ^ Op argument (e.g. amount to add) -> FCode () doAtomicRMW res amop mba idx idx_ty n = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let width = typeWidth idx_ty - addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags) + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx emitPrimCall [ res ] @@ -2877,10 +2880,10 @@ doAtomicReadByteArray -> CmmType -- ^ Type of element by which we are indexing -> FCode () doAtomicReadByteArray res mba idx idx_ty = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let width = typeWidth idx_ty - addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags) + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx emitPrimCall [ res ] @@ -2895,10 +2898,10 @@ doAtomicWriteByteArray -> CmmExpr -- ^ Value to write -> FCode () doAtomicWriteByteArray mba idx idx_ty val = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let width = typeWidth idx_ty - addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags) + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx emitPrimCall [ {- no results -} ] @@ -2914,10 +2917,10 @@ doCasByteArray -> CmmExpr -- ^ New value -> FCode () doCasByteArray res mba idx idx_ty old new = do - dflags <- getDynFlags + profile <- getProfile platform <- getPlatform let width = (typeWidth idx_ty) - addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags) + addr = cmmIndexOffExpr platform (arrWordsHdrSize profile) width mba idx emitPrimCall [ res ] diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs index 1381617f89..d58f20cfd1 100644 --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -26,6 +26,7 @@ module GHC.StgToCmm.Prof ( import GHC.Prelude import GHC.Platform +import GHC.Platform.Profile import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad @@ -67,32 +68,30 @@ mkCCostCentre cc = CmmLabel (mkCCLabel cc) mkCCostCentreStack :: CostCentreStack -> CmmLit mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) -costCentreFrom :: DynFlags - -> CmmExpr -- A closure pointer +costCentreFrom :: Platform + -> CmmExpr -- A closure pointer -> CmmExpr -- The cost centre from that closure -costCentreFrom dflags cl = CmmLoad (cmmOffsetB platform cl (oFFSET_StgHeader_ccs dflags)) (ccsType platform) - where platform = targetPlatform dflags +costCentreFrom platform cl = CmmLoad (cmmOffsetB platform cl (pc_OFFSET_StgHeader_ccs (platformConstants platform))) (ccsType platform) -- | The profiling header words in a static closure -staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit] -staticProfHdr dflags ccs - | sccProfilingEnabled dflags = [mkCCostCentreStack ccs, staticLdvInit platform] +staticProfHdr :: Profile -> CostCentreStack -> [CmmLit] +staticProfHdr profile ccs + | profileIsProfiling profile = [mkCCostCentreStack ccs, staticLdvInit platform] | otherwise = [] - where platform = targetPlatform dflags + where platform = profilePlatform profile -- | Profiling header words in a dynamic closure -dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr] -dynProfHdr dflags ccs - | sccProfilingEnabled dflags = [ccs, dynLdvInit dflags] +dynProfHdr :: Profile -> CmmExpr -> [CmmExpr] +dynProfHdr profile ccs + | profileIsProfiling profile = [ccs, dynLdvInit (profilePlatform profile)] | otherwise = [] -- | Initialise the profiling field of an update frame initUpdFrameProf :: CmmExpr -> FCode () initUpdFrameProf frame = ifProfiling $ -- frame->header.prof.ccs = CCCS - do dflags <- getDynFlags - platform <- getPlatform - emitStore (cmmOffset platform frame (oFFSET_StgHeader_ccs dflags)) cccsExpr + do platform <- getPlatform + emitStore (cmmOffset platform frame (pc_OFFSET_StgHeader_ccs (platformConstants platform))) cccsExpr -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) -- is unnecessary because it is not used anyhow. @@ -152,9 +151,9 @@ restoreCurrentCostCentre (Just local_cc) profDynAlloc :: SMRep -> CmmExpr -> FCode () profDynAlloc rep ccs = ifProfiling $ - do dflags <- getDynFlags - platform <- getPlatform - profAlloc (mkIntExpr platform (heapClosureSizeW dflags rep)) ccs + do profile <- targetProfile <$> getDynFlags + let platform = profilePlatform profile + profAlloc (mkIntExpr platform (heapClosureSizeW profile rep)) ccs -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts @@ -162,16 +161,16 @@ profDynAlloc rep ccs profAlloc :: CmmExpr -> CmmExpr -> FCode () profAlloc words ccs = ifProfiling $ - do dflags <- getDynFlags - platform <- getPlatform - let alloc_rep = rEP_CostCentreStack_mem_alloc dflags - emit (addToMemE alloc_rep - (cmmOffsetB platform ccs (oFFSET_CostCentreStack_mem_alloc dflags)) + do profile <- targetProfile <$> getDynFlags + let platform = profilePlatform profile + let alloc_rep = rEP_CostCentreStack_mem_alloc platform + emit $ addToMemE alloc_rep + (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_mem_alloc (platformConstants platform))) (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) $ - [CmmMachOp (mo_wordSub platform) [words, - mkIntExpr platform (profHdrSize dflags)]])) - -- subtract the "profiling overhead", which is the - -- profiling header in a closure. + -- subtract the "profiling overhead", which is the + -- profiling header in a closure. + [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (profHdrSize profile)]] + ) -- ----------------------------------------------------------------------- -- Setting the current cost centre on entry to a closure @@ -179,23 +178,23 @@ profAlloc words ccs enterCostCentreThunk :: CmmExpr -> FCode () enterCostCentreThunk closure = ifProfiling $ do - dflags <- getDynFlags - emit $ storeCurCCS (costCentreFrom dflags closure) + platform <- getPlatform + emit $ storeCurCCS (costCentreFrom platform closure) enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () enterCostCentreFun ccs closure = ifProfiling $ do if isCurrentCCS ccs - then do dflags <- getDynFlags + then do platform <- getPlatform emitRtsCall rtsUnitId (fsLit "enterFunCCS") [(baseExpr, AddrHint), - (costCentreFrom dflags closure, AddrHint)] False + (costCentreFrom platform closure, AddrHint)] False else return () -- top-level function, nothing to do ifProfiling :: FCode () -> FCode () ifProfiling code - = do dflags <- getDynFlags - if sccProfilingEnabled dflags + = do profile <- targetProfile <$> getDynFlags + if profileIsProfiling profile then code else return () @@ -206,10 +205,9 @@ ifProfiling code initCostCentres :: CollectedCCs -> FCode () -- Emit the declarations initCostCentres (local_CCs, singleton_CCSs) - = do dflags <- getDynFlags - when (sccProfilingEnabled dflags) $ - do mapM_ emitCostCentreDecl local_CCs - mapM_ emitCostCentreStackDecl singleton_CCSs + = ifProfiling $ do + mapM_ emitCostCentreDecl local_CCs + mapM_ emitCostCentreStackDecl singleton_CCSs emitCostCentreDecl :: CostCentre -> FCode () @@ -243,11 +241,10 @@ emitCostCentreStackDecl :: CostCentreStack -> FCode () emitCostCentreStackDecl ccs = case maybeSingletonCCS ccs of Just cc -> - do dflags <- getDynFlags - platform <- getPlatform + do platform <- getPlatform let mk_lits cc = zero platform : mkCCostCentre cc : - replicate (sizeof_ccs_words dflags - 2) (zero platform) + replicate (sizeof_ccs_words platform - 2) (zero platform) -- Note: to avoid making any assumptions about how the -- C compiler (that compiles the RTS, in particular) does -- layouts of structs containing long-longs, simply @@ -261,27 +258,26 @@ zero platform = mkIntCLit platform 0 zero64 :: CmmLit zero64 = CmmInt 0 W64 -sizeof_ccs_words :: DynFlags -> Int -sizeof_ccs_words dflags +sizeof_ccs_words :: Platform -> Int +sizeof_ccs_words platform -- round up to the next word. | ms == 0 = ws | otherwise = ws + 1 where - platform = targetPlatform dflags - (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` platformWordSizeInBytes platform + (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform -- --------------------------------------------------------------------------- -- Set the current cost centre stack emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () emitSetCCC cc tick push - = do dflags <- getDynFlags - platform <- getPlatform - if not (sccProfilingEnabled dflags) + = do profile <- targetProfile <$> getDynFlags + let platform = profilePlatform profile + if not (profileIsProfiling profile) then return () else do tmp <- newTemp (ccsType platform) pushCostCentre tmp cccsExpr cc - when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp))) + when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp))) when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () @@ -292,11 +288,10 @@ pushCostCentre result ccs cc (CmmLit (mkCCostCentre cc), AddrHint)] False -bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph -bumpSccCount dflags ccs - = addToMem (rEP_CostCentreStack_scc_count dflags) - (cmmOffsetB platform ccs (oFFSET_CostCentreStack_scc_count dflags)) 1 - where platform = targetPlatform dflags +bumpSccCount :: Platform -> CmmExpr -> CmmAGraph +bumpSccCount platform ccs + = addToMem (rEP_CostCentreStack_scc_count platform) + (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_scc_count (platformConstants platform))) 1 ----------------------------------------------------------------------------- -- @@ -313,22 +308,20 @@ staticLdvInit = zeroCLit -- -- Initial value of the LDV field in a dynamic closure -- -dynLdvInit :: DynFlags -> CmmExpr -dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE +dynLdvInit :: Platform -> CmmExpr +dynLdvInit platform = -- (era << LDV_SHIFT) | LDV_STATE_CREATE CmmMachOp (mo_wordOr platform) [ - CmmMachOp (mo_wordShl platform) [loadEra dflags, mkIntExpr platform (lDV_SHIFT dflags)], - CmmLit (mkWordCLit platform (iLDV_STATE_CREATE dflags)) + CmmMachOp (mo_wordShl platform) [loadEra platform, mkIntExpr platform (pc_LDV_SHIFT (platformConstants platform))], + CmmLit (mkWordCLit platform (pc_ILDV_STATE_CREATE (platformConstants platform))) ] - where - platform = targetPlatform dflags -- -- Initialise the LDV word of a new closure -- ldvRecordCreate :: CmmExpr -> FCode () ldvRecordCreate closure = do - dflags <- getDynFlags - emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags) + platform <- getPlatform + emit $ mkStore (ldvWord platform closure) (dynLdvInit platform) -- -- | Called when a closure is entered, marks the closure as having @@ -337,40 +330,37 @@ ldvRecordCreate closure = do -- ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode () ldvEnterClosure closure_info node_reg = do - dflags <- getDynFlags platform <- getPlatform - let tag = funTag dflags closure_info + let tag = funTag platform closure_info -- don't forget to subtract node's tag ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-tag)) ldvEnter :: CmmExpr -> FCode () -- Argument is a closure pointer ldvEnter cl_ptr = do - dflags <- getDynFlags platform <- getPlatform - let -- don't forget to subtract node's tag - ldv_wd = ldvWord dflags cl_ptr + let constants = platformConstants platform + -- don't forget to subtract node's tag + ldv_wd = ldvWord platform cl_ptr new_ldv_wd = cmmOrWord platform (cmmAndWord platform (CmmLoad ldv_wd (bWord platform)) - (CmmLit (mkWordCLit platform (iLDV_CREATE_MASK dflags)))) - (cmmOrWord platform (loadEra dflags) (CmmLit (mkWordCLit platform (iLDV_STATE_USE dflags)))) + (CmmLit (mkWordCLit platform (pc_ILDV_CREATE_MASK constants)))) + (cmmOrWord platform (loadEra platform) (CmmLit (mkWordCLit platform (pc_ILDV_STATE_USE constants)))) ifProfiling $ -- if (era > 0) { -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) | -- era | LDV_STATE_USE } - emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra dflags, CmmLit (zeroCLit platform)]) + emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra platform, CmmLit (zeroCLit platform)]) (mkStore ldv_wd new_ldv_wd) mkNop -loadEra :: DynFlags -> CmmExpr -loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth platform)) +loadEra :: Platform -> CmmExpr +loadEra platform = CmmMachOp (MO_UU_Conv (cIntWidth platform) (wordWidth platform)) [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era"))) - (cInt dflags)] - where platform = targetPlatform dflags + (cInt platform)] -ldvWord :: DynFlags -> CmmExpr -> CmmExpr --- Takes the address of a closure, and returns +-- | Takes the address of a closure, and returns -- the address of the LDV word in the closure -ldvWord dflags closure_ptr - = cmmOffsetB platform closure_ptr (oFFSET_StgHeader_ldvw dflags) - where platform = targetPlatform dflags +ldvWord :: Platform -> CmmExpr -> CmmExpr +ldvWord platform closure_ptr + = cmmOffsetB platform closure_ptr (pc_OFFSET_StgHeader_ldvw (platformConstants platform)) diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs index cf412c6384..733af2db96 100644 --- a/compiler/GHC/StgToCmm/Ticky.hs +++ b/compiler/GHC/StgToCmm/Ticky.hs @@ -103,6 +103,8 @@ module GHC.StgToCmm.Ticky ( import GHC.Prelude import GHC.Platform +import GHC.Platform.Profile + import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString ) import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils @@ -340,20 +342,20 @@ registerTickyCtr :: CLabel -> FCode () -- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */ -- f_ct.registeredp = 1 } registerTickyCtr ctr_lbl = do - dflags <- getDynFlags platform <- getPlatform let + constants = platformConstants platform -- krc: code generator doesn't handle Not, so we test for Eq 0 instead test = CmmMachOp (MO_Eq (wordWidth platform)) [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl - (oFFSET_StgEntCounter_registeredp dflags))) (bWord platform), + (pc_OFFSET_StgEntCounter_registeredp constants))) (bWord platform), zeroExpr platform] register_stmts - = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags))) + = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_link constants))) (CmmLoad ticky_entry_ctrs (bWord platform)) , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl) , mkStore (CmmLit (cmmLabelOffB ctr_lbl - (oFFSET_StgEntCounter_registeredp dflags))) + (pc_OFFSET_StgEntCounter_registeredp constants))) (mkIntExpr platform 1) ] ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs")) emit =<< mkCmmIfThen test (catAGraphs register_stmts) @@ -440,9 +442,9 @@ tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode () -- -- TODO what else to count while we're here? tickyDynAlloc mb_id rep lf = ifTicky $ do - dflags <- getDynFlags - let platform = targetPlatform dflags - bytes = platformWordSizeInBytes platform * heapClosureSizeW dflags rep + profile <- getProfile + let platform = profilePlatform profile + bytes = platformWordSizeInBytes platform * heapClosureSizeW profile rep countGlobal tot ctr = do bumpTickyCounterBy tot bytes @@ -482,8 +484,7 @@ tickyAllocHeap :: -- Must be lazy in the amount of allocation! tickyAllocHeap genuine hp = ifTicky $ - do { dflags <- getDynFlags - ; platform <- getPlatform + do { platform <- getPlatform ; ticky_ctr <- getTickyCtrLabel ; emit $ catAGraphs $ -- only test hp from within the emit so that the monadic @@ -492,8 +493,8 @@ tickyAllocHeap genuine hp if hp == 0 then [] else let !bytes = platformWordSizeInBytes platform * hp in [ -- Bump the allocation total in the closure's StgEntCounter - addToMem (rEP_StgEntCounter_allocs dflags) - (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags))) + addToMem (rEP_StgEntCounter_allocs platform) + (CmmLit (cmmLabelOffB ticky_ctr (pc_OFFSET_StgEntCounter_allocs (platformConstants platform)))) bytes, -- Bump the global allocation total ALLOC_HEAP_tot addToMemLbl (bWord platform) @@ -576,13 +577,13 @@ bumpTickyCounterByE lbl = bumpTickyLblByE (mkRtsCmmDataLabel lbl) bumpTickyEntryCount :: CLabel -> FCode () bumpTickyEntryCount lbl = do - dflags <- getDynFlags - bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags)) + platform <- getPlatform + bumpTickyLit (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) bumpTickyAllocd :: CLabel -> Int -> FCode () bumpTickyAllocd lbl bytes = do - dflags <- getDynFlags - bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes + platform <- getPlatform + bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_allocd (platformConstants platform))) bytes bumpTickyLbl :: CLabel -> FCode () bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1 @@ -608,9 +609,8 @@ bumpTickyLitByE lhs e = do bumpHistogram :: FastString -> Int -> FCode () bumpHistogram lbl n = do - dflags <- getDynFlags platform <- getPlatform - let offset = n `min` (tICKY_BIN_COUNT dflags - 1) + let offset = n `min` (pc_TICKY_BIN_COUNT (platformConstants platform) - 1) emit (addToMem (bWord platform) (cmmIndexExpr platform (wordWidth platform) diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 27c79a8e62..8531ca2283 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -197,9 +197,9 @@ emitRtsCallGen -> Bool -- True <=> CmmSafe call -> FCode () emitRtsCallGen res lbl args safe - = do { dflags <- getDynFlags + = do { platform <- targetPlatform <$> getDynFlags ; updfr_off <- getUpdFrameOff - ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags + ; let (caller_save, caller_load) = callerSaveVolatileRegs platform ; emit caller_save ; call updfr_off ; emit caller_load } @@ -245,13 +245,11 @@ emitRtsCallGen res lbl args safe -- "GHC.Cmm.Node". Right now the workaround is to avoid inlining across -- unsafe foreign calls in rewriteAssignments, but this is strictly -- temporary. -callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph) -callerSaveVolatileRegs dflags = (caller_save, caller_load) +callerSaveVolatileRegs :: Platform -> (CmmAGraph, CmmAGraph) +callerSaveVolatileRegs platform = (caller_save, caller_load) where - platform = targetPlatform dflags - - caller_save = catAGraphs (map (callerSaveGlobalReg dflags) regs_to_save) - caller_load = catAGraphs (map (callerRestoreGlobalReg dflags) regs_to_save) + caller_save = catAGraphs (map (callerSaveGlobalReg platform) regs_to_save) + caller_load = catAGraphs (map (callerRestoreGlobalReg platform) regs_to_save) system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery {- ,SparkHd,SparkTl,SparkBase,SparkLim -} @@ -259,14 +257,14 @@ callerSaveVolatileRegs dflags = (caller_save, caller_load) regs_to_save = filter (callerSaves platform) system_regs -callerSaveGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph -callerSaveGlobalReg dflags reg - = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg)) +callerSaveGlobalReg :: Platform -> GlobalReg -> CmmAGraph +callerSaveGlobalReg platform reg + = mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal reg)) -callerRestoreGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph -callerRestoreGlobalReg dflags reg +callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph +callerRestoreGlobalReg platform reg = mkAssign (CmmGlobal reg) - (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType (targetPlatform dflags) reg)) + (CmmLoad (get_GlobalReg_addr platform reg) (globalRegType platform reg)) ------------------------------------------------------------------------- diff --git a/testsuite/tests/codeGen/should_run/T13825-unit.hs b/testsuite/tests/codeGen/should_run/T13825-unit.hs index 5861435d9b..c689a3a676 100644 --- a/testsuite/tests/codeGen/should_run/T13825-unit.hs +++ b/testsuite/tests/codeGen/should_run/T13825-unit.hs @@ -59,7 +59,7 @@ assert_32_64 actual expected32 expected64 = do expected | word_size == 4 = expected32 | word_size == 8 = expected64 - word_size = wORD_SIZE dflags + word_size = pc_WORD_SIZE (platformConstants (targetPlatform dflags)) case actual == expected of True -> return () False -> @@ -69,7 +69,7 @@ assert_32_64 actual expected32 expected64 = do runTest :: [(a, PrimRep)] -> Ghc (WordOff , WordOff, [FieldOffOrPadding a]) runTest prim_reps = do dflags <- getDynFlags - return $ mkVirtHeapOffsetsWithPadding dflags StdHeader (mkNonVoids prim_reps) + return $ mkVirtHeapOffsetsWithPadding (targetProfile dflags) StdHeader (mkNonVoids prim_reps) where mkNonVoids = map (\(a, prim_rep) -> NonVoid (prim_rep, a)) |