#include "HsVersions.h"
#include "nativeGen/NCG.h"
module PPC.Instr (
archWordFormat,
RI(..),
Instr(..),
maxSpillSlots,
allocMoreStack,
makeFarBranches
)
where
import PPC.Regs
import PPC.Cond
import Instruction
import Format
import TargetReg
import RegClass
import Reg
import CodeGen.Platform
import BlockId
import DynFlags
import Cmm
import CmmInfo
import FastString
import CLabel
import Outputable
import Platform
import UniqFM (listToUFM, lookupUFM)
import UniqSupply
import Control.Monad (replicateM)
import Data.Maybe (fromMaybe)
archWordFormat :: Bool -> Format
archWordFormat is32Bit
| is32Bit = II32
| otherwise = II64
instance Instruction Instr where
regUsageOfInstr = ppc_regUsageOfInstr
patchRegsOfInstr = ppc_patchRegsOfInstr
isJumpishInstr = ppc_isJumpishInstr
jumpDestsOfInstr = ppc_jumpDestsOfInstr
patchJumpInstr = ppc_patchJumpInstr
mkSpillInstr = ppc_mkSpillInstr
mkLoadInstr = ppc_mkLoadInstr
takeDeltaInstr = ppc_takeDeltaInstr
isMetaInstr = ppc_isMetaInstr
mkRegRegMoveInstr _ = ppc_mkRegRegMoveInstr
takeRegRegMoveInstr = ppc_takeRegRegMoveInstr
mkJumpInstr = ppc_mkJumpInstr
mkStackAllocInstr = ppc_mkStackAllocInstr
mkStackDeallocInstr = ppc_mkStackDeallocInstr
ppc_mkStackAllocInstr :: Platform -> Int -> Instr
ppc_mkStackAllocInstr platform amount
= 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 -> UPDATE_SP II32 (ImmInt amount)
ArchPPC_64 _ -> UPDATE_SP II64 (ImmInt amount)
_ -> panic $ "ppc_mkStackAllocInstr' "
++ show (platformArch platform)
allocMoreStack
:: Platform
-> Int
-> NatCmmDecl statics PPC.Instr.Instr
-> UniqSM (NatCmmDecl statics PPC.Instr.Instr)
allocMoreStack _ _ top@(CmmData _ _) = return top
allocMoreStack platform slots (CmmProc info lbl live (ListGraph code)) = do
let
infos = mapKeys info
entries = case code of
[] -> infos
BasicBlock entry _ : _
| entry `elem` infos -> infos
| otherwise -> entry : infos
uniqs <- replicateM (length entries) getUniqueM
let
delta = ((x + stackAlign 1) `quot` stackAlign) * stackAlign
where x = slots * spillSlotSize
alloc = mkStackAllocInstr platform delta
dealloc = mkStackDeallocInstr platform delta
new_blockmap :: BlockEnv BlockId
new_blockmap = mapFromList (zip entries (map mkBlockId uniqs))
insert_stack_insns (BasicBlock id insns)
| Just new_blockid <- mapLookup id new_blockmap
= [ BasicBlock id [alloc, BCC ALWAYS new_blockid]
, BasicBlock new_blockid block'
]
| otherwise
= [ BasicBlock id block' ]
where
block' = foldr insert_dealloc [] insns
insert_dealloc insn r
= case insn of
JMP _ -> dealloc : insn : r
BCTR [] Nothing -> dealloc : insn : r
BCTR ids label -> BCTR (map (fmap retarget) ids) label : r
BCCFAR cond b -> BCCFAR cond (retarget b) : r
BCC cond b -> BCC cond (retarget b) : r
_ -> insn : r
retarget :: BlockId -> BlockId
retarget b
= fromMaybe b (mapLookup b new_blockmap)
new_code
= concatMap insert_stack_insns code
return (CmmProc info lbl live (ListGraph new_code))
data RI
= RIReg Reg
| RIImm Imm
data Instr
= COMMENT FastString
| LDATA Section CmmStatics
| NEWBLOCK BlockId
| DELTA Int
| LD Format Reg AddrMode
| LDFAR Format Reg AddrMode
| LA Format Reg AddrMode
| ST Format Reg AddrMode
| STFAR Format Reg AddrMode
| STU Format Reg AddrMode
| LIS Reg Imm
| LI Reg Imm
| MR Reg Reg
| CMP Format Reg RI
| CMPL Format Reg RI
| BCC Cond BlockId
| BCCFAR Cond BlockId
| JMP CLabel
| MTCTR Reg
| BCTR [Maybe BlockId] (Maybe CLabel)
| BL CLabel [Reg]
| BCTRL [Reg]
| ADD Reg Reg RI
| ADDC Reg Reg Reg
| ADDE Reg Reg Reg
| ADDI Reg Reg Imm
| ADDIS Reg Reg Imm
| SUBF Reg Reg Reg
| SUBFC Reg Reg Reg
| SUBFE Reg Reg Reg
| MULLD Reg Reg RI
| MULLW Reg Reg RI
| DIVW Reg Reg Reg
| DIVD Reg Reg Reg
| DIVWU Reg Reg Reg
| DIVDU Reg Reg Reg
| MULLW_MayOflo Reg Reg Reg
| MULLD_MayOflo Reg Reg Reg
| AND Reg Reg RI
| OR Reg Reg RI
| ORIS Reg Reg Imm
| XOR Reg Reg RI
| XORIS Reg Reg Imm
| EXTS Format Reg Reg
| NEG Reg Reg
| NOT Reg Reg
| SL Format Reg Reg RI
| SR Format Reg Reg RI
| SRA Format Reg Reg RI
| RLWINM Reg Reg Int Int Int
| FADD Format Reg Reg Reg
| FSUB Format Reg Reg Reg
| FMUL Format Reg Reg Reg
| FDIV Format Reg Reg Reg
| FNEG Reg Reg
| FCMP Reg Reg
| FCTIWZ Reg Reg
| FCTIDZ Reg Reg
| FCFID Reg Reg
| FRSP Reg Reg
| CRNOR Int Int Int
| MFCR Reg
| MFLR Reg
| FETCHPC Reg
| FETCHTOC Reg CLabel
| LWSYNC
| NOP
| UPDATE_SP Format Imm
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])
MR reg1 reg2 -> usage ([reg2], [reg1])
CMP _ reg ri -> usage (reg : regRI ri,[])
CMPL _ reg ri -> usage (reg : regRI ri,[])
BCC _ _ -> noUsage
BCCFAR _ _ -> noUsage
MTCTR reg -> usage ([reg],[])
BCTR _ _ -> noUsage
BL _ params -> usage (params, callClobberedRegs platform)
BCTRL params -> usage (params, callClobberedRegs platform)
ADD reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
ADDC reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
ADDE reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
ADDI reg1 reg2 _ -> usage ([reg2], [reg1])
ADDIS reg1 reg2 _ -> usage ([reg2], [reg1])
SUBF reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
SUBFC reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
SUBFE reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
MULLD reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
MULLW reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
DIVW reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
DIVD reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
DIVWU reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
DIVDU reg1 reg2 reg3 -> usage ([reg2,reg3], [reg1])
MULLW_MayOflo reg1 reg2 reg3
-> usage ([reg2,reg3], [reg1])
MULLD_MayOflo reg1 reg2 reg3
-> usage ([reg2,reg3], [reg1])
AND reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
OR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
ORIS reg1 reg2 _ -> usage ([reg2], [reg1])
XOR reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
XORIS reg1 reg2 _ -> usage ([reg2], [reg1])
EXTS _ reg1 reg2 -> usage ([reg2], [reg1])
NEG reg1 reg2 -> usage ([reg2], [reg1])
NOT reg1 reg2 -> usage ([reg2], [reg1])
SL _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
SR _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
SRA _ reg1 reg2 ri -> usage (reg2 : regRI ri, [reg1])
RLWINM reg1 reg2 _ _ _ -> usage ([reg2], [reg1])
FADD _ r1 r2 r3 -> usage ([r2,r3], [r1])
FSUB _ r1 r2 r3 -> usage ([r2,r3], [r1])
FMUL _ r1 r2 r3 -> usage ([r2,r3], [r1])
FDIV _ r1 r2 r3 -> usage ([r2,r3], [r1])
FNEG r1 r2 -> usage ([r2], [r1])
FCMP r1 r2 -> usage ([r1,r2], [])
FCTIWZ r1 r2 -> usage ([r2], [r1])
FCTIDZ r1 r2 -> usage ([r2], [r1])
FCFID r1 r2 -> usage ([r2], [r1])
FRSP r1 r2 -> usage ([r2], [r1])
MFCR reg -> usage ([], [reg])
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)
(filter (interesting platform) dst)
regAddr (AddrRegReg r1 r2) = [r1, r2]
regAddr (AddrRegImm r1 _) = [r1]
regRI (RIReg r) = [r]
regRI _ = []
interesting :: Platform -> Reg -> Bool
interesting _ (RegVirtual _) = True
interesting platform (RegReal (RealRegSingle i)) = freeReg platform i
interesting _ (RegReal (RealRegPair{}))
= panic "PPC.Instr.interesting: no reg pairs on this arch"
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
MR reg1 reg2 -> MR (env reg1) (env reg2)
CMP fmt reg ri -> CMP fmt (env reg) (fixRI ri)
CMPL fmt reg ri -> CMPL fmt (env reg) (fixRI ri)
BCC cond lbl -> BCC cond lbl
BCCFAR cond lbl -> BCCFAR cond lbl
MTCTR reg -> MTCTR (env reg)
BCTR targets lbl -> BCTR targets lbl
BL imm argRegs -> BL imm argRegs
BCTRL argRegs -> BCTRL argRegs
ADD reg1 reg2 ri -> ADD (env reg1) (env reg2) (fixRI ri)
ADDC reg1 reg2 reg3 -> ADDC (env reg1) (env reg2) (env reg3)
ADDE reg1 reg2 reg3 -> ADDE (env reg1) (env reg2) (env reg3)
ADDI reg1 reg2 imm -> ADDI (env reg1) (env reg2) imm
ADDIS reg1 reg2 imm -> ADDIS (env reg1) (env reg2) imm
SUBF reg1 reg2 reg3 -> SUBF (env reg1) (env reg2) (env reg3)
SUBFC reg1 reg2 reg3 -> SUBFC (env reg1) (env reg2) (env reg3)
SUBFE reg1 reg2 reg3 -> SUBFE (env reg1) (env reg2) (env reg3)
MULLD reg1 reg2 ri -> MULLD (env reg1) (env reg2) (fixRI ri)
MULLW reg1 reg2 ri -> MULLW (env reg1) (env reg2) (fixRI ri)
DIVW reg1 reg2 reg3 -> DIVW (env reg1) (env reg2) (env reg3)
DIVD reg1 reg2 reg3 -> DIVD (env reg1) (env reg2) (env reg3)
DIVWU reg1 reg2 reg3 -> DIVWU (env reg1) (env reg2) (env reg3)
DIVDU reg1 reg2 reg3 -> DIVDU (env reg1) (env reg2) (env reg3)
MULLW_MayOflo reg1 reg2 reg3
-> MULLW_MayOflo (env reg1) (env reg2) (env reg3)
MULLD_MayOflo reg1 reg2 reg3
-> MULLD_MayOflo (env reg1) (env reg2) (env reg3)
AND reg1 reg2 ri -> AND (env reg1) (env reg2) (fixRI ri)
OR reg1 reg2 ri -> OR (env reg1) (env reg2) (fixRI ri)
ORIS reg1 reg2 imm -> ORIS (env reg1) (env reg2) imm
XOR reg1 reg2 ri -> XOR (env reg1) (env reg2) (fixRI ri)
XORIS reg1 reg2 imm -> XORIS (env reg1) (env reg2) imm
EXTS fmt reg1 reg2 -> EXTS fmt (env reg1) (env reg2)
NEG reg1 reg2 -> NEG (env reg1) (env reg2)
NOT reg1 reg2 -> NOT (env reg1) (env reg2)
SL fmt reg1 reg2 ri
-> SL fmt (env reg1) (env reg2) (fixRI ri)
SR fmt reg1 reg2 ri
-> SR fmt (env reg1) (env reg2) (fixRI ri)
SRA fmt reg1 reg2 ri
-> SRA fmt (env reg1) (env reg2) (fixRI ri)
RLWINM reg1 reg2 sh mb me
-> RLWINM (env reg1) (env reg2) sh mb me
FADD fmt r1 r2 r3 -> FADD fmt (env r1) (env r2) (env r3)
FSUB fmt r1 r2 r3 -> FSUB fmt (env r1) (env r2) (env r3)
FMUL fmt r1 r2 r3 -> FMUL fmt (env r1) (env r2) (env r3)
FDIV fmt r1 r2 r3 -> FDIV fmt (env r1) (env r2) (env r3)
FNEG r1 r2 -> FNEG (env r1) (env r2)
FCMP r1 r2 -> FCMP (env r1) (env r2)
FCTIWZ r1 r2 -> FCTIWZ (env r1) (env r2)
FCTIDZ r1 r2 -> FCTIDZ (env r1) (env r2)
FCFID r1 r2 -> FCFID (env r1) (env r2)
FRSP r1 r2 -> FRSP (env r1) (env r2)
MFCR reg -> MFCR (env reg)
MFLR reg -> MFLR (env reg)
FETCHPC reg -> FETCHPC (env reg)
FETCHTOC reg lab -> FETCHTOC (env reg) lab
_ -> instr
where
fixAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)
fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i
fixRI (RIReg r) = RIReg (env r)
fixRI other = other
ppc_isJumpishInstr :: Instr -> Bool
ppc_isJumpishInstr instr
= case instr of
BCC{} -> True
BCCFAR{} -> True
BCTR{} -> True
BCTRL{} -> True
BL{} -> True
JMP{} -> True
_ -> False
ppc_jumpDestsOfInstr :: Instr -> [BlockId]
ppc_jumpDestsOfInstr insn
= case insn of
BCC _ id -> [id]
BCCFAR _ id -> [id]
BCTR targets _ -> [id | Just id <- targets]
_ -> []
ppc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
ppc_patchJumpInstr insn patchF
= case insn of
BCC cc id -> BCC cc (patchF id)
BCCFAR cc id -> BCCFAR cc (patchF id)
BCTR ids lbl -> BCTR (map (fmap patchF) ids) lbl
_ -> insn
ppc_mkSpillInstr
:: DynFlags
-> Reg
-> Int
-> Int
-> Instr
ppc_mkSpillInstr dflags reg delta slot
= let platform = targetPlatform dflags
off = spillSlotToOffset slot
arch = platformArch platform
in
let fmt = case targetClassOfReg platform reg of
RcInteger -> case arch of
ArchPPC -> II32
_ -> II64
RcDouble -> FF64
_ -> panic "PPC.Instr.mkSpillInstr: no match"
instr = case makeImmediate W32 True (offdelta) of
Just _ -> ST
Nothing -> STFAR
in instr fmt reg (AddrRegImm sp (ImmInt (offdelta)))
ppc_mkLoadInstr
:: DynFlags
-> Reg
-> Int
-> Int
-> Instr
ppc_mkLoadInstr dflags reg delta slot
= let platform = targetPlatform dflags
off = spillSlotToOffset slot
arch = platformArch platform
in
let fmt = case targetClassOfReg platform reg of
RcInteger -> case arch of
ArchPPC -> II32
_ -> II64
RcDouble -> FF64
_ -> panic "PPC.Instr.mkLoadInstr: no match"
instr = case makeImmediate W32 True (offdelta) of
Just _ -> LD
Nothing -> LDFAR
in instr fmt reg (AddrRegImm sp (ImmInt (offdelta)))
spillSlotSize :: Int
spillSlotSize = 8
maxSpillSlots :: DynFlags -> Int
maxSpillSlots dflags
= ((rESERVED_C_STACK_BYTES dflags 64) `div` spillSlotSize) 1
stackAlign :: Int
stackAlign = 16
spillSlotToOffset :: Int -> Int
spillSlotToOffset slot
= 64 + spillSlotSize * slot
ppc_takeDeltaInstr
:: Instr
-> Maybe Int
ppc_takeDeltaInstr instr
= case instr of
DELTA i -> Just i
_ -> Nothing
ppc_isMetaInstr
:: Instr
-> Bool
ppc_isMetaInstr instr
= case instr of
COMMENT{} -> True
LDATA{} -> True
NEWBLOCK{} -> True
DELTA{} -> True
_ -> False
ppc_mkRegRegMoveInstr
:: Reg
-> Reg
-> Instr
ppc_mkRegRegMoveInstr src dst
= MR dst src
ppc_mkJumpInstr
:: BlockId
-> [Instr]
ppc_mkJumpInstr id
= [BCC ALWAYS id]
ppc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)
ppc_takeRegRegMoveInstr (MR dst src) = Just (src,dst)
ppc_takeRegRegMoveInstr _ = Nothing
makeFarBranches
:: BlockEnv CmmStatics
-> [NatBasicBlock Instr]
-> [NatBasicBlock Instr]
makeFarBranches info_env blocks
| last blockAddresses < nearLimit = blocks
| otherwise = zipWith handleBlock blockAddresses blocks
where
blockAddresses = scanl (+) 0 $ map blockLen blocks
blockLen (BasicBlock _ instrs) = length instrs
handleBlock addr (BasicBlock id instrs)
= BasicBlock id (zipWith makeFar [addr..] instrs)
makeFar _ (BCC ALWAYS tgt) = BCC ALWAYS tgt
makeFar addr (BCC cond tgt)
| abs (addr targetAddr) >= nearLimit
= BCCFAR cond tgt
| otherwise
= BCC cond tgt
where Just targetAddr = lookupUFM blockAddressMap tgt
makeFar _ other = other
nearLimit = 7000 mapSize info_env * maxRetInfoTableSizeW
blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses