GitLab

Peter Trommler pushed to branch wip/T26519 at Glasgow Haskell Compiler / GHC

Commits:

023c301c

by sheaf at 2026-01-13T04:57:30-05:00

Don't re-use stack slots for growing registers

This commit avoids re-using a stack slot for a register that has grown
but already had a stack slot.

For example, suppose we have stack slot assigments

  %v1 :: FF64 |-> StackSlot 0
  %v2 :: FF64 |-> StackSlot 1

Later, we start using %v1 at a larger format (e.g. F64x2) and we need
to spill it again. Then we **must not** use StackSlot 0, as a spill
at format F64x2 would clobber the data in StackSlot 1.

This can cause some fragmentation of the `StackMap`, but that's probably
OK.

Fixes #26668

d0966e64
by fendor at 2026-01-13T04:58:11-05:00
```
Remove `traceId` from ghc-pkg executable
```

b324fd55

by Peter Trommler at 2026-01-13T13:28:52+01:00

PPC NCG: Fix shift right MO code

The shift amount in shift right [arithmetic] MOs is machine word
width. Therefore remove unnecessary zero- or sign-extending of
shift amount.

It looks harmless to extend the shift amount argument because the
shift right instruction uses only the seven lowest bits (i. e. mod 128).
But now we have a conversion operation from a smaller type to word width
around a memory load at word width. The types are not matching up but
there is no check done in CodeGen. The necessary conversion from word
width down to the smaller width would be translated into a no-op on
PowerPC anyway. So all seems harmless if it was not for a small
optimisation in getRegister'.

In getRegister' a load instruction with the smaller width of the
conversion operation was generated. This loaded the most significant
bits of the word in memory on a big-endian platform. These bits were
zero and hence shift right was used with shift amount zero and not one
as required in test Sized.

Fixes #26519

4 changed files:

compiler/GHC/CmmToAsm/PPC/CodeGen.hs
compiler/GHC/CmmToAsm/Reg/Linear.hs
compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs
utils/ghc-pkg/Main.hs

Changes:

compiler/GHC/CmmToAsm/PPC/CodeGen.hs

@@ -467,48 +467,26 @@ getRegister' _ platform (CmmLoad mem pk _)
          return (Any II64 code)
  -- catch simple cases of zero- or sign-extended load
 -getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _ _]) = do
 -    Amode addr addr_code <- getAmode D mem
 -    return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
+-
 -getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _ _]) = do
 -    Amode addr addr_code <- getAmode D mem
 -    return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))
+-
 -getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _ _]) = do
 -    Amode addr addr_code <- getAmode D mem
 -    return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))
+-
 -getRegister' _ _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _ _]) = do
 -    Amode addr addr_code <- getAmode D mem
 -    return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))
+-
 --- Note: there is no Load Byte Arithmetic instruction, so no signed case here
+-
 -getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _ _]) = do
 -    Amode addr addr_code <- getAmode D mem
 -    return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr))
+-
 -getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _ _]) = do
 -    Amode addr addr_code <- getAmode D mem
 -    return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr))
+-
 -getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _ _]) = do
 -    Amode addr addr_code <- getAmode D mem
 -    return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr))
+-
 -getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _ _]) = do
 -    Amode addr addr_code <- getAmode D mem
 -    return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr))
+-
 -getRegister' _ _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _ _]) = do
 -    Amode addr addr_code <- getAmode D mem
 -    return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr))
+-
 -getRegister' _ _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _ _]) = do
 -    -- lwa is DS-form. See Note [Power instruction format]
 -    Amode addr addr_code <- getAmode DS mem
 -    return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr))
 +getRegister' _ _ (CmmMachOp (MO_UU_Conv src tgt) [CmmLoad mem pk _])
 +  | src < tgt
 +  , cmmTypeFormat pk == intFormat src = loadZeroExpand mem pk tgt
++
 +getRegister' _ _ (CmmMachOp (MO_XX_Conv src tgt) [CmmLoad mem pk _])
 +  | src < tgt
 +  , cmmTypeFormat pk == intFormat src = loadZeroExpand mem pk tgt
++
 +  -- XXX: This is ugly, refactor
 +getRegister' _ _ (CmmMachOp (MO_SS_Conv src tgt) [CmmLoad mem pk _])
 +  -- Note: there is no Load Byte Arithmetic instruction
 +  | cmmTypeFormat pk /= II8
 +  , src < tgt = do
 +      let format = cmmTypeFormat pk
 +      -- lwa is DS-form. See Note [Power instruction format]
 +      let form = if format >= II32 then DS else D
 +      Amode addr addr_code <- getAmode form mem
 +      let code dst = assert (format == intFormat src)
 +                     $ addr_code `snocOL` LA format dst addr
 +      return (Any (intFormat tgt) code)
  getRegister' config platform (CmmMachOp (MO_RelaxedRead w) [e]) =
        getRegister' config platform (CmmLoad e (cmmBits w) NaturallyAligned)
@@ -789,6 +767,12 @@ extendSExpr from to x = CmmMachOp (MO_SS_Conv from to) [x]
  extendUExpr :: Width -> Width -> CmmExpr -> CmmExpr
  extendUExpr from to x = CmmMachOp (MO_UU_Conv from to) [x]
 +loadZeroExpand :: CmmExpr -> CmmType -> Width -> NatM Register
 +loadZeroExpand mem pk tgt = do
 +    Amode addr addr_code <- getAmode D mem
 +    let code dst = addr_code `snocOL` LD (cmmTypeFormat pk) dst addr
 +    return (Any (intFormat tgt) code)
++
  -- -----------------------------------------------------------------------------
  --  The 'Amode' type: Memory addressing modes passed up the tree.
@@ -2448,8 +2432,8 @@ srCode width sgn instr x y = do
    let op_len = max W32 width
        extend = if sgn then extendSExpr else extendUExpr
    (src1, code1) <- getSomeReg (extend width op_len x)
 -  (src2, code2) <- getSomeReg (extendUExpr width op_len y)
 -  -- Note: Shift amount `y` is unsigned
 +  (src2, code2) <- getSomeReg y
++
    let code dst = code1 `appOL` code2 `snocOL`
                   instr (intFormat op_len) dst src1 (RIReg src2)
    return (Any (intFormat width) code)

compiler/GHC/CmmToAsm/Reg/Linear.hs

@@ -406,7 +406,7 @@ linearRA block_live block_id = go [] []
  -- | Do allocation for a single instruction.
  raInsn
          :: OutputableRegConstraint freeRegs instr
 -        => BlockMap Regs                      -- ^ map of what vregs are love on entry to each block.
 +        => BlockMap Regs                         -- ^ map of what vregs are live on entry to each block.
          -> [instr]                              -- ^ accumulator for instructions already processed.
          -> BlockId                              -- ^ the id of the current block, for debugging
          -> LiveInstr instr                      -- ^ the instr to have its regs allocated, with liveness info.

compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs

@@ -37,7 +37,11 @@ data StackMap
            -- See Note [UniqFM and the register allocator]
            -- | Assignment of vregs to stack slots.
 -        , stackMapAssignment    :: UniqFM Unique StackSlot }
 +          --
 +          -- We record not just the slot, but also how many stack slots the vreg
 +          -- takes up, in order to avoid re-using a stack slot for a register
 +          -- that has grown but already had a stack slot (#26668).
 +        , stackMapAssignment    :: UniqFM Unique (StackSlot, Int) }
  -- | An empty stack map, with all slots available.
@@ -50,14 +54,19 @@ emptyStackMap = StackMap 0 emptyUFM
  --
  getStackSlotFor :: StackMap -> Format -> Unique -> (StackMap, Int)
 -getStackSlotFor fs@(StackMap _ reserved) _fmt regUnique
 -  | Just slot <- lookupUFM reserved regUnique  =  (fs, slot)
+-
 -getStackSlotFor (StackMap freeSlot reserved) fmt regUnique =
 -  let
 -    nbSlots = (formatInBytes fmt + 7) `div` 8
 -  in
 -    (StackMap (freeSlot+nbSlots) (addToUFM reserved regUnique freeSlot), freeSlot)
 +getStackSlotFor fs@(StackMap freeSlot reserved) fmt regUnique
 +  -- The register already has a stack slot; try to re-use it.
 +  | Just (slot, nbSlots) <- lookupUFM reserved regUnique
 +  -- Make sure the slot is big enough for this format, in case the register
 +  -- has grown (#26668).
 +  , nbNeededSlots <= nbSlots
 +  = (fs, slot)
 +  | otherwise
 +  = (StackMap (freeSlot+nbNeededSlots) (addToUFM reserved regUnique (freeSlot, nbNeededSlots)), freeSlot)
 +    -- NB: this can create fragmentation if a register keeps growing.
 +    -- That's probably OK, as this is only happens very rarely.
 +  where
 +    !nbNeededSlots = (formatInBytes fmt + 7) `div` 8
  -- | Return the number of stack slots that were allocated
  getStackUse :: StackMap -> Int

utils/ghc-pkg/Main.hs

@@ -23,7 +23,6 @@
  module Main (main) where
 -import Debug.Trace
  import qualified GHC.Unit.Database as GhcPkg
  import GHC.Unit.Database hiding (mkMungePathUrl)
  import GHC.HandleEncoding
@@ -1634,7 +1633,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do
  simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
  simplePackageList my_flags pkgs = do
     let showPkg :: InstalledPackageInfo -> String
 -       showPkg | FlagShowUnitIds `elem` my_flags = traceId . display . installedUnitId
 +       showPkg | FlagShowUnitIds `elem` my_flags = display . installedUnitId
                 | FlagNamesOnly `elem` my_flags   = display . mungedName . mungedId
                 | otherwise                       = display . mungedId
         strs = map showPkg pkgs