module PPC.CodeGen (
cmmTopCodeGen,
generateJumpTableForInstr,
InstrBlock
)
where
#include "HsVersions.h"
#include "nativeGen/NCG.h"
#include "../includes/MachDeps.h"
import CodeGen.Platform
import PPC.Instr
import PPC.Cond
import PPC.Regs
import CPrim
import NCGMonad
import Instruction
import PIC
import Format
import RegClass
import Reg
import TargetReg
import Platform
import BlockId
import PprCmm ( pprExpr )
import Cmm
import CmmUtils
import CmmSwitch
import CLabel
import Hoopl
import OrdList
import Outputable
import Unique
import DynFlags
import Control.Monad ( mapAndUnzipM, when )
import Data.Bits
import Data.Word
import BasicTypes
import FastString
import Util
cmmTopCodeGen
:: RawCmmDecl
-> NatM [NatCmmDecl CmmStatics Instr]
cmmTopCodeGen (CmmProc info lab live graph) = do
let blocks = toBlockListEntryFirst graph
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
dflags <- getDynFlags
let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
tops = proc : concat statics
os = platformOS $ targetPlatform dflags
arch = platformArch $ targetPlatform dflags
case arch of
ArchPPC | os == OSAIX -> return tops
| otherwise -> do
picBaseMb <- getPicBaseMaybeNat
case picBaseMb of
Just picBase -> initializePicBase_ppc arch os picBase tops
Nothing -> return tops
ArchPPC_64 ELF_V1 -> return tops
ArchPPC_64 ELF_V2 -> return tops
_ -> panic "PPC.cmmTopCodeGen: unknown arch"
cmmTopCodeGen (CmmData sec dat) = do
return [CmmData sec dat]
basicBlockCodeGen
:: Block CmmNode C C
-> NatM ( [NatBasicBlock Instr]
, [NatCmmDecl CmmStatics Instr])
basicBlockCodeGen block = do
let (_, nodes, tail) = blockSplit block
id = entryLabel block
stmts = blockToList nodes
mid_instrs <- stmtsToInstrs stmts
tail_instrs <- stmtToInstrs tail
let instrs = mid_instrs `appOL` tail_instrs
let
(top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
mkBlocks (NEWBLOCK id) (instrs,blocks,statics)
= ([], BasicBlock id instrs : blocks, statics)
mkBlocks (LDATA sec dat) (instrs,blocks,statics)
= (instrs, blocks, CmmData sec dat:statics)
mkBlocks instr (instrs,blocks,statics)
= (instr:instrs, blocks, statics)
return (BasicBlock id top : other_blocks, statics)
stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
stmtsToInstrs stmts
= do instrss <- mapM stmtToInstrs stmts
return (concatOL instrss)
stmtToInstrs :: CmmNode e x -> NatM InstrBlock
stmtToInstrs stmt = do
dflags <- getDynFlags
case stmt of
CmmComment s -> return (unitOL (COMMENT s))
CmmTick {} -> return nilOL
CmmUnwind {} -> return nilOL
CmmAssign reg src
| isFloatType ty -> assignReg_FltCode format reg src
| target32Bit (targetPlatform dflags) &&
isWord64 ty -> assignReg_I64Code reg src
| otherwise -> assignReg_IntCode format reg src
where ty = cmmRegType dflags reg
format = cmmTypeFormat ty
CmmStore addr src
| isFloatType ty -> assignMem_FltCode format addr src
| target32Bit (targetPlatform dflags) &&
isWord64 ty -> assignMem_I64Code addr src
| otherwise -> assignMem_IntCode format addr src
where ty = cmmExprType dflags src
format = cmmTypeFormat ty
CmmUnsafeForeignCall target result_regs args
-> genCCall target result_regs args
CmmBranch id -> genBranch id
CmmCondBranch arg true false _ -> do
b1 <- genCondJump true arg
b2 <- genBranch false
return (b1 `appOL` b2)
CmmSwitch arg ids -> do dflags <- getDynFlags
genSwitch dflags arg ids
CmmCall { cml_target = arg } -> genJump arg
_ ->
panic "stmtToInstrs: statement should have been cps'd away"
type InstrBlock
= OrdList Instr
data Register
= Fixed Format Reg InstrBlock
| Any Format (Reg -> InstrBlock)
swizzleRegisterRep :: Register -> Format -> Register
swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code
swizzleRegisterRep (Any _ codefn) format = Any format codefn
getRegisterReg :: Platform -> CmmReg -> Reg
getRegisterReg _ (CmmLocal (LocalReg u pk))
= RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)
getRegisterReg platform (CmmGlobal mid)
= case globalRegMaybe platform mid of
Just reg -> RegReal reg
Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)
jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))
jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
where blockLabel = mkAsmTempLabel (getUnique blockid)
mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr
mangleIndexTree dflags (CmmRegOff reg off)
= CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
where width = typeWidth (cmmRegType dflags reg)
mangleIndexTree _ _
= panic "PPC.CodeGen.mangleIndexTree: no match"
data ChildCode64
= ChildCode64
InstrBlock
Reg
getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg expr = do
r <- getRegister expr
case r of
Any rep code -> do
tmp <- getNewRegNat rep
return (tmp, code tmp)
Fixed _ reg code ->
return (reg, code)
getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)
getI64Amodes addrTree = do
Amode hi_addr addr_code <- getAmode D addrTree
case addrOffset hi_addr 4 of
Just lo_addr -> return (hi_addr, lo_addr, addr_code)
Nothing -> do (hi_ptr, code) <- getSomeReg addrTree
return (AddrRegImm hi_ptr (ImmInt 0),
AddrRegImm hi_ptr (ImmInt 4),
code)
assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_I64Code addrTree valueTree = do
(hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
ChildCode64 vcode rlo <- iselExpr64 valueTree
let
rhi = getHiVRegFromLo rlo
mov_hi = ST II32 rhi hi_addr
mov_lo = ST II32 rlo lo_addr
return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do
ChildCode64 vcode r_src_lo <- iselExpr64 valueTree
let
r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32
r_dst_hi = getHiVRegFromLo r_dst_lo
r_src_hi = getHiVRegFromLo r_src_lo
mov_lo = MR r_dst_lo r_src_lo
mov_hi = MR r_dst_hi r_src_hi
return (
vcode `snocOL` mov_lo `snocOL` mov_hi
)
assignReg_I64Code _ _
= panic "assignReg_I64Code(powerpc): invalid lvalue"
iselExpr64 :: CmmExpr -> NatM ChildCode64
iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do
(hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree
(rlo, rhi) <- getNewRegPairNat II32
let mov_hi = LD II32 rhi hi_addr
mov_lo = LD II32 rlo lo_addr
return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
rlo
iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty
= return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))
iselExpr64 (CmmLit (CmmInt i _)) = do
(rlo,rhi) <- getNewRegPairNat II32
let
half0 = fromIntegral (fromIntegral i :: Word16)
half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)
half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16)
half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16)
code = toOL [
LIS rlo (ImmInt half1),
OR rlo rlo (RIImm $ ImmInt half0),
LIS rhi (ImmInt half3),
OR rhi rhi (RIImm $ ImmInt half2)
]
return (ChildCode64 code rlo)
iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do
ChildCode64 code1 r1lo <- iselExpr64 e1
ChildCode64 code2 r2lo <- iselExpr64 e2
(rlo,rhi) <- getNewRegPairNat II32
let
r1hi = getHiVRegFromLo r1lo
r2hi = getHiVRegFromLo r2lo
code = code1 `appOL`
code2 `appOL`
toOL [ ADDC rlo r1lo r2lo,
ADDE rhi r1hi r2hi ]
return (ChildCode64 code rlo)
iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do
ChildCode64 code1 r1lo <- iselExpr64 e1
ChildCode64 code2 r2lo <- iselExpr64 e2
(rlo,rhi) <- getNewRegPairNat II32
let
r1hi = getHiVRegFromLo r1lo
r2hi = getHiVRegFromLo r2lo
code = code1 `appOL`
code2 `appOL`
toOL [ SUBFC rlo r2lo r1lo,
SUBFE rhi r2hi r1hi ]
return (ChildCode64 code rlo)
iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do
(expr_reg,expr_code) <- getSomeReg expr
(rlo, rhi) <- getNewRegPairNat II32
let mov_hi = LI rhi (ImmInt 0)
mov_lo = MR rlo expr_reg
return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
rlo
iselExpr64 expr
= pprPanic "iselExpr64(powerpc)" (pprExpr expr)
getRegister :: CmmExpr -> NatM Register
getRegister e = do dflags <- getDynFlags
getRegister' dflags e
getRegister' :: DynFlags -> CmmExpr -> NatM Register
getRegister' dflags (CmmReg (CmmGlobal PicBaseReg))
| OSAIX <- platformOS (targetPlatform dflags) = do
let code dst = toOL [ LD II32 dst tocAddr ]
tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]"))
return (Any II32 code)
| target32Bit (targetPlatform dflags) = do
reg <- getPicBaseNat $ archWordFormat (target32Bit (targetPlatform dflags))
return (Fixed (archWordFormat (target32Bit (targetPlatform dflags)))
reg nilOL)
| otherwise = return (Fixed II64 toc nilOL)
getRegister' dflags (CmmReg reg)
= return (Fixed (cmmTypeFormat (cmmRegType dflags reg))
(getRegisterReg (targetPlatform dflags) reg) nilOL)
getRegister' dflags tree@(CmmRegOff _ _)
= getRegister' dflags (mangleIndexTree dflags tree)
getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32)
[CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
| target32Bit (targetPlatform dflags) = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 (getHiVRegFromLo rlo) code
getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32)
[CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
| target32Bit (targetPlatform dflags) = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 (getHiVRegFromLo rlo) code
getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) [x])
| target32Bit (targetPlatform dflags) = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 rlo code
getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x])
| target32Bit (targetPlatform dflags) = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 rlo code
getRegister' dflags (CmmLoad mem pk)
| not (isWord64 pk) = do
let platform = targetPlatform dflags
Amode addr addr_code <- getAmode D mem
let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk)
addr_code `snocOL` LD format dst addr
return (Any format code)
| not (target32Bit (targetPlatform dflags)) = do
Amode addr addr_code <- getAmode DS mem
let code dst = addr_code `snocOL` LD II64 dst addr
return (Any II64 code)
where format = cmmTypeFormat pk
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_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_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
Amode addr addr_code <- getAmode D mem
return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr))
getRegister' dflags (CmmMachOp mop [x])
= case mop of
MO_Not rep -> triv_ucode_int rep NOT
MO_F_Neg w -> triv_ucode_float w FNEG
MO_S_Neg w -> triv_ucode_int w NEG
MO_FF_Conv W64 W32 -> trivialUCode FF32 FRSP x
MO_FF_Conv W32 W64 -> conversionNop FF64 x
MO_FS_Conv from to -> coerceFP2Int from to x
MO_SF_Conv from to -> coerceInt2FP from to x
MO_SS_Conv from to
| from == to -> conversionNop (intFormat to) x
MO_SS_Conv W64 to
| arch32 -> panic "PPC.CodeGen.getRegister no 64 bit int register"
| otherwise -> conversionNop (intFormat to) x
MO_SS_Conv W32 to
| arch32 -> conversionNop (intFormat to) x
| otherwise -> case to of
W64 -> triv_ucode_int to (EXTS II32)
W16 -> conversionNop II16 x
W8 -> conversionNop II8 x
_ -> panic "PPC.CodeGen.getRegister: no match"
MO_SS_Conv W16 W8 -> conversionNop II8 x
MO_SS_Conv W8 to -> triv_ucode_int to (EXTS II8)
MO_SS_Conv W16 to -> triv_ucode_int to (EXTS II16)
MO_UU_Conv from to
| from == to -> conversionNop (intFormat to) x
MO_UU_Conv W64 to
| arch32 -> panic "PPC.CodeGen.getRegister no 64 bit target"
| otherwise -> conversionNop (intFormat to) x
MO_UU_Conv W32 to
| arch32 -> conversionNop (intFormat to) x
| otherwise ->
case to of
W64 -> trivialCode to False AND x (CmmLit (CmmInt 4294967295 W64))
W16 -> conversionNop II16 x
W8 -> conversionNop II8 x
_ -> panic "PPC.CodeGen.getRegister: no match"
MO_UU_Conv W16 W8 -> conversionNop II8 x
MO_UU_Conv W8 to -> trivialCode to False AND x (CmmLit (CmmInt 255 W32))
MO_UU_Conv W16 to -> trivialCode to False AND x (CmmLit (CmmInt 65535 W32))
_ -> panic "PPC.CodeGen.getRegister: no match"
where
triv_ucode_int width instr = trivialUCode (intFormat width) instr x
triv_ucode_float width instr = trivialUCode (floatFormat width) instr x
conversionNop new_format expr
= do e_code <- getRegister' dflags expr
return (swizzleRegisterRep e_code new_format)
arch32 = target32Bit $ targetPlatform dflags
getRegister' dflags (CmmMachOp mop [x, y])
= case mop of
MO_F_Eq _ -> condFltReg EQQ x y
MO_F_Ne _ -> condFltReg NE x y
MO_F_Gt _ -> condFltReg GTT x y
MO_F_Ge _ -> condFltReg GE x y
MO_F_Lt _ -> condFltReg LTT x y
MO_F_Le _ -> condFltReg LE x y
MO_Eq rep -> condIntReg EQQ (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_Ne rep -> condIntReg NE (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_S_Gt rep -> condIntReg GTT (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_S_Ge rep -> condIntReg GE (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_S_Lt rep -> condIntReg LTT (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_S_Le rep -> condIntReg LE (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_U_Gt rep -> condIntReg GU (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_U_Ge rep -> condIntReg GEU (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_U_Lt rep -> condIntReg LU (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_U_Le rep -> condIntReg LEU (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_F_Add w -> triv_float w FADD
MO_F_Sub w -> triv_float w FSUB
MO_F_Mul w -> triv_float w FMUL
MO_F_Quot w -> triv_float w FDIV
MO_Add W32 ->
case y of
CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate W32 True (imm)
-> trivialCode W32 True ADD x (CmmLit $ CmmInt imm immrep)
CmmLit lit
-> do
(src, srcCode) <- getSomeReg x
let imm = litToImm lit
code dst = srcCode `appOL` toOL [
ADDIS dst src (HA imm),
ADD dst dst (RIImm (LO imm))
]
return (Any II32 code)
_ -> trivialCode W32 True ADD x y
MO_Add rep -> trivialCode rep True ADD x y
MO_Sub rep ->
case y of
CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (imm)
-> trivialCode rep True ADD x (CmmLit $ CmmInt (imm) immrep)
_ -> trivialCodeNoImm' (intFormat rep) SUBF y x
MO_Mul rep
| arch32 -> trivialCode rep True MULLW x y
| otherwise -> trivialCode rep True MULLD x y
MO_S_MulMayOflo W32 -> trivialCodeNoImm' II32 MULLW_MayOflo x y
MO_S_MulMayOflo W64 -> trivialCodeNoImm' II64 MULLD_MayOflo x y
MO_S_MulMayOflo _ -> panic "S_MulMayOflo: (II8/16) not implemented"
MO_U_MulMayOflo _ -> panic "U_MulMayOflo: not implemented"
MO_S_Quot rep
| arch32 -> trivialCodeNoImm' (intFormat rep) DIVW
(extendSExpr dflags rep x) (extendSExpr dflags rep y)
| otherwise -> trivialCodeNoImm' (intFormat rep) DIVD
(extendSExpr dflags rep x) (extendSExpr dflags rep y)
MO_U_Quot rep
| arch32 -> trivialCodeNoImm' (intFormat rep) DIVWU
(extendUExpr dflags rep x) (extendUExpr dflags rep y)
| otherwise -> trivialCodeNoImm' (intFormat rep) DIVDU
(extendUExpr dflags rep x) (extendUExpr dflags rep y)
MO_S_Rem rep
| arch32 -> remainderCode rep DIVW (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
| otherwise -> remainderCode rep DIVD (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_U_Rem rep
| arch32 -> remainderCode rep DIVWU (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
| otherwise -> remainderCode rep DIVDU (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_And rep -> trivialCode rep False AND x y
MO_Or rep -> trivialCode rep False OR x y
MO_Xor rep -> trivialCode rep False XOR x y
MO_Shl rep -> shiftCode rep SL x y
MO_S_Shr rep -> shiftCode rep SRA (extendSExpr dflags rep x) y
MO_U_Shr rep -> shiftCode rep SR (extendUExpr dflags rep x) y
_ -> panic "PPC.CodeGen.getRegister: no match"
where
triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float width instr = trivialCodeNoImm (floatFormat width) instr x y
arch32 = target32Bit $ targetPlatform dflags
getRegister' _ (CmmLit (CmmInt i rep))
| Just imm <- makeImmediate rep True i
= let
code dst = unitOL (LI dst imm)
in
return (Any (intFormat rep) code)
getRegister' _ (CmmLit (CmmFloat f frep)) = do
lbl <- getNewLabelNat
dflags <- getDynFlags
dynRef <- cmmMakeDynamicReference dflags DataReference lbl
Amode addr addr_code <- getAmode D dynRef
let format = floatFormat frep
code dst =
LDATA (Section ReadOnlyData lbl)
(Statics lbl [CmmStaticLit (CmmFloat f frep)])
`consOL` (addr_code `snocOL` LD format dst addr)
return (Any format code)
getRegister' dflags (CmmLit lit)
| target32Bit (targetPlatform dflags)
= let rep = cmmLitType dflags lit
imm = litToImm lit
code dst = toOL [
LIS dst (HA imm),
ADD dst dst (RIImm (LO imm))
]
in return (Any (cmmTypeFormat rep) code)
| otherwise
= do lbl <- getNewLabelNat
dflags <- getDynFlags
dynRef <- cmmMakeDynamicReference dflags DataReference lbl
Amode addr addr_code <- getAmode D dynRef
let rep = cmmLitType dflags lit
format = cmmTypeFormat rep
code dst =
LDATA (Section ReadOnlyData lbl) (Statics lbl [CmmStaticLit lit])
`consOL` (addr_code `snocOL` LD format dst addr)
return (Any format code)
getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other)
extendSExpr :: DynFlags -> Width -> CmmExpr -> CmmExpr
extendSExpr dflags W32 x
| target32Bit (targetPlatform dflags) = x
extendSExpr dflags W64 x
| not (target32Bit (targetPlatform dflags)) = x
extendSExpr dflags rep x =
let size = if target32Bit $ targetPlatform dflags
then W32
else W64
in CmmMachOp (MO_SS_Conv rep size) [x]
extendUExpr :: DynFlags -> Width -> CmmExpr -> CmmExpr
extendUExpr dflags W32 x
| target32Bit (targetPlatform dflags) = x
extendUExpr dflags W64 x
| not (target32Bit (targetPlatform dflags)) = x
extendUExpr dflags rep x =
let size = if target32Bit $ targetPlatform dflags
then W32
else W64
in CmmMachOp (MO_UU_Conv rep size) [x]
data Amode
= Amode AddrMode InstrBlock
data InstrForm = D | DS
getAmode :: InstrForm -> CmmExpr -> NatM Amode
getAmode inf tree@(CmmRegOff _ _)
= do dflags <- getDynFlags
getAmode inf (mangleIndexTree dflags tree)
getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)])
| Just off <- makeImmediate W32 True (i)
= do
(reg, code) <- getSomeReg x
return (Amode (AddrRegImm reg off) code)
getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)])
| Just off <- makeImmediate W32 True i
= do
(reg, code) <- getSomeReg x
return (Amode (AddrRegImm reg off) code)
getAmode D (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])
| Just off <- makeImmediate W64 True (i)
= do
(reg, code) <- getSomeReg x
return (Amode (AddrRegImm reg off) code)
getAmode D (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])
| Just off <- makeImmediate W64 True i
= do
(reg, code) <- getSomeReg x
return (Amode (AddrRegImm reg off) code)
getAmode DS (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])
| Just off <- makeImmediate W64 True (i)
= do
(reg, code) <- getSomeReg x
(reg', off', code') <-
if i `mod` 4 == 0
then do return (reg, off, code)
else do
tmp <- getNewRegNat II64
return (tmp, ImmInt 0,
code `snocOL` ADD tmp reg (RIImm off))
return (Amode (AddrRegImm reg' off') code')
getAmode DS (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])
| Just off <- makeImmediate W64 True i
= do
(reg, code) <- getSomeReg x
(reg', off', code') <-
if i `mod` 4 == 0
then do return (reg, off, code)
else do
tmp <- getNewRegNat II64
return (tmp, ImmInt 0,
code `snocOL` ADD tmp reg (RIImm off))
return (Amode (AddrRegImm reg' off') code')
getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit])
= do
dflags <- getDynFlags
(src, srcCode) <- getSomeReg x
let imm = litToImm lit
case () of
_ | OSAIX <- platformOS (targetPlatform dflags)
, isCmmLabelType lit ->
return (Amode (AddrRegImm src imm) srcCode)
| otherwise -> do
tmp <- getNewRegNat II32
let code = srcCode `snocOL` ADDIS tmp src (HA imm)
return (Amode (AddrRegImm tmp (LO imm)) code)
where
isCmmLabelType (CmmLabel {}) = True
isCmmLabelType (CmmLabelOff {}) = True
isCmmLabelType (CmmLabelDiffOff {}) = True
isCmmLabelType _ = False
getAmode _ (CmmLit lit)
= do
dflags <- getDynFlags
case platformArch $ targetPlatform dflags of
ArchPPC -> do
tmp <- getNewRegNat II32
let imm = litToImm lit
code = unitOL (LIS tmp (HA imm))
return (Amode (AddrRegImm tmp (LO imm)) code)
_ -> do
tmp <- getNewRegNat II64
let imm = litToImm lit
code = toOL [
LIS tmp (HIGHESTA imm),
OR tmp tmp (RIImm (HIGHERA imm)),
SL II64 tmp tmp (RIImm (ImmInt 32)),
ORIS tmp tmp (HA imm)
]
return (Amode (AddrRegImm tmp (LO imm)) code)
getAmode _ (CmmMachOp (MO_Add W32) [x, y])
= do
(regX, codeX) <- getSomeReg x
(regY, codeY) <- getSomeReg y
return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
getAmode _ (CmmMachOp (MO_Add W64) [x, y])
= do
(regX, codeX) <- getSomeReg x
(regY, codeY) <- getSomeReg y
return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
getAmode _ other
= do
(reg, code) <- getSomeReg other
let
off = ImmInt 0
return (Amode (AddrRegImm reg off) code)
data CondCode
= CondCode Bool Cond InstrBlock
getCondCode :: CmmExpr -> NatM CondCode
getCondCode (CmmMachOp mop [x, y])
= do
dflags <- getDynFlags
case mop of
MO_F_Eq W32 -> condFltCode EQQ x y
MO_F_Ne W32 -> condFltCode NE x y
MO_F_Gt W32 -> condFltCode GTT x y
MO_F_Ge W32 -> condFltCode GE x y
MO_F_Lt W32 -> condFltCode LTT x y
MO_F_Le W32 -> condFltCode LE x y
MO_F_Eq W64 -> condFltCode EQQ x y
MO_F_Ne W64 -> condFltCode NE x y
MO_F_Gt W64 -> condFltCode GTT x y
MO_F_Ge W64 -> condFltCode GE x y
MO_F_Lt W64 -> condFltCode LTT x y
MO_F_Le W64 -> condFltCode LE x y
MO_Eq rep -> condIntCode EQQ (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_Ne rep -> condIntCode NE (extendUExpr dflags rep x)
(extendUExpr dflags rep y)
MO_S_Gt rep -> condIntCode GTT (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_S_Ge rep -> condIntCode GE (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_S_Lt rep -> condIntCode LTT (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_S_Le rep -> condIntCode LE (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_U_Gt rep -> condIntCode GU (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_U_Ge rep -> condIntCode GEU (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_U_Lt rep -> condIntCode LU (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
MO_U_Le rep -> condIntCode LEU (extendSExpr dflags rep x)
(extendSExpr dflags rep y)
_ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop)
getCondCode _ = panic "getCondCode(2)(powerpc)"
condIntCode, condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode cond x (CmmLit (CmmInt y rep))
| Just src2 <- makeImmediate rep (not $ condUnsigned cond) y
= do
(src1, code) <- getSomeReg x
dflags <- getDynFlags
let format = archWordFormat $ target32Bit $ targetPlatform dflags
code' = code `snocOL`
(if condUnsigned cond then CMPL else CMP) format src1 (RIImm src2)
return (CondCode False cond code')
condIntCode cond x y = do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
dflags <- getDynFlags
let format = archWordFormat $ target32Bit $ targetPlatform dflags
code' = code1 `appOL` code2 `snocOL`
(if condUnsigned cond then CMPL else CMP) format src1 (RIReg src2)
return (CondCode False cond code')
condFltCode cond x y = do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let
code' = code1 `appOL` code2 `snocOL` FCMP src1 src2
code'' = case cond of
GE -> code' `snocOL` CRNOR ltbit eqbit gtbit
LE -> code' `snocOL` CRNOR gtbit eqbit ltbit
_ -> code'
where
ltbit = 0 ; eqbit = 2 ; gtbit = 1
return (CondCode True cond code'')
assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
assignMem_IntCode pk addr src = do
(srcReg, code) <- getSomeReg src
Amode dstAddr addr_code <- case pk of
II64 -> getAmode DS addr
_ -> getAmode D addr
return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
assignReg_IntCode _ reg src
= do
dflags <- getDynFlags
let dst = getRegisterReg (targetPlatform dflags) reg
r <- getRegister src
return $ case r of
Any _ code -> code dst
Fixed _ freg fcode -> fcode `snocOL` MR dst freg
assignMem_FltCode = assignMem_IntCode
assignReg_FltCode = assignReg_IntCode
genJump :: CmmExpr -> NatM InstrBlock
genJump (CmmLit (CmmLabel lbl))
= return (unitOL $ JMP lbl)
genJump tree
= do
dflags <- getDynFlags
let platform = targetPlatform dflags
case platformOS platform of
OSLinux -> case platformArch platform of
ArchPPC -> genJump' tree GCPLinux
ArchPPC_64 ELF_V1 -> genJump' tree (GCPLinux64ELF 1)
ArchPPC_64 ELF_V2 -> genJump' tree (GCPLinux64ELF 2)
_ -> panic "PPC.CodeGen.genJump: Unknown Linux"
OSAIX -> genJump' tree GCPAIX
OSDarwin -> genJump' tree GCPDarwin
_ -> panic "PPC.CodeGen.genJump: not defined for this os"
genJump' :: CmmExpr -> GenCCallPlatform -> NatM InstrBlock
genJump' tree (GCPLinux64ELF 1)
= do
(target,code) <- getSomeReg tree
return (code
`snocOL` LD II64 r11 (AddrRegImm target (ImmInt 0))
`snocOL` LD II64 toc (AddrRegImm target (ImmInt 8))
`snocOL` MTCTR r11
`snocOL` LD II64 r11 (AddrRegImm target (ImmInt 16))
`snocOL` BCTR [] Nothing)
genJump' tree (GCPLinux64ELF 2)
= do
(target,code) <- getSomeReg tree
return (code
`snocOL` MR r12 target
`snocOL` MTCTR r12
`snocOL` BCTR [] Nothing)
genJump' tree _
= do
(target,code) <- getSomeReg tree
return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing)
genBranch :: BlockId -> NatM InstrBlock
genBranch = return . toOL . mkJumpInstr
genCondJump
:: BlockId
-> CmmExpr
-> NatM InstrBlock
genCondJump id bool = do
CondCode _ cond code <- getCondCode bool
return (code `snocOL` BCC cond id)
genCCall :: ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM InstrBlock
genCCall target dest_regs argsAndHints
= do dflags <- getDynFlags
let platform = targetPlatform dflags
case platformOS platform of
OSLinux -> case platformArch platform of
ArchPPC -> genCCall' dflags GCPLinux
target dest_regs argsAndHints
ArchPPC_64 ELF_V1 -> genCCall' dflags (GCPLinux64ELF 1)
target dest_regs argsAndHints
ArchPPC_64 ELF_V2 -> genCCall' dflags (GCPLinux64ELF 2)
target dest_regs argsAndHints
_ -> panic "PPC.CodeGen.genCCall: Unknown Linux"
OSAIX -> genCCall' dflags GCPAIX target dest_regs argsAndHints
OSDarwin -> genCCall' dflags GCPDarwin target dest_regs argsAndHints
_ -> panic "PPC.CodeGen.genCCall: not defined for this os"
data GenCCallPlatform = GCPLinux | GCPDarwin | GCPLinux64ELF Int | GCPAIX
genCCall'
:: DynFlags
-> GenCCallPlatform
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM InstrBlock
genCCall' _ _ (PrimTarget MO_WriteBarrier) _ _
= return $ unitOL LWSYNC
genCCall' _ _ (PrimTarget MO_Touch) _ _
= return $ nilOL
genCCall' _ _ (PrimTarget (MO_Prefetch_Data _)) _ _
= return $ nilOL
genCCall' dflags gcp target dest_regs args
= ASSERT(not $ any (`elem` [II16]) $ map cmmTypeFormat argReps)
do
(finalStack,passArgumentsCode,usedRegs) <- passArguments
(zip args argReps)
allArgRegs
(allFPArgRegs platform)
initialStackOffset
(toOL []) []
(labelOrExpr, reduceToFF32) <- case target of
ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do
uses_pic_base_implicitly
return (Left lbl, False)
ForeignTarget expr _ -> do
uses_pic_base_implicitly
return (Right expr, False)
PrimTarget mop -> outOfLineMachOp mop
let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
`appOL` toc_before
codeAfter = toc_after labelOrExpr `appOL` move_sp_up finalStack
`appOL` moveResult reduceToFF32
case labelOrExpr of
Left lbl -> do
return ( codeBefore
`snocOL` BL lbl usedRegs
`appOL` codeAfter)
Right dyn -> do
(dynReg, dynCode) <- getSomeReg dyn
case gcp of
GCPLinux64ELF 1 -> return ( dynCode
`appOL` codeBefore
`snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 0))
`snocOL` LD II64 toc (AddrRegImm dynReg (ImmInt 8))
`snocOL` MTCTR r11
`snocOL` LD II64 r11 (AddrRegImm dynReg (ImmInt 16))
`snocOL` BCTRL usedRegs
`appOL` codeAfter)
GCPLinux64ELF 2 -> return ( dynCode
`appOL` codeBefore
`snocOL` MR r12 dynReg
`snocOL` MTCTR r12
`snocOL` BCTRL usedRegs
`appOL` codeAfter)
GCPAIX -> return ( dynCode
`appOL` codeBefore
`snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 0))
`snocOL` LD II32 toc (AddrRegImm dynReg (ImmInt 4))
`snocOL` MTCTR r11
`snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 8))
`snocOL` BCTRL usedRegs
`appOL` codeAfter)
_ -> return ( dynCode
`snocOL` MTCTR dynReg
`appOL` codeBefore
`snocOL` BCTRL usedRegs
`appOL` codeAfter)
where
platform = targetPlatform dflags
uses_pic_base_implicitly = do
when (gopt Opt_PIC dflags && target32Bit platform) $ do
_ <- getPicBaseNat $ archWordFormat True
return ()
initialStackOffset = case gcp of
GCPAIX -> 24
GCPDarwin -> 24
GCPLinux -> 8
GCPLinux64ELF 1 -> 48
GCPLinux64ELF 2 -> 32
_ -> panic "genCall': unknown calling convention"
stackDelta finalStack = case gcp of
GCPAIX ->
roundTo 16 $ (24 +) $ max 32 $ sum $
map (widthInBytes . typeWidth) argReps
GCPDarwin ->
roundTo 16 $ (24 +) $ max 32 $ sum $
map (widthInBytes . typeWidth) argReps
GCPLinux -> roundTo 16 finalStack
GCPLinux64ELF 1 ->
roundTo 16 $ (48 +) $ max 64 $ sum $
map (widthInBytes . typeWidth) argReps
GCPLinux64ELF 2 ->
roundTo 16 $ (32 +) $ max 64 $ sum $
map (widthInBytes . typeWidth) argReps
_ -> panic "genCall': unknown calling conv."
argReps = map (cmmExprType dflags) args
roundTo a x | x `mod` a == 0 = x
| otherwise = x + a (x `mod` a)
spFormat = if target32Bit platform then II32 else II64
move_sp_down finalStack
| delta > 64 =
toOL [STU spFormat sp (AddrRegImm sp (ImmInt (delta))),
DELTA (delta)]
| otherwise = nilOL
where delta = stackDelta finalStack
toc_before = case gcp of
GCPLinux64ELF 1 -> unitOL $ ST spFormat toc (AddrRegImm sp (ImmInt 40))
GCPLinux64ELF 2 -> unitOL $ ST spFormat toc (AddrRegImm sp (ImmInt 24))
GCPAIX -> unitOL $ ST spFormat toc (AddrRegImm sp (ImmInt 20))
_ -> nilOL
toc_after labelOrExpr = case gcp of
GCPLinux64ELF 1 -> case labelOrExpr of
Left _ -> toOL [ NOP ]
Right _ -> toOL [ LD spFormat toc
(AddrRegImm sp
(ImmInt 40))
]
GCPLinux64ELF 2 -> case labelOrExpr of
Left _ -> toOL [ NOP ]
Right _ -> toOL [ LD spFormat toc
(AddrRegImm sp
(ImmInt 24))
]
GCPAIX -> case labelOrExpr of
Left _ -> unitOL NOP
Right _ -> unitOL (LD spFormat toc
(AddrRegImm sp
(ImmInt 20)))
_ -> nilOL
move_sp_up finalStack
| delta > 64 =
toOL [ADD sp sp (RIImm (ImmInt delta)),
DELTA 0]
| otherwise = nilOL
where delta = stackDelta finalStack
passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed)
passArguments ((arg,arg_ty):args) gprs fprs stackOffset
accumCode accumUsed | isWord64 arg_ty
&& target32Bit (targetPlatform dflags) =
do
ChildCode64 code vr_lo <- iselExpr64 arg
let vr_hi = getHiVRegFromLo vr_lo
case gcp of
GCPAIX ->
do let storeWord vr (gpr:_) _ = MR gpr vr
storeWord vr [] offset
= ST II32 vr (AddrRegImm sp (ImmInt offset))
passArguments args
(drop 2 gprs)
fprs
(stackOffset+8)
(accumCode `appOL` code
`snocOL` storeWord vr_hi gprs stackOffset
`snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
((take 2 gprs) ++ accumUsed)
GCPDarwin ->
do let storeWord vr (gpr:_) _ = MR gpr vr
storeWord vr [] offset
= ST II32 vr (AddrRegImm sp (ImmInt offset))
passArguments args
(drop 2 gprs)
fprs
(stackOffset+8)
(accumCode `appOL` code
`snocOL` storeWord vr_hi gprs stackOffset
`snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))
((take 2 gprs) ++ accumUsed)
GCPLinux ->
do let stackOffset' = roundTo 8 stackOffset
stackCode = accumCode `appOL` code
`snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset'))
`snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4)))
regCode hireg loreg =
accumCode `appOL` code
`snocOL` MR hireg vr_hi
`snocOL` MR loreg vr_lo
case gprs of
hireg : loreg : regs | even (length gprs) ->
passArguments args regs fprs stackOffset
(regCode hireg loreg) (hireg : loreg : accumUsed)
_skipped : hireg : loreg : regs ->
passArguments args regs fprs stackOffset
(regCode hireg loreg) (hireg : loreg : accumUsed)
_ ->
passArguments args [] fprs (stackOffset'+8)
stackCode accumUsed
GCPLinux64ELF _ -> panic "passArguments: 32 bit code"
passArguments ((arg,rep):args) gprs fprs stackOffset accumCode accumUsed
| reg : _ <- regs = do
register <- getRegister arg
let code = case register of
Fixed _ freg fcode -> fcode `snocOL` MR reg freg
Any _ acode -> acode reg
stackOffsetRes = case gcp of
GCPDarwin -> stackOffset + stackBytes
GCPAIX -> stackOffset + stackBytes
GCPLinux -> stackOffset
GCPLinux64ELF _ -> stackOffset + stackBytes
passArguments args
(drop nGprs gprs)
(drop nFprs fprs)
stackOffsetRes
(accumCode `appOL` code)
(reg : accumUsed)
| otherwise = do
(vr, code) <- getSomeReg arg
passArguments args
(drop nGprs gprs)
(drop nFprs fprs)
(stackOffset' + stackBytes)
(accumCode `appOL` code `snocOL` ST (cmmTypeFormat rep) vr stackSlot)
accumUsed
where
stackOffset' = case gcp of
GCPDarwin ->
stackOffset
GCPAIX ->
stackOffset
GCPLinux
| isFloatType rep && typeWidth rep == W64 ->
roundTo 8 stackOffset
| otherwise ->
stackOffset
GCPLinux64ELF _ ->
stackOffset
stackSlot = AddrRegImm sp (ImmInt stackOffset')
(nGprs, nFprs, stackBytes, regs)
= case gcp of
GCPAIX ->
case cmmTypeFormat rep of
II8 -> (1, 0, 4, gprs)
II16 -> (1, 0, 4, gprs)
II32 -> (1, 0, 4, gprs)
FF32 -> (1, 1, 4, fprs)
FF64 -> (2, 1, 8, fprs)
II64 -> panic "genCCall' passArguments II64"
FF80 -> panic "genCCall' passArguments FF80"
GCPDarwin ->
case cmmTypeFormat rep of
II8 -> (1, 0, 4, gprs)
II16 -> (1, 0, 4, gprs)
II32 -> (1, 0, 4, gprs)
FF32 -> (1, 1, 4, fprs)
FF64 -> (2, 1, 8, fprs)
II64 -> panic "genCCall' passArguments II64"
FF80 -> panic "genCCall' passArguments FF80"
GCPLinux ->
case cmmTypeFormat rep of
II8 -> (1, 0, 4, gprs)
II16 -> (1, 0, 4, gprs)
II32 -> (1, 0, 4, gprs)
FF32 -> (0, 1, 4, fprs)
FF64 -> (0, 1, 8, fprs)
II64 -> panic "genCCall' passArguments II64"
FF80 -> panic "genCCall' passArguments FF80"
GCPLinux64ELF _ ->
case cmmTypeFormat rep of
II8 -> (1, 0, 8, gprs)
II16 -> (1, 0, 8, gprs)
II32 -> (1, 0, 8, gprs)
II64 -> (1, 0, 8, gprs)
FF32 -> (1, 1, 8, fprs)
FF64 -> (1, 1, 8, fprs)
FF80 -> panic "genCCall' passArguments FF80"
moveResult reduceToFF32 =
case dest_regs of
[] -> nilOL
[dest]
| reduceToFF32 && isFloat32 rep -> unitOL (FRSP r_dest f1)
| isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1)
| isWord64 rep && target32Bit (targetPlatform dflags)
-> toOL [MR (getHiVRegFromLo r_dest) r3,
MR r_dest r4]
| otherwise -> unitOL (MR r_dest r3)
where rep = cmmRegType dflags (CmmLocal dest)
r_dest = getRegisterReg platform (CmmLocal dest)
_ -> panic "genCCall' moveResult: Bad dest_regs"
outOfLineMachOp mop =
do
dflags <- getDynFlags
mopExpr <- cmmMakeDynamicReference dflags CallReference $
mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction
let mopLabelOrExpr = case mopExpr of
CmmLit (CmmLabel lbl) -> Left lbl
_ -> Right mopExpr
return (mopLabelOrExpr, reduce)
where
(functionName, reduce) = case mop of
MO_F32_Exp -> (fsLit "exp", True)
MO_F32_Log -> (fsLit "log", True)
MO_F32_Sqrt -> (fsLit "sqrt", True)
MO_F32_Sin -> (fsLit "sin", True)
MO_F32_Cos -> (fsLit "cos", True)
MO_F32_Tan -> (fsLit "tan", True)
MO_F32_Asin -> (fsLit "asin", True)
MO_F32_Acos -> (fsLit "acos", True)
MO_F32_Atan -> (fsLit "atan", True)
MO_F32_Sinh -> (fsLit "sinh", True)
MO_F32_Cosh -> (fsLit "cosh", True)
MO_F32_Tanh -> (fsLit "tanh", True)
MO_F32_Pwr -> (fsLit "pow", True)
MO_F64_Exp -> (fsLit "exp", False)
MO_F64_Log -> (fsLit "log", False)
MO_F64_Sqrt -> (fsLit "sqrt", False)
MO_F64_Sin -> (fsLit "sin", False)
MO_F64_Cos -> (fsLit "cos", False)
MO_F64_Tan -> (fsLit "tan", False)
MO_F64_Asin -> (fsLit "asin", False)
MO_F64_Acos -> (fsLit "acos", False)
MO_F64_Atan -> (fsLit "atan", False)
MO_F64_Sinh -> (fsLit "sinh", False)
MO_F64_Cosh -> (fsLit "cosh", False)
MO_F64_Tanh -> (fsLit "tanh", False)
MO_F64_Pwr -> (fsLit "pow", False)
MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False)
MO_Memcpy _ -> (fsLit "memcpy", False)
MO_Memset _ -> (fsLit "memset", False)
MO_Memmove _ -> (fsLit "memmove", False)
MO_BSwap w -> (fsLit $ bSwapLabel w, False)
MO_PopCnt w -> (fsLit $ popCntLabel w, False)
MO_Clz w -> (fsLit $ clzLabel w, False)
MO_Ctz w -> (fsLit $ ctzLabel w, False)
MO_AtomicRMW w amop -> (fsLit $ atomicRMWLabel w amop, False)
MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False)
MO_AtomicRead w -> (fsLit $ atomicReadLabel w, False)
MO_AtomicWrite w -> (fsLit $ atomicWriteLabel w, False)
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
MO_Add2 {} -> unsupported
MO_SubWordC {} -> unsupported
MO_AddIntC {} -> unsupported
MO_SubIntC {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
(MO_Prefetch_Data _ ) -> unsupported
unsupported = panic ("outOfLineCmmOp: " ++ show mop
++ " not supported")
genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch dflags expr targets
| OSAIX <- platformOS (targetPlatform dflags)
= do
(reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
sha = if target32Bit $ targetPlatform dflags then 2 else 3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
dynRef <- cmmMakeDynamicReference dflags DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
let code = e_code `appOL` t_code `appOL` toOL [
SL fmt tmp reg (RIImm (ImmInt sha)),
LD fmt tmp (AddrRegReg tableReg tmp),
MTCTR tmp,
BCTR ids (Just lbl)
]
return code
| (gopt Opt_PIC dflags) || (not $ target32Bit $ targetPlatform dflags)
= do
(reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
sha = if target32Bit $ targetPlatform dflags then 2 else 3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
dynRef <- cmmMakeDynamicReference dflags DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
let code = e_code `appOL` t_code `appOL` toOL [
SL fmt tmp reg (RIImm (ImmInt sha)),
LD fmt tmp (AddrRegReg tableReg tmp),
ADD tmp tmp (RIReg tableReg),
MTCTR tmp,
BCTR ids (Just lbl)
]
return code
| otherwise
= do
(reg,e_code) <- getSomeReg (cmmOffset dflags expr offset)
let fmt = archWordFormat $ target32Bit $ targetPlatform dflags
sha = if target32Bit $ targetPlatform dflags then 2 else 3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
let code = e_code `appOL` toOL [
SL fmt tmp reg (RIImm (ImmInt sha)),
ADDIS tmp tmp (HA (ImmCLbl lbl)),
LD fmt tmp (AddrRegImm tmp (LO (ImmCLbl lbl))),
MTCTR tmp,
BCTR ids (Just lbl)
]
return code
where (offset, ids) = switchTargetsToTable targets
generateJumpTableForInstr :: DynFlags -> Instr
-> Maybe (NatCmmDecl CmmStatics Instr)
generateJumpTableForInstr dflags (BCTR ids (Just lbl)) =
let jumpTable
| (gopt Opt_PIC dflags)
|| (not $ target32Bit $ targetPlatform dflags)
= map jumpTableEntryRel ids
| otherwise = map (jumpTableEntry dflags) ids
where jumpTableEntryRel Nothing
= CmmStaticLit (CmmInt 0 (wordWidth dflags))
jumpTableEntryRel (Just blockid)
= CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
where blockLabel = mkAsmTempLabel (getUnique blockid)
in Just (CmmData (Section ReadOnlyData lbl) (Statics lbl jumpTable))
generateJumpTableForInstr _ _ = Nothing
condIntReg, condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
condReg :: NatM CondCode -> NatM Register
condReg getCond = do
CondCode _ cond cond_code <- getCond
dflags <- getDynFlags
let
code dst = cond_code
`appOL` negate_code
`appOL` toOL [
MFCR dst,
RLWINM dst dst (bit + 1) 31 31
]
negate_code | do_negate = unitOL (CRNOR bit bit bit)
| otherwise = nilOL
(bit, do_negate) = case cond of
LTT -> (0, False)
LE -> (1, True)
EQQ -> (2, False)
GE -> (0, True)
GTT -> (1, False)
NE -> (2, True)
LU -> (0, False)
LEU -> (1, True)
GEU -> (0, True)
GU -> (1, False)
_ -> panic "PPC.CodeGen.codeReg: no match"
format = archWordFormat $ target32Bit $ targetPlatform dflags
return (Any format code)
condIntReg cond x y = condReg (condIntCode cond x y)
condFltReg cond x y = condReg (condFltCode cond x y)
trivialCode
:: Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode rep signed instr x (CmmLit (CmmInt y _))
| Just imm <- makeImmediate rep signed y
= do
(src1, code1) <- getSomeReg x
let code dst = code1 `snocOL` instr dst src1 (RIImm imm)
return (Any (intFormat rep) code)
trivialCode rep _ instr x y = do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let code dst = code1 `appOL` code2 `snocOL` instr dst src1 (RIReg src2)
return (Any (intFormat rep) code)
shiftCode
:: Width
-> (Format-> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shiftCode width instr x (CmmLit (CmmInt y _))
| Just imm <- makeImmediate width False y
= do
(src1, code1) <- getSomeReg x
let format = intFormat width
let code dst = code1 `snocOL` instr format dst src1 (RIImm imm)
return (Any format code)
shiftCode width instr x y = do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let format = intFormat width
let code dst = code1 `appOL` code2 `snocOL` instr format dst src1 (RIReg src2)
return (Any format code)
trivialCodeNoImm' :: Format -> (Reg -> Reg -> Reg -> Instr)
-> CmmExpr -> CmmExpr -> NatM Register
trivialCodeNoImm' format instr x y = do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2
return (Any format code)
trivialCodeNoImm :: Format -> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr -> CmmExpr -> NatM Register
trivialCodeNoImm format instr x y = trivialCodeNoImm' format (instr format) x y
trivialUCode
:: Format
-> (Reg -> Reg -> Instr)
-> CmmExpr
-> NatM Register
trivialUCode rep instr x = do
(src, code) <- getSomeReg x
let code' dst = code `snocOL` instr dst src
return (Any rep code')
remainderCode :: Width -> (Reg -> Reg -> Reg -> Instr)
-> CmmExpr -> CmmExpr -> NatM Register
remainderCode rep div x y = do
dflags <- getDynFlags
let mull_instr = if target32Bit $ targetPlatform dflags then MULLW
else MULLD
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let code dst = code1 `appOL` code2 `appOL` toOL [
div dst src1 src2,
mull_instr dst dst (RIReg src2),
SUBF dst dst src1
]
return (Any (intFormat rep) code)
coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP fromRep toRep x = do
dflags <- getDynFlags
let arch = platformArch $ targetPlatform dflags
coerceInt2FP' arch fromRep toRep x
coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP' ArchPPC fromRep toRep x = do
(src, code) <- getSomeReg x
lbl <- getNewLabelNat
itmp <- getNewRegNat II32
ftmp <- getNewRegNat FF64
dflags <- getDynFlags
dynRef <- cmmMakeDynamicReference dflags DataReference lbl
Amode addr addr_code <- getAmode D dynRef
let
code' dst = code `appOL` maybe_exts `appOL` toOL [
LDATA (Section ReadOnlyData lbl) $ Statics lbl
[CmmStaticLit (CmmInt 0x43300000 W32),
CmmStaticLit (CmmInt 0x80000000 W32)],
XORIS itmp src (ImmInt 0x8000),
ST II32 itmp (spRel dflags 3),
LIS itmp (ImmInt 0x4330),
ST II32 itmp (spRel dflags 2),
LD FF64 ftmp (spRel dflags 2)
] `appOL` addr_code `appOL` toOL [
LD FF64 dst addr,
FSUB FF64 dst ftmp dst
] `appOL` maybe_frsp dst
maybe_exts = case fromRep of
W8 -> unitOL $ EXTS II8 src src
W16 -> unitOL $ EXTS II16 src src
W32 -> nilOL
_ -> panic "PPC.CodeGen.coerceInt2FP: no match"
maybe_frsp dst
= case toRep of
W32 -> unitOL $ FRSP dst dst
W64 -> nilOL
_ -> panic "PPC.CodeGen.coerceInt2FP: no match"
return (Any (floatFormat toRep) code')
coerceInt2FP' (ArchPPC_64 _) fromRep toRep x = do
(src, code) <- getSomeReg x
dflags <- getDynFlags
let
code' dst = code `appOL` maybe_exts `appOL` toOL [
ST II64 src (spRel dflags 3),
LD FF64 dst (spRel dflags 3),
FCFID dst dst
] `appOL` maybe_frsp dst
maybe_exts = case fromRep of
W8 -> unitOL $ EXTS II8 src src
W16 -> unitOL $ EXTS II16 src src
W32 -> unitOL $ EXTS II32 src src
W64 -> nilOL
_ -> panic "PPC.CodeGen.coerceInt2FP: no match"
maybe_frsp dst
= case toRep of
W32 -> unitOL $ FRSP dst dst
W64 -> nilOL
_ -> panic "PPC.CodeGen.coerceInt2FP: no match"
return (Any (floatFormat toRep) code')
coerceInt2FP' _ _ _ _ = panic "PPC.CodeGen.coerceInt2FP: unknown arch"
coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int fromRep toRep x = do
dflags <- getDynFlags
let arch = platformArch $ targetPlatform dflags
coerceFP2Int' arch fromRep toRep x
coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int' ArchPPC _ toRep x = do
dflags <- getDynFlags
(src, code) <- getSomeReg x
tmp <- getNewRegNat FF64
let
code' dst = code `appOL` toOL [
FCTIWZ tmp src,
ST FF64 tmp (spRel dflags 2),
LD II32 dst (spRel dflags 3)]
return (Any (intFormat toRep) code')
coerceFP2Int' (ArchPPC_64 _) _ toRep x = do
dflags <- getDynFlags
(src, code) <- getSomeReg x
tmp <- getNewRegNat FF64
let
code' dst = code `appOL` toOL [
FCTIDZ tmp src,
ST FF64 tmp (spRel dflags 3),
LD II64 dst (spRel dflags 3)]
return (Any (intFormat toRep) code')
coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch"