summaryrefslogtreecommitdiff
path: root/compiler/nativeGen/PPC
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/nativeGen/PPC')
-rw-r--r--compiler/nativeGen/PPC/Instr.hs39
-rw-r--r--compiler/nativeGen/PPC/Ppr.hs68
-rw-r--r--compiler/nativeGen/PPC/Regs.hs14
3 files changed, 95 insertions, 26 deletions
diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs
index 975527817d..b5c26ed906 100644
--- a/compiler/nativeGen/PPC/Instr.hs
+++ b/compiler/nativeGen/PPC/Instr.hs
@@ -74,19 +74,19 @@ 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_64 _ -> STU II64 sp (AddrRegImm sp (ImmInt (-amount)))
- arch -> panic $ "ppc_mkStackAllocInstr " ++ show arch
+ = ppc_mkStackAllocInstr' platform (-amount)
ppc_mkStackDeallocInstr :: Platform -> Int -> Instr
ppc_mkStackDeallocInstr platform amount
+ = ppc_mkStackAllocInstr' platform amount
+
+ppc_mkStackAllocInstr' :: Platform -> Int -> Instr
+ppc_mkStackAllocInstr' platform amount
= case platformArch platform of
- ArchPPC -> -- ADD II32 (OpImm (ImmInt amount)) (OpReg esp)
- ADD sp sp (RIImm (ImmInt amount))
- ArchPPC_64 _ -> ADD sp sp (RIImm (ImmInt amount))
- arch -> panic $ "ppc_mkStackDeallocInstr " ++ show arch
+ ArchPPC -> UPDATE_SP II32 (ImmInt amount)
+ ArchPPC_64 _ -> UPDATE_SP II64 (ImmInt amount)
+ _ -> panic $ "ppc_mkStackAllocInstr' "
+ ++ show (platformArch platform)
--
-- See note [extra spill slots] in X86/Instr.hs
@@ -186,8 +186,10 @@ data Instr
-- Loads and stores.
| LD Format Reg AddrMode -- Load format, dst, src
+ | LDFAR Format Reg AddrMode -- Load format, dst, src 32 bit offset
| LA Format Reg AddrMode -- Load arithmetic format, dst, src
| ST Format Reg AddrMode -- Store format, src, dst
+ | STFAR Format Reg AddrMode -- Store format, src, dst 32 bit offset
| STU Format Reg AddrMode -- Store with Update format, src, dst
| LIS Reg Imm -- Load Immediate Shifted dst, src
| LI Reg Imm -- Load Immediate dst, src
@@ -277,6 +279,8 @@ data Instr
| NOP -- no operation, PowerPC 64 bit
-- needs this as place holder to
-- reload TOC pointer
+ | UPDATE_SP Format 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.
@@ -288,8 +292,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])
@@ -349,6 +355,7 @@ ppc_regUsageOfInstr platform instr
MFLR reg -> usage ([], [reg])
FETCHPC reg -> usage ([], [reg])
FETCHTOC reg _ -> usage ([], [reg])
+ UPDATE_SP _ _ -> usage ([], [sp])
_ -> noUsage
where
usage (src, dst) = RU (filter (interesting platform) src)
@@ -373,8 +380,10 @@ ppc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
ppc_patchRegsOfInstr instr env
= case instr of
LD fmt reg addr -> LD fmt (env reg) (fixAddr addr)
+ LDFAR fmt reg addr -> LDFAR fmt (env reg) (fixAddr addr)
LA fmt reg addr -> LA fmt (env reg) (fixAddr addr)
ST fmt reg addr -> ST fmt (env reg) (fixAddr addr)
+ STFAR fmt reg addr -> STFAR fmt (env reg) (fixAddr addr)
STU fmt reg addr -> STU fmt (env reg) (fixAddr addr)
LIS reg imm -> LIS (env reg) imm
LI reg imm -> LI (env reg) imm
@@ -505,7 +514,11 @@ ppc_mkSpillInstr dflags reg delta slot
_ -> II64
RcDouble -> FF64
_ -> panic "PPC.Instr.mkSpillInstr: no match"
- in ST fmt 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 fmt reg (AddrRegImm sp (ImmInt (off-delta)))
ppc_mkLoadInstr
@@ -526,7 +539,11 @@ ppc_mkLoadInstr dflags reg delta slot
_ -> II64
RcDouble -> FF64
_ -> panic "PPC.Instr.mkLoadInstr: no match"
- in LD fmt 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 fmt reg (AddrRegImm sp (ImmInt (off-delta)))
-- | The maximum number of bytes required to spill a register. PPC32
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 6b9150a2d1..e5147794ce 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -246,10 +246,10 @@ pprFormat x
FF32 -> sLit "fs"
FF64 -> sLit "fd"
_ -> panic "PPC.Ppr.pprFormat: no match")
-
-
+
+
pprCond :: Cond -> SDoc
-pprCond c
+pprCond c
= ptext (case c of {
ALWAYS -> sLit "";
EQQ -> sLit "eq"; NE -> sLit "ne";
@@ -373,7 +373,7 @@ pprDataItem lit
ppr_item II64 (CmmInt x _) dflags
| not(archPPC_64 dflags) =
[ptext (sLit "\t.long\t")
- <> int (fromIntegral
+ <> int (fromIntegral
(fromIntegral (x `shiftR` 32) :: Word32)),
ptext (sLit "\t.long\t")
<> int (fromIntegral (fromIntegral x :: Word32))]
@@ -437,6 +437,15 @@ pprInstr (LD fmt 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 fmt reg addr) = hcat [
char '\t',
ptext (sLit "l"),
@@ -467,6 +476,14 @@ pprInstr (ST fmt 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 fmt reg addr) = hcat [
char '\t',
ptext (sLit "st"),
@@ -494,7 +511,7 @@ pprInstr (LI reg imm) = hcat [
ptext (sLit ", "),
pprImm imm
]
-pprInstr (MR reg1 reg2)
+pprInstr (MR reg1 reg2)
| reg1 == reg2 = empty
| otherwise = hcat [
char '\t',
@@ -693,6 +710,21 @@ pprInstr (EXTS fmt reg1 reg2) = hcat [
pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2
pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2
+pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 =
+ -- Handle the case where we are asked to shift a 32 bit register by
+ -- less than zero or more than 31 bits. We convert this into a clear
+ -- of the destination register.
+ -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/5900
+ pprInstr (XOR reg1 reg2 (RIReg reg2))
+
+pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 =
+ -- As aboce for SR, but for left shifts.
+ -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/10870
+ pprInstr (XOR reg1 reg2 (RIReg reg2))
+
+pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0 || i > 31 =
+ pprInstr (XOR reg1 reg2 (RIReg reg2))
+
pprInstr (SL fmt reg1 reg2 ri) =
let op = case fmt of
II32 -> "slw"
@@ -700,12 +732,6 @@ pprInstr (SL fmt reg1 reg2 ri) =
_ -> panic "PPC.Ppr.pprInstr: shift illegal size"
in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)
-pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 || i < 0 =
- -- Handle the case where we are asked to shift a 32 bit register by
- -- less than zero or more than 31 bits. We convert this into a clear
- -- of the destination register.
- -- Fixes ticket http://ghc.haskell.org/trac/ghc/ticket/5900
- pprInstr (XOR reg1 reg2 (RIReg reg2))
pprInstr (SR fmt reg1 reg2 ri) =
let op = case fmt of
II32 -> "srw"
@@ -732,7 +758,7 @@ pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [
ptext (sLit ", "),
int me
]
-
+
pprInstr (FADD fmt reg1 reg2 reg3) = pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3
pprInstr (FSUB fmt reg1 reg2 reg3) = pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3
pprInstr (FMUL fmt reg1 reg2 reg3) = pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3
@@ -799,6 +825,22 @@ pprInstr LWSYNC = ptext (sLit "\tlwsync")
pprInstr NOP = ptext (sLit "\tnop")
+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)"
@@ -841,7 +883,7 @@ pprBinaryF op fmt reg1 reg2 reg3 = hcat [
ptext (sLit ", "),
pprReg reg3
]
-
+
pprRI :: RI -> SDoc
pprRI (RIReg r) = pprReg r
pprRI (RIImm r) = pprImm r
diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs
index 05efaeb1f4..14bdab734b 100644
--- a/compiler/nativeGen/PPC/Regs.hs
+++ b/compiler/nativeGen/PPC/Regs.hs
@@ -37,7 +37,8 @@ module PPC.Regs (
fits16Bits,
makeImmediate,
fReg,
- sp, toc, r3, r4, r11, r12, r27, r28, r30,
+ r0, sp, toc, r3, r4, r11, r12, r27, r28, r30,
+ tmpReg,
f1, f20, f21,
allocatableRegs
@@ -304,7 +305,8 @@ point registers.
fReg :: Int -> RegNo
fReg x = (32 + x)
-sp, toc, r3, r4, r11, r12, r27, r28, r30, f1, f20, f21 :: Reg
+r0, sp, toc, r3, r4, r11, r12, r27, r28, r30, f1, f20, f21 :: Reg
+r0 = regSingle 0
sp = regSingle 1
toc = regSingle 2
r3 = regSingle 3
@@ -325,3 +327,11 @@ allocatableRegs :: Platform -> [RealReg]
allocatableRegs platform
= let isFree i = 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
+ ArchPPC_64 _ -> regSingle 30
+ _ -> panic "PPC.Regs.tmpReg: unknowm arch"
View Lorry Controller Status