nativeGen PPC: fix > 16 bit offsets in stack handling

Back port of Peter Trommler's patch from master (19dae027cb) to the
7.10 branch. Peter's commit does not apply to the 7.10 branch because
PowerPC64 was added to master after the 7.10 branch was started.

Comments from the original commit:
Implement access to spill slots at offsets larger than 16 bits.
Also allocation and deallocation of spill slots was restricted to
16 bit offsets. Now 32 bit offsets are supported on all PowerPC
platforms.

The implementation of 32 bit offsets requires more than one instruction
but the native code generator wants one instruction. So we implement
pseudo-instructions that are pretty printed into multiple assembly
instructions.

With pseudo-instructions for spill slot allocation and deallocation
we can also implement handling of the back chain pointer according
to the ELF ABIs.

compiler/nativeGen/PPC/Instr.hs

@@ -74,15 +74,13 @@ instance Instruction Instr where
 ppc_mkStackAllocInstr :: Platform -> Int -> Instr
 ppc_mkStackAllocInstr platform amount
   = case platformArch platform of
-      ArchPPC -> -- SUB II32 (OpImm (ImmInt amount)) (OpReg esp)
-                 ADD sp sp (RIImm (ImmInt (-amount)))
+      ArchPPC -> UPDATE_SP II32 (ImmInt (-amount))
       arch -> panic $ "ppc_mkStackAllocInstr " ++ show arch
 
 ppc_mkStackDeallocInstr :: Platform -> Int -> Instr
 ppc_mkStackDeallocInstr platform amount
   = case platformArch platform of
-      ArchPPC -> -- ADD II32 (OpImm (ImmInt amount)) (OpReg esp)
-                 ADD sp sp (RIImm (ImmInt amount))
+      ArchPPC -> UPDATE_SP II32 (ImmInt amount)
       arch -> panic $ "ppc_mkStackDeallocInstr " ++ show arch
 
 --
@@ -183,8 +181,10 @@ data Instr
 
     -- Loads and stores.
     | LD      Size Reg AddrMode     -- Load size, dst, src
+    | LDFAR   Size Reg AddrMode     -- Load format, dst, src 32 bit offset
     | LA      Size Reg AddrMode     -- Load arithmetic size, dst, src
     | ST      Size Reg AddrMode     -- Store size, src, dst
+    | STFAR   Size Reg AddrMode     -- Store format, src, dst 32 bit offset
     | STU     Size Reg AddrMode     -- Store with Update size, src, dst
     | LIS     Reg Imm               -- Load Immediate Shifted dst, src
     | LI      Reg Imm               -- Load Immediate dst, src
@@ -258,6 +258,9 @@ data Instr
 
     | LWSYNC                    -- memory barrier
 
+    | UPDATE_SP Size Imm        -- expand/shrink spill area on C stack
+                                -- pseudo-instruction
+
 
 -- | Get the registers that are being used by this instruction.
 -- regUsage doesn't need to do any trickery for jumps and such.
@@ -269,8 +272,10 @@ ppc_regUsageOfInstr :: Platform -> Instr -> RegUsage
 ppc_regUsageOfInstr platform instr
  = case instr of
     LD      _ reg addr       -> usage (regAddr addr, [reg])
+    LDFAR   _ reg addr       -> usage (regAddr addr, [reg])
     LA      _ reg addr       -> usage (regAddr addr, [reg])
     ST      _ reg addr       -> usage (reg : regAddr addr, [])
+    STFAR   _ reg addr       -> usage (reg : regAddr addr, [])
     STU     _ reg addr       -> usage (reg : regAddr addr, [])
     LIS     reg _            -> usage ([], [reg])
     LI      reg _            -> usage ([], [reg])
@@ -321,6 +326,7 @@ ppc_regUsageOfInstr platform instr
     MFCR    reg             -> usage ([], [reg])
     MFLR    reg             -> usage ([], [reg])
     FETCHPC reg             -> usage ([], [reg])
+    UPDATE_SP _ _           -> usage ([], [sp])
     _                       -> noUsage
   where
     usage (src, dst) = RU (filter (interesting platform) src)
@@ -347,8 +353,10 @@ ppc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
 ppc_patchRegsOfInstr instr env
  = case instr of
     LD      sz reg addr     -> LD sz (env reg) (fixAddr addr)
+    LDFAR   fmt reg addr    -> LDFAR fmt (env reg) (fixAddr addr)
     LA      sz reg addr     -> LA sz (env reg) (fixAddr addr)
     ST      sz reg addr     -> ST sz (env reg) (fixAddr addr)
+    STFAR   fmt reg addr    -> STFAR fmt (env reg) (fixAddr addr)
     STU     sz reg addr     -> STU sz (env reg) (fixAddr addr)
     LIS     reg imm         -> LIS (env reg) imm
     LI      reg imm         -> LI (env reg) imm
@@ -464,8 +472,10 @@ ppc_mkSpillInstr dflags reg delta slot
                 RcInteger -> II32
                 RcDouble  -> FF64
                 _      -> panic "PPC.Instr.mkSpillInstr: no match"
-    in ST sz reg (AddrRegImm sp (ImmInt (off-delta)))
-
+        instr = case makeImmediate W32 True (off-delta) of
+                   Just _  -> ST
+                   Nothing -> STFAR -- pseudo instruction: 32 bit offsets
+    in instr sz reg (AddrRegImm sp (ImmInt (off-delta)))
 
 ppc_mkLoadInstr
    :: DynFlags
@@ -482,7 +492,10 @@ ppc_mkLoadInstr dflags reg delta slot
                 RcInteger -> II32
                 RcDouble  -> FF64
                 _         -> panic "PPC.Instr.mkLoadInstr: no match"
-    in LD sz reg (AddrRegImm sp (ImmInt (off-delta)))
+        instr = case makeImmediate W32 True (off-delta) of
+                Just _  -> LD
+                Nothing -> LDFAR -- pseudo instruction: 32 bit offsets
+    in instr sz reg (AddrRegImm sp (ImmInt (off-delta)))
 
 
 -- | The maximum number of bytes required to spill a register. PPC32

compiler/nativeGen/PPC/Ppr.hs

@@ -376,6 +376,16 @@ pprInstr (LD sz reg addr) = hcat [
         ptext (sLit ", "),
         pprAddr addr
     ]
+
+pprInstr (LDFAR fmt reg (AddrRegImm source off)) =
+   sdocWithPlatform $ \platform -> vcat [
+         pprInstr (ADDIS (tmpReg platform) source (HA off)),
+         pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off)))
+    ]
+
+pprInstr (LDFAR _ _ _) =
+   panic "PPC.Ppr.pprInstr LDFAR: no match"
+
 pprInstr (LA sz reg addr) = hcat [
         char '\t',
         ptext (sLit "l"),
@@ -405,6 +415,13 @@ pprInstr (ST sz reg addr) = hcat [
         ptext (sLit ", "),
         pprAddr addr
     ]
+pprInstr (STFAR fmt reg (AddrRegImm source off)) =
+   sdocWithPlatform $ \platform -> vcat [
+         pprInstr (ADDIS (tmpReg platform) source (HA off)),
+         pprInstr (ST fmt reg (AddrRegImm (tmpReg platform) (LO off)))
+    ]
+pprInstr (STFAR _ _ _) =
+   panic "PPC.Ppr.pprInstr STFAR: no match"
 pprInstr (STU sz reg addr) = hcat [
         char '\t',
         ptext (sLit "st"),
@@ -681,6 +698,22 @@ pprInstr (FETCHPC reg) = vcat [
 
 pprInstr LWSYNC = ptext (sLit "\tlwsync")
 
+pprInstr (UPDATE_SP fmt amount@(ImmInt offset))
+   | fits16Bits offset = vcat [
+       pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))),
+       pprInstr (STU fmt r0 (AddrRegImm sp amount))
+     ]
+
+pprInstr (UPDATE_SP fmt amount)
+   = sdocWithPlatform $ \platform ->
+       let tmp = tmpReg platform in
+         vcat [
+           pprInstr (LD fmt r0 (AddrRegImm sp (ImmInt 0))),
+           pprInstr (ADDIS tmp sp (HA amount)),
+           pprInstr (ADD tmp tmp (RIImm (LO amount))),
+           pprInstr (STU fmt r0 (AddrRegReg sp tmp))
+         ]
+
 -- pprInstr _ = panic "pprInstr (ppc)"
 
 

compiler/nativeGen/PPC/Regs.hs

@@ -38,6 +38,8 @@ module PPC.Regs (
         makeImmediate,
         fReg,
         sp, r3, r4, r27, r28, r30,
+        r0, sp, r3, r4, r27, r28, r30,
+        tmpReg,
         f1, f20, f21,
 
         allocatableRegs
@@ -296,7 +298,8 @@ point registers.
 fReg :: Int -> RegNo
 fReg x = (32 + x)
 
-sp, r3, r4, r27, r28, r30, f1, f20, f21 :: Reg
+r0, sp, r3, r4, r27, r28, r30, f1, f20, f21 :: Reg
+r0      = regSingle 0
 sp      = regSingle 1
 r3      = regSingle 3
 r4      = regSingle 4
@@ -314,3 +317,10 @@ allocatableRegs :: Platform -> [RealReg]
 allocatableRegs platform
    = let isFree i = isFastTrue (freeReg platform i)
      in  map RealRegSingle $ filter isFree allMachRegNos
+
+-- temporary register for compiler use
+tmpReg :: Platform -> Reg
+tmpReg platform =
+       case platformArch platform of
+       ArchPPC      -> regSingle 13
+       _            -> panic "PPC.Regs.tmpReg: unknowm arch"

includes/CodeGen.Platform.hs

@@ -875,8 +875,11 @@ freeRegBase _ = fastBool True
 
 #elif MACHREGS_powerpc
 
-freeReg 0 = fastBool False -- Hack: r0 can't be used in all insns,
-                           -- but it's actually free
+freeReg 0 = fastBool False
+                  -- Used by code setting the back chain pointer
+                  -- in stack reallocations on Linux
+                  -- r0 is not usable in all insns so also reserved
+                  -- on Darwin.
 freeReg 1 = fastBool False -- The Stack Pointer
 # if !MACHREGS_darwin
 -- most non-darwin powerpc OSes use r2 as a TOC pointer or something like that