diff options
| author | sheaf <sam.derbyshire@gmail.com> | 2023-01-27 13:43:44 +0100 |
|---|---|---|
| committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2023-01-31 15:51:06 -0500 |
| commit | 5618fc21dc480f88ac7cbe14337e72c92b8001d7 (patch) | |
| tree | d627c46b9f7f4a636d45ae75b0ed1104e74eb436 | |
| parent | a2d814dc84dbdcdb6c1e274b8bd7c212cc98c39e (diff) | |
| download | haskell-5618fc21dc480f88ac7cbe14337e72c92b8001d7.tar.gz | |
Cmm: track the type of global registers
This patch tracks the type of Cmm global registers. This is needed
in order to lint uses of polymorphic registers, such as SIMD vector
registers that can be used both for floating-point and integer values.
This changes allows us to refactor VanillaReg to not store VGcPtr,
as that information is instead stored in the type of the usage of the
register.
Fixes #22297
40 files changed, 671 insertions, 617 deletions
diff --git a/compiler/CodeGen.Platform.h b/compiler/CodeGen.Platform.h index 01ea529fa0..fb006c9f1a 100644 --- a/compiler/CodeGen.Platform.h +++ b/compiler/CodeGen.Platform.h @@ -452,34 +452,34 @@ callerSaves :: GlobalReg -> Bool callerSaves BaseReg = True #endif #if defined(CALLER_SAVES_R1) -callerSaves (VanillaReg 1 _) = True +callerSaves (VanillaReg 1) = True #endif #if defined(CALLER_SAVES_R2) -callerSaves (VanillaReg 2 _) = True +callerSaves (VanillaReg 2) = True #endif #if defined(CALLER_SAVES_R3) -callerSaves (VanillaReg 3 _) = True +callerSaves (VanillaReg 3) = True #endif #if defined(CALLER_SAVES_R4) -callerSaves (VanillaReg 4 _) = True +callerSaves (VanillaReg 4) = True #endif #if defined(CALLER_SAVES_R5) -callerSaves (VanillaReg 5 _) = True +callerSaves (VanillaReg 5) = True #endif #if defined(CALLER_SAVES_R6) -callerSaves (VanillaReg 6 _) = True +callerSaves (VanillaReg 6) = True #endif #if defined(CALLER_SAVES_R7) -callerSaves (VanillaReg 7 _) = True +callerSaves (VanillaReg 7) = True #endif #if defined(CALLER_SAVES_R8) -callerSaves (VanillaReg 8 _) = True +callerSaves (VanillaReg 8) = True #endif #if defined(CALLER_SAVES_R9) -callerSaves (VanillaReg 9 _) = True +callerSaves (VanillaReg 9) = True #endif #if defined(CALLER_SAVES_R10) -callerSaves (VanillaReg 10 _) = True +callerSaves (VanillaReg 10) = True #endif #if defined(CALLER_SAVES_F1) callerSaves (FloatReg 1) = True @@ -555,34 +555,34 @@ activeStgRegs = [ ,Hp #endif #if defined(REG_R1) - ,VanillaReg 1 VGcPtr + ,VanillaReg 1 #endif #if defined(REG_R2) - ,VanillaReg 2 VGcPtr + ,VanillaReg 2 #endif #if defined(REG_R3) - ,VanillaReg 3 VGcPtr + ,VanillaReg 3 #endif #if defined(REG_R4) - ,VanillaReg 4 VGcPtr + ,VanillaReg 4 #endif #if defined(REG_R5) - ,VanillaReg 5 VGcPtr + ,VanillaReg 5 #endif #if defined(REG_R6) - ,VanillaReg 6 VGcPtr + ,VanillaReg 6 #endif #if defined(REG_R7) - ,VanillaReg 7 VGcPtr + ,VanillaReg 7 #endif #if defined(REG_R8) - ,VanillaReg 8 VGcPtr + ,VanillaReg 8 #endif #if defined(REG_R9) - ,VanillaReg 9 VGcPtr + ,VanillaReg 9 #endif #if defined(REG_R10) - ,VanillaReg 10 VGcPtr + ,VanillaReg 10 #endif #if defined(REG_SpLim) ,SpLim @@ -740,34 +740,34 @@ globalRegMaybe :: GlobalReg -> Maybe RealReg globalRegMaybe BaseReg = Just (RealRegSingle REG_Base) # endif # if defined(REG_R1) -globalRegMaybe (VanillaReg 1 _) = Just (RealRegSingle REG_R1) +globalRegMaybe (VanillaReg 1) = Just (RealRegSingle REG_R1) # endif # if defined(REG_R2) -globalRegMaybe (VanillaReg 2 _) = Just (RealRegSingle REG_R2) +globalRegMaybe (VanillaReg 2) = Just (RealRegSingle REG_R2) # endif # if defined(REG_R3) -globalRegMaybe (VanillaReg 3 _) = Just (RealRegSingle REG_R3) +globalRegMaybe (VanillaReg 3) = Just (RealRegSingle REG_R3) # endif # if defined(REG_R4) -globalRegMaybe (VanillaReg 4 _) = Just (RealRegSingle REG_R4) +globalRegMaybe (VanillaReg 4) = Just (RealRegSingle REG_R4) # endif # if defined(REG_R5) -globalRegMaybe (VanillaReg 5 _) = Just (RealRegSingle REG_R5) +globalRegMaybe (VanillaReg 5) = Just (RealRegSingle REG_R5) # endif # if defined(REG_R6) -globalRegMaybe (VanillaReg 6 _) = Just (RealRegSingle REG_R6) +globalRegMaybe (VanillaReg 6) = Just (RealRegSingle REG_R6) # endif # if defined(REG_R7) -globalRegMaybe (VanillaReg 7 _) = Just (RealRegSingle REG_R7) +globalRegMaybe (VanillaReg 7) = Just (RealRegSingle REG_R7) # endif # if defined(REG_R8) -globalRegMaybe (VanillaReg 8 _) = Just (RealRegSingle REG_R8) +globalRegMaybe (VanillaReg 8) = Just (RealRegSingle REG_R8) # endif # if defined(REG_R9) -globalRegMaybe (VanillaReg 9 _) = Just (RealRegSingle REG_R9) +globalRegMaybe (VanillaReg 9) = Just (RealRegSingle REG_R9) # endif # if defined(REG_R10) -globalRegMaybe (VanillaReg 10 _) = Just (RealRegSingle REG_R10) +globalRegMaybe (VanillaReg 10) = Just (RealRegSingle REG_R10) # endif # if defined(REG_F1) globalRegMaybe (FloatReg 1) = Just (RealRegSingle REG_F1) diff --git a/compiler/GHC/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs index 97cebf99e6..14f3672a4b 100644 --- a/compiler/GHC/Cmm/CallConv.hs +++ b/compiler/GHC/Cmm/CallConv.hs @@ -68,35 +68,33 @@ assignArgumentsPos profile off conv arg_ty reps = (stk_off, assignments) | isFloatType ty = float | otherwise = int where vec = case (w, regs) of - (W128, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W128 profile -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss)) - (W256, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W256 profile -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss)) - (W512, (vs, fs, ds, ls, s:ss)) - | passVectorInReg W512 profile -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss)) + (W128, AvailRegs vs fs ds ls (s:ss)) + | passVectorInReg W128 profile -> k (RegisterParam (XmmReg s), AvailRegs vs fs ds ls ss) + (W256, AvailRegs vs fs ds ls (s:ss)) + | passVectorInReg W256 profile -> k (RegisterParam (YmmReg s), AvailRegs vs fs ds ls ss) + (W512, AvailRegs vs fs ds ls (s:ss)) + | passVectorInReg W512 profile -> k (RegisterParam (ZmmReg s), AvailRegs vs fs ds ls ss) _ -> (assts, (r:rs)) float = case (w, regs) of - (W32, (vs, fs, ds, ls, s:ss)) - | passFloatInXmm -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss)) - (W32, (vs, f:fs, ds, ls, ss)) - | not passFloatInXmm -> k (RegisterParam f, (vs, fs, ds, ls, ss)) - (W64, (vs, fs, ds, ls, s:ss)) - | passFloatInXmm -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss)) - (W64, (vs, fs, d:ds, ls, ss)) - | not passFloatInXmm -> k (RegisterParam d, (vs, fs, ds, ls, ss)) + (W32, AvailRegs vs fs ds ls (s:ss)) + | passFloatInXmm -> k (RegisterParam (FloatReg s), AvailRegs vs fs ds ls ss) + (W32, AvailRegs vs (f:fs) ds ls ss) + | not passFloatInXmm -> k (RegisterParam f, AvailRegs vs fs ds ls ss) + (W64, AvailRegs vs fs ds ls (s:ss)) + | passFloatInXmm -> k (RegisterParam (DoubleReg s), AvailRegs vs fs ds ls ss) + (W64, AvailRegs vs fs (d:ds) ls ss) + | not passFloatInXmm -> k (RegisterParam d, AvailRegs vs fs ds ls ss) _ -> (assts, (r:rs)) int = case (w, regs) of (W128, _) -> panic "W128 unsupported register type" - (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth platform) - -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss)) - (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth platform) - -> k (RegisterParam l, (vs, fs, ds, ls, ss)) + (_, AvailRegs (v:vs) fs ds ls ss) | widthInBits w <= widthInBits (wordWidth platform) + -> k (RegisterParam v, AvailRegs vs fs ds ls ss) + (_, AvailRegs vs fs ds (l:ls) ss) | widthInBits w > widthInBits (wordWidth platform) + -> k (RegisterParam l, AvailRegs vs fs ds ls ss) _ -> (assts, (r:rs)) k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' ty = arg_ty r w = typeWidth ty - !gcp | isGcPtrType ty = VGcPtr - | otherwise = VNonGcPtr passFloatInXmm = passFloatArgsInXmm platform passFloatArgsInXmm :: Platform -> Bool @@ -131,12 +129,23 @@ assignStack platform offset arg_ty args = assign_stk offset [] (reverse args) ----------------------------------------------------------------------------- -- Local information about the registers available -type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. - , [GlobalReg] -- floats - , [GlobalReg] -- doubles - , [GlobalReg] -- longs (int64 and word64) - , [Int] -- XMM (floats and doubles) - ) +-- | Keep track of locally available registers. +data AvailRegs + = AvailRegs + { availVanillaRegs :: [GlobalReg] + -- ^ Available vanilla registers + , availFloatRegs :: [GlobalReg] + -- ^ Available float registers + , availDoubleRegs :: [GlobalReg] + -- ^ Available double registers + , availLongRegs :: [GlobalReg] + -- ^ Available long registers + , availXMMRegs :: [Int] + -- ^ Available vector XMM registers + } + +noAvailRegs :: AvailRegs +noAvailRegs = AvailRegs [] [] [] [] [] -- Vanilla registers can contain pointers, Ints, Chars. -- Floats and doubles have separate register supplies. @@ -146,24 +155,26 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs. getRegsWithoutNode, getRegsWithNode :: Platform -> AvailRegs getRegsWithoutNode platform = - ( filter (\r -> r VGcPtr /= node) (realVanillaRegs platform) - , realFloatRegs platform - , realDoubleRegs platform - , realLongRegs platform - , realXmmRegNos platform) + AvailRegs + { availVanillaRegs = filter (\r -> r /= node) (realVanillaRegs platform) + , availFloatRegs = realFloatRegs platform + , availDoubleRegs = realDoubleRegs platform + , availLongRegs = realLongRegs platform + , availXMMRegs = realXmmRegNos platform } -- getRegsWithNode uses R1/node even if it isn't a register getRegsWithNode platform = - ( if null (realVanillaRegs platform) - then [VanillaReg 1] - else realVanillaRegs platform - , realFloatRegs platform - , realDoubleRegs platform - , realLongRegs platform - , realXmmRegNos platform) + AvailRegs + { availVanillaRegs = if null (realVanillaRegs platform) + then [VanillaReg 1] + else realVanillaRegs platform + , availFloatRegs = realFloatRegs platform + , availDoubleRegs = realDoubleRegs platform + , availLongRegs = realLongRegs platform + , availXMMRegs = realXmmRegNos platform } allFloatRegs, allDoubleRegs, allLongRegs :: Platform -> [GlobalReg] -allVanillaRegs :: Platform -> [VGcPtr -> GlobalReg] +allVanillaRegs :: Platform -> [GlobalReg] allXmmRegs :: Platform -> [Int] allVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Vanilla_REG (platformConstants platform)) @@ -173,7 +184,7 @@ allLongRegs platform = map LongReg $ regList (pc_MAX_Long_REG (platform allXmmRegs platform = regList (pc_MAX_XMM_REG (platformConstants platform)) realFloatRegs, realDoubleRegs, realLongRegs :: Platform -> [GlobalReg] -realVanillaRegs :: Platform -> [VGcPtr -> GlobalReg] +realVanillaRegs :: Platform -> [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)) @@ -189,15 +200,16 @@ regList :: Int -> [Int] regList n = [1 .. n] allRegs :: Platform -> AvailRegs -allRegs platform = ( allVanillaRegs platform - , allFloatRegs platform - , allDoubleRegs platform - , allLongRegs platform - , allXmmRegs platform - ) +allRegs platform = + AvailRegs + { availVanillaRegs = allVanillaRegs platform + , availFloatRegs = allFloatRegs platform + , availDoubleRegs = allDoubleRegs platform + , availLongRegs = allLongRegs platform + , availXMMRegs = allXmmRegs platform } nodeOnly :: AvailRegs -nodeOnly = ([VanillaReg 1], [], [], [], []) +nodeOnly = noAvailRegs { availVanillaRegs = [VanillaReg 1] } -- This returns the set of global registers that *cover* the machine registers -- used for argument passing. On platforms where registers can overlap---right @@ -207,18 +219,19 @@ nodeOnly = ([VanillaReg 1], [], [], [], []) 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... + = 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 platform) ++ - realFloatRegs platform ++ - realDoubleRegs platform ++ - realLongRegs platform - -- we don't save XMM registers if they are not used for parameter passing + = realVanillaRegs platform ++ + realFloatRegs platform ++ + realDoubleRegs platform ++ + realLongRegs platform + -- we don't save XMM registers if they are not used for parameter passing {- @@ -325,4 +338,4 @@ realArgRegsCover platform allArgRegsCover :: Platform -> [GlobalReg] allArgRegsCover platform = - nub (VanillaReg 1 VGcPtr : realArgRegsCover platform) + nub (VanillaReg 1 : realArgRegsCover platform) diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs index bfcb16bff9..8eee5843aa 100644 --- a/compiler/GHC/Cmm/DebugBlock.hs +++ b/compiler/GHC/Cmm/DebugBlock.hs @@ -39,7 +39,7 @@ import GHC.Platform import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm -import GHC.Cmm.Reg ( pprGlobalReg ) +import GHC.Cmm.Reg ( pprGlobalReg, pprGlobalRegUse ) import GHC.Cmm.Utils import GHC.Data.FastString ( nilFS, mkFastString ) import GHC.Unit.Module @@ -513,7 +513,7 @@ type UnwindTable = Map.Map GlobalReg (Maybe UnwindExpr) -- | Expressions, used for unwind information data UnwindExpr = UwConst !Int -- ^ literal value - | UwReg !GlobalReg !Int -- ^ register plus offset + | UwReg !GlobalRegUse !Int -- ^ register plus offset | UwDeref UnwindExpr -- ^ pointer dereferencing | UwLabel CLabel | UwPlus UnwindExpr UnwindExpr @@ -535,7 +535,7 @@ pprUnwindTable platform u = brackets (fsep (punctuate comma (map print_entry (Ma pprUnwindExpr :: IsLine doc => Rational -> Platform -> UnwindExpr -> doc pprUnwindExpr p env = \case UwConst i -> int i - UwReg g 0 -> pprGlobalReg g + UwReg g 0 -> pprGlobalRegUse g UwReg g x -> pprUnwindExpr p env (UwPlus (UwReg g 0) (UwConst x)) UwDeref e -> char '*' <> pprUnwindExpr 3 env e UwLabel l -> pprAsmLabel env l diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs index ccbb7f18ce..726f6cbc38 100644 --- a/compiler/GHC/Cmm/Expr.hs +++ b/compiler/GHC/Cmm/Expr.hs @@ -12,11 +12,11 @@ module GHC.Cmm.Expr , AlignmentSpec(..) -- TODO: Remove: , LocalReg(..), localRegType - , GlobalReg(..), isArgReg, globalRegType + , GlobalReg(..), isArgReg, globalRegSpillType + , GlobalRegUse(..) , spReg, hpReg, spLimReg, hpLimReg, nodeReg , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg , node, baseReg - , VGcPtr(..) , DefinerOfRegs, UserOfRegs , foldRegsDefd, foldRegsUsed @@ -248,9 +248,9 @@ cmmExprType :: Platform -> CmmExpr -> CmmType cmmExprType platform = \case (CmmLit lit) -> cmmLitType platform lit (CmmLoad _ rep _) -> rep - (CmmReg reg) -> cmmRegType platform reg + (CmmReg reg) -> cmmRegType reg (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args) - (CmmRegOff reg _) -> cmmRegType platform reg + (CmmRegOff reg _) -> cmmRegType reg (CmmStackSlot _ _) -> bWord platform -- an address -- Careful though: what is stored at the stack slot may be bigger than -- an address @@ -385,10 +385,18 @@ instance DefinerOfRegs LocalReg CmmReg where instance UserOfRegs GlobalReg CmmReg where {-# INLINEABLE foldRegsUsed #-} foldRegsUsed _ _ z (CmmLocal _) = z - foldRegsUsed _ f z (CmmGlobal reg) = f z reg + foldRegsUsed _ f z (CmmGlobal (GlobalRegUse reg _)) = f z reg +instance UserOfRegs GlobalRegUse CmmReg where + {-# INLINEABLE foldRegsUsed #-} + foldRegsUsed _ _ z (CmmLocal _) = z + foldRegsUsed _ f z (CmmGlobal reg) = f z reg instance DefinerOfRegs GlobalReg CmmReg where foldRegsDefd _ _ z (CmmLocal _) = z + foldRegsDefd _ f z (CmmGlobal (GlobalRegUse reg _)) = f z reg + +instance DefinerOfRegs GlobalRegUse CmmReg where + foldRegsDefd _ _ z (CmmLocal _) = z foldRegsDefd _ f z (CmmGlobal reg) = f z reg instance Ord r => UserOfRegs r r where @@ -427,7 +435,7 @@ pprExpr platform e CmmRegOff reg i -> pprExpr platform (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) - where rep = typeWidth (cmmRegType platform reg) + where rep = typeWidth (cmmRegType reg) CmmLit lit -> pprLit platform lit _other -> pprExpr1 platform e diff --git a/compiler/GHC/Cmm/Graph.hs b/compiler/GHC/Cmm/Graph.hs index d59658e2af..47420fc338 100644 --- a/compiler/GHC/Cmm/Graph.hs +++ b/compiler/GHC/Cmm/Graph.hs @@ -38,8 +38,8 @@ import GHC.Types.ForeignCall import GHC.Data.OrdList import GHC.Runtime.Heap.Layout (ByteOff) import GHC.Types.Unique.Supply -import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn) +import GHC.Utils.Panic ----------------------------------------------------------------------------- @@ -313,30 +313,36 @@ copyIn profile conv area formals extra_stk = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args)) where platform = profilePlatform profile - -- See Note [Width of parameters] + + ci :: (LocalReg, ParamLocation) -> CmmNode O O ci (reg, RegisterParam r@(VanillaReg {})) = let local = CmmLocal reg - global = CmmReg (CmmGlobal r) - width = cmmRegWidth platform local - expr - | width == wordWidth platform = global - | width < wordWidth platform = - CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global] - | otherwise = panic "Parameter width greater than word width" + width = cmmRegWidth local + (expr, ty) + -- See Note [Width of parameters] + | width == wordWidth platform + = (global, localRegType reg) + | width < wordWidth platform + = (CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global] + ,setCmmTypeWidth (wordWidth platform) (localRegType reg)) + | otherwise + = panic "Parameter width greater than word width" + global = CmmReg (CmmGlobal $ GlobalRegUse r ty) in CmmAssign local expr -- Non VanillaRegs ci (reg, RegisterParam r) = - CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r)) + CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal $ GlobalRegUse r (localRegType reg))) ci (reg, StackParam off) | isBitsType $ localRegType reg + -- See Note [Width of parameters] , typeWidth (localRegType reg) < wordWidth platform = let stack_slot = CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform) NaturallyAligned local = CmmLocal reg - width = cmmRegWidth platform local + width = cmmRegWidth local expr = CmmMachOp (MO_XX_Conv (wordWidth platform) width) [stack_slot] in CmmAssign local expr @@ -376,25 +382,28 @@ copyOutOflow profile conv transfer area actuals updfr_off extra_stack_stuff platform = profilePlatform profile (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params) - -- See Note [Width of parameters] + co :: (CmmExpr, ParamLocation) + -> ([GlobalReg], CmmAGraph) + -> ([GlobalReg], CmmAGraph) co (v, RegisterParam r@(VanillaReg {})) (rs, ms) = let width = cmmExprWidth platform v value + -- See Note [Width of parameters] | width == wordWidth platform = v | width < wordWidth platform = CmmMachOp (MO_XX_Conv width (wordWidth platform)) [v] | otherwise = panic "Parameter width greater than word width" - in (r:rs, mkAssign (CmmGlobal r) value <*> ms) + in (r:rs, mkAssign (CmmGlobal $ GlobalRegUse r (cmmExprType platform value)) value <*> ms) -- Non VanillaRegs co (v, RegisterParam r) (rs, ms) = - (r:rs, mkAssign (CmmGlobal r) v <*> ms) + (r:rs, mkAssign (CmmGlobal $ GlobalRegUse r (cmmExprType platform v)) v <*> ms) - -- See Note [Width of parameters] co (v, StackParam off) (rs, ms) = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms) + -- See Note [Width of parameters] width v = cmmExprWidth platform v value v | isBitsType $ cmmExprType platform v @@ -427,19 +436,18 @@ copyOutOflow profile conv transfer area actuals updfr_off extra_stack_stuff -- Note [Width of parameters] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- -- Consider passing a small (< word width) primitive like Int8# to a function. -- It's actually non-trivial to do this without extending/narrowing: --- * Global registers are considered to have native word width (i.e., 64-bits on --- x86-64), so CmmLint would complain if we assigned an 8-bit parameter to a --- global register. --- * Same problem exists with LLVM IR. --- * Lowering gets harder since on x86-32 not every register exposes its lower +-- * Lowering gets harder, since on x86-32 not every register exposes its lower -- 8 bits (e.g., for %eax we can use %al, but there isn't a corresponding -- 8-bit register for %edi). So we would either need to extend/narrow anyway, -- or complicate the calling convention. -- * Passing a small integer in a stack slot, which has native word width, -- requires extending to word width when writing to the stack and narrowing -- when reading off the stack (see #16258). +-- This is because the generated Cmm application functions (such as stg_ap_n) +-- always load the full width from the stack. -- So instead, we always extend every parameter smaller than native word width -- in copyOutOflow and then truncate it back to the expected width in copyIn. -- Note that we do this in cmm using MO_XX_Conv to avoid requiring diff --git a/compiler/GHC/Cmm/LayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs index 0d759f5559..29b5d348cb 100644 --- a/compiler/GHC/Cmm/LayoutStack.hs +++ b/compiler/GHC/Cmm/LayoutStack.hs @@ -350,7 +350,7 @@ layout cfg procpoints liveness entry entry_args final_stackmaps final_sp_high bl -- Not foolproof, but GCFun is the culprit we most want to catch isGcJump :: CmmNode O C -> Bool -isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) }) +isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal (GlobalRegUse l _)) }) = l == GCFun || l == GCEnter1 isGcJump _something_else = False @@ -875,7 +875,7 @@ maybeAddSpAdj cfg sp0 sp_off block = do_stk_unwinding_gen = cmmGenStackUnwindInstr cfg adj block | sp_off /= 0 - = block `blockSnoc` CmmAssign spReg (cmmOffset platform spExpr sp_off) + = block `blockSnoc` CmmAssign (spReg platform) (cmmOffset platform (spExpr platform) sp_off) | otherwise = block -- Add unwind pseudo-instruction at the beginning of each block to -- document Sp level for debugging @@ -884,7 +884,7 @@ maybeAddSpAdj cfg sp0 sp_off block = = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block | otherwise = block - where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform) + where sp_unwind = CmmRegOff (spReg platform) (sp0 - platformWordSizeInBytes platform) -- Add unwind pseudo-instruction right after the Sp adjustment -- if there is one. @@ -894,7 +894,7 @@ maybeAddSpAdj cfg sp0 sp_off block = = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)] | otherwise = block - where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform - sp_off) + where sp_unwind = CmmRegOff (spReg platform) (sp0 - platformWordSizeInBytes platform - sp_off) {- Note [SP old/young offsets] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -917,7 +917,7 @@ arguments. areaToSp :: Platform -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr areaToSp platform sp_old _sp_hwm area_off (CmmStackSlot area n) - = cmmOffset platform spExpr (sp_old - area_off area - n) + = cmmOffset platform (spExpr platform) (sp_old - area_off area - n) -- Replace (CmmStackSlot area n) with an offset from Sp areaToSp platform _ sp_hwm _ (CmmLit CmmHighStackMark) @@ -939,9 +939,9 @@ areaToSp _ _ _ _ other = other -- | Determine whether a stack check cannot fail. falseStackCheck :: [CmmExpr] -> Bool falseStackCheck [ CmmMachOp (MO_Sub _) - [ CmmRegOff (CmmGlobal Sp) x_off + [ CmmRegOff (CmmGlobal (GlobalRegUse Sp _)) x_off , CmmLit (CmmInt y_lit _)] - , CmmReg (CmmGlobal SpLim)] + , CmmReg (CmmGlobal (GlobalRegUse SpLim _))] = fromIntegral x_off >= y_lit falseStackCheck _ = False @@ -1087,7 +1087,7 @@ insertReloads platform stackmap live = [ CmmAssign (CmmLocal reg) -- This cmmOffset basically corresponds to manifesting -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets] - (CmmLoad (cmmOffset platform spExpr (sp_off - reg_off)) + (CmmLoad (cmmOffset platform (spExpr platform) (sp_off - reg_off)) (localRegType reg) NaturallyAligned) | (reg, reg_off) <- stackSlotRegs stackmap @@ -1142,7 +1142,7 @@ lowerSafeForeignCall profile block -- 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) + new_base <- newTemp (cmmRegType $ baseReg platform) let (caller_save, caller_load) = callerSaveVolatileRegs platform save_state_code <- saveThreadState profile load_state_code <- loadThreadState profile @@ -1153,7 +1153,7 @@ lowerSafeForeignCall profile block resume = mkMiddle (callResumeThread new_base id) <*> -- Assign the result to BaseReg: we -- might now have a different Capability! - mkAssign baseReg (CmmReg (CmmLocal new_base)) <*> + mkAssign (baseReg platform) (CmmReg (CmmLocal new_base)) <*> caller_load <*> load_state_code @@ -1168,7 +1168,7 @@ lowerSafeForeignCall profile block -- different. Hence we continue by jumping to the top stack frame, -- not by jumping to succ. jump = CmmCall { cml_target = entryCode platform $ - cmmLoadBWord platform spExpr + cmmLoadBWord platform (spExpr platform) , cml_cont = Just succ , cml_args_regs = regs , cml_args = widthInBytes (wordWidth platform) @@ -1193,7 +1193,7 @@ lowerSafeForeignCall profile block callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O callSuspendThread platform id intrbl = CmmUnsafeForeignCall (PrimTarget MO_SuspendThread) - [id] [baseExpr, mkIntExpr platform (fromEnum intrbl)] + [id] [baseExpr platform, mkIntExpr platform (fromEnum intrbl)] callResumeThread :: LocalReg -> LocalReg -> CmmNode O O callResumeThread new_base id = diff --git a/compiler/GHC/Cmm/Lexer.x b/compiler/GHC/Cmm/Lexer.x index 1699527689..5a422933c2 100644 --- a/compiler/GHC/Cmm/Lexer.x +++ b/compiler/GHC/Cmm/Lexer.x @@ -28,6 +28,7 @@ import GHC.Data.FastString import GHC.Parser.CharClass import GHC.Parser.Errors.Types import GHC.Parser.Errors.Ppr () +import GHC.Platform import GHC.Utils.Error import GHC.Utils.Misc --import TRACE @@ -103,22 +104,22 @@ $white_no_nl+ ; "False" { kw CmmT_False } "likely" { kw CmmT_likely} - P@decimal { global_regN (\n -> VanillaReg n VGcPtr) } - R@decimal { global_regN (\n -> VanillaReg n VNonGcPtr) } - F@decimal { global_regN FloatReg } - D@decimal { global_regN DoubleReg } - L@decimal { global_regN LongReg } - Sp { global_reg Sp } - SpLim { global_reg SpLim } - Hp { global_reg Hp } - HpLim { global_reg HpLim } - CCCS { global_reg CCCS } - CurrentTSO { global_reg CurrentTSO } - CurrentNursery { global_reg CurrentNursery } - HpAlloc { global_reg HpAlloc } - BaseReg { global_reg BaseReg } - MachSp { global_reg MachSp } - UnwindReturnReg { global_reg UnwindReturnReg } + P@decimal { global_regN VanillaReg gcWord } + R@decimal { global_regN VanillaReg bWord } + F@decimal { global_regN FloatReg (const $ cmmFloat W32) } + D@decimal { global_regN DoubleReg (const $ cmmFloat W64) } + L@decimal { global_regN LongReg (const $ cmmBits W64) } + Sp { global_reg Sp bWord } + SpLim { global_reg SpLim bWord } + Hp { global_reg Hp gcWord } + HpLim { global_reg HpLim bWord } + CCCS { global_reg CCCS bWord } + CurrentTSO { global_reg CurrentTSO bWord } + CurrentNursery { global_reg CurrentNursery bWord } + HpAlloc { global_reg HpAlloc bWord } + BaseReg { global_reg BaseReg bWord } + MachSp { global_reg MachSp bWord } + UnwindReturnReg { global_reg UnwindReturnReg bWord } $namebegin $namechar* { name } @@ -178,7 +179,7 @@ data CmmToken | CmmT_float32 | CmmT_float64 | CmmT_gcptr - | CmmT_GlobalReg GlobalReg + | CmmT_GlobalReg GlobalRegUse | CmmT_Name FastString | CmmT_String String | CmmT_Int Integer @@ -210,14 +211,20 @@ special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf))) kw :: CmmToken -> Action kw tok span _buf _len = return (L span tok) -global_regN :: (Int -> GlobalReg) -> Action -global_regN con span buf len - = return (L span (CmmT_GlobalReg (con (fromIntegral n)))) +global_regN :: (Int -> GlobalReg) -> (Platform -> CmmType) -> Action +global_regN con ty_fn span buf len + = do { platform <- getPlatform + ; let reg = con (fromIntegral n) + ty = ty_fn platform + ; return (L span (CmmT_GlobalReg (GlobalRegUse reg ty))) } where buf' = stepOn buf n = parseUnsignedInteger buf' (len-1) 10 octDecDigit -global_reg :: GlobalReg -> Action -global_reg r span _buf _len = return (L span (CmmT_GlobalReg r)) +global_reg :: GlobalReg -> (Platform -> CmmType) -> Action +global_reg reg ty_fn span _buf _len + = do { platform <- getPlatform + ; let ty = ty_fn platform + ; return (L span (CmmT_GlobalReg (GlobalRegUse reg ty))) } strtoken :: (String -> CmmToken) -> Action strtoken f span buf len = diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs index 8ba4f20fa8..e6773d2d15 100644 --- a/compiler/GHC/Cmm/Lint.hs +++ b/compiler/GHC/Cmm/Lint.hs @@ -107,8 +107,7 @@ lintCmmExpr expr@(CmmMachOp op args) = do then cmmCheckMachOp op args tys else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op) lintCmmExpr (CmmRegOff reg offset) - = do platform <- getPlatform - let rep = typeWidth (cmmRegType platform reg) + = do let rep = typeWidth (cmmRegType reg) lintCmmExpr (CmmMachOp (MO_Add rep) [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) lintCmmExpr expr = @@ -171,9 +170,8 @@ lintCmmMiddle node = case node of CmmUnwind{} -> return () CmmAssign reg expr -> do - platform <- getPlatform erep <- lintCmmExpr expr - let reg_ty = cmmRegType platform reg + let reg_ty = cmmRegType reg unless (compat_regs erep reg_ty) $ cmmLintAssignErr (CmmAssign reg expr) erep reg_ty where diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs index 0e381e31c4..165bd5ad8b 100644 --- a/compiler/GHC/Cmm/Node.hs +++ b/compiler/GHC/Cmm/Node.hs @@ -565,7 +565,6 @@ instance UserOfRegs GlobalReg (CmmNode e x) where where fold :: forall a b. UserOfRegs GlobalReg a => (b -> GlobalReg -> b) -> b -> a -> b fold f z n = foldRegsUsed platform f z n - instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where -- The (Ord r) in the context is necessary here -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance diff --git a/compiler/GHC/Cmm/Opt.hs b/compiler/GHC/Cmm/Opt.hs index 48581d8e64..a7a03b2526 100644 --- a/compiler/GHC/Cmm/Opt.hs +++ b/compiler/GHC/Cmm/Opt.hs @@ -425,5 +425,5 @@ That's what the constant-folding operations on comparison operators do above. -- Utils isPicReg :: CmmExpr -> Bool -isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True +isPicReg (CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))) = True isPicReg _ = False diff --git a/compiler/GHC/Cmm/Parser.y b/compiler/GHC/Cmm/Parser.y index 35d8e4c40f..6ba2d9df71 100644 --- a/compiler/GHC/Cmm/Parser.y +++ b/compiler/GHC/Cmm/Parser.y @@ -375,11 +375,11 @@ import qualified Data.ByteString.Char8 as BS8 'float64' { L _ (CmmT_float64) } 'gcptr' { L _ (CmmT_gcptr) } - GLOBALREG { L _ (CmmT_GlobalReg $$) } - NAME { L _ (CmmT_Name $$) } - STRING { L _ (CmmT_String $$) } - INT { L _ (CmmT_Int $$) } - FLOAT { L _ (CmmT_Float $$) } + GLOBALREG { L _ (CmmT_GlobalReg $$) } + NAME { L _ (CmmT_Name $$) } + STRING { L _ (CmmT_String $$) } + INT { L _ (CmmT_Int $$) } + FLOAT { L _ (CmmT_Float $$) } %monad { PD } { >>= } { return } %lexer { cmmlex } { L _ CmmT_EOF } @@ -714,9 +714,9 @@ stmt :: { CmmParse () } unwind_regs :: { CmmParse [(GlobalReg, Maybe CmmExpr)] } : GLOBALREG '=' expr_or_unknown ',' unwind_regs - { do e <- $3; rest <- $5; return (($1, e) : rest) } + { do e <- $3; rest <- $5; return ((globalRegUseGlobalReg $1, e) : rest) } | GLOBALREG '=' expr_or_unknown - { do e <- $3; return [($1, e)] } + { do e <- $3; return [(globalRegUseGlobalReg $1, e)] } -- | A memory ordering mem_ordering :: { CmmParse MemoryOrdering } @@ -763,9 +763,9 @@ vols :: { [GlobalReg] } ; return (realArgRegsCover platform) } -- All of them. See comment attached -- to realArgRegsCover - | '[' globals ']' { $2 } + | '[' globals ']' { map globalRegUseGlobalReg $2 } -globals :: { [GlobalReg] } +globals :: { [GlobalRegUse] } : GLOBALREG { [$1] } | GLOBALREG ',' globals { $1 : $3 } @@ -1177,19 +1177,30 @@ parseCmmHint str = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ -- labels are always pointers, so we might as well infer the hint inferCmmHint :: CmmExpr -> ForeignHint -inferCmmHint (CmmLit (CmmLabel _)) = AddrHint -inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint -inferCmmHint _ = NoHint - -isPtrGlobalReg Sp = True -isPtrGlobalReg SpLim = True -isPtrGlobalReg Hp = True -isPtrGlobalReg HpLim = True -isPtrGlobalReg CCCS = True -isPtrGlobalReg CurrentTSO = True -isPtrGlobalReg CurrentNursery = True -isPtrGlobalReg (VanillaReg _ VGcPtr) = True -isPtrGlobalReg _ = False +inferCmmHint (CmmLit (CmmLabel _)) + = AddrHint +inferCmmHint (CmmReg (CmmGlobal reg)) + | isPtrGlobalRegUse reg + = AddrHint +inferCmmHint _ + = NoHint + +isPtrGlobalRegUse :: GlobalRegUse -> Bool +isPtrGlobalRegUse (GlobalRegUse reg ty) + | VanillaReg {} <- reg + , isGcPtrType ty + = True + | otherwise + = go reg + where + go Sp = True + go SpLim = True + go Hp = True + go HpLim = True + go CCCS = True + go CurrentTSO = True + go CurrentNursery = True + go _ = False happyError :: PD a happyError = PD $ \_ _ s -> unP srcParseFail s diff --git a/compiler/GHC/Cmm/Reg.hs b/compiler/GHC/Cmm/Reg.hs index 104702f312..4c03f49995 100644 --- a/compiler/GHC/Cmm/Reg.hs +++ b/compiler/GHC/Cmm/Reg.hs @@ -11,12 +11,11 @@ module GHC.Cmm.Reg , LocalReg(..) , localRegType -- * Global registers - , GlobalReg(..), isArgReg, globalRegType - , pprGlobalReg + , GlobalReg(..), isArgReg, globalRegSpillType, pprGlobalReg , spReg, hpReg, spLimReg, hpLimReg, nodeReg , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg , node, baseReg - , VGcPtr(..) + , GlobalRegUse(..), pprGlobalRegUse ) where import GHC.Prelude @@ -30,10 +29,66 @@ import GHC.Cmm.Type -- Cmm registers ----------------------------------------------------------------------------- +{- Note [GlobalReg vs GlobalRegUse] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We distinguish GlobalReg, which describes registers in the STG abstract machine, +with GlobalRegUse, which describes an usage of such a register to store values +of a particular CmmType. + +For example, we might want to load/store an 8-bit integer in a register that +can store 32-bit integers. + +The width of the type must fit in the register, i.e. for a usage +@GlobalRegUse reg ty@ we must have that + + > typeWidth ty <= typeWidth (globalRegSpillType reg) + +The restrictions about what categories of types can be stored in a given +register are less easily stated. Some examples are: + + - Vanilla registers can contain both pointers (gcWord) and non-pointers (bWord), + as well as sub-word sized values (e.g. b16). + - On x86_64, SIMD registers can be used to hold vectors of both floating + and integral values (e.g. XmmReg may store 2 Double values or 4 Int32 values). +-} + +-- | A use of a global register at a particular type. +-- +-- While a 'GlobalReg' identifies a global register in the STG machine, +-- a 'GlobalRegUse' also contains information about the type we are storing +-- in the register. +-- +-- See Note [GlobalReg vs GlobalRegUse] for more information. +data GlobalRegUse + = GlobalRegUse + { globalRegUseGlobalReg :: !GlobalReg + -- ^ The underlying 'GlobalReg' + , globalRegUseType :: !CmmType + -- ^ The 'CmmType' at which we are using the 'GlobalReg'. + -- + -- Its width must be less than the width of the 'GlobalReg': + -- + -- > typeWidth ty <= typeWidth (globalRegSpillType reg) + } + deriving Show + +instance Outputable GlobalRegUse where + ppr (GlobalRegUse reg _) = ppr reg + +pprGlobalRegUse :: IsLine doc => GlobalRegUse -> doc +pprGlobalRegUse (GlobalRegUse reg _) = pprGlobalReg reg + +-- TODO: these instances should be removed in favour +-- of more surgical uses of equality. +instance Eq GlobalRegUse where + GlobalRegUse r1 _ == GlobalRegUse r2 _ = r1 == r2 +instance Ord GlobalRegUse where + GlobalRegUse r1 _ `compare` GlobalRegUse r2 _ = compare r1 r2 + data CmmReg = CmmLocal {-# UNPACK #-} !LocalReg - | CmmGlobal GlobalReg - deriving( Eq, Ord, Show ) + | CmmGlobal GlobalRegUse + deriving ( Eq, Ord, Show ) instance Outputable CmmReg where ppr e = pprReg e @@ -41,16 +96,15 @@ instance Outputable CmmReg where pprReg :: CmmReg -> SDoc pprReg r = case r of - CmmLocal local -> pprLocalReg local - CmmGlobal global -> pprGlobalReg global - -cmmRegType :: Platform -> CmmReg -> CmmType -cmmRegType _ (CmmLocal reg) = localRegType reg -cmmRegType platform (CmmGlobal reg) = globalRegType platform reg + CmmLocal local -> pprLocalReg local + CmmGlobal (GlobalRegUse global _) -> pprGlobalReg global -cmmRegWidth :: Platform -> CmmReg -> Width -cmmRegWidth platform = typeWidth . cmmRegType platform +cmmRegType :: CmmReg -> CmmType +cmmRegType (CmmLocal reg) = localRegType reg +cmmRegType (CmmGlobal reg) = globalRegUseType reg +cmmRegWidth :: CmmReg -> Width +cmmRegWidth = typeWidth . cmmRegType ----------------------------------------------------------------------------- -- Local registers @@ -129,13 +183,15 @@ account. However it is still used in UserOfRegs/DefinerOfRegs and there are likely still bugs there, beware! -} -data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show ) - +-- | An abstract global register for the STG machine. +-- +-- See also 'GlobalRegUse', which denotes a usage of a register at a particular +-- type (e.g. using a 32-bit wide register to store an 8-bit wide value), as per +-- Note [GlobalReg vs GlobalRegUse]. data GlobalReg -- Argument and return registers = VanillaReg -- pointers, unboxed ints and chars {-# UNPACK #-} !Int -- its number - VGcPtr | FloatReg -- single-precision floating-point registers {-# UNPACK #-} !Int -- its number @@ -192,104 +248,9 @@ data GlobalReg -- from platform to platform (see module PositionIndependentCode). | PicBaseReg - deriving( Show ) - -instance Eq GlobalReg where - VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes - FloatReg i == FloatReg j = i==j - DoubleReg i == DoubleReg j = i==j - LongReg i == LongReg j = i==j - -- NOTE: XMM, YMM, ZMM registers actually are the same registers - -- at least with respect to store at YMM i and then read from XMM i - -- and similarly for ZMM etc. - XmmReg i == XmmReg j = i==j - YmmReg i == YmmReg j = i==j - ZmmReg i == ZmmReg j = i==j - Sp == Sp = True - SpLim == SpLim = True - Hp == Hp = True - HpLim == HpLim = True - CCCS == CCCS = True - CurrentTSO == CurrentTSO = True - CurrentNursery == CurrentNursery = True - HpAlloc == HpAlloc = True - EagerBlackholeInfo == EagerBlackholeInfo = True - GCEnter1 == GCEnter1 = True - GCFun == GCFun = True - BaseReg == BaseReg = True - MachSp == MachSp = True - UnwindReturnReg == UnwindReturnReg = True - PicBaseReg == PicBaseReg = True - _r1 == _r2 = False - --- NOTE: this Ord instance affects the tuple layout in GHCi, see --- Note [GHCi and native call registers] -instance Ord GlobalReg where - compare (VanillaReg i _) (VanillaReg j _) = compare i j - -- Ignore type when seeking clashes - compare (FloatReg i) (FloatReg j) = compare i j - compare (DoubleReg i) (DoubleReg j) = compare i j - compare (LongReg i) (LongReg j) = compare i j - compare (XmmReg i) (XmmReg j) = compare i j - compare (YmmReg i) (YmmReg j) = compare i j - compare (ZmmReg i) (ZmmReg j) = compare i j - compare Sp Sp = EQ - compare SpLim SpLim = EQ - compare Hp Hp = EQ - compare HpLim HpLim = EQ - compare CCCS CCCS = EQ - compare CurrentTSO CurrentTSO = EQ - compare CurrentNursery CurrentNursery = EQ - compare HpAlloc HpAlloc = EQ - compare EagerBlackholeInfo EagerBlackholeInfo = EQ - compare GCEnter1 GCEnter1 = EQ - compare GCFun GCFun = EQ - compare BaseReg BaseReg = EQ - compare MachSp MachSp = EQ - compare UnwindReturnReg UnwindReturnReg = EQ - compare PicBaseReg PicBaseReg = EQ - compare (VanillaReg _ _) _ = LT - compare _ (VanillaReg _ _) = GT - compare (FloatReg _) _ = LT - compare _ (FloatReg _) = GT - compare (DoubleReg _) _ = LT - compare _ (DoubleReg _) = GT - compare (LongReg _) _ = LT - compare _ (LongReg _) = GT - compare (XmmReg _) _ = LT - compare _ (XmmReg _) = GT - compare (YmmReg _) _ = LT - compare _ (YmmReg _) = GT - compare (ZmmReg _) _ = LT - compare _ (ZmmReg _) = GT - compare Sp _ = LT - compare _ Sp = GT - compare SpLim _ = LT - compare _ SpLim = GT - compare Hp _ = LT - compare _ Hp = GT - compare HpLim _ = LT - compare _ HpLim = GT - compare CCCS _ = LT - compare _ CCCS = GT - compare CurrentTSO _ = LT - compare _ CurrentTSO = GT - compare CurrentNursery _ = LT - compare _ CurrentNursery = GT - compare HpAlloc _ = LT - compare _ HpAlloc = GT - compare GCEnter1 _ = LT - compare _ GCEnter1 = GT - compare GCFun _ = LT - compare _ GCFun = GT - compare BaseReg _ = LT - compare _ BaseReg = GT - compare MachSp _ = LT - compare _ MachSp = GT - compare UnwindReturnReg _ = LT - compare _ UnwindReturnReg = GT - compare EagerBlackholeInfo _ = LT - compare _ EagerBlackholeInfo = GT + deriving( Eq, Ord, Show ) + -- NOTE: the Ord instance affects the tuple layout in GHCi, see + -- Note [GHCi and native call registers] instance Outputable GlobalReg where ppr e = pprGlobalReg e @@ -300,10 +261,7 @@ instance OutputableP env GlobalReg where pprGlobalReg :: IsLine doc => GlobalReg -> doc pprGlobalReg gr = case gr of - VanillaReg n _ -> char 'R' <> int n --- Temp Jan08 --- VanillaReg n VNonGcPtr -> char 'R' <> int n --- VanillaReg n VGcPtr -> char 'P' <> int n + VanillaReg n -> char 'R' <> int n FloatReg n -> char 'F' <> int n DoubleReg n -> char 'D' <> int n LongReg n -> char 'L' <> int n @@ -331,38 +289,38 @@ pprGlobalReg gr -- convenient aliases baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg, - currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: CmmReg -baseReg = CmmGlobal BaseReg -spReg = CmmGlobal Sp -hpReg = CmmGlobal Hp -hpLimReg = CmmGlobal HpLim -spLimReg = CmmGlobal SpLim -nodeReg = CmmGlobal node -currentTSOReg = CmmGlobal CurrentTSO -currentNurseryReg = CmmGlobal CurrentNursery -hpAllocReg = CmmGlobal HpAlloc -cccsReg = CmmGlobal CCCS + currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: Platform -> CmmReg +baseReg p = CmmGlobal (GlobalRegUse BaseReg $ bWord p) +spReg p = CmmGlobal (GlobalRegUse Sp $ bWord p) +hpReg p = CmmGlobal (GlobalRegUse Hp $ gcWord p) +hpLimReg p = CmmGlobal (GlobalRegUse HpLim $ bWord p) +spLimReg p = CmmGlobal (GlobalRegUse SpLim $ bWord p) +nodeReg p = CmmGlobal (GlobalRegUse (VanillaReg 1) $ gcWord p) +currentTSOReg p = CmmGlobal (GlobalRegUse CurrentTSO $ bWord p) +currentNurseryReg p = CmmGlobal (GlobalRegUse CurrentNursery $ bWord p) +hpAllocReg p = CmmGlobal (GlobalRegUse HpAlloc $ bWord p) +cccsReg p = CmmGlobal (GlobalRegUse CCCS $ bWord p) node :: GlobalReg -node = VanillaReg 1 VGcPtr - -globalRegType :: Platform -> GlobalReg -> CmmType -globalRegType platform = \case - (VanillaReg _ VGcPtr) -> gcWord platform - (VanillaReg _ VNonGcPtr) -> bWord platform - (FloatReg _) -> cmmFloat W32 - (DoubleReg _) -> cmmFloat W64 - (LongReg _) -> cmmBits W64 +node = VanillaReg 1 + +globalRegSpillType :: Platform -> GlobalReg -> CmmType +globalRegSpillType platform = \case + VanillaReg _ -> gcWord platform + FloatReg _ -> cmmFloat W32 + DoubleReg _ -> cmmFloat W64 + LongReg _ -> cmmBits W64 + -- TODO: improve the internal model of SIMD/vectorized registers - -- the right design SHOULd improve handling of float and double code too. + -- the right design SHOULD improve handling of float and double code too. -- see remarks in Note [SIMD Design for the future] in GHC.StgToCmm.Prim - (XmmReg _) -> cmmVec 4 (cmmBits W32) - (YmmReg _) -> cmmVec 8 (cmmBits W32) - (ZmmReg _) -> cmmVec 16 (cmmBits W32) + XmmReg _ -> cmmVec 4 (cmmBits W32) + YmmReg _ -> cmmVec 8 (cmmBits W32) + ZmmReg _ -> cmmVec 16 (cmmBits W32) - Hp -> gcWord platform -- The initialiser for all - -- dynamically allocated closures - _ -> bWord platform + Hp -> gcWord platform -- The initialiser for all + -- dynamically allocated closures + _ -> bWord platform isArgReg :: GlobalReg -> Bool isArgReg (VanillaReg {}) = True diff --git a/compiler/GHC/Cmm/Sink.hs b/compiler/GHC/Cmm/Sink.hs index 9ad5c455ac..7addd43909 100644 --- a/compiler/GHC/Cmm/Sink.hs +++ b/compiler/GHC/Cmm/Sink.hs @@ -244,7 +244,7 @@ isSmall _ = False -- isTrivial :: Platform -> CmmExpr -> Bool isTrivial _ (CmmReg (CmmLocal _)) = True -isTrivial platform (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?] +isTrivial platform (CmmReg (CmmGlobal (GlobalRegUse r _))) = -- see Note [Inline GlobalRegs?] if isARM (platformArch platform) then True -- CodeGen.Platform.ARM does not have globalRegMaybe else isJust (globalRegMaybe platform r) @@ -667,9 +667,9 @@ conflicts platform (r, rhs, addr) node , memConflicts addr (loadAddr platform addr' (cmmExprWidth platform e)) = True -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively - | HeapMem <- addr, CmmAssign (CmmGlobal Hp) _ <- node = True - | StackMem <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True - | SpMem{} <- addr, CmmAssign (CmmGlobal Sp) _ <- node = True + | HeapMem <- addr, CmmAssign (CmmGlobal (GlobalRegUse Hp _)) _ <- node = True + | StackMem <- addr, CmmAssign (CmmGlobal (GlobalRegUse Sp _)) _ <- node = True + | SpMem{} <- addr, CmmAssign (CmmGlobal (GlobalRegUse Sp _)) _ <- node = True -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap] | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem = True @@ -703,9 +703,9 @@ conflicts platform (r, rhs, addr) node -- Cmm expression globalRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool globalRegistersConflict platform expr node = - -- See Note [Inlining foldRegsDefd] - inline foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmGlobal r) expr) - False node + -- See Note [Inlining foldRegsDefd] + inline foldRegsDefd platform (\b r -> b || globalRegUsedIn platform r expr) + False node -- Returns True if node defines any local registers that are used in the -- Cmm expression @@ -852,17 +852,17 @@ exprMem _ _ = NoMem loadAddr :: Platform -> CmmExpr -> Width -> AbsMem loadAddr platform e w = case e of - CmmReg r -> regAddr platform r 0 w - CmmRegOff r i -> regAddr platform r i w - _other | regUsedIn platform spReg e -> StackMem - | otherwise -> AnyMem - -regAddr :: Platform -> CmmReg -> Int -> Width -> AbsMem -regAddr _ (CmmGlobal Sp) i w = SpMem i (widthInBytes w) -regAddr _ (CmmGlobal Hp) _ _ = HeapMem -regAddr _ (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps -regAddr platform r _ _ | isGcPtrType (cmmRegType platform r) = HeapMem -- yay! GCPtr pays for itself -regAddr _ _ _ _ = AnyMem + CmmReg r -> regAddr r 0 w + CmmRegOff r i -> regAddr r i w + _other | regUsedIn platform (spReg platform) e -> StackMem + | otherwise -> AnyMem + +regAddr :: CmmReg -> Int -> Width -> AbsMem +regAddr (CmmGlobal (GlobalRegUse Sp _)) i w = SpMem i (widthInBytes w) +regAddr (CmmGlobal (GlobalRegUse Hp _)) _ _ = HeapMem +regAddr (CmmGlobal (GlobalRegUse CurrentTSO _)) _ _ = HeapMem -- important for PrimOps +regAddr r _ _ | isGcPtrType (cmmRegType r) = HeapMem -- yay! GCPtr pays for itself +regAddr _ _ _ = AnyMem {- Note [Inline GlobalRegs?] diff --git a/compiler/GHC/Cmm/ThreadSanitizer.hs b/compiler/GHC/Cmm/ThreadSanitizer.hs index 0200654ae2..ab4e16edb7 100644 --- a/compiler/GHC/Cmm/ThreadSanitizer.hs +++ b/compiler/GHC/Cmm/ThreadSanitizer.hs @@ -156,17 +156,23 @@ saveRestoreCallerRegs platform = regs = filter (callerSaves platform) (activeStgRegs platform) save = blockFromList (map saveReg regs) + + saveReg :: GlobalReg -> CmmNode O O saveReg reg = CmmStore (get_GlobalReg_addr platform reg) - (CmmReg (CmmGlobal reg)) + (CmmReg (CmmGlobal (GlobalRegUse reg ty))) NaturallyAligned + where ty = globalRegSpillType platform reg restore = blockFromList (map restoreReg regs) + + restoreReg :: GlobalReg -> CmmNode O O restoreReg reg = - CmmAssign (CmmGlobal reg) + CmmAssign (CmmGlobal (GlobalRegUse reg ty)) (CmmLoad (get_GlobalReg_addr platform reg) - (globalRegType platform reg) + ty NaturallyAligned) + where ty = globalRegSpillType platform reg -- | Mirrors __tsan_memory_order -- <https://github.com/llvm-mirror/compiler-rt/blob/master/include/sanitizer/tsan_interface_atomic.h#L32> diff --git a/compiler/GHC/Cmm/Type.hs b/compiler/GHC/Cmm/Type.hs index ec000a3c47..b1196052bd 100644 --- a/compiler/GHC/Cmm/Type.hs +++ b/compiler/GHC/Cmm/Type.hs @@ -3,7 +3,8 @@ module GHC.Cmm.Type , b8, b16, b32, b64, b128, b256, b512, f32, f64, bWord, bHalfWord, gcWord , cInt , cmmBits, cmmFloat - , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood + , typeWidth, setCmmTypeWidth + , cmmEqType, cmmEqType_ignoring_ptrhood , isFloatType, isGcPtrType, isBitsType , isWordAny, isWord32, isWord64 , isFloat64, isFloat32 @@ -106,6 +107,9 @@ cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2) typeWidth :: CmmType -> Width typeWidth (CmmType _ w) = w +setCmmTypeWidth :: Width -> CmmType -> CmmType +setCmmTypeWidth w (CmmType c _) = CmmType c w + cmmBits, cmmFloat :: Width -> CmmType cmmBits = CmmType BitsCat cmmFloat = CmmType FloatCat diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs index bf8c96fd14..0378eaa99e 100644 --- a/compiler/GHC/Cmm/Utils.hs +++ b/compiler/GHC/Cmm/Utils.hs @@ -50,7 +50,7 @@ module GHC.Cmm.Utils( cmmConstrTag1, mAX_PTR_TAG, tAG_MASK, -- Overlap and usage - regsOverlap, regUsedIn, + regsOverlap, globalRegsOverlap, regUsedIn, globalRegUsedIn, -- Liveness and bitmaps mkLiveness, @@ -437,13 +437,19 @@ cmmConstrTag1 platform e = cmmAndWord platform e (cmmTagMask platform) -- other. This includes the case that the two registers are the same -- STG register. See Note [Overlapping global registers] for details. regsOverlap :: Platform -> CmmReg -> CmmReg -> Bool -regsOverlap platform (CmmGlobal g) (CmmGlobal g') - | Just real <- globalRegMaybe platform g, - Just real' <- globalRegMaybe platform g', - real == real' - = True +regsOverlap platform (CmmGlobal (GlobalRegUse g1 _)) (CmmGlobal (GlobalRegUse g2 _)) + = globalRegsOverlap platform g1 g2 regsOverlap _ reg reg' = reg == reg' +globalRegsOverlap :: Platform -> GlobalReg -> GlobalReg -> Bool +globalRegsOverlap platform g1 g2 + | Just real <- globalRegMaybe platform g1 + , Just real' <- globalRegMaybe platform g2 + , real == real' + = True + | otherwise + = g1 == g2 + -- | Returns True if the STG register is used by the expression, in -- the sense that a store to the register might affect the value of -- the expression. @@ -461,6 +467,27 @@ regUsedIn platform = regUsedIn_ where reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es _ `regUsedIn_` CmmStackSlot _ _ = False +globalRegUsedIn :: Platform -> GlobalReg -> CmmExpr -> Bool +globalRegUsedIn platform = globalRegUsedIn_ where + _ `globalRegUsedIn_` CmmLit _ + = False + reg `globalRegUsedIn_` CmmLoad e _ _ + = reg `globalRegUsedIn_` e + reg `globalRegUsedIn_` CmmReg reg' + | CmmGlobal (GlobalRegUse reg' _) <- reg' + = globalRegsOverlap platform reg reg' + | otherwise + = False + reg `globalRegUsedIn_` CmmRegOff reg' _ + | CmmGlobal (GlobalRegUse reg' _) <- reg' + = globalRegsOverlap platform reg reg' + | otherwise + = False + reg `globalRegUsedIn_` CmmMachOp _ es + = any (reg `globalRegUsedIn_`) es + _ `globalRegUsedIn_` CmmStackSlot _ _ + = False + -------------------------------------------- -- -- mkLiveness @@ -571,12 +598,12 @@ blockTicks b = reverse $ foldBlockNodesF goStmt b [] -- Access to common global registers baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr, - spLimExpr, hpLimExpr, cccsExpr :: CmmExpr -baseExpr = CmmReg baseReg -spExpr = CmmReg spReg -spLimExpr = CmmReg spLimReg -hpExpr = CmmReg hpReg -hpLimExpr = CmmReg hpLimReg -currentTSOExpr = CmmReg currentTSOReg -currentNurseryExpr = CmmReg currentNurseryReg -cccsExpr = CmmReg cccsReg + spLimExpr, hpLimExpr, cccsExpr :: Platform -> CmmExpr +baseExpr p = CmmReg $ baseReg p +spExpr p = CmmReg $ spReg p +spLimExpr p = CmmReg $ spLimReg p +hpExpr p = CmmReg $ hpReg p +hpLimExpr p = CmmReg $ hpLimReg p +currentTSOExpr p = CmmReg $ currentTSOReg p +currentNurseryExpr p = CmmReg $ currentNurseryReg p +cccsExpr p = CmmReg $ cccsReg p diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index 94bdaa648b..96f5f6d78b 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -1125,15 +1125,15 @@ cmmExprNative referenceKind expr = do -- On powerpc (non-PIC), it's easier to jump directly to a label than -- to use the register table, so we replace these registers -- with the corresponding labels: - CmmReg (CmmGlobal EagerBlackholeInfo) + CmmReg (CmmGlobal (GlobalRegUse EagerBlackholeInfo _)) | arch == ArchPPC && not (ncgPIC config) -> cmmExprNative referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info"))) - CmmReg (CmmGlobal GCEnter1) + CmmReg (CmmGlobal (GlobalRegUse GCEnter1 _)) | arch == ArchPPC && not (ncgPIC config) -> cmmExprNative referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1"))) - CmmReg (CmmGlobal GCFun) + CmmReg (CmmGlobal (GlobalRegUse GCFun _)) | arch == ArchPPC && not (ncgPIC config) -> cmmExprNative referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun"))) diff --git a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs index 4569caecca..2d6a6d7c05 100644 --- a/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/AArch64/CodeGen.hs @@ -289,7 +289,7 @@ stmtToInstrs bid stmt = do CmmAssign reg src | isFloatType ty -> assignReg_FltCode format reg src | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType platform reg + where ty = cmmRegType reg format = cmmTypeFormat ty CmmStore addr src _alignment @@ -342,10 +342,10 @@ getRegisterReg :: Platform -> CmmReg -> Reg getRegisterReg _ (CmmLocal (LocalReg u pk)) = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk) -getRegisterReg platform (CmmGlobal mid) +getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _)) = case globalRegMaybe platform mid of Just reg -> RegReal reg - Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) + Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal reg) -- By this stage, the only MagicIds remaining should be the -- ones which map to a real machine register on this -- platform. Hence if it's not mapped to a registers something @@ -489,7 +489,7 @@ getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt i w1)]) | i < -- Generic case. getRegister' config plat expr = case expr of - CmmReg (CmmGlobal PicBaseReg) + CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)) -> pprPanic "getRegisterReg-memory" (ppr $ PicBaseReg) CmmLit lit -> case lit of @@ -607,19 +607,19 @@ getRegister' config plat expr CmmStackSlot _ _ -> pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr) CmmReg reg - -> return (Fixed (cmmTypeFormat (cmmRegType plat reg)) + -> return (Fixed (cmmTypeFormat (cmmRegType reg)) (getRegisterReg plat reg) nilOL) CmmRegOff reg off | isNbitEncodeable 12 (fromIntegral off) -> do getRegister' config plat $ CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType plat reg) + where width = typeWidth (cmmRegType reg) CmmRegOff reg off -> do (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width) (reg, _format, code) <- getSomeReg $ CmmReg reg return $ Any (intFormat width) (\dst -> off_code `appOL` code `snocOL` ADD (OpReg width dst) (OpReg width reg) (OpReg width off_r)) - where width = typeWidth (cmmRegType plat reg) + where width = typeWidth (cmmRegType reg) @@ -698,12 +698,12 @@ getRegister' config plat expr CmmMachOp (MO_Add w) [(CmmReg reg), CmmLit (CmmInt n _)] | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12. - where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) + where w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) r' = getRegisterReg plat reg CmmMachOp (MO_Sub w) [(CmmReg reg), CmmLit (CmmInt n _)] | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12. - where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) + where w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) r' = getRegisterReg plat reg CmmMachOp (MO_U_Quot w) [x, y] | w == W8 -> do @@ -775,12 +775,12 @@ getRegister' config plat expr -- 3. Logic &&, || CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (fromIntegral n) -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) - where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) + where w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) r' = getRegisterReg plat reg CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (fromIntegral n) -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORR (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n)))) - where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg)) + where w' = formatToWidth (cmmTypeFormat (cmmRegType reg)) r' = getRegisterReg plat reg -- Generic case. @@ -1704,9 +1704,9 @@ genCCall target dest_regs arg_regs bid = do readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do -- gp/fp reg -> dst platform <- getPlatform - let rep = cmmRegType platform (CmmLocal dst) + let rep = cmmRegType (CmmLocal dst) format = cmmTypeFormat rep - w = cmmRegWidth platform (CmmLocal dst) + w = cmmRegWidth (CmmLocal dst) r_dst = getRegisterReg platform (CmmLocal dst) if isFloatFormat format then readResults (gpReg:gpRegs) fpRegs dsts (fpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg)) diff --git a/compiler/GHC/CmmToAsm/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs index 0eef6ecb49..58f0815329 100644 --- a/compiler/GHC/CmmToAsm/Dwarf.hs +++ b/compiler/GHC/CmmToAsm/Dwarf.hs @@ -5,7 +5,7 @@ module GHC.CmmToAsm.Dwarf ( import GHC.Prelude import GHC.Cmm.CLabel -import GHC.Cmm.Expr ( GlobalReg(..) ) +import GHC.Cmm.Expr import GHC.Settings.Config ( cProjectName, cProjectVersion ) import GHC.Types.Tickish ( CmmTickish, GenTickish(..) ) import GHC.Cmm.DebugBlock @@ -82,7 +82,7 @@ dwarfGen compPath config modLoc us blocks = (framesU, us'') = takeUniqFromSupply us' frameSct = dwarfFrameSection platform $$ line (dwarfFrameLabel <> colon) $$ - pprDwarfFrame platform (debugFrame framesU procs) + pprDwarfFrame platform (debugFrame platform framesU procs) -- .aranges section: Information about the bounds of compilation units aranges' | ncgSplitSections config = map mkDwarfARange procs @@ -215,15 +215,15 @@ tickToDwarf _ = [] -- | Generates the data for the debug frame section, which encodes the -- desired stack unwind behaviour for the debugger -debugFrame :: Unique -> [DebugBlock] -> DwarfFrame -debugFrame u procs +debugFrame :: Platform -> Unique -> [DebugBlock] -> DwarfFrame +debugFrame p u procs = DwarfFrame { dwCieLabel = mkAsmTempLabel u , dwCieInit = initUws , dwCieProcs = map (procToFrame initUws) procs } where initUws :: UnwindTable - initUws = Map.fromList [(Sp, Just (UwReg Sp 0))] + initUws = Map.fromList [(Sp, Just (UwReg (GlobalRegUse Sp $ bWord p) 0))] -- | Generates unwind information for a procedure debug block procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc diff --git a/compiler/GHC/CmmToAsm/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs index 94593508c3..457c075e3c 100644 --- a/compiler/GHC/CmmToAsm/Dwarf/Types.hs +++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs @@ -31,7 +31,7 @@ import GHC.Prelude import GHC.Cmm.DebugBlock import GHC.Cmm.CLabel -import GHC.Cmm.Expr ( GlobalReg(..) ) +import GHC.Cmm.Expr import GHC.Utils.Encoding import GHC.Data.FastString import GHC.Utils.Outputable @@ -469,7 +469,7 @@ pprSetUnwind _ Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s' = if o' >= 0 then pprByte dW_CFA_def_cfa_offset $$ pprLEBWord (fromIntegral o') else pprByte dW_CFA_def_cfa_offset_sf $$ pprLEBInt o' -pprSetUnwind plat Sp (_, Just (UwReg s' o')) +pprSetUnwind plat Sp (_, Just (UwReg (GlobalRegUse s' _) o')) = if o' >= 0 then pprByte dW_CFA_def_cfa $$ pprLEBRegNo plat s' $$ @@ -479,7 +479,7 @@ pprSetUnwind plat Sp (_, Just (UwReg s' o')) pprLEBInt o' pprSetUnwind plat Sp (_, Just uw) = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr plat False uw -pprSetUnwind plat g (_, Just (UwDeref (UwReg Sp o))) +pprSetUnwind plat g (_, Just (UwDeref (UwReg (GlobalRegUse Sp _) o))) | o < 0 && ((-o) `mod` platformWordSizeInBytes plat) == 0 -- expected case = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$ pprLEBWord (fromIntegral ((-o) `div` platformWordSizeInBytes plat)) @@ -491,7 +491,7 @@ pprSetUnwind plat g (_, Just (UwDeref uw)) = pprByte dW_CFA_expression $$ pprLEBRegNo plat g $$ pprUnwindExpr plat True uw -pprSetUnwind plat g (_, Just (UwReg g' 0)) +pprSetUnwind plat g (_, Just (UwReg (GlobalRegUse g' _) 0)) | g == g' = pprByte dW_CFA_same_value $$ pprLEBRegNo plat g @@ -513,12 +513,14 @@ pprUnwindExpr platform spIsCFA expr = let pprE (UwConst i) | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i) | otherwise = pprByte dW_OP_consts $$ pprLEBInt i -- lazy... - pprE (UwReg Sp i) | spIsCFA - = if i == 0 - then pprByte dW_OP_call_frame_cfa - else pprE (UwPlus (UwReg Sp 0) (UwConst i)) - pprE (UwReg g i) = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$ - pprLEBInt i + pprE (UwReg r@(GlobalRegUse Sp _) i) + | spIsCFA + = if i == 0 + then pprByte dW_OP_call_frame_cfa + else pprE (UwPlus (UwReg r 0) (UwConst i)) + pprE (UwReg (GlobalRegUse g _) i) + = pprByte (dW_OP_breg0+dwarfGlobalRegNo platform g) $$ + pprLEBInt i pprE (UwDeref u) = pprE u $$ pprByte dW_OP_deref pprE (UwLabel l) = pprByte dW_OP_addr $$ pprWord platform (pprAsmLabel platform l) pprE (UwPlus u1 u2) = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus diff --git a/compiler/GHC/CmmToAsm/PIC.hs b/compiler/GHC/CmmToAsm/PIC.hs index d388d5b328..908c526d74 100644 --- a/compiler/GHC/CmmToAsm/PIC.hs +++ b/compiler/GHC/CmmToAsm/PIC.hs @@ -166,7 +166,7 @@ cmmMakePicReference config lbl | OSAIX <- platformOS platform = CmmMachOp (MO_Add W32) - [ CmmReg (CmmGlobal PicBaseReg) + [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform)) , CmmLit $ picRelative (wordWidth platform) (platformArch platform) (platformOS platform) @@ -175,7 +175,7 @@ cmmMakePicReference config lbl -- both ABI versions default to medium code model | ArchPPC_64 _ <- platformArch platform = CmmMachOp (MO_Add W32) -- code model medium - [ CmmReg (CmmGlobal PicBaseReg) + [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform)) , CmmLit $ picRelative (wordWidth platform) (platformArch platform) (platformOS platform) @@ -184,7 +184,7 @@ cmmMakePicReference config lbl | (ncgPIC config || ncgExternalDynamicRefs config) && absoluteLabel lbl = CmmMachOp (MO_Add (wordWidth platform)) - [ CmmReg (CmmGlobal PicBaseReg) + [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform)) , CmmLit $ picRelative (wordWidth platform) (platformArch platform) (platformOS platform) diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs index 1d6169a45d..7dac4f221b 100644 --- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs @@ -171,7 +171,7 @@ stmtToInstrs stmt = do | target32Bit platform && isWord64 ty -> assignReg_I64Code reg src | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType platform reg + where ty = cmmRegType reg format = cmmTypeFormat ty CmmStore addr src _alignment @@ -233,7 +233,7 @@ getRegisterReg _ (CmmLocal local_reg) = getLocalRegReg local_reg getRegisterReg platform (CmmGlobal mid) - = case globalRegMaybe platform mid of + = case globalRegMaybe platform (globalRegUseGlobalReg mid) of Just reg -> RegReal reg Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) -- By this stage, the only MagicIds remaining should be the @@ -253,12 +253,12 @@ jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) -- Expand CmmRegOff. ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff? -mangleIndexTree :: Platform -> CmmExpr -> CmmExpr -mangleIndexTree platform (CmmRegOff reg off) +mangleIndexTree :: CmmExpr -> CmmExpr +mangleIndexTree (CmmRegOff reg off) = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType platform reg) + where width = typeWidth (cmmRegType reg) -mangleIndexTree _ _ +mangleIndexTree _ = panic "PPC.CodeGen.mangleIndexTree: no match" -- ----------------------------------------------------------------------------- @@ -404,7 +404,7 @@ getRegister e = do config <- getConfig getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register -getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg)) +getRegister' _ platform (CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))) | OSAIX <- platformOS platform = do let code dst = toOL [ LD II32 dst tocAddr ] tocAddr = AddrRegImm toc (ImmLit (fsLit "ghc_toc_table[TC]")) @@ -416,11 +416,11 @@ getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg)) | otherwise = return (Fixed II64 toc nilOL) getRegister' _ platform (CmmReg reg) - = return (Fixed (cmmTypeFormat (cmmRegType platform reg)) + = return (Fixed (cmmTypeFormat (cmmRegType reg)) (getRegisterReg platform reg) nilOL) getRegister' config platform tree@(CmmRegOff _ _) - = getRegister' config platform (mangleIndexTree platform tree) + = getRegister' config platform (mangleIndexTree tree) -- for 32-bit architectures, support some 64 -> 32 bit conversions: -- TO_W_(x), TO_W_(x >> 32) @@ -735,8 +735,7 @@ data InstrForm = D | DS getAmode :: InstrForm -> CmmExpr -> NatM Amode getAmode inf tree@(CmmRegOff _ _) - = do platform <- getPlatform - getAmode inf (mangleIndexTree platform tree) + = getAmode inf (mangleIndexTree tree) getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)]) | Just off <- makeImmediate W32 True (-i) @@ -1952,7 +1951,7 @@ genCCall' config gcp target dest_regs args -> toOL [MR (getHiVRegFromLo r_dest) r3, MR r_dest r4] | otherwise -> unitOL (MR r_dest r3) - where rep = cmmRegType platform (CmmLocal dest) + where rep = cmmRegType (CmmLocal dest) r_dest = getLocalRegReg dest _ -> panic "genCCall' moveResult: Bad dest_regs" diff --git a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs index 8e4f285d27..76411bfe65 100644 --- a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs +++ b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs @@ -177,7 +177,7 @@ trouble. -} globalInfoFromCmmGlobalReg :: WasmTypeTag w -> GlobalReg -> Maybe GlobalInfo globalInfoFromCmmGlobalReg t reg = case reg of - VanillaReg i _ + VanillaReg i | i >= 1 && i <= 10 -> Just (fromString $ "__R" <> show i, ty_word) FloatReg i | i >= 1 && i <= 6 -> @@ -198,7 +198,7 @@ globalInfoFromCmmGlobalReg t reg = case reg of supportedCmmGlobalRegs :: [GlobalReg] supportedCmmGlobalRegs = - [VanillaReg i VGcPtr | i <- [1 .. 10]] + [VanillaReg i | i <- [1 .. 10]] <> [FloatReg i | i <- [1 .. 6]] <> [DoubleReg i | i <- [1 .. 6]] <> [LongReg i | i <- [1 .. 1]] @@ -873,38 +873,35 @@ lower_CmmReg :: CLabel -> CmmReg -> WasmCodeGenM w (SomeWasmExpr w) lower_CmmReg _ (CmmLocal reg) = do (reg_i, SomeWasmType ty) <- onCmmLocalReg reg pure $ SomeWasmExpr ty $ WasmExpr $ WasmLocalGet ty reg_i -lower_CmmReg _ (CmmGlobal EagerBlackholeInfo) = do - ty_word <- wasmWordTypeM - pure $ - SomeWasmExpr ty_word $ - WasmExpr $ - WasmSymConst "stg_EAGER_BLACKHOLE_info" -lower_CmmReg _ (CmmGlobal GCEnter1) = do +lower_CmmReg lbl (CmmGlobal (GlobalRegUse greg reg_use_ty)) = do ty_word <- wasmWordTypeM ty_word_cmm <- wasmWordCmmTypeM - onFuncSym "__stg_gc_enter_1" [] [ty_word_cmm] - pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_enter_1" -lower_CmmReg _ (CmmGlobal GCFun) = do - ty_word <- wasmWordTypeM - ty_word_cmm <- wasmWordCmmTypeM - onFuncSym "__stg_gc_fun" [] [ty_word_cmm] - pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_fun" -lower_CmmReg lbl (CmmGlobal BaseReg) = do - platform <- wasmPlatformM - lower_CmmExpr lbl $ regTableOffset platform 0 -lower_CmmReg lbl (CmmGlobal reg) = do - ty_word <- wasmWordTypeM - if + case greg of + EagerBlackholeInfo -> + pure $ + SomeWasmExpr ty_word $ + WasmExpr $ + WasmSymConst "stg_EAGER_BLACKHOLE_info" + GCEnter1 -> do + onFuncSym "__stg_gc_enter_1" [] [ty_word_cmm] + pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_enter_1" + GCFun -> do + onFuncSym "__stg_gc_fun" [] [ty_word_cmm] + pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_fun" + BaseReg -> do + platform <- wasmPlatformM + lower_CmmExpr lbl $ regTableOffset platform 0 + _other | Just (sym_global, SomeWasmType ty) <- - globalInfoFromCmmGlobalReg ty_word reg -> + globalInfoFromCmmGlobalReg ty_word greg -> pure $ SomeWasmExpr ty $ WasmExpr $ WasmGlobalGet ty sym_global | otherwise -> do platform <- wasmPlatformM - case someWasmTypeFromCmmType $ globalRegType platform reg of + case someWasmTypeFromCmmType reg_use_ty of SomeWasmType ty -> do (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl $ - get_GlobalReg_addr platform reg + get_GlobalReg_addr platform greg pure $ SomeWasmExpr ty $ WasmExpr $ @@ -1380,7 +1377,7 @@ lower_CmmUnsafeForeignCall lbl target mb_hints ret_info ret_locals arg_exprs = d (reg_i, SomeWasmType reg_ty) <- onCmmLocalReg reg pure $ SomeWasmPostCCall (reg_ty `TypeListCons` acc_tys) $ - case (# ret_hint, cmmRegWidth platform $ CmmLocal reg #) of + case (# ret_hint, cmmRegWidth $ CmmLocal reg #) of (# SignedHint, W8 #) -> acc_instr `WasmConcat` WasmConst reg_ty 0xFF @@ -1459,7 +1456,7 @@ lower_CmmAction lbl act = do (i, SomeWasmType ty_reg) <- onCmmLocalReg reg WasmExpr instrs <- lower_CmmExpr_Typed lbl ty_reg e pure $ WasmStatements $ instrs `WasmConcat` WasmLocalSet ty_reg i - CmmAssign (CmmGlobal reg) e + CmmAssign (CmmGlobal (GlobalRegUse reg _)) e | BaseReg <- reg -> pure $ WasmStatements WasmNop | Just (sym_global, SomeWasmType ty_reg) <- globalInfoFromCmmGlobalReg ty_word reg -> do diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs index bc0135b920..bf1c36bf55 100644 --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -228,9 +228,10 @@ basicBlockCodeGen block = do addSpUnwindings :: Instr -> NatM (OrdList Instr) addSpUnwindings instr@(DELTA d) = do config <- getConfig + let platform = ncgPlatform config if ncgDwarfUnwindings config then do lbl <- mkAsmTempLabel <$> getUniqueM - let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d) + let unwind = M.singleton MachSp (Just $ UwReg (GlobalRegUse MachSp (bWord platform)) $ negate d) return $ toOL [ instr, UNWIND lbl unwind ] else return (unitOL instr) addSpUnwindings instr = return $ unitOL instr @@ -342,7 +343,7 @@ stmtToInstrs bid stmt = do | isFloatType ty -> assignReg_FltCode format reg src | is32Bit && isWord64 ty -> assignReg_I64Code reg src | otherwise -> assignReg_IntCode format reg src - where ty = cmmRegType platform reg + where ty = cmmRegType reg format = cmmTypeFormat ty CmmStore addr src _alignment @@ -407,7 +408,7 @@ getRegisterReg :: Platform -> CmmReg -> Reg getRegisterReg _ (CmmLocal lreg) = getLocalRegReg lreg getRegisterReg platform (CmmGlobal mid) - = case globalRegMaybe platform mid of + = case globalRegMaybe platform $ globalRegUseGlobalReg mid of Just reg -> RegReal $ reg Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid) -- By this stage, the only MagicIds remaining should be the @@ -480,10 +481,10 @@ jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel) -- Expand CmmRegOff. ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff? -mangleIndexTree :: Platform -> CmmReg -> Int -> CmmExpr -mangleIndexTree platform reg off +mangleIndexTree :: CmmReg -> Int -> CmmExpr +mangleIndexTree reg off = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] - where width = typeWidth (cmmRegType platform reg) + where width = typeWidth (cmmRegType reg) -- | The dual to getAnyReg: compute an expression into a register, but -- we don't mind which one it is. @@ -623,9 +624,9 @@ getRegister e = do platform <- getPlatform getRegister' :: Platform -> Bool -> CmmExpr -> NatM Register -getRegister' platform is32Bit (CmmReg reg) +getRegister' _ is32Bit (CmmReg reg) = case reg of - CmmGlobal PicBaseReg + CmmGlobal (GlobalRegUse PicBaseReg _) | is32Bit -> -- on x86_64, we have %rip for PicBaseReg, but it's not -- a full-featured register, it can only be used for @@ -635,7 +636,7 @@ getRegister' platform is32Bit (CmmReg reg) _ -> do let - fmt = cmmTypeFormat (cmmRegType platform reg) + fmt = cmmTypeFormat (cmmRegType reg) format = fmt -- platform <- ncgPlatform <$> getConfig @@ -645,7 +646,7 @@ getRegister' platform is32Bit (CmmReg reg) getRegister' platform is32Bit (CmmRegOff r n) - = getRegister' platform is32Bit $ mangleIndexTree platform r n + = getRegister' platform is32Bit $ mangleIndexTree r n getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e]) = addAlignmentCheck align <$> getRegister' platform is32Bit e @@ -738,7 +739,7 @@ getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _ _]) code <- intLoadCode (MOVSxL II32) addr return (Any II64 code) -getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), +getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)), CmmLit displacement]) | not is32Bit = return $ Any II64 (\dst -> unitOL $ @@ -1279,9 +1280,9 @@ getAmode e = do case e of CmmRegOff r n - -> getAmode $ mangleIndexTree platform r n + -> getAmode $ mangleIndexTree r n - CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement] + CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)), CmmLit displacement] | not is32Bit -> return $ Amode (ripRel (litToImm displacement)) nilOL diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs index 58d6b9d0af..d4ac5cd4e4 100644 --- a/compiler/GHC/CmmToC.hs +++ b/compiler/GHC/CmmToC.hs @@ -383,7 +383,7 @@ pprExpr platform e = case e of -- CmmRegOff is an alias of MO_Add CmmRegOff reg i -> pprExpr platform $ CmmMachOp (MO_Add w) [CmmReg reg, CmmLit $ CmmInt (toInteger i) w] - where w = cmmRegWidth platform reg + where w = cmmRegWidth reg CmmMachOp mop args -> pprMachOpApp platform mop args @@ -1044,9 +1044,11 @@ 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 + where mkAssign x = + case r1 of + CmmGlobal (GlobalRegUse BaseReg _) -> + text "ASSIGN_BaseReg" <> parens x <> semi + _ -> pprReg r1 <> text " = " <> x <> semi -- --------------------------------------------------------------------- -- Registers @@ -1061,17 +1063,16 @@ pprCastReg reg -- StgPtr. isFixedPtrReg :: CmmReg -> Bool isFixedPtrReg (CmmLocal _) = False -isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r +isFixedPtrReg (CmmGlobal (GlobalRegUse r _)) = isFixedPtrGlobalReg r -- True if (pprAsPtrReg reg) will give an expression with type StgPtr -- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST. -- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT; -- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY. isPtrReg :: CmmReg -> Bool -isPtrReg (CmmLocal _) = False -isPtrReg (CmmGlobal (VanillaReg _ VGcPtr)) = True -- if we print via pprAsPtrReg -isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg -isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg +isPtrReg (CmmLocal _) = False +isPtrReg (CmmGlobal (GlobalRegUse (VanillaReg _) ty)) = isGcPtrType ty -- if we print via pprAsPtrReg +isPtrReg (CmmGlobal (GlobalRegUse reg _)) = isFixedPtrGlobalReg reg -- True if this global reg has type StgPtr isFixedPtrGlobalReg :: GlobalReg -> Bool @@ -1085,7 +1086,7 @@ isFixedPtrGlobalReg _ = False -- (machRepCType (cmmRegType reg)), so it has to be cast. isStrangeTypeReg :: CmmReg -> Bool isStrangeTypeReg (CmmLocal _) = False -isStrangeTypeReg (CmmGlobal g) = isStrangeTypeGlobal g +isStrangeTypeReg (CmmGlobal (GlobalRegUse g _)) = isStrangeTypeGlobal g isStrangeTypeGlobal :: GlobalReg -> Bool isStrangeTypeGlobal CCCS = True @@ -1095,10 +1096,10 @@ isStrangeTypeGlobal BaseReg = True isStrangeTypeGlobal r = isFixedPtrGlobalReg r strangeRegType :: CmmReg -> Maybe SDoc -strangeRegType (CmmGlobal CCCS) = Just (text "struct CostCentreStack_ *") -strangeRegType (CmmGlobal CurrentTSO) = Just (text "struct StgTSO_ *") -strangeRegType (CmmGlobal CurrentNursery) = Just (text "struct bdescr_ *") -strangeRegType (CmmGlobal BaseReg) = Just (text "struct StgRegTable_ *") +strangeRegType (CmmGlobal (GlobalRegUse CCCS _)) = Just (text "struct CostCentreStack_ *") +strangeRegType (CmmGlobal (GlobalRegUse CurrentTSO _)) = Just (text "struct StgTSO_ *") +strangeRegType (CmmGlobal (GlobalRegUse CurrentNursery _)) = Just (text "struct bdescr_ *") +strangeRegType (CmmGlobal (GlobalRegUse BaseReg _)) = Just (text "struct StgRegTable_ *") strangeRegType _ = Nothing -- pprReg just prints the register name. @@ -1106,16 +1107,16 @@ strangeRegType _ = Nothing pprReg :: CmmReg -> SDoc pprReg r = case r of CmmLocal local -> pprLocalReg local - CmmGlobal global -> pprGlobalReg global + CmmGlobal (GlobalRegUse global _ ) -> pprGlobalReg global pprAsPtrReg :: CmmReg -> SDoc -pprAsPtrReg (CmmGlobal (VanillaReg n gcp)) - = warnPprTrace (gcp /= VGcPtr) "pprAsPtrReg" (ppr n) $ char 'R' <> int n <> text ".p" +pprAsPtrReg (CmmGlobal (GlobalRegUse (VanillaReg n) ty)) + = warnPprTrace (not $ isGcPtrType ty) "pprAsPtrReg" (ppr n) $ char 'R' <> int n <> text ".p" pprAsPtrReg other_reg = pprReg other_reg pprGlobalReg :: GlobalReg -> SDoc pprGlobalReg gr = case gr of - VanillaReg n _ -> char 'R' <> int n <> text ".w" + VanillaReg n -> char 'R' <> int n <> text ".w" -- pprGlobalReg prints a VanillaReg as a .w regardless -- Example: R1.w = R1.w & (-0x8UL); -- JMP_(*R1.p); diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs index 17fa7394a7..d625ae341e 100644 --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -47,7 +47,7 @@ import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe ) import GHC.Driver.Session import GHC.Data.FastString import GHC.Cmm hiding ( succ ) -import GHC.Cmm.Utils (regsOverlap) +import GHC.Cmm.Utils (globalRegsOverlap) import GHC.Utils.Outputable as Outp import GHC.Platform import GHC.Types.Unique.FM @@ -194,8 +194,8 @@ padLiveArgs platform live = -- all use the same real regs on X86-64 (XMM registers). -- classes = NE.groupBy sharesClass fprLive - sharesClass a b = regsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers - norm x = CmmGlobal ((fpr_ctor x) 1) -- get the first register of the family + sharesClass a b = globalRegsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers + norm x = fpr_ctor x 1 -- get the first register of the family -- For each class, we just have to fill missing registers numbers. We use -- the constructor of the greatest register to build padding registers. diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs index dbe623f85e..60eb1624b2 100644 --- a/compiler/GHC/CmmToLlvm/CodeGen.hs +++ b/compiler/GHC/CmmToLlvm/CodeGen.hs @@ -1143,12 +1143,12 @@ genStore addr val alignment -- | CmmStore operation -- This is a special case for storing to a global register pointer -- offset such as I32[Sp+8]. -genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr -> AlignmentSpec +genStore_fast :: CmmExpr -> GlobalRegUse -> Int -> CmmExpr -> AlignmentSpec -> LlvmM StmtData genStore_fast addr r n val alignment = do platform <- getPlatform (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) - meta <- getTBAARegMeta r + meta <- getTBAARegMeta (globalRegUseGlobalReg r) let (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8) case isPointer grt && rem == 0 of True -> do @@ -1388,8 +1388,7 @@ exprToVarOpt opt e = case e of -> genMachOp opt op exprs CmmRegOff r i - -> do platform <- getPlatform - exprToVar $ expandCmmReg platform (r, i) + -> exprToVar $ expandCmmReg (r, i) CmmStackSlot _ _ -> panic "exprToVar: CmmStackSlot not supported!" @@ -1554,7 +1553,7 @@ genMachOp opt op e = genMachOp_slow opt op e -- | Handle CmmMachOp expressions -- This is a specialised method that handles Global register manipulations like -- 'Sp - 16', using the getelementptr instruction. -genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] +genMachOp_fast :: EOption -> MachOp -> GlobalRegUse -> Int -> [CmmExpr] -> LlvmM ExprData genMachOp_fast opt op r n e = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) @@ -1822,12 +1821,12 @@ genLoad atomic e ty align -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer -- offset such as I32[Sp+8]. -genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType +genLoad_fast :: Atomic -> CmmExpr -> GlobalRegUse -> Int -> CmmType -> AlignmentSpec -> LlvmM ExprData genLoad_fast atomic e r n ty align = do platform <- getPlatform (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) - meta <- getTBAARegMeta r + meta <- getTBAARegMeta (globalRegUseGlobalReg r) let ty' = cmmToLlvmType ty (ix,rem) = n `divMod` ((llvmWidthInBits platform . pLower) grt `div` 8) case isPointer grt && rem == 0 of @@ -1917,10 +1916,11 @@ getCmmReg (CmmLocal (LocalReg un _)) -- "funPrologue" to allocate it on the stack. getCmmReg (CmmGlobal g) - = do onStack <- checkStackReg g + = do let r = globalRegUseGlobalReg g + onStack <- checkStackReg r platform <- getPlatform if onStack - then return (lmGlobalRegVar platform g) + then return (lmGlobalRegVar platform r) else pprPanic "getCmmReg: Cmm register " $ ppr g <> text " not stack-allocated!" @@ -1930,10 +1930,10 @@ getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements) getCmmRegVal reg = case reg of CmmGlobal g -> do - onStack <- checkStackReg g + onStack <- checkStackReg (globalRegUseGlobalReg g) platform <- getPlatform if onStack then loadFromStack else do - let r = lmGlobalRegArg platform g + let r = lmGlobalRegArg platform (globalRegUseGlobalReg g) return (r, getVarType r, nilOL) _ -> loadFromStack where loadFromStack = do @@ -2064,7 +2064,7 @@ funPrologue live cmmBlocks = do let (newv, stmts) = allocReg reg varInsert un (pLower $ getVarType newv) return stmts - CmmGlobal r -> do + CmmGlobal (GlobalRegUse r _) -> do let reg = lmGlobalRegVar platform r arg = lmGlobalRegArg platform r ty = (pLower . getVarType) reg @@ -2107,8 +2107,8 @@ funEpilogue live = do let allRegs = activeStgRegs platform loads <- forM allRegs $ \r -> if -- load live registers - | r `elem` alwaysLive -> loadExpr r - | r `elem` live -> loadExpr r + | r `elem` alwaysLive -> loadExpr (GlobalRegUse r (globalRegSpillType platform r)) + | r `elem` live -> loadExpr (GlobalRegUse r (globalRegSpillType platform r)) -- load all non Floating-Point Registers | not (isFPR r) -> loadUndef r -- load padding Floating-Point Registers @@ -2152,9 +2152,9 @@ doExpr ty expr = do -- | Expand CmmRegOff -expandCmmReg :: Platform -> (CmmReg, Int) -> CmmExpr -expandCmmReg platform (reg, off) - = let width = typeWidth (cmmRegType platform reg) +expandCmmReg :: (CmmReg, Int) -> CmmExpr +expandCmmReg (reg, off) + = let width = typeWidth (cmmRegType reg) voff = CmmLit $ CmmInt (fromIntegral off) width in CmmMachOp (MO_Add width) [CmmReg reg, voff] diff --git a/compiler/GHC/CmmToLlvm/Regs.hs b/compiler/GHC/CmmToLlvm/Regs.hs index b18df77ed4..691f55eaaf 100644 --- a/compiler/GHC/CmmToLlvm/Regs.hs +++ b/compiler/GHC/CmmToLlvm/Regs.hs @@ -37,16 +37,16 @@ lmGlobalReg platform suf reg BaseReg -> ptrGlobal $ "Base" ++ suf Sp -> ptrGlobal $ "Sp" ++ suf Hp -> ptrGlobal $ "Hp" ++ suf - VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf - VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf - VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf - VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf - VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf - VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf - VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf - VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf - VanillaReg 9 _ -> wordGlobal $ "R9" ++ suf - VanillaReg 10 _ -> wordGlobal $ "R10" ++ suf + VanillaReg 1 -> wordGlobal $ "R1" ++ suf + VanillaReg 2 -> wordGlobal $ "R2" ++ suf + VanillaReg 3 -> wordGlobal $ "R3" ++ suf + VanillaReg 4 -> wordGlobal $ "R4" ++ suf + VanillaReg 5 -> wordGlobal $ "R5" ++ suf + VanillaReg 6 -> wordGlobal $ "R6" ++ suf + VanillaReg 7 -> wordGlobal $ "R7" ++ suf + VanillaReg 8 -> wordGlobal $ "R8" ++ suf + VanillaReg 9 -> wordGlobal $ "R9" ++ suf + VanillaReg 10 -> wordGlobal $ "R10" ++ suf SpLim -> wordGlobal $ "SpLim" ++ suf FloatReg 1 -> floatGlobal $ "F1" ++ suf FloatReg 2 -> floatGlobal $ "F2" ++ suf @@ -129,8 +129,8 @@ tbaa = fsLit "tbaa" -- | Get the correct TBAA metadata information for this register type getTBAA :: GlobalReg -> Unique -getTBAA BaseReg = baseN -getTBAA Sp = stackN -getTBAA Hp = heapN -getTBAA (VanillaReg _ _) = rxN -getTBAA _ = topN +getTBAA BaseReg = baseN +getTBAA Sp = stackN +getTBAA Hp = heapN +getTBAA (VanillaReg _) = rxN +getTBAA _ = topN diff --git a/compiler/GHC/StgToByteCode.hs b/compiler/GHC/StgToByteCode.hs index 02c5e5aa7b..c557bc554f 100644 --- a/compiler/GHC/StgToByteCode.hs +++ b/compiler/GHC/StgToByteCode.hs @@ -1079,9 +1079,6 @@ layoutNativeCall profile call_type start_off arg_ty reps = reg_order :: GlobalReg -> (Int, GlobalReg) reg_order reg | Just n <- Map.lookup reg regs_order = (n, reg) - -- a VanillaReg goes to the same place regardless of whether it - -- contains a pointer - reg_order (VanillaReg n VNonGcPtr) = reg_order (VanillaReg n VGcPtr) -- if we don't have a position for a FloatReg then they must be passed -- in the equivalent DoubleReg reg_order (FloatReg n) = reg_order (DoubleReg n) diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index 1ae0dcd6e0..428512b805 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -272,9 +272,10 @@ cgDataCon mn data_con -- return it. -- NB 2: We don't set CC when entering data (WDP 94/06) do { tickyEnterDynCon - ; ldvEnter (CmmReg nodeReg) + ; let node = CmmReg $ nodeReg platform + ; ldvEnter node ; tickyReturnOldCon (length arg_reps) - ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon platform data_con)] + ; void $ emitReturn [cmmOffsetB platform node (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 abe42d90d8..57cdb1d3f9 100644 --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -424,7 +424,7 @@ mkRhsClosure profile _use_ap _check_tags bndr cc fvs upd_flag args body -- BUILD THE OBJECT -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body - ; let use_cc = cccsExpr; blame_cc = cccsExpr + ; let use_cc = cccsExpr platform; blame_cc = cccsExpr platform ; emit (mkComment $ mkFastString "calling allocDynClosure") ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off) ; let info_tbl = mkCmmInfo closure_info bndr currentCCS @@ -465,7 +465,7 @@ cgRhsStdThunk bndr lf_info payload descr -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body - ; let use_cc = cccsExpr; blame_cc = cccsExpr + ; let use_cc = cccsExpr platform; blame_cc = cccsExpr platform -- BUILD THE OBJECT @@ -634,6 +634,7 @@ thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack -> LocalReg -> CgStgExpr -> FCode () thunkCode cl_info fv_details _cc node body = do { profile <- getProfile + ; platform <- getPlatform ; 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 @@ -652,7 +653,7 @@ thunkCode cl_info fv_details _cc node body -- that cc of enclosing scope will be recorded -- in update frame CAF/DICT functions will be -- subsumed by this enclosing cc - do { enterCostCentreThunk (CmmReg nodeReg) + do { enterCostCentreThunk (CmmReg $ nodeReg platform) ; let lf_info = closureLFInfo cl_info ; fv_bindings <- mapM bind_fv fv_details ; load_fvs node lf_info fv_bindings @@ -701,10 +702,11 @@ emitBlackHoleCode node = do when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node - emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) currentTSOExpr + emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) (currentTSOExpr platform) -- See Note [Heap memory barriers] in SMP.h. let w = wordWidth platform - emitPrimCall [] (MO_AtomicWrite w MemOrderRelease) [node, CmmReg (CmmGlobal EagerBlackholeInfo)] + emitPrimCall [] (MO_AtomicWrite w MemOrderRelease) + [node, CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)] setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), @@ -790,7 +792,7 @@ link_caf node = do ; let platform = profilePlatform profile ; bh <- newTemp (bWord platform) ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl - [ (baseExpr, AddrHint), + [ (baseExpr platform, AddrHint), (CmmReg (CmmLocal node), AddrHint) ] False diff --git a/compiler/GHC/StgToCmm/CgUtils.hs b/compiler/GHC/StgToCmm/CgUtils.hs index 4718cbf74a..adf640a7ca 100644 --- a/compiler/GHC/StgToCmm/CgUtils.hs +++ b/compiler/GHC/StgToCmm/CgUtils.hs @@ -33,17 +33,17 @@ import GHC.Utils.Panic 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 ++ ")") + 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 @@ -124,7 +124,7 @@ regTableOffset platform n = get_Regtable_addr_from_offset :: Platform -> Int -> CmmExpr get_Regtable_addr_from_offset platform offset = if haveRegBase platform - then cmmRegOff baseReg offset + then cmmRegOff (baseReg platform) offset else regTableOffset platform offset -- | Fixup global registers so that they assign to locations within the @@ -144,43 +144,48 @@ fixStgRegStmt platform stmt = fixAssign $ mapExpDeep fixExpr stmt where fixAssign stmt = case stmt of - CmmAssign (CmmGlobal reg) src + CmmAssign (CmmGlobal reg_use) src -- MachSp isn't an STG register; it's merely here for tracking unwind -- information | reg == MachSp -> stmt | otherwise -> let baseAddr = get_GlobalReg_addr platform reg in case reg `elem` activeStgRegs platform of - True -> CmmAssign (CmmGlobal reg) src + True -> CmmAssign (CmmGlobal reg_use) src False -> CmmStore baseAddr src NaturallyAligned + where reg = globalRegUseGlobalReg reg_use other_stmt -> other_stmt fixExpr expr = case expr of -- MachSp isn't an STG; it's merely here for tracking unwind information - CmmReg (CmmGlobal MachSp) -> expr - CmmReg (CmmGlobal reg) -> + CmmReg (CmmGlobal (GlobalRegUse MachSp _)) -> expr + CmmReg (CmmGlobal reg_use) -> -- Replace register leaves with appropriate StixTrees for -- the given target. MagicIds which map to a reg on this -- arch are left unchanged. For the rest, BaseReg is taken -- to mean the address of the reg table in MainCapability, -- and for all others we generate an indirection to its -- location in the register table. + let reg = globalRegUseGlobalReg reg_use in case reg `elem` activeStgRegs platform of True -> expr False -> let baseAddr = get_GlobalReg_addr platform reg in case reg of BaseReg -> baseAddr - _other -> CmmLoad baseAddr (globalRegType platform reg) NaturallyAligned + _other -> CmmLoad baseAddr + (globalRegSpillType platform reg) + NaturallyAligned - CmmRegOff (CmmGlobal reg) offset -> + CmmRegOff (CmmGlobal reg_use) offset -> -- RegOf leaves are just a shorthand form. If the reg maps -- to a real reg, we keep the shorthand, otherwise, we just -- expand it and defer to the above code. + let reg = globalRegUseGlobalReg reg_use in case reg `elem` activeStgRegs platform of True -> expr False -> CmmMachOp (MO_Add (wordWidth platform)) [ - fixExpr (CmmReg (CmmGlobal reg)), + fixExpr (CmmReg (CmmGlobal reg_use)), CmmLit (CmmInt (fromIntegral offset) (wordWidth platform))] diff --git a/compiler/GHC/StgToCmm/DataCon.hs b/compiler/GHC/StgToCmm/DataCon.hs index 89bdb88058..f9402efd37 100644 --- a/compiler/GHC/StgToCmm/DataCon.hs +++ b/compiler/GHC/StgToCmm/DataCon.hs @@ -215,11 +215,12 @@ buildDynCon' binder mn actually_bound ccs con args ; checkConArgsDyn (hang (text "TagCheck failed on constructor application.") 4 $ text "On binder:" <> ppr binder $$ text "Constructor:" <> ppr con) con (map fromNonVoid args) ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info - use_cc blame_cc args_w_offsets + (use_cc platform) (blame_cc platform) + args_w_offsets ; return (mkRhsInit platform reg lf_info hp_plus_n) } where - use_cc -- cost-centre to stick in the object - | isCurrentCCS ccs = cccsExpr + use_cc platform -- cost-centre to stick in the object + | isCurrentCCS ccs = cccsExpr platform | otherwise = panic "buildDynCon: non-current CCS not implemented" blame_cc = use_cc -- cost-centre on which to blame the alloc (same) diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index fcf91b4509..2450792426 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -222,12 +222,11 @@ cgLetNoEscapeClosure cgLetNoEscapeClosure bndr cc_slot _unused_cc args body = do platform <- getPlatform + let code = forkLneBody $ withNewTickyCounterLNE bndr args $ do + { restoreCurrentCostCentre platform cc_slot + ; arg_regs <- bindArgsToRegs args + ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) } return ( lneIdInfo platform bndr args, code ) - where - code = forkLneBody $ withNewTickyCounterLNE bndr args $ do - { restoreCurrentCostCentre cc_slot - ; arg_regs <- bindArgsToRegs args - ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) } ------------------------------------------------------------------------ @@ -519,7 +518,7 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _ ; mb_cc <- maybeSaveCostCentre True ; _ <- withSequel (AssignTo [idToReg platform (NonVoid v)] False) (cgExpr scrut) - ; restoreCurrentCostCentre mb_cc + ; restoreCurrentCostCentre platform mb_cc ; emitComment $ mkFastString "should be unreachable code" ; l <- newBlockId ; emitLabel l @@ -568,7 +567,7 @@ cgCase scrut bndr alt_type alts ; let sequel = AssignTo alt_regs do_gc{- Note [scrut sequel] -} ; ret_kind <- withSequel sequel (cgExpr scrut) - ; restoreCurrentCostCentre mb_cc + ; restoreCurrentCostCentre platform mb_cc ; _ <- bindArgsToRegs ret_bndrs ; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts } @@ -1179,7 +1178,7 @@ emitEnter fun = do Return -> do { let entry = entryCode platform $ closureInfoPtr platform align_check - $ CmmReg nodeReg + $ CmmReg (nodeReg platform) ; emit $ mkJump profile NativeNodeCall entry [cmmUntag platform fun] updfr_off ; return AssignedDirectly @@ -1222,12 +1221,13 @@ emitEnter fun = do -- 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 platform align_check (CmmReg nodeReg)) + ; let node = CmmReg $ nodeReg platform + entry = entryCode platform (closureInfoPtr platform align_check node) the_call = toCall entry (Just lret) updfr_off off outArgs regs ; tscope <- getTickScope ; emit $ copyout <*> - mkCbranch (cmmIsTagged platform (CmmReg nodeReg)) + mkCbranch (cmmIsTagged platform node) lret lcall Nothing <*> outOfLine lcall (the_call,tscope) <*> mkLabel lret tscope <*> diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs index 95b7d1c5fd..dd2e72444b 100644 --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -299,7 +299,7 @@ saveThreadState profile = do close_nursery <- closeNursery profile tso pure $ catAGraphs [ -- tso = CurrentTSO; - mkAssign (CmmLocal tso) currentTSOExpr + mkAssign (CmmLocal tso) (currentTSOExpr platform) , -- tso->stackobj->sp = Sp; mkStore (cmmOffset platform @@ -307,13 +307,14 @@ saveThreadState profile = do (CmmReg (CmmLocal tso)) (tso_stackobj profile))) (stack_SP profile)) - spExpr + (spExpr platform) , 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 + then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile)) + (cccsExpr platform) else mkNop ] @@ -372,14 +373,14 @@ emitPushArgRegs regs_live = do let mask = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform)) live = cmmAndWord platform regs_live mask cond = cmmNeWord platform live (zeroExpr platform) - reg_ty = cmmRegType platform (CmmGlobal reg) + reg_ty = globalRegSpillType platform reg width = roundUpToWords platform (widthInBytes $ typeWidth reg_ty) - adj_sp = mkAssign spReg - (cmmOffset platform spExpr (negate width)) - save_reg = mkStore spExpr (CmmReg $ CmmGlobal reg) + adj_sp = mkAssign (spReg platform) + (cmmOffset platform (spExpr platform) (negate width)) + save_reg = mkStore (spExpr platform) (CmmReg $ CmmGlobal $ GlobalRegUse reg reg_ty) in mkCmmIfThen cond $ catAGraphs [adj_sp, save_reg] - emit . catAGraphs =<< mapM save_arg (reverse regs) + emit . catAGraphs =<< mapM save_arg (reverse $ regs) -- | Pop a subset of STG registers from the stack (see 'emitPushArgRegs') emitPopArgRegs :: CmmExpr -> FCode () @@ -390,12 +391,13 @@ emitPopArgRegs regs_live = do let mask = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform)) live = cmmAndWord platform regs_live mask cond = cmmNeWord platform live (zeroExpr platform) - reg_ty = cmmRegType platform (CmmGlobal reg) + reg_ty = globalRegSpillType platform reg width = roundUpToWords platform (widthInBytes $ typeWidth reg_ty) - adj_sp = mkAssign spReg - (cmmOffset platform spExpr width) - restore_reg = mkAssign (CmmGlobal reg) (CmmLoad spExpr reg_ty NaturallyAligned) + adj_sp = mkAssign (spReg platform) + (cmmOffset platform (spExpr platform) width) + restore_reg = mkAssign (CmmGlobal $ GlobalRegUse reg reg_ty) + (CmmLoad (spExpr platform) reg_ty NaturallyAligned) in mkCmmIfThen cond $ catAGraphs [restore_reg, adj_sp] emit . catAGraphs =<< mapM save_arg regs @@ -406,7 +408,7 @@ emitCloseNursery = do let platform = profilePlatform profile tso <- newTemp (bWord platform) code <- closeNursery profile tso - emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code + emit $ mkAssign (CmmLocal tso) (currentTSOExpr platform) <*> code {- | @closeNursery dflags tso@ produces code to close the nursery. @@ -435,14 +437,14 @@ closeNursery profile tso = do platform = profilePlatform profile cnreg <- CmmLocal <$> newTemp (bWord platform) pure $ catAGraphs [ - mkAssign cnreg currentNurseryExpr, + mkAssign cnreg (currentNurseryExpr platform), -- CurrentNursery->free = Hp+1; - mkStore (nursery_bdescr_free platform cnreg) (cmmOffsetW platform hpExpr 1), + mkStore (nursery_bdescr_free platform cnreg) (cmmOffsetW platform (hpExpr platform) 1), let alloc = CmmMachOp (mo_wordSub platform) - [ cmmOffsetW platform hpExpr 1 + [ cmmOffsetW platform (hpExpr platform) 1 , cmmLoadBWord platform (nursery_bdescr_start platform cnreg) ] @@ -470,23 +472,23 @@ loadThreadState profile = do open_nursery <- openNursery profile tso pure $ catAGraphs [ -- tso = CurrentTSO; - mkAssign (CmmLocal tso) currentTSOExpr, + mkAssign (CmmLocal tso) (currentTSOExpr platform), -- stack = tso->stackobj; mkAssign (CmmLocal stack) (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj profile))), -- Sp = stack->sp; - mkAssign spReg (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile))), + mkAssign (spReg platform) (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile))), -- SpLim = stack->stack + RESERVED_STACK_WORDS; - mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK profile)) + mkAssign (spLimReg platform) (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), + mkAssign (hpAllocReg platform) (zeroExpr platform), open_nursery, -- and load the current cost centre stack from the TSO when profiling: if profileIsProfiling profile then let ccs_ptr = cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile) - in storeCurCCS (CmmLoad ccs_ptr (ccsType platform) NaturallyAligned) + in storeCurCCS platform (CmmLoad ccs_ptr (ccsType platform) NaturallyAligned) else mkNop ] @@ -497,7 +499,7 @@ emitOpenNursery = do let platform = profilePlatform profile tso <- newTemp (bWord platform) code <- openNursery profile tso - emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code + emit $ mkAssign (CmmLocal tso) (currentTSOExpr platform) <*> code {- | @openNursery profile tso@ produces code to open the nursery. A local register @@ -540,17 +542,17 @@ openNursery profile tso = do -- what code we generate, look at the assembly for -- stg_returnToStackTop in rts/StgStartup.cmm. pure $ catAGraphs [ - mkAssign cnreg currentNurseryExpr, + mkAssign cnreg (currentNurseryExpr platform), mkAssign bdfreereg (cmmLoadBWord platform (nursery_bdescr_free platform cnreg)), -- Hp = CurrentNursery->free - 1; - mkAssign hpReg (cmmOffsetW platform (CmmReg bdfreereg) (-1)), + mkAssign (hpReg platform) (cmmOffsetW platform (CmmReg bdfreereg) (-1)), mkAssign bdstartreg (cmmLoadBWord platform (nursery_bdescr_start platform cnreg)), -- HpLim = CurrentNursery->start + -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; - mkAssign hpLimReg + mkAssign (hpLimReg platform) (cmmOffsetExpr platform (CmmReg bdstartreg) (cmmOffset platform diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs index 55132860d6..1f9e0e68b1 100644 --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -353,11 +353,12 @@ entryHeapCheck' :: Bool -- is a known function pattern -> FCode () entryHeapCheck' is_fastf node arity args code = do profile <- getProfile - let is_thunk = arity == 0 + let platform = profilePlatform profile + is_thunk = arity == 0 args' = map (CmmReg . CmmLocal) args - stg_gc_fun = CmmReg (CmmGlobal GCFun) - stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1) + stg_gc_fun = CmmReg (CmmGlobal $ GlobalRegUse GCFun $ bWord platform) + stg_gc_enter1 = CmmReg (CmmGlobal $ GlobalRegUse GCEnter1 $ bWord platform) {- Thunks: jump stg_gc_enter_1 @@ -615,14 +616,14 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do -- See Note [Single stack check] sp_oflo sp_hwm = CmmMachOp (mo_wordULt platform) - [CmmMachOp (MO_Sub (typeWidth (cmmRegType platform spReg))) + [CmmMachOp (MO_Sub (typeWidth (cmmRegType $ spReg platform))) [CmmStackSlot Old 0, sp_hwm], - CmmReg spLimReg] + CmmReg $ spLimReg platform] -- Hp overflow if (Hp > HpLim) -- (Hp has been incremented by now) -- HpLim points to the LAST WORD of valid allocation space. - hp_oflo = CmmMachOp (mo_wordUGt platform) [hpExpr, hpLimExpr] + hp_oflo = CmmMachOp (mo_wordUGt platform) [hpExpr platform, hpLimExpr platform] case mb_stk_hwm of Nothing -> return () @@ -640,16 +641,16 @@ do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do case mb_alloc_lit of Just alloc_lit -> do - let bump_hp = cmmOffsetExprB platform hpExpr alloc_lit - alloc_n = mkAssign hpAllocReg alloc_lit + let bump_hp = cmmOffsetExprB platform (hpExpr platform) alloc_lit + alloc_n = mkAssign (hpAllocReg platform) alloc_lit tickyHeapCheck - emitAssign hpReg bump_hp + emitAssign (hpReg platform) bump_hp emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False) Nothing -> when (checkYield && not omit_yields) $ do -- Yielding if HpLim == 0 let yielding = CmmMachOp (mo_wordEq platform) - [CmmReg hpLimReg, + [CmmReg $ hpLimReg platform, CmmLit (zeroCLit platform)] emit =<< mkCmmIfGoto' yielding gc_id (Just False) diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs index d465e42800..a85a4aa495 100644 --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -155,9 +155,10 @@ adjustHpBackwards adjust_words = vHp -rHp ; new_hp <- getHpRelOffset vHp + ; platform <- getPlatform ; emit (if adjust_words == 0 then mkNop - else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp + else mkAssign (hpReg platform) new_hp) -- Generates nothing when vHp==rHp ; tickyAllocHeap False adjust_words -- ...ditto @@ -305,10 +306,11 @@ direct_call caller call_conv lbl arity args | otherwise -- Note [over-saturated calls] = do do_scc_prof <- stgToCmmSCCProfiling <$> getStgToCmmConfig + platform <- getPlatform emitCallWithExtraStack (call_conv, NativeReturn) target (nonVArgs fast_args) - (nonVArgs (slowArgs rest_args do_scc_prof)) + (nonVArgs (slowArgs platform rest_args do_scc_prof)) where target = CmmLit (CmmLabel lbl) (fast_args, rest_args) = splitAt real_arity args @@ -375,18 +377,18 @@ just more arguments that we are passing on the stack (cml_args). -- | 'slowArgs' takes a list of function arguments and prepares them for -- pushing on the stack for "extra" arguments to a function which requires -- fewer arguments than we currently have. -slowArgs :: [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)] -slowArgs [] _ = mempty -slowArgs args sccProfilingEnabled -- careful: reps contains voids (V), but args does not - | sccProfilingEnabled = save_cccs ++ this_pat ++ slowArgs rest_args sccProfilingEnabled - | otherwise = this_pat ++ slowArgs rest_args sccProfilingEnabled +slowArgs :: Platform -> [(ArgRep, Maybe CmmExpr)] -> DoSCCProfiling -> [(ArgRep, Maybe CmmExpr)] +slowArgs _ [] _ = mempty +slowArgs platform args sccProfilingEnabled -- careful: reps contains voids (V), but args does not + | sccProfilingEnabled = save_cccs ++ this_pat ++ slowArgs platform rest_args sccProfilingEnabled + | otherwise = this_pat ++ slowArgs platform rest_args sccProfilingEnabled where (arg_pat, n) = slowCallPattern (map fst args) (call_args, rest_args) = splitAt n args stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat this_pat = (N, Just (mkLblExpr stg_ap_pat)) : call_args - save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)] + save_cccs = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just $ cccsExpr platform)] save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs") ------------------------------------------------------------------------- @@ -404,7 +406,7 @@ getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr getHpRelOffset virtual_offset = do platform <- getPlatform hp_usg <- getHpUsage - return (cmmRegOffW platform hpReg (hpRel (realHp hp_usg) virtual_offset)) + return (cmmRegOffW platform (hpReg platform) (hpRel (realHp hp_usg) virtual_offset)) data FieldOffOrPadding a = FieldOff (NonVoid a) -- Something that needs an offset. diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index e17a937a9e..f7afeb71a9 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -255,7 +255,7 @@ emitPrimOp cfg primop = emitCCall [(res,NoHint)] (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) - [(baseExpr, AddrHint), (arg,AddrHint)] + [(baseExpr platform, AddrHint), (arg,AddrHint)] SparkOp -> \[arg] -> opIntoRegs $ \[res] -> do -- returns the value of arg in res. We're going to therefore @@ -266,7 +266,7 @@ emitPrimOp cfg primop = emitCCall [(tmp2,NoHint)] (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction))) - [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] + [(baseExpr platform, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp)) GetCCSOfOp -> \[arg] -> opIntoRegs $ \[res] -> do @@ -277,10 +277,10 @@ emitPrimOp cfg primop = emitAssign (CmmLocal res) val GetCurrentCCSOp -> \[_] -> opIntoRegs $ \[res] -> - emitAssign (CmmLocal res) cccsExpr + emitAssign (CmmLocal res) (cccsExpr platform) MyThreadIdOp -> \[] -> opIntoRegs $ \[res] -> - emitAssign (CmmLocal res) currentTSOExpr + emitAssign (CmmLocal res) (currentTSOExpr platform) ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] -> emitPrimCall [res] (MO_AtomicRead (wordWidth platform) MemOrderAcquire) @@ -302,7 +302,7 @@ emitPrimOp cfg primop = mkdirtyMutVarCCall <- getCode $! emitCCall [{-no results-}] (CmmLit (CmmLabel mkDirty_MUT_VAR_Label)) - [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)] + [(baseExpr platform, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)] emit =<< mkCmmIfThen (cmmEqWord platform (mkLblExpr mkMUT_VAR_CLEAN_infoLabel) (closureInfoPtr platform (stgToCmmAlignCheck cfg) mutv)) @@ -2437,7 +2437,7 @@ doNewByteArrayOp res_r n = do let hdr_size = fixedHdrSize profile - base <- allocHeapClosure rep info_ptr cccsExpr + base <- allocHeapClosure rep info_ptr (cccsExpr platform) [ (mkIntExpr platform n, hdr_size + pc_OFFSET_StgArrBytes_bytes (platformConstants platform)) ] @@ -2646,7 +2646,7 @@ doNewArrayOp res_r rep info payload n init = do (mkIntExpr platform (nonHdrSize platform rep)) (zeroExpr platform) - base <- allocHeapClosure rep info_ptr cccsExpr payload + base <- allocHeapClosure rep info_ptr (cccsExpr platform) payload arr <- CmmLocal `fmap` newTemp (bWord platform) emit $ mkAssign arr base @@ -2836,7 +2836,7 @@ emitCloneArray info_p res_r src src_off n = do let hdr_size = fixedHdrSize profile constants = platformConstants platform - base <- allocHeapClosure rep info_ptr cccsExpr + base <- allocHeapClosure rep info_ptr (cccsExpr platform) [ (mkIntExpr platform n, hdr_size + pc_OFFSET_StgMutArrPtrs_ptrs constants) , (mkIntExpr platform (nonHdrSizeW rep), @@ -2876,7 +2876,7 @@ emitCloneSmallArray info_p res_r src src_off n = do let hdr_size = fixedHdrSize profile - base <- allocHeapClosure rep info_ptr cccsExpr + base <- allocHeapClosure rep info_ptr (cccsExpr platform) [ (mkIntExpr platform n, hdr_size + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)) ] diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs index e07ee0a272..c7bfb40ccb 100644 --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -71,8 +71,8 @@ ccsType = bWord ccType :: Platform -> CmmType -- Type of a cost centre ccType = bWord -storeCurCCS :: CmmExpr -> CmmAGraph -storeCurCCS = mkAssign cccsReg +storeCurCCS :: Platform -> CmmExpr -> CmmAGraph +storeCurCCS platform = mkAssign (cccsReg platform) mkCCostCentre :: CostCentre -> CmmLit mkCCostCentre cc = CmmLabel (mkCCLabel cc) @@ -103,7 +103,7 @@ initUpdFrameProf :: CmmExpr -> FCode () initUpdFrameProf frame = ifProfiling $ -- frame->header.prof.ccs = CCCS do platform <- getPlatform - emitStore (cmmOffset platform frame (pc_OFFSET_StgHeader_ccs (platformConstants platform))) cccsExpr + emitStore (cmmOffset platform frame (pc_OFFSET_StgHeader_ccs (platformConstants platform))) (cccsExpr platform) -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) -- is unnecessary because it is not used anyhow. @@ -144,14 +144,14 @@ saveCurrentCostCentre if not sccProfilingEnabled then return Nothing else do local_cc <- newTemp (ccType platform) - emitAssign (CmmLocal local_cc) cccsExpr + emitAssign (CmmLocal local_cc) (cccsExpr platform) return (Just local_cc) -restoreCurrentCostCentre :: Maybe LocalReg -> FCode () -restoreCurrentCostCentre Nothing +restoreCurrentCostCentre :: Platform -> Maybe LocalReg -> FCode () +restoreCurrentCostCentre _ Nothing = return () -restoreCurrentCostCentre (Just local_cc) - = emit (storeCurCCS (CmmReg (CmmLocal local_cc))) +restoreCurrentCostCentre platform (Just local_cc) + = emit (storeCurCCS platform (CmmReg (CmmLocal local_cc))) ------------------------------------------------------------------------------- @@ -191,7 +191,7 @@ enterCostCentreThunk :: CmmExpr -> FCode () enterCostCentreThunk closure = ifProfiling $ do platform <- getPlatform - emit $ storeCurCCS (costCentreFrom platform closure) + emit $ storeCurCCS platform (costCentreFrom platform closure) enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () enterCostCentreFun ccs closure = ifProfiling $ @@ -200,7 +200,7 @@ enterCostCentreFun ccs closure = ifProfiling $ emitRtsCall rtsUnitId (fsLit "enterFunCCS") - [(baseExpr, AddrHint), (costCentreFrom platform closure, AddrHint)] + [(baseExpr platform, AddrHint), (costCentreFrom platform closure, AddrHint)] False -- otherwise we have a top-level function, nothing to do @@ -300,9 +300,9 @@ emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () emitSetCCC cc tick push = ifProfiling $ do platform <- getPlatform tmp <- newTemp (ccsType platform) - pushCostCentre tmp cccsExpr cc + pushCostCentre tmp (cccsExpr platform) cc when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp))) - when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp))) + when push $ emit (storeCurCCS platform (CmmReg (CmmLocal tmp))) pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode () pushCostCentre result ccs cc diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 704b09d1d4..7123ac5d60 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -240,15 +240,17 @@ callerSaveVolatileRegs platform = (caller_save, caller_load) callerSaveGlobalReg :: Platform -> GlobalReg -> CmmAGraph callerSaveGlobalReg platform reg - = mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal reg)) + = mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal (GlobalRegUse reg spill_ty))) + where + spill_ty = globalRegSpillType platform reg callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph callerRestoreGlobalReg platform reg - = mkAssign (CmmGlobal reg) + = mkAssign (CmmGlobal (GlobalRegUse reg spill_ty)) (CmmLoad (get_GlobalReg_addr platform reg) - (globalRegType platform reg) - NaturallyAligned) - + spill_ty NaturallyAligned) + where + spill_ty = globalRegSpillType platform reg ------------------------------------------------------------------------- -- @@ -578,21 +580,23 @@ whenUpdRemSetEnabled code = do -- remembered set. emitUpdRemSetPush :: CmmExpr -- ^ value of pointer which was overwritten -> FCode () -emitUpdRemSetPush ptr = +emitUpdRemSetPush ptr = do + platform <- getPlatform emitRtsCall rtsUnitId (fsLit "updateRemembSetPushClosure_") - [(CmmReg (CmmGlobal BaseReg), AddrHint), + [(CmmReg $ baseReg platform, AddrHint), (ptr, AddrHint)] False emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk -> FCode () -emitUpdRemSetPushThunk ptr = +emitUpdRemSetPushThunk ptr = do + platform <- getPlatform emitRtsCall rtsUnitId (fsLit "updateRemembSetPushThunk_") - [(CmmReg (CmmGlobal BaseReg), AddrHint), + [(CmmReg $ baseReg platform, AddrHint), (ptr, AddrHint)] False |