module GHC.CmmToAsm.PPC.CodeGen (
cmmTopCodeGen,
generateJumpTableForInstr,
InstrBlock
)
where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Platform.Regs
import GHC.CmmToAsm.PPC.Instr
import GHC.CmmToAsm.PPC.Cond
import GHC.CmmToAsm.PPC.Regs
import GHC.CmmToAsm.CPrim
import GHC.Cmm.DebugBlock
( DebugBlock(..) )
import GHC.CmmToAsm.Monad
( NatM, getNewRegNat, getNewLabelNat
, getBlockIdNat, getPicBaseNat, getNewRegPairNat
, getPicBaseMaybeNat, getPlatform, getConfig
, getDebugBlock, getFileId
)
import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.PIC
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Config
import GHC.Platform.Reg.Class
import GHC.Platform.Reg
import GHC.CmmToAsm.Reg.Target
import GHC.Platform
import GHC.Cmm.BlockId
import GHC.Cmm.Ppr ( pprExpr )
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.Cmm.CLabel
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Core ( Tickish(..) )
import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
import GHC.Data.OrdList
import GHC.Utils.Outputable
import Control.Monad ( mapAndUnzipM, when )
import Data.Bits
import Data.Word
import GHC.Types.Basic
import GHC.Data.FastString
import GHC.Utils.Misc
cmmTopCodeGen
:: RawCmmDecl
-> NatM [NatCmmDecl RawCmmStatics Instr]
cmmTopCodeGen (CmmProc info lab live graph) = do
let blocks = toBlockListEntryFirst graph
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
platform <- getPlatform
let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)
tops = proc : concat statics
os = platformOS platform
arch = platformArch platform
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 -> fixup_entry tops
ArchPPC_64 ELF_V2 -> fixup_entry tops
_ -> panic "PPC.cmmTopCodeGen: unknown arch"
where
fixup_entry (CmmProc info lab live (ListGraph (entry:blocks)) : statics)
= do
let BasicBlock bID insns = entry
bID' <- if lab == (blockLbl bID)
then newBlockId
else return bID
let b' = BasicBlock bID' insns
return (CmmProc info lab live (ListGraph (b':blocks)) : statics)
fixup_entry _ = panic "cmmTopCodegen: Broken CmmProc"
cmmTopCodeGen (CmmData sec dat) = do
return [CmmData sec dat]
basicBlockCodeGen
:: Block CmmNode C C
-> NatM ( [NatBasicBlock Instr]
, [NatCmmDecl RawCmmStatics Instr])
basicBlockCodeGen block = do
let (_, nodes, tail) = blockSplit block
id = entryLabel block
stmts = blockToList nodes
dbg <- getDebugBlock (entryLabel block)
loc_instrs <- case dblSourceTick =<< dbg of
Just (SourceNote span name)
-> do fileid <- getFileId (srcSpanFile span)
let line = srcSpanStartLine span; col =srcSpanStartCol span
return $ unitOL $ LOCATION fileid line col name
_ -> return nilOL
mid_instrs <- stmtsToInstrs stmts
tail_instrs <- stmtToInstrs tail
let instrs = loc_instrs `appOL` 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
config <- getConfig
platform <- getPlatform
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 platform &&
isWord64 ty -> assignReg_I64Code reg src
| otherwise -> assignReg_IntCode format reg src
where ty = cmmRegType platform reg
format = cmmTypeFormat ty
CmmStore addr src
| isFloatType ty -> assignMem_FltCode format addr src
| target32Bit platform &&
isWord64 ty -> assignMem_I64Code addr src
| otherwise -> assignMem_IntCode format addr src
where ty = cmmExprType platform src
format = cmmTypeFormat ty
CmmUnsafeForeignCall target result_regs args
-> genCCall target result_regs args
CmmBranch id -> genBranch id
CmmCondBranch arg true false prediction -> do
b1 <- genCondJump true arg prediction
b2 <- genBranch false
return (b1 `appOL` b2)
CmmSwitch arg ids -> genSwitch config arg ids
CmmCall { cml_target = arg
, cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)
_ ->
panic "stmtToInstrs: statement should have been cps'd away"
jumpRegs :: Platform -> [GlobalReg] -> [Reg]
jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]
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 :: NCGConfig -> Maybe BlockId -> CmmStatic
jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config))
jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
where blockLabel = blockLbl blockid
mangleIndexTree :: Platform -> CmmExpr -> CmmExpr
mangleIndexTree platform (CmmRegOff reg off)
= CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]
where width = typeWidth (cmmRegType platform 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 (RIReg 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 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do
(expr_reg,expr_code) <- getSomeReg expr
(rlo, rhi) <- getNewRegPairNat II32
let mov_hi = SRA II32 rhi expr_reg (RIImm (ImmInt 31))
mov_lo = MR rlo expr_reg
return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
rlo
iselExpr64 expr
= do
platform <- getPlatform
pprPanic "iselExpr64(powerpc)" (pprExpr platform expr)
getRegister :: CmmExpr -> NatM Register
getRegister e = do config <- getConfig
getRegister' config (ncgPlatform config) e
getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg))
| OSAIX <- platformOS platform = do
let code dst = toOL [ LD II32 dst tocAddr ]
tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]"))
return (Any II32 code)
| target32Bit platform = do
reg <- getPicBaseNat $ archWordFormat (target32Bit platform)
return (Fixed (archWordFormat (target32Bit platform))
reg nilOL)
| otherwise = return (Fixed II64 toc nilOL)
getRegister' _ platform (CmmReg reg)
= return (Fixed (cmmTypeFormat (cmmRegType platform reg))
(getRegisterReg platform reg) nilOL)
getRegister' config platform tree@(CmmRegOff _ _)
= getRegister' config platform (mangleIndexTree platform tree)
getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32)
[CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
| target32Bit platform = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 (getHiVRegFromLo rlo) code
getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32)
[CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])
| target32Bit platform = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 (getHiVRegFromLo rlo) code
getRegister' _ platform (CmmMachOp (MO_UU_Conv W64 W32) [x])
| target32Bit platform = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 rlo code
getRegister' _ platform (CmmMachOp (MO_SS_Conv W64 W32) [x])
| target32Bit platform = do
ChildCode64 code rlo <- iselExpr64 x
return $ Fixed II32 rlo code
getRegister' _ platform (CmmLoad mem pk)
| not (isWord64 pk) = do
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 platform) = 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_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))
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 DS mem
return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr))
getRegister' config platform (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
| otherwise -> triv_ucode_int to (EXTS (intFormat from))
MO_UU_Conv from to
| from >= to -> conversionNop (intFormat to) x
| otherwise -> clearLeft from to
MO_XX_Conv _ to -> conversionNop (intFormat to) x
_ -> 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' config platform expr
return (swizzleRegisterRep e_code new_format)
clearLeft from to
= do (src1, code1) <- getSomeReg x
let arch_fmt = intFormat (wordWidth platform)
arch_bits = widthInBits (wordWidth platform)
size = widthInBits from
code dst = code1 `snocOL`
CLRLI arch_fmt dst src1 (arch_bits size)
return (Any (intFormat to) code)
getRegister' _ _ (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 rep x y
MO_Ne rep -> condIntReg NE rep x y
MO_S_Gt rep -> condIntReg GTT rep x y
MO_S_Ge rep -> condIntReg GE rep x y
MO_S_Lt rep -> condIntReg LTT rep x y
MO_S_Le rep -> condIntReg LE rep x y
MO_U_Gt rep -> condIntReg GU rep x y
MO_U_Ge rep -> condIntReg GEU rep x y
MO_U_Lt rep -> condIntReg LU rep x y
MO_U_Le rep -> condIntReg LEU rep x 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)
_ -> case x of
CmmLit (CmmInt imm _)
| Just _ <- makeImmediate rep True imm
-> trivialCode rep True SUBFC y x
_ -> trivialCodeNoImm' (intFormat rep) SUBF y x
MO_Mul rep -> shiftMulCode rep True MULL x y
MO_S_MulMayOflo rep -> do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let
format = intFormat rep
code dst = code1 `appOL` code2
`appOL` toOL [ MULLO format dst src1 src2
, MFOV format dst
]
return (Any format code)
MO_S_Quot rep -> divCode rep True x y
MO_U_Quot rep -> divCode rep False x y
MO_S_Rem rep -> remainder rep True x y
MO_U_Rem rep -> remainder rep False x y
MO_And rep -> case y of
(CmmLit (CmmInt imm _)) | imm == 8 || imm == 4
-> do
(src, srcCode) <- getSomeReg x
let clear_mask = if imm == 4 then 2 else 3
fmt = intFormat rep
code dst = srcCode
`appOL` unitOL (CLRRI fmt dst src clear_mask)
return (Any fmt code)
_ -> 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 -> shiftMulCode rep False SL x y
MO_S_Shr rep -> srCode rep True SRA x y
MO_U_Shr rep -> srCode rep False SR 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
remainder :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
remainder rep sgn x y = do
let fmt = intFormat rep
tmp <- getNewRegNat fmt
code <- remainderCode rep sgn tmp x y
return (Any fmt code)
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' config _ (CmmLit (CmmFloat f frep)) = do
lbl <- getNewLabelNat
dynRef <- cmmMakeDynamicReference config DataReference lbl
Amode addr addr_code <- getAmode D dynRef
let format = floatFormat frep
code dst =
LDATA (Section ReadOnlyData lbl)
(CmmStaticsRaw lbl [CmmStaticLit (CmmFloat f frep)])
`consOL` (addr_code `snocOL` LD format dst addr)
return (Any format code)
getRegister' config platform (CmmLit lit)
| target32Bit platform
= let rep = cmmLitType platform 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
dynRef <- cmmMakeDynamicReference config DataReference lbl
Amode addr addr_code <- getAmode D dynRef
let rep = cmmLitType platform lit
format = cmmTypeFormat rep
code dst =
LDATA (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmStaticLit lit])
`consOL` (addr_code `snocOL` LD format dst addr)
return (Any format code)
getRegister' _ platform other = pprPanic "getRegister(ppc)" (pprExpr platform other)
extendSExpr :: Width -> Width -> CmmExpr -> CmmExpr
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]
data Amode
= Amode AddrMode InstrBlock
data InstrForm = D | DS
getAmode :: InstrForm -> CmmExpr -> NatM Amode
getAmode inf tree@(CmmRegOff _ _)
= do platform <- getPlatform
getAmode inf (mangleIndexTree platform 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
platform <- getPlatform
(src, srcCode) <- getSomeReg x
let imm = litToImm lit
case () of
_ | OSAIX <- platformOS platform
, 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
platform <- getPlatform
case platformArch platform 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
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 rep x y
MO_Ne rep -> condIntCode NE rep x y
MO_S_Gt rep -> condIntCode GTT rep x y
MO_S_Ge rep -> condIntCode GE rep x y
MO_S_Lt rep -> condIntCode LTT rep x y
MO_S_Le rep -> condIntCode LE rep x y
MO_U_Gt rep -> condIntCode GU rep x y
MO_U_Ge rep -> condIntCode GEU rep x y
MO_U_Lt rep -> condIntCode LU rep x y
MO_U_Le rep -> condIntCode LEU rep x y
_ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop)
getCondCode _ = panic "getCondCode(2)(powerpc)"
condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode cond width x y = do
platform <- getPlatform
condIntCode' (target32Bit platform) cond width x y
condIntCode' :: Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode' True cond W64 x y
| condUnsigned cond
= do
ChildCode64 code_x x_lo <- iselExpr64 x
ChildCode64 code_y y_lo <- iselExpr64 y
let x_hi = getHiVRegFromLo x_lo
y_hi = getHiVRegFromLo y_lo
end_lbl <- getBlockIdNat
let code = code_x `appOL` code_y `appOL` toOL
[ CMPL II32 x_hi (RIReg y_hi)
, BCC NE end_lbl Nothing
, CMPL II32 x_lo (RIReg y_lo)
, BCC ALWAYS end_lbl Nothing
, NEWBLOCK end_lbl
]
return (CondCode False cond code)
| otherwise
= do
ChildCode64 code_x x_lo <- iselExpr64 x
ChildCode64 code_y y_lo <- iselExpr64 y
let x_hi = getHiVRegFromLo x_lo
y_hi = getHiVRegFromLo y_lo
end_lbl <- getBlockIdNat
cmp_lo <- getBlockIdNat
let code = code_x `appOL` code_y `appOL` toOL
[ CMP II32 x_hi (RIReg y_hi)
, BCC NE end_lbl Nothing
, CMP II32 x_hi (RIImm (ImmInt 0))
, BCC LE cmp_lo Nothing
, CMPL II32 x_lo (RIReg y_lo)
, BCC ALWAYS end_lbl Nothing
, NEWBLOCK cmp_lo
, CMPL II32 y_lo (RIReg x_lo)
, BCC ALWAYS end_lbl Nothing
, NEWBLOCK end_lbl
]
return (CondCode False cond code)
condIntCode' _ cond _ (CmmMachOp (MO_And _) [x, CmmLit (CmmInt imm rep)])
(CmmLit (CmmInt 0 _))
| not $ condUnsigned cond,
Just src2 <- makeImmediate rep False imm
= do
(src1, code) <- getSomeReg x
let code' = code `snocOL` AND r0 src1 (RIImm src2)
return (CondCode False cond code')
condIntCode' _ cond width x (CmmLit (CmmInt y rep))
| Just src2 <- makeImmediate rep (not $ condUnsigned cond) y
= do
let op_len = max W32 width
let extend = extendSExpr width op_len
(src1, code) <- getSomeReg (extend x)
let format = intFormat op_len
code' = code `snocOL`
(if condUnsigned cond then CMPL else CMP) format src1 (RIImm src2)
return (CondCode False cond code')
condIntCode' _ cond width x y = do
let op_len = max W32 width
let extend = if condUnsigned cond then extendUExpr width op_len
else extendSExpr width op_len
(src1, code1) <- getSomeReg (extend x)
(src2, code2) <- getSomeReg (extend y)
let format = intFormat op_len
code' = code1 `appOL` code2 `snocOL`
(if condUnsigned cond then CMPL else CMP) format src1 (RIReg src2)
return (CondCode False cond code')
condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
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
platform <- getPlatform
let dst = getRegisterReg platform 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 -> [Reg] -> NatM InstrBlock
genJump (CmmLit (CmmLabel lbl)) regs
= return (unitOL $ JMP lbl regs)
genJump tree gregs
= do
platform <- getPlatform
genJump' tree (platformToGCP platform) gregs
genJump' :: CmmExpr -> GenCCallPlatform -> [Reg] -> NatM InstrBlock
genJump' tree (GCP64ELF 1) regs
= 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 regs)
genJump' tree (GCP64ELF 2) regs
= do
(target,code) <- getSomeReg tree
return (code
`snocOL` MR r12 target
`snocOL` MTCTR r12
`snocOL` BCTR [] Nothing regs)
genJump' tree _ regs
= do
(target,code) <- getSomeReg tree
return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing regs)
genBranch :: BlockId -> NatM InstrBlock
genBranch = return . toOL . mkJumpInstr
genCondJump
:: BlockId
-> CmmExpr
-> Maybe Bool
-> NatM InstrBlock
genCondJump id bool prediction = do
CondCode _ cond code <- getCondCode bool
return (code `snocOL` BCC cond id prediction)
genCCall :: ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM InstrBlock
genCCall (PrimTarget MO_ReadBarrier) _ _
= return $ unitOL LWSYNC
genCCall (PrimTarget MO_WriteBarrier) _ _
= return $ unitOL LWSYNC
genCCall (PrimTarget MO_Touch) _ _
= return $ nilOL
genCCall (PrimTarget (MO_Prefetch_Data _)) _ _
= return $ nilOL
genCCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n]
= do platform <- getPlatform
let fmt = intFormat width
reg_dst = getRegisterReg platform (CmmLocal dst)
(instr, n_code) <- case amop of
AMO_Add -> getSomeRegOrImm ADD True reg_dst
AMO_Sub -> case n of
CmmLit (CmmInt i _)
| Just imm <- makeImmediate width True (i)
-> return (ADD reg_dst reg_dst (RIImm imm), nilOL)
_
-> do
(n_reg, n_code) <- getSomeReg n
return (SUBF reg_dst n_reg reg_dst, n_code)
AMO_And -> getSomeRegOrImm AND False reg_dst
AMO_Nand -> do (n_reg, n_code) <- getSomeReg n
return (NAND reg_dst reg_dst n_reg, n_code)
AMO_Or -> getSomeRegOrImm OR False reg_dst
AMO_Xor -> getSomeRegOrImm XOR False reg_dst
Amode addr_reg addr_code <- getAmodeIndex addr
lbl_retry <- getBlockIdNat
return $ n_code `appOL` addr_code
`appOL` toOL [ HWSYNC
, BCC ALWAYS lbl_retry Nothing
, NEWBLOCK lbl_retry
, LDR fmt reg_dst addr_reg
, instr
, STC fmt reg_dst addr_reg
, BCC NE lbl_retry (Just False)
, ISYNC
]
where
getAmodeIndex (CmmMachOp (MO_Add _) [x, y])
= do
(regX, codeX) <- getSomeReg x
(regY, codeY) <- getSomeReg y
return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
getAmodeIndex other
= do
(reg, code) <- getSomeReg other
return (Amode (AddrRegReg r0 reg) code)
getSomeRegOrImm op sign dst
= case n of
CmmLit (CmmInt i _) | Just imm <- makeImmediate width sign i
-> return (op dst dst (RIImm imm), nilOL)
_
-> do
(n_reg, n_code) <- getSomeReg n
return (op dst dst (RIReg n_reg), n_code)
genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr]
= do platform <- getPlatform
let fmt = intFormat width
reg_dst = getRegisterReg platform (CmmLocal dst)
form = if widthInBits width == 64 then DS else D
Amode addr_reg addr_code <- getAmode form addr
lbl_end <- getBlockIdNat
return $ addr_code `appOL` toOL [ HWSYNC
, LD fmt reg_dst addr_reg
, CMP fmt reg_dst (RIReg reg_dst)
, BCC NE lbl_end (Just False)
, BCC ALWAYS lbl_end Nothing
, NEWBLOCK lbl_end
, ISYNC
]
genCCall (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do
code <- assignMem_IntCode (intFormat width) addr val
return $ unitOL(HWSYNC) `appOL` code
genCCall (PrimTarget (MO_Clz width)) [dst] [src]
= do platform <- getPlatform
let reg_dst = getRegisterReg platform (CmmLocal dst)
if target32Bit platform && width == W64
then do
ChildCode64 code vr_lo <- iselExpr64 src
lbl1 <- getBlockIdNat
lbl2 <- getBlockIdNat
lbl3 <- getBlockIdNat
let vr_hi = getHiVRegFromLo vr_lo
cntlz = toOL [ CMPL II32 vr_hi (RIImm (ImmInt 0))
, BCC NE lbl2 Nothing
, BCC ALWAYS lbl1 Nothing
, NEWBLOCK lbl1
, CNTLZ II32 reg_dst vr_lo
, ADD reg_dst reg_dst (RIImm (ImmInt 32))
, BCC ALWAYS lbl3 Nothing
, NEWBLOCK lbl2
, CNTLZ II32 reg_dst vr_hi
, BCC ALWAYS lbl3 Nothing
, NEWBLOCK lbl3
]
return $ code `appOL` cntlz
else do
let format = if width == W64 then II64 else II32
(s_reg, s_code) <- getSomeReg src
(pre, reg , post) <-
case width of
W64 -> return (nilOL, s_reg, nilOL)
W32 -> return (nilOL, s_reg, nilOL)
W16 -> do
reg_tmp <- getNewRegNat format
return
( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 65535))
, reg_tmp
, unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (16)))
)
W8 -> do
reg_tmp <- getNewRegNat format
return
( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 255))
, reg_tmp
, unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (24)))
)
_ -> panic "genCall: Clz wrong format"
let cntlz = unitOL (CNTLZ format reg_dst reg)
return $ s_code `appOL` pre `appOL` cntlz `appOL` post
genCCall (PrimTarget (MO_Ctz width)) [dst] [src]
= do platform <- getPlatform
let reg_dst = getRegisterReg platform (CmmLocal dst)
if target32Bit platform && width == W64
then do
let format = II32
ChildCode64 code vr_lo <- iselExpr64 src
lbl1 <- getBlockIdNat
lbl2 <- getBlockIdNat
lbl3 <- getBlockIdNat
x' <- getNewRegNat format
x'' <- getNewRegNat format
r' <- getNewRegNat format
cnttzlo <- cnttz format reg_dst vr_lo
let vr_hi = getHiVRegFromLo vr_lo
cnttz64 = toOL [ CMPL format vr_lo (RIImm (ImmInt 0))
, BCC NE lbl2 Nothing
, BCC ALWAYS lbl1 Nothing
, NEWBLOCK lbl1
, ADD x' vr_hi (RIImm (ImmInt (1)))
, ANDC x'' x' vr_hi
, CNTLZ format r' x''
, SUBFC reg_dst r' (RIImm (ImmInt 64))
, BCC ALWAYS lbl3 Nothing
, NEWBLOCK lbl2
]
`appOL` cnttzlo `appOL`
toOL [ BCC ALWAYS lbl3 Nothing
, NEWBLOCK lbl3
]
return $ code `appOL` cnttz64
else do
let format = if width == W64 then II64 else II32
(s_reg, s_code) <- getSomeReg src
(reg_ctz, pre_code) <-
case width of
W64 -> return (s_reg, nilOL)
W32 -> return (s_reg, nilOL)
W16 -> do
reg_tmp <- getNewRegNat format
return (reg_tmp, unitOL $ ORIS reg_tmp s_reg (ImmInt 1))
W8 -> do
reg_tmp <- getNewRegNat format
return (reg_tmp, unitOL $ OR reg_tmp s_reg (RIImm (ImmInt 256)))
_ -> panic "genCall: Ctz wrong format"
ctz_code <- cnttz format reg_dst reg_ctz
return $ s_code `appOL` pre_code `appOL` ctz_code
where
cnttz format dst src = do
let format_bits = 8 * formatInBytes format
x' <- getNewRegNat format
x'' <- getNewRegNat format
r' <- getNewRegNat format
return $ toOL [ ADD x' src (RIImm (ImmInt (1)))
, ANDC x'' x' src
, CNTLZ format r' x''
, SUBFC dst r' (RIImm (ImmInt (format_bits)))
]
genCCall target dest_regs argsAndHints
= do platform <- getPlatform
case target of
PrimTarget (MO_S_QuotRem width) -> divOp1 platform True width
dest_regs argsAndHints
PrimTarget (MO_U_QuotRem width) -> divOp1 platform False width
dest_regs argsAndHints
PrimTarget (MO_U_QuotRem2 width) -> divOp2 platform width dest_regs
argsAndHints
PrimTarget (MO_U_Mul2 width) -> multOp2 platform width dest_regs
argsAndHints
PrimTarget (MO_Add2 _) -> add2Op platform dest_regs argsAndHints
PrimTarget (MO_AddWordC _) -> addcOp platform dest_regs argsAndHints
PrimTarget (MO_SubWordC _) -> subcOp platform dest_regs argsAndHints
PrimTarget (MO_AddIntC width) -> addSubCOp ADDO platform width
dest_regs argsAndHints
PrimTarget (MO_SubIntC width) -> addSubCOp SUBFO platform width
dest_regs argsAndHints
PrimTarget MO_F64_Fabs -> fabs platform dest_regs argsAndHints
PrimTarget MO_F32_Fabs -> fabs platform dest_regs argsAndHints
_ -> do config <- getConfig
genCCall' config (platformToGCP platform)
target dest_regs argsAndHints
where divOp1 platform signed width [res_q, res_r] [arg_x, arg_y]
= do let reg_q = getRegisterReg platform (CmmLocal res_q)
reg_r = getRegisterReg platform (CmmLocal res_r)
remainderCode width signed reg_q arg_x arg_y
<*> pure reg_r
divOp1 _ _ _ _ _
= panic "genCCall: Wrong number of arguments for divOp1"
divOp2 platform width [res_q, res_r]
[arg_x_high, arg_x_low, arg_y]
= do let reg_q = getRegisterReg platform (CmmLocal res_q)
reg_r = getRegisterReg platform (CmmLocal res_r)
fmt = intFormat width
half = 4 * (formatInBytes fmt)
(xh_reg, xh_code) <- getSomeReg arg_x_high
(xl_reg, xl_code) <- getSomeReg arg_x_low
(y_reg, y_code) <- getSomeReg arg_y
s <- getNewRegNat fmt
b <- getNewRegNat fmt
v <- getNewRegNat fmt
vn1 <- getNewRegNat fmt
vn0 <- getNewRegNat fmt
un32 <- getNewRegNat fmt
tmp <- getNewRegNat fmt
un10 <- getNewRegNat fmt
un1 <- getNewRegNat fmt
un0 <- getNewRegNat fmt
q1 <- getNewRegNat fmt
rhat <- getNewRegNat fmt
tmp1 <- getNewRegNat fmt
q0 <- getNewRegNat fmt
un21 <- getNewRegNat fmt
again1 <- getBlockIdNat
no1 <- getBlockIdNat
then1 <- getBlockIdNat
endif1 <- getBlockIdNat
again2 <- getBlockIdNat
no2 <- getBlockIdNat
then2 <- getBlockIdNat
endif2 <- getBlockIdNat
return $ y_code `appOL` xl_code `appOL` xh_code `appOL`
toOL [
LI b (ImmInt 1)
, SL fmt b b (RIImm (ImmInt half))
, CNTLZ fmt s y_reg
, SL fmt v y_reg (RIReg s)
, SR fmt vn1 v (RIImm (ImmInt half))
, CLRLI fmt vn0 v half
, SL fmt un32 xh_reg (RIReg s)
, SUBFC tmp s
(RIImm (ImmInt (8 * formatInBytes fmt)))
, SR fmt tmp xl_reg (RIReg tmp)
, OR un32 un32 (RIReg tmp)
, SL fmt un10 xl_reg (RIReg s)
, SR fmt un1 un10 (RIImm (ImmInt half))
, CLRLI fmt un0 un10 half
, DIV fmt False q1 un32 vn1
, MULL fmt tmp q1 (RIReg vn1)
, SUBF rhat tmp un32
, BCC ALWAYS again1 Nothing
, NEWBLOCK again1
, CMPL fmt q1 (RIReg b)
, BCC GEU then1 Nothing
, BCC ALWAYS no1 Nothing
, NEWBLOCK no1
, MULL fmt tmp q1 (RIReg vn0)
, SL fmt tmp1 rhat (RIImm (ImmInt half))
, ADD tmp1 tmp1 (RIReg un1)
, CMPL fmt tmp (RIReg tmp1)
, BCC LEU endif1 Nothing
, BCC ALWAYS then1 Nothing
, NEWBLOCK then1
, ADD q1 q1 (RIImm (ImmInt (1)))
, ADD rhat rhat (RIReg vn1)
, CMPL fmt rhat (RIReg b)
, BCC LTT again1 Nothing
, BCC ALWAYS endif1 Nothing
, NEWBLOCK endif1
, SL fmt un21 un32 (RIImm (ImmInt half))
, ADD un21 un21 (RIReg un1)
, MULL fmt tmp q1 (RIReg v)
, SUBF un21 tmp un21
, DIV fmt False q0 un21 vn1
, MULL fmt tmp q0 (RIReg vn1)
, SUBF rhat tmp un21
, BCC ALWAYS again2 Nothing
, NEWBLOCK again2
, CMPL fmt q0 (RIReg b)
, BCC GEU then2 Nothing
, BCC ALWAYS no2 Nothing
, NEWBLOCK no2
, MULL fmt tmp q0 (RIReg vn0)
, SL fmt tmp1 rhat (RIImm (ImmInt half))
, ADD tmp1 tmp1 (RIReg un0)
, CMPL fmt tmp (RIReg tmp1)
, BCC LEU endif2 Nothing
, BCC ALWAYS then2 Nothing
, NEWBLOCK then2
, ADD q0 q0 (RIImm (ImmInt (1)))
, ADD rhat rhat (RIReg vn1)
, CMPL fmt rhat (RIReg b)
, BCC LTT again2 Nothing
, BCC ALWAYS endif2 Nothing
, NEWBLOCK endif2
, SL fmt reg_r un21 (RIImm (ImmInt half))
, ADD reg_r reg_r (RIReg un0)
, MULL fmt tmp q0 (RIReg v)
, SUBF reg_r tmp reg_r
, SR fmt reg_r reg_r (RIReg s)
, SL fmt reg_q q1 (RIImm (ImmInt half))
, ADD reg_q reg_q (RIReg q0)
]
divOp2 _ _ _ _
= panic "genCCall: Wrong number of arguments for divOp2"
multOp2 platform width [res_h, res_l] [arg_x, arg_y]
= do let reg_h = getRegisterReg platform (CmmLocal res_h)
reg_l = getRegisterReg platform (CmmLocal res_l)
fmt = intFormat width
(x_reg, x_code) <- getSomeReg arg_x
(y_reg, y_code) <- getSomeReg arg_y
return $ y_code `appOL` x_code
`appOL` toOL [ MULL fmt reg_l x_reg (RIReg y_reg)
, MULHU fmt reg_h x_reg y_reg
]
multOp2 _ _ _ _
= panic "genCall: Wrong number of arguments for multOp2"
add2Op platform [res_h, res_l] [arg_x, arg_y]
= do let reg_h = getRegisterReg platform (CmmLocal res_h)
reg_l = getRegisterReg platform (CmmLocal res_l)
(x_reg, x_code) <- getSomeReg arg_x
(y_reg, y_code) <- getSomeReg arg_y
return $ y_code `appOL` x_code
`appOL` toOL [ LI reg_h (ImmInt 0)
, ADDC reg_l x_reg y_reg
, ADDZE reg_h reg_h
]
add2Op _ _ _
= panic "genCCall: Wrong number of arguments/results for add2"
addcOp platform [res_r, res_c] [arg_x, arg_y]
= add2Op platform [res_c , res_r ] [arg_x, arg_y]
addcOp _ _ _
= panic "genCCall: Wrong number of arguments/results for addc"
subcOp platform [res_r, res_c] [arg_x, arg_y]
= do let reg_r = getRegisterReg platform (CmmLocal res_r)
reg_c = getRegisterReg platform (CmmLocal res_c)
(x_reg, x_code) <- getSomeReg arg_x
(y_reg, y_code) <- getSomeReg arg_y
return $ y_code `appOL` x_code
`appOL` toOL [ LI reg_c (ImmInt 0)
, SUBFC reg_r y_reg (RIReg x_reg)
, ADDZE reg_c reg_c
, XOR reg_c reg_c (RIImm (ImmInt 1))
]
subcOp _ _ _
= panic "genCCall: Wrong number of arguments/results for subc"
addSubCOp instr platform width [res_r, res_c] [arg_x, arg_y]
= do let reg_r = getRegisterReg platform (CmmLocal res_r)
reg_c = getRegisterReg platform (CmmLocal res_c)
(x_reg, x_code) <- getSomeReg arg_x
(y_reg, y_code) <- getSomeReg arg_y
return $ y_code `appOL` x_code
`appOL` toOL [ instr reg_r y_reg x_reg,
MFOV (intFormat width) reg_c
]
addSubCOp _ _ _ _ _
= panic "genCall: Wrong number of arguments/results for addC"
fabs platform [res] [arg]
= do let res_r = getRegisterReg platform (CmmLocal res)
(arg_reg, arg_code) <- getSomeReg arg
return $ arg_code `snocOL` FABS res_r arg_reg
fabs _ _ _
= panic "genCall: Wrong number of arguments/results for fabs"
data GenCCallPlatform = GCP32ELF | GCP64ELF !Int | GCPAIX
platformToGCP :: Platform -> GenCCallPlatform
platformToGCP platform
= case platformOS platform of
OSAIX -> GCPAIX
_ -> case platformArch platform of
ArchPPC -> GCP32ELF
ArchPPC_64 ELF_V1 -> GCP64ELF 1
ArchPPC_64 ELF_V2 -> GCP64ELF 2
_ -> panic "platformToGCP: Not PowerPC"
genCCall'
:: NCGConfig
-> GenCCallPlatform
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM InstrBlock
genCCall' config gcp target dest_regs args
= do
(finalStack,passArgumentsCode,usedRegs) <- passArguments
(zip3 args argReps argHints)
allArgRegs
(allFPArgRegs platform)
initialStackOffset
nilOL []
(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
codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32
case labelOrExpr of
Left lbl -> do
return ( codeBefore
`snocOL` BL lbl usedRegs
`appOL` maybeNOP
`appOL` codeAfter)
Right dyn -> do
(dynReg, dynCode) <- getSomeReg dyn
case gcp of
GCP64ELF 1 -> return ( dynCode
`appOL` codeBefore
`snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 40))
`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
`snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 40))
`appOL` codeAfter)
GCP64ELF 2 -> return ( dynCode
`appOL` codeBefore
`snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 24))
`snocOL` MR r12 dynReg
`snocOL` MTCTR r12
`snocOL` BCTRL usedRegs
`snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 24))
`appOL` codeAfter)
GCPAIX -> return ( dynCode
`appOL` codeBefore
`snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 20))
`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
`snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 20))
`appOL` codeAfter)
_ -> return ( dynCode
`snocOL` MTCTR dynReg
`appOL` codeBefore
`snocOL` BCTRL usedRegs
`appOL` codeAfter)
where
platform = ncgPlatform config
uses_pic_base_implicitly = do
when (ncgPIC config && target32Bit platform) $ do
_ <- getPicBaseNat $ archWordFormat True
return ()
initialStackOffset = case gcp of
GCPAIX -> 24
GCP32ELF -> 8
GCP64ELF 1 -> 48
GCP64ELF 2 -> 32
_ -> panic "genCall': unknown calling convention"
stackDelta finalStack = case gcp of
GCPAIX ->
roundTo 16 $ (24 +) $ max 32 $ sum $
map (widthInBytes . typeWidth) argReps
GCP32ELF -> roundTo 16 finalStack
GCP64ELF 1 ->
roundTo 16 $ (48 +) $ max 64 $ sum $
map (roundTo 8 . widthInBytes . typeWidth)
argReps
GCP64ELF 2 ->
roundTo 16 $ (32 +) $ max 64 $ sum $
map (roundTo 8 . widthInBytes . typeWidth)
argReps
_ -> panic "genCall': unknown calling conv."
argReps = map (cmmExprType platform) args
(argHints, _) = foreignTargetHints target
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 > stackFrameHeaderSize platform =
toOL [STU spFormat sp (AddrRegImm sp (ImmInt (delta))),
DELTA (delta)]
| otherwise = nilOL
where delta = stackDelta finalStack
move_sp_up finalStack
| delta > stackFrameHeaderSize platform =
toOL [ADD sp sp (RIImm (ImmInt delta)),
DELTA 0]
| otherwise = nilOL
where delta = stackDelta finalStack
maybeNOP = case gcp of
GCP32ELF -> nilOL
GCPAIX -> unitOL NOP
GCP64ELF 1 -> unitOL NOP
GCP64ELF 2 -> unitOL NOP
_ -> panic "maybeNOP: Unknown PowerPC 64-bit ABI"
passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed)
passArguments ((arg,arg_ty,_):args) gprs fprs stackOffset
accumCode accumUsed | isWord64 arg_ty
&& target32Bit (ncgPlatform config) =
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)
GCP32ELF ->
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
GCP64ELF _ -> panic "passArguments: 32 bit code"
passArguments ((arg,rep,hint):args) gprs fprs stackOffset accumCode accumUsed
| reg : _ <- regs = do
register <- getRegister arg_pro
let code = case register of
Fixed _ freg fcode -> fcode `snocOL` MR reg freg
Any _ acode -> acode reg
stackOffsetRes = case gcp of
GCPAIX -> stackOffset + stackBytes
GCP32ELF -> stackOffset
GCP64ELF _ -> stackOffset + stackBytes
passArguments args
(drop nGprs gprs)
(drop nFprs fprs)
stackOffsetRes
(accumCode `appOL` code)
(reg : accumUsed)
| otherwise = do
(vr, code) <- getSomeReg arg_pro
passArguments args
(drop nGprs gprs)
(drop nFprs fprs)
(stackOffset' + stackBytes)
(accumCode `appOL` code
`snocOL` ST format_pro vr stackSlot)
accumUsed
where
arg_pro
| isBitsType rep = CmmMachOp (conv_op (typeWidth rep) (wordWidth platform)) [arg]
| otherwise = arg
format_pro
| isBitsType rep = intFormat (wordWidth platform)
| otherwise = cmmTypeFormat rep
conv_op = case hint of
SignedHint -> MO_SS_Conv
_ -> MO_UU_Conv
stackOffset' = case gcp of
GCPAIX ->
stackOffset
GCP32ELF
| isFloatType rep && typeWidth rep == W64 ->
roundTo 8 stackOffset
| otherwise ->
stackOffset
GCP64ELF _ ->
stackOffset
stackOffset''
| isFloatType rep && typeWidth rep == W32 =
case gcp of
GCP64ELF 1 -> stackOffset' + 4
_ -> stackOffset'
| otherwise = 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"
GCP32ELF ->
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"
GCP64ELF _ ->
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)
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 platform
-> toOL [MR (getHiVRegFromLo r_dest) r3,
MR r_dest r4]
| otherwise -> unitOL (MR r_dest r3)
where rep = cmmRegType platform (CmmLocal dest)
r_dest = getRegisterReg platform (CmmLocal dest)
_ -> panic "genCCall' moveResult: Bad dest_regs"
outOfLineMachOp mop =
do
mopExpr <- cmmMakeDynamicReference config 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_ExpM1 -> (fsLit "expm1", True)
MO_F32_Log -> (fsLit "log", True)
MO_F32_Log1P -> (fsLit "log1p", True)
MO_F32_Sqrt -> (fsLit "sqrt", True)
MO_F32_Fabs -> unsupported
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_F32_Asinh -> (fsLit "asinh", True)
MO_F32_Acosh -> (fsLit "acosh", True)
MO_F32_Atanh -> (fsLit "atanh", True)
MO_F64_Exp -> (fsLit "exp", False)
MO_F64_ExpM1 -> (fsLit "expm1", False)
MO_F64_Log -> (fsLit "log", False)
MO_F64_Log1P -> (fsLit "log1p", False)
MO_F64_Sqrt -> (fsLit "sqrt", False)
MO_F64_Fabs -> unsupported
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_F64_Asinh -> (fsLit "asinh", False)
MO_F64_Acosh -> (fsLit "acosh", False)
MO_F64_Atanh -> (fsLit "atanh", 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_Memcmp _ -> (fsLit "memcmp", False)
MO_BSwap w -> (fsLit $ bSwapLabel w, False)
MO_BRev w -> (fsLit $ bRevLabel w, False)
MO_PopCnt w -> (fsLit $ popCntLabel w, False)
MO_Pdep w -> (fsLit $ pdepLabel w, False)
MO_Pext w -> (fsLit $ pextLabel w, False)
MO_Clz _ -> unsupported
MO_Ctz _ -> unsupported
MO_AtomicRMW {} -> unsupported
MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False)
MO_Xchg w -> (fsLit $ xchgLabel w, False)
MO_AtomicRead _ -> unsupported
MO_AtomicWrite _ -> unsupported
MO_S_Mul2 {} -> unsupported
MO_S_QuotRem {} -> unsupported
MO_U_QuotRem {} -> unsupported
MO_U_QuotRem2 {} -> unsupported
MO_Add2 {} -> unsupported
MO_AddWordC {} -> unsupported
MO_SubWordC {} -> unsupported
MO_AddIntC {} -> unsupported
MO_SubIntC {} -> unsupported
MO_U_Mul2 {} -> unsupported
MO_ReadBarrier -> unsupported
MO_WriteBarrier -> unsupported
MO_Touch -> unsupported
MO_Prefetch_Data _ -> unsupported
unsupported = panic ("outOfLineCmmOp: " ++ show mop
++ " not supported")
genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch config expr targets
| OSAIX <- platformOS platform
= do
(reg,e_code) <- getSomeReg (cmmOffset platform expr offset)
let fmt = archWordFormat $ target32Bit platform
sha = if target32Bit platform then 2 else 3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
dynRef <- cmmMakeDynamicReference config 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
| (ncgPIC config) || (not $ target32Bit platform)
= do
(reg,e_code) <- getSomeReg (cmmOffset platform expr offset)
let fmt = archWordFormat $ target32Bit platform
sha = if target32Bit platform then 2 else 3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
dynRef <- cmmMakeDynamicReference config 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 platform expr offset)
let fmt = archWordFormat $ target32Bit platform
sha = if target32Bit platform 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
platform = ncgPlatform config
generateJumpTableForInstr :: NCGConfig -> Instr
-> Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr config (BCTR ids (Just lbl) _) =
let jumpTable
| (ncgPIC config) || (not $ target32Bit $ ncgPlatform config)
= map jumpTableEntryRel ids
| otherwise = map (jumpTableEntry config) ids
where jumpTableEntryRel Nothing
= CmmStaticLit (CmmInt 0 (ncgWordWidth config))
jumpTableEntryRel (Just blockid)
= CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0
(ncgWordWidth config))
where blockLabel = blockLbl blockid
in Just (CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl jumpTable))
generateJumpTableForInstr _ _ = Nothing
condReg :: NatM CondCode -> NatM Register
condReg getCond = do
CondCode _ cond cond_code <- getCond
platform <- getPlatform
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 platform
return (Any format code)
condIntReg :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg cond width x y = condReg (condIntCode cond width x y)
condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
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)
shiftMulCode
:: Width
-> Bool
-> (Format-> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shiftMulCode width sign instr x (CmmLit (CmmInt y _))
| Just imm <- makeImmediate width sign y
= do
(src1, code1) <- getSomeReg x
let format = intFormat width
let ins_fmt = intFormat (max W32 width)
let code dst = code1 `snocOL` instr ins_fmt dst src1 (RIImm imm)
return (Any format code)
shiftMulCode width _ instr x y = do
(src1, code1) <- getSomeReg x
(src2, code2) <- getSomeReg y
let format = intFormat width
let ins_fmt = intFormat (max W32 width)
let code dst = code1 `appOL` code2
`snocOL` instr ins_fmt 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
srCode :: Width -> Bool -> (Format-> Reg -> Reg -> RI -> Instr)
-> CmmExpr -> CmmExpr -> NatM Register
srCode width sgn instr x (CmmLit (CmmInt y _))
| Just imm <- makeImmediate width sgn y
= do
let op_len = max W32 width
extend = if sgn then extendSExpr else extendUExpr
(src1, code1) <- getSomeReg (extend width op_len x)
let code dst = code1 `snocOL`
instr (intFormat op_len) dst src1 (RIImm imm)
return (Any (intFormat width) code)
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)
let code dst = code1 `appOL` code2 `snocOL`
instr (intFormat op_len) dst src1 (RIReg src2)
return (Any (intFormat width) code)
divCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
divCode width sgn 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 (extend width op_len y)
let code dst = code1 `appOL` code2 `snocOL`
DIV (intFormat op_len) sgn dst src1 src2
return (Any (intFormat width) code)
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 -> Bool -> Reg -> CmmExpr -> CmmExpr
-> NatM (Reg -> InstrBlock)
remainderCode rep sgn reg_q arg_x arg_y = do
let op_len = max W32 rep
fmt = intFormat op_len
extend = if sgn then extendSExpr else extendUExpr
(x_reg, x_code) <- getSomeReg (extend rep op_len arg_x)
(y_reg, y_code) <- getSomeReg (extend rep op_len arg_y)
return $ \reg_r -> y_code `appOL` x_code
`appOL` toOL [ DIV fmt sgn reg_q x_reg y_reg
, MULL fmt reg_r reg_q (RIReg y_reg)
, SUBF reg_r reg_r x_reg
]
coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP fromRep toRep x = do
platform <- getPlatform
let arch = platformArch platform
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
config <- getConfig
platform <- getPlatform
dynRef <- cmmMakeDynamicReference config DataReference lbl
Amode addr addr_code <- getAmode D dynRef
let
code' dst = code `appOL` maybe_exts `appOL` toOL [
LDATA (Section ReadOnlyData lbl) $ CmmStaticsRaw lbl
[CmmStaticLit (CmmInt 0x43300000 W32),
CmmStaticLit (CmmInt 0x80000000 W32)],
XORIS itmp src (ImmInt 0x8000),
ST II32 itmp (spRel platform 3),
LIS itmp (ImmInt 0x4330),
ST II32 itmp (spRel platform 2),
LD FF64 ftmp (spRel platform 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
platform <- getPlatform
let
code' dst = code `appOL` maybe_exts `appOL` toOL [
ST II64 src (spRel platform 3),
LD FF64 dst (spRel platform 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
platform <- getPlatform
let arch = platformArch platform
coerceFP2Int' arch fromRep toRep x
coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int' ArchPPC _ toRep x = do
platform <- getPlatform
(src, code) <- getSomeReg x
tmp <- getNewRegNat FF64
let
code' dst = code `appOL` toOL [
FCTIWZ tmp src,
ST FF64 tmp (spRel platform 2),
LD II32 dst (spRel platform 3)]
return (Any (intFormat toRep) code')
coerceFP2Int' (ArchPPC_64 _) _ toRep x = do
platform <- getPlatform
(src, code) <- getSomeReg x
tmp <- getNewRegNat FF64
let
code' dst = code `appOL` toOL [
FCTIDZ tmp src,
ST FF64 tmp (spRel platform 3),
LD II64 dst (spRel platform 3)]
return (Any (intFormat toRep) code')
coerceFP2Int' _ _ _ _ = panic "PPC.CodeGen.coerceFP2Int: unknown arch"