{-# LANGUAGE GADTs #-}
module GHC.CmmToAsm.PPC.CodeGen (
cmmTopCodeGen,
generateJumpTableForInstr,
InstrBlock
)
where
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.CmmToAsm.Types
import GHC.Cmm.DebugBlock
( DebugBlock(..) )
import GHC.CmmToAsm.Monad
( NatM, getNewRegNat, getNewLabelNat
, getBlockIdNat, getPicBaseNat
, Reg64(..), RegCode64(..), getNewReg64, localReg64
, getPicBaseMaybeNat, getPlatform, getConfig
, getDebugBlock, getFileId
)
import GHC.CmmToAsm.PIC
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Config
import GHC.Platform.Reg.Class.Unified
import GHC.Platform.Reg
import GHC.CmmToAsm.Reg.Target
import GHC.Platform
import GHC.Cmm.BlockId
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.Types.Tickish ( GenTickish(..) )
import GHC.Types.SrcLoc ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
import GHC.Data.OrdList
import GHC.Utils.Outputable
import GHC.Utils.Panic
import Control.Monad ( mapAndUnzipM, when )
import Data.Word
import GHC.Types.Basic
import GHC.Data.FastString
cmmTopCodeGen
:: RawCmmDecl
-> NatM [NatCmmDecl RawCmmStatics Instr]
cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl RawCmmStatics Instr]
cmmTopCodeGen (CmmProc LabelMap RawCmmStatics
info CLabel
lab [GlobalRegUse]
live CmmGraph
graph) = do
let blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
toBlockListEntryFirst CmmGraph
graph
(nat_blocks,statics) <- (CmmBlock
-> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr]))
-> [CmmBlock]
-> NatM
([[NatBasicBlock Instr]], [[NatCmmDecl RawCmmStatics Instr]])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM CmmBlock
-> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr])
basicBlockCodeGen [CmmBlock]
blocks
platform <- getPlatform
let proc = LabelMap RawCmmStatics
-> CLabel
-> [GlobalRegUse]
-> ListGraph Instr
-> NatCmmDecl RawCmmStatics Instr
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
info CLabel
lab [GlobalRegUse]
live ([NatBasicBlock Instr] -> ListGraph Instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph ([NatBasicBlock Instr] -> ListGraph Instr)
-> [NatBasicBlock Instr] -> ListGraph Instr
forall a b. (a -> b) -> a -> b
$ [[NatBasicBlock Instr]] -> [NatBasicBlock Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NatBasicBlock Instr]]
nat_blocks)
tops = NatCmmDecl RawCmmStatics Instr
proc NatCmmDecl RawCmmStatics Instr
-> [NatCmmDecl RawCmmStatics Instr]
-> [NatCmmDecl RawCmmStatics Instr]
forall a. a -> [a] -> [a]
: [[NatCmmDecl RawCmmStatics Instr]]
-> [NatCmmDecl RawCmmStatics Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NatCmmDecl RawCmmStatics Instr]]
statics
os = Platform -> OS
platformOS Platform
platform
arch = Platform -> Arch
platformArch Platform
platform
case arch of
Arch
ArchPPC | OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSAIX -> [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return [NatCmmDecl RawCmmStatics Instr]
tops
| Bool
otherwise -> do
picBaseMb <- NatM (Maybe Reg)
getPicBaseMaybeNat
case picBaseMb of
Just Reg
picBase -> Arch
-> OS
-> Reg
-> [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
initializePicBase_ppc Arch
arch OS
os Reg
picBase [NatCmmDecl RawCmmStatics Instr]
tops
Maybe Reg
Nothing -> [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return [NatCmmDecl RawCmmStatics Instr]
tops
ArchPPC_64 PPC_64ABI
ELF_V1 -> [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
forall {m :: * -> *} {d} {h} {i}.
MonadGetUnique m =>
[GenCmmDecl d h (ListGraph i)] -> m [GenCmmDecl d h (ListGraph i)]
fixup_entry [NatCmmDecl RawCmmStatics Instr]
tops
ArchPPC_64 PPC_64ABI
ELF_V2 -> [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
forall {m :: * -> *} {d} {h} {i}.
MonadGetUnique m =>
[GenCmmDecl d h (ListGraph i)] -> m [GenCmmDecl d h (ListGraph i)]
fixup_entry [NatCmmDecl RawCmmStatics Instr]
tops
Arch
_ -> String -> NatM [NatCmmDecl RawCmmStatics Instr]
forall a. HasCallStack => String -> a
panic String
"PPC.cmmTopCodeGen: unknown arch"
where
fixup_entry :: [GenCmmDecl d h (ListGraph i)] -> m [GenCmmDecl d h (ListGraph i)]
fixup_entry (CmmProc h
info CLabel
lab [GlobalRegUse]
live (ListGraph (GenBasicBlock i
entry:[GenBasicBlock i]
blocks)) : [GenCmmDecl d h (ListGraph i)]
statics)
= do
let BasicBlock BlockId
bID [i]
insns = GenBasicBlock i
entry
bID' <- if CLabel
lab CLabel -> CLabel -> Bool
forall a. Eq a => a -> a -> Bool
== (BlockId -> CLabel
blockLbl BlockId
bID)
then m BlockId
forall (m :: * -> *). MonadGetUnique m => m BlockId
newBlockId
else BlockId -> m BlockId
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockId
bID
let b' = BlockId -> [i] -> GenBasicBlock i
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
bID' [i]
insns
return (CmmProc info lab live (ListGraph (b':blocks)) : statics)
fixup_entry [GenCmmDecl d h (ListGraph i)]
_ = String -> m [GenCmmDecl d h (ListGraph i)]
forall a. HasCallStack => String -> a
panic String
"cmmTopCodegen: Broken CmmProc"
cmmTopCodeGen (CmmData Section
sec RawCmmStatics
dat) =
[NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Section -> RawCmmStatics -> NatCmmDecl RawCmmStatics Instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec RawCmmStatics
dat]
basicBlockCodeGen
:: Block CmmNode C C
-> NatM ( [NatBasicBlock Instr]
, [NatCmmDecl RawCmmStatics Instr])
basicBlockCodeGen :: CmmBlock
-> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr])
basicBlockCodeGen CmmBlock
block = do
let (CmmNode C O
_, Block CmmNode O O
nodes, CmmNode O C
tail) = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
id :: BlockId
id = CmmBlock -> BlockId
forall (x :: Extensibility). Block CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block
stmts :: [CmmNode O O]
stmts = Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
nodes
dbg <- BlockId -> NatM (Maybe DebugBlock)
getDebugBlock (CmmBlock -> BlockId
forall (x :: Extensibility). Block CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block)
loc_instrs <- case dblSourceTick =<< dbg of
Just (SourceNote RealSrcSpan
span (LexicalFastString FastString
name))
-> do fileid <- FastString -> NatM Int
getFileId (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
span)
let line = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span; col =RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
span
return $ unitOL $ LOCATION fileid line col (unpackFS name)
Maybe CmmTickish
_ -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
mid_instrs <- stmtsToInstrs stmts
tail_instrs <- stmtToInstrs tail
let instrs = OrdList Instr
loc_instrs OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
mid_instrs OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
tail_instrs
let
(top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs
mkBlocks (NEWBLOCK BlockId
id) ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl RawCmmStatics h g]
statics)
= ([], BlockId -> [Instr] -> NatBasicBlock Instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id [Instr]
instrs NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
blocks, [GenCmmDecl RawCmmStatics h g]
statics)
mkBlocks (LDATA Section
sec RawCmmStatics
dat) ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl RawCmmStatics h g]
statics)
= ([Instr]
instrs, [NatBasicBlock Instr]
blocks, Section -> RawCmmStatics -> GenCmmDecl RawCmmStatics h g
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec RawCmmStatics
datGenCmmDecl RawCmmStatics h g
-> [GenCmmDecl RawCmmStatics h g] -> [GenCmmDecl RawCmmStatics h g]
forall a. a -> [a] -> [a]
:[GenCmmDecl RawCmmStatics h g]
statics)
mkBlocks Instr
instr ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl RawCmmStatics h g]
statics)
= (Instr
instrInstr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:[Instr]
instrs, [NatBasicBlock Instr]
blocks, [GenCmmDecl RawCmmStatics h g]
statics)
return (BasicBlock id top : other_blocks, statics)
stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
stmtsToInstrs :: forall (e :: Extensibility) (x :: Extensibility).
[CmmNode e x] -> NatM (OrdList Instr)
stmtsToInstrs [CmmNode e x]
stmts
= do instrss <- (CmmNode e x -> NatM (OrdList Instr))
-> [CmmNode e x] -> NatM [OrdList Instr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CmmNode e x -> NatM (OrdList Instr)
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> NatM (OrdList Instr)
stmtToInstrs [CmmNode e x]
stmts
return (concatOL instrss)
stmtToInstrs :: CmmNode e x -> NatM InstrBlock
stmtToInstrs :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> NatM (OrdList Instr)
stmtToInstrs CmmNode e x
stmt = do
config <- NatM NCGConfig
getConfig
platform <- getPlatform
case stmt of
CmmComment FastString
s -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (FastString -> Instr
COMMENT FastString
s))
CmmTick {} -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
CmmUnwind {} -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
CmmAssign CmmReg
reg CmmExpr
src
| CmmType -> Bool
isFloatType CmmType
ty -> Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_FltCode Format
format CmmReg
reg CmmExpr
src
| Platform -> Bool
target32Bit Platform
platform Bool -> Bool -> Bool
&&
CmmType -> Bool
isWord64 CmmType
ty -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_I64Code CmmReg
reg CmmExpr
src
| Bool
otherwise -> Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_IntCode Format
format CmmReg
reg CmmExpr
src
where ty :: CmmType
ty = CmmReg -> CmmType
cmmRegType CmmReg
reg
format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty
CmmStore CmmExpr
addr CmmExpr
src AlignmentSpec
_alignment
| CmmType -> Bool
isFloatType CmmType
ty -> Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_FltCode Format
format CmmExpr
addr CmmExpr
src
| Platform -> Bool
target32Bit Platform
platform Bool -> Bool -> Bool
&&
CmmType -> Bool
isWord64 CmmType
ty -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_I64Code CmmExpr
addr CmmExpr
src
| Bool
otherwise -> Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_IntCode Format
format CmmExpr
addr CmmExpr
src
where ty :: CmmType
ty = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
src
format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty
CmmUnsafeForeignCall ForeignTarget
target [CmmFormal]
result_regs [CmmExpr]
args
-> ForeignTarget -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
genCCall ForeignTarget
target [CmmFormal]
result_regs [CmmExpr]
args
CmmBranch BlockId
id -> BlockId -> NatM (OrdList Instr)
genBranch BlockId
id
CmmCondBranch CmmExpr
arg BlockId
true BlockId
false Maybe Bool
prediction -> do
b1 <- BlockId -> CmmExpr -> Maybe Bool -> NatM (OrdList Instr)
genCondJump BlockId
true CmmExpr
arg Maybe Bool
prediction
b2 <- genBranch false
return (b1 `appOL` b2)
CmmSwitch CmmExpr
arg SwitchTargets
ids -> NCGConfig -> CmmExpr -> SwitchTargets -> NatM (OrdList Instr)
genSwitch NCGConfig
config CmmExpr
arg SwitchTargets
ids
CmmCall { cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmExpr
arg
, cml_args_regs :: CmmNode O C -> [GlobalRegUse]
cml_args_regs = [GlobalRegUse]
gregs } -> CmmExpr -> [RegWithFormat] -> NatM (OrdList Instr)
genJump CmmExpr
arg (Platform -> [GlobalRegUse] -> [RegWithFormat]
jumpRegs Platform
platform [GlobalRegUse]
gregs)
CmmNode e x
_ ->
String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"stmtToInstrs: statement should have been cps'd away"
jumpRegs :: Platform -> [GlobalRegUse] -> [RegWithFormat]
jumpRegs :: Platform -> [GlobalRegUse] -> [RegWithFormat]
jumpRegs Platform
platform [GlobalRegUse]
gregs =
[ Reg -> Format -> RegWithFormat
RegWithFormat (RealReg -> Reg
RegReal RealReg
r) (CmmType -> Format
cmmTypeFormat CmmType
ty)
| GlobalRegUse GlobalReg
gr CmmType
ty <- [GlobalRegUse]
gregs
, Just RealReg
r <- [Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe Platform
platform GlobalReg
gr] ]
type InstrBlock
= OrdList Instr
data Register
= Fixed Format Reg InstrBlock
| Any Format (Reg -> InstrBlock)
swizzleRegisterRep :: Register -> Format -> Register
swizzleRegisterRep :: Register -> Format -> Register
swizzleRegisterRep (Fixed Format
_ Reg
reg OrdList Instr
code) Format
format = Format -> Reg -> OrdList Instr -> Register
Fixed Format
format Reg
reg OrdList Instr
code
swizzleRegisterRep (Any Format
_ Reg -> OrdList Instr
codefn) Format
format = Format -> (Reg -> OrdList Instr) -> Register
Any Format
format Reg -> OrdList Instr
codefn
getLocalRegReg :: LocalReg -> Reg
getLocalRegReg :: CmmFormal -> Reg
getLocalRegReg (LocalReg Unique
u CmmType
pk)
= VirtualReg -> Reg
RegVirtual (Unique -> Format -> VirtualReg
mkVirtualReg Unique
u (CmmType -> Format
cmmTypeFormat CmmType
pk))
getRegisterReg :: Platform -> CmmReg -> Reg
getRegisterReg :: Platform -> CmmReg -> Reg
getRegisterReg Platform
_ (CmmLocal CmmFormal
local_reg)
= CmmFormal -> Reg
getLocalRegReg CmmFormal
local_reg
getRegisterReg Platform
platform (CmmGlobal GlobalRegUse
mid)
= case Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe Platform
platform (GlobalRegUse -> GlobalReg
globalRegUse_reg GlobalRegUse
mid) of
Just RealReg
reg -> RealReg -> Reg
RegReal RealReg
reg
Maybe RealReg
Nothing -> String -> SDoc -> Reg
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegisterReg-memory" (CmmReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CmmReg -> SDoc) -> CmmReg -> SDoc
forall a b. (a -> b) -> a -> b
$ GlobalRegUse -> CmmReg
CmmGlobal GlobalRegUse
mid)
jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic
jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic
jumpTableEntry NCGConfig
config Maybe BlockId
Nothing = CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
0 (NCGConfig -> Width
ncgWordWidth NCGConfig
config))
jumpTableEntry NCGConfig
_ (Just BlockId
blockid) = CmmLit -> CmmStatic
CmmStaticLit (CLabel -> CmmLit
CmmLabel CLabel
blockLabel)
where blockLabel :: CLabel
blockLabel = BlockId -> CLabel
blockLbl BlockId
blockid
mangleIndexTree :: CmmExpr -> CmmExpr
mangleIndexTree :: CmmExpr -> CmmExpr
mangleIndexTree (CmmRegOff CmmReg
reg Int
off)
= MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
width) [CmmReg -> CmmExpr
CmmReg CmmReg
reg, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
width)]
where width :: Width
width = CmmType -> Width
typeWidth (CmmReg -> CmmType
cmmRegType CmmReg
reg)
mangleIndexTree CmmExpr
_
= String -> CmmExpr
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.mangleIndexTree: no match"
getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg :: CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
expr = do
r <- CmmExpr -> NatM Register
getRegister CmmExpr
expr
case r of
Any Format
rep Reg -> OrdList Instr
code -> do
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
return (tmp, code tmp)
Fixed Format
_ Reg
reg OrdList Instr
code ->
(Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg, OrdList Instr
code)
getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)
getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, OrdList Instr)
getI64Amodes CmmExpr
addrTree = do
Amode hi_addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
addrTree
case addrOffset hi_addr 4 of
Just AddrMode
lo_addr -> (AddrMode, AddrMode, OrdList Instr)
-> NatM (AddrMode, AddrMode, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode
hi_addr, AddrMode
lo_addr, OrdList Instr
addr_code)
Maybe AddrMode
Nothing -> do (hi_ptr, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
addrTree
return (AddrRegImm hi_ptr (ImmInt 0),
AddrRegImm hi_ptr (ImmInt 4),
code)
assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_I64Code CmmExpr
addrTree CmmExpr
valueTree = do
(hi_addr, lo_addr, addr_code) <- CmmExpr -> NatM (AddrMode, AddrMode, OrdList Instr)
getI64Amodes CmmExpr
addrTree
RegCode64 vcode rhi rlo <- iselExpr64 valueTree
let
mov_hi = Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
rhi AddrMode
hi_addr
mov_lo = Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
rlo AddrMode
lo_addr
return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)
assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_I64Code :: CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_I64Code (CmmLocal CmmFormal
lreg) CmmExpr
valueTree = do
RegCode64 vcode r_src_hi r_src_lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
valueTree
let Reg64 r_dst_hi r_dst_lo = localReg64 lreg
mov_lo = Reg -> Reg -> Instr
MR Reg
r_dst_lo Reg
r_src_lo
mov_hi = Reg -> Reg -> Instr
MR Reg
r_dst_hi Reg
r_src_hi
return (
vcode `snocOL` mov_lo `snocOL` mov_hi
)
assignReg_I64Code CmmReg
_ CmmExpr
_
= String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"assignReg_I64Code(powerpc): invalid lvalue"
iselExpr64 :: CmmExpr -> NatM (RegCode64 InstrBlock)
iselExpr64 :: CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 (CmmLoad CmmExpr
addrTree CmmType
ty AlignmentSpec
_) | CmmType -> Bool
isWord64 CmmType
ty = do
(hi_addr, lo_addr, addr_code) <- CmmExpr -> NatM (AddrMode, AddrMode, OrdList Instr)
getI64Amodes CmmExpr
addrTree
Reg64 rhi rlo <- getNewReg64
let mov_hi = Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
rhi AddrMode
hi_addr
mov_lo = Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
rlo AddrMode
lo_addr
return $ RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
rhi rlo
iselExpr64 (CmmReg (CmmLocal CmmFormal
local_reg)) = do
let Reg64 Reg
hi Reg
lo = HasDebugCallStack => CmmFormal -> Reg64
CmmFormal -> Reg64
localReg64 CmmFormal
local_reg
RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> Reg -> RegCode64 (OrdList Instr)
forall code. code -> Reg -> Reg -> RegCode64 code
RegCode64 OrdList Instr
forall a. OrdList a
nilOL Reg
hi Reg
lo)
iselExpr64 (CmmLit (CmmInt Integer
i Width
_)) = do
Reg64 rhi rlo <- NatM Reg64
getNewReg64
let
half0 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Word16)
half1 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) :: Word16)
half2 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
32) :: Word16)
half3 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
48) :: Word16)
code = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Reg -> Imm -> Instr
LIS Reg
rlo (Int -> Imm
ImmInt Int
half1),
Reg -> Reg -> RI -> Instr
OR Reg
rlo Reg
rlo (Imm -> RI
RIImm (Imm -> RI) -> Imm -> RI
forall a b. (a -> b) -> a -> b
$ Int -> Imm
ImmInt Int
half0),
Reg -> Imm -> Instr
LIS Reg
rhi (Int -> Imm
ImmInt Int
half3),
Reg -> Reg -> RI -> Instr
OR Reg
rhi Reg
rhi (Imm -> RI
RIImm (Imm -> RI) -> Imm -> RI
forall a b. (a -> b) -> a -> b
$ Int -> Imm
ImmInt Int
half2)
]
return (RegCode64 code rhi rlo)
iselExpr64 (CmmMachOp (MO_Add Width
_) [CmmExpr
e1,CmmExpr
e2]) = do
RegCode64 code1 r1hi r1lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
e1
RegCode64 code2 r2hi r2lo <- iselExpr64 e2
Reg64 rhi rlo <- getNewReg64
let
code = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
OrdList Instr
code2 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Reg -> Reg -> Reg -> Instr
ADDC Reg
rlo Reg
r1lo Reg
r2lo,
Reg -> Reg -> Reg -> Instr
ADDE Reg
rhi Reg
r1hi Reg
r2hi ]
return (RegCode64 code rhi rlo)
iselExpr64 (CmmMachOp (MO_Sub Width
_) [CmmExpr
e1,CmmExpr
e2]) = do
RegCode64 code1 r1hi r1lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
e1
RegCode64 code2 r2hi r2lo <- iselExpr64 e2
Reg64 rhi rlo <- getNewReg64
let
code = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
OrdList Instr
code2 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Reg -> Reg -> RI -> Instr
SUBFC Reg
rlo Reg
r2lo (Reg -> RI
RIReg Reg
r1lo),
Reg -> Reg -> Reg -> Instr
SUBFE Reg
rhi Reg
r2hi Reg
r1hi ]
return (RegCode64 code rhi rlo)
iselExpr64 (CmmMachOp (MO_UU_Conv Width
W32 Width
W64) [CmmExpr
expr]) = do
(expr_reg,expr_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
expr
Reg64 rhi rlo <- getNewReg64
let mov_hi = Reg -> Imm -> Instr
LI Reg
rhi (Int -> Imm
ImmInt Int
0)
mov_lo = Reg -> Reg -> Instr
MR Reg
rlo Reg
expr_reg
return $ RegCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
rhi rlo
iselExpr64 (CmmMachOp (MO_SS_Conv Width
W32 Width
W64) [CmmExpr
expr]) = do
(expr_reg,expr_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
expr
Reg64 rhi rlo <- getNewReg64
let mov_hi = Format -> Reg -> Reg -> RI -> Instr
SRA Format
II32 Reg
rhi Reg
expr_reg (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
31))
mov_lo = Reg -> Reg -> Instr
MR Reg
rlo Reg
expr_reg
return $ RegCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
rhi rlo
iselExpr64 CmmExpr
expr
= do
platform <- NatM Platform
getPlatform
pprPanic "iselExpr64(powerpc)" (pdoc platform expr)
getRegister :: CmmExpr -> NatM Register
getRegister :: CmmExpr -> NatM Register
getRegister CmmExpr
e = do config <- NatM NCGConfig
getConfig
getRegister' config (ncgPlatform config) e
getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
_ Platform
platform (CmmReg (CmmGlobal (GlobalRegUse GlobalReg
PicBaseReg CmmType
_)))
| OS
OSAIX <- Platform -> OS
platformOS Platform
platform = do
let code :: Reg -> OrdList Instr
code Reg
dst = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
dst AddrMode
tocAddr ]
tocAddr :: AddrMode
tocAddr = Reg -> Imm -> AddrMode
AddrRegImm Reg
toc (FastString -> Imm
ImmLit (String -> FastString
fsLit String
"ghc_toc_table[TC]"))
Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II32 Reg -> OrdList Instr
code)
| Platform -> Bool
target32Bit Platform
platform = do
reg <- Format -> NatM Reg
getPicBaseNat (Format -> NatM Reg) -> Format -> NatM Reg
forall a b. (a -> b) -> a -> b
$ Bool -> Format
archWordFormat (Platform -> Bool
target32Bit Platform
platform)
return (Fixed (archWordFormat (target32Bit platform))
reg nilOL)
| Bool
otherwise = Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed Format
II64 Reg
toc OrdList Instr
forall a. OrdList a
nilOL)
getRegister' NCGConfig
_ Platform
platform (CmmReg CmmReg
reg)
= Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed (CmmType -> Format
cmmTypeFormat (CmmReg -> CmmType
cmmRegType CmmReg
reg))
(Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg) OrdList Instr
forall a. OrdList a
nilOL)
getRegister' NCGConfig
config Platform
platform tree :: CmmExpr
tree@(CmmRegOff CmmReg
_ Int
_)
= NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
platform (CmmExpr -> CmmExpr
mangleIndexTree CmmExpr
tree)
getRegister' NCGConfig
_ Platform
platform (CmmMachOp (MO_UU_Conv Width
W64 Width
W32)
[CmmMachOp (MO_U_Shr Width
W64) [CmmExpr
x,CmmLit (CmmInt Integer
32 Width
_)]])
| Platform -> Bool
target32Bit Platform
platform = do
RegCode64 code _rhi rlo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
return $ Fixed II32 (getHiVRegFromLo rlo) code
getRegister' NCGConfig
_ Platform
platform (CmmMachOp (MO_SS_Conv Width
W64 Width
W32)
[CmmMachOp (MO_U_Shr Width
W64) [CmmExpr
x,CmmLit (CmmInt Integer
32 Width
_)]])
| Platform -> Bool
target32Bit Platform
platform = do
RegCode64 code _rhi rlo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
return $ Fixed II32 (getHiVRegFromLo rlo) code
getRegister' NCGConfig
_ Platform
platform (CmmMachOp (MO_UU_Conv Width
W64 Width
W32) [CmmExpr
x])
| Platform -> Bool
target32Bit Platform
platform = do
RegCode64 code _rhi rlo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
return $ Fixed II32 rlo code
getRegister' NCGConfig
_ Platform
platform (CmmMachOp (MO_SS_Conv Width
W64 Width
W32) [CmmExpr
x])
| Platform -> Bool
target32Bit Platform
platform = do
RegCode64 code _rhi rlo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
return $ Fixed II32 rlo code
getRegister' NCGConfig
_ Platform
platform (CmmLoad CmmExpr
mem CmmType
pk AlignmentSpec
_)
| Bool -> Bool
not (CmmType -> Bool
isWord64 CmmType
pk) = do
Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
let format = CmmType -> Format
cmmTypeFormat CmmType
pk
let code Reg
dst = Bool -> OrdList Instr -> OrdList Instr
forall a. HasCallStack => Bool -> a -> a
assert ((Platform -> Reg -> RegClass
targetClassOfReg Platform
platform Reg
dst RegClass -> RegClass -> Bool
forall a. Eq a => a -> a -> Bool
== RegClass
RcFloatOrVector) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== CmmType -> Bool
isFloatType CmmType
pk) (OrdList Instr -> OrdList Instr) -> OrdList Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$
OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
format Reg
dst AddrMode
addr
return (Any format code)
| Bool -> Bool
not (Platform -> Bool
target32Bit Platform
platform) = do
Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
DS CmmExpr
mem
let code Reg
dst = OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II64 Reg
dst AddrMode
addr
return (Any II64 code)
| Bool
otherwise = do
(hi_addr, lo_addr, addr_code) <- CmmExpr -> NatM (AddrMode, AddrMode, OrdList Instr)
getI64Amodes CmmExpr
mem
let code Reg
dst = OrdList Instr
addr_code
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
dst AddrMode
lo_addr
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II32 (Reg -> Reg
getHiVRegFromLo Reg
dst) AddrMode
hi_addr
return (Any II64 code)
getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_UU_Conv Width
W8 Width
W32) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
return (Any II32 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II8 Reg
dst AddrMode
addr))
getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_XX_Conv Width
W8 Width
W32) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
return (Any II32 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II8 Reg
dst AddrMode
addr))
getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_UU_Conv Width
W8 Width
W64) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
return (Any II64 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II8 Reg
dst AddrMode
addr))
getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_XX_Conv Width
W8 Width
W64) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
return (Any II64 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II8 Reg
dst AddrMode
addr))
getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_UU_Conv Width
W16 Width
W32) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
return (Any II32 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II16 Reg
dst AddrMode
addr))
getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_SS_Conv Width
W16 Width
W32) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
return (Any II32 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LA Format
II16 Reg
dst AddrMode
addr))
getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_UU_Conv Width
W16 Width
W64) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
return (Any II64 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II16 Reg
dst AddrMode
addr))
getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_SS_Conv Width
W16 Width
W64) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
return (Any II64 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LA Format
II16 Reg
dst AddrMode
addr))
getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_UU_Conv Width
W32 Width
W64) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
return (Any II64 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
dst AddrMode
addr))
getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_SS_Conv Width
W32 Width
W64) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
DS CmmExpr
mem
return (Any II64 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LA Format
II32 Reg
dst AddrMode
addr))
getRegister' NCGConfig
config Platform
platform (CmmMachOp (MO_RelaxedRead Width
w) [CmmExpr
e]) =
NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
platform (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad CmmExpr
e (Width -> CmmType
cmmBits Width
w) AlignmentSpec
NaturallyAligned)
getRegister' NCGConfig
config Platform
platform (CmmMachOp MachOp
mop [CmmExpr
x])
= case MachOp
mop of
MO_Not Width
rep -> Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_int Width
rep Reg -> Reg -> Instr
NOT
MO_F_Neg Width
w -> Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_float Width
w Reg -> Reg -> Instr
FNEG
MO_S_Neg Width
w -> Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_int Width
w Reg -> Reg -> Instr
NEG
MO_FF_Conv Width
W64 Width
W32 -> Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUCode Format
FF32 Reg -> Reg -> Instr
FRSP CmmExpr
x
MO_FF_Conv Width
W32 Width
W64 -> Format -> CmmExpr -> NatM Register
conversionNop Format
FF64 CmmExpr
x
MO_FS_Truncate Width
from Width
to -> Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int Width
from Width
to CmmExpr
x
MO_SF_Round Width
from Width
to -> Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP Width
from Width
to CmmExpr
x
MO_SS_Conv Width
from Width
to
| Width
from Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
>= Width
to -> Format -> CmmExpr -> NatM Register
conversionNop (Width -> Format
intFormat Width
to) CmmExpr
x
| Bool
otherwise -> Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_int Width
to (Format -> Reg -> Reg -> Instr
EXTS (Width -> Format
intFormat Width
from))
MO_UU_Conv Width
from Width
to
| Width
from Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
>= Width
to -> Format -> CmmExpr -> NatM Register
conversionNop (Width -> Format
intFormat Width
to) CmmExpr
x
| Bool
otherwise -> Width -> Width -> NatM Register
clearLeft Width
from Width
to
MO_XX_Conv Width
_ Width
to -> Format -> CmmExpr -> NatM Register
conversionNop (Width -> Format
intFormat Width
to) CmmExpr
x
MO_V_Broadcast {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VF_Broadcast {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VF_Neg {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MachOp
_ -> String -> NatM Register
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.getRegister: no match"
where
vectorsNeedLlvm :: a
vectorsNeedLlvm =
String -> a
forall a. HasCallStack => String -> a
sorry String
"SIMD operations on PowerPC currently require the LLVM backend"
triv_ucode_int :: Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_int Width
width Reg -> Reg -> Instr
instr = Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUCode (Width -> Format
intFormat Width
width) Reg -> Reg -> Instr
instr CmmExpr
x
triv_ucode_float :: Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_float Width
width Reg -> Reg -> Instr
instr = Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUCode (Width -> Format
floatFormat Width
width) Reg -> Reg -> Instr
instr CmmExpr
x
conversionNop :: Format -> CmmExpr -> NatM Register
conversionNop Format
new_format CmmExpr
expr
= do e_code <- NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
platform CmmExpr
expr
return (swizzleRegisterRep e_code new_format)
clearLeft :: Width -> Width -> NatM Register
clearLeft Width
from Width
to
= do (src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
let arch_fmt = Width -> Format
intFormat (Platform -> Width
wordWidth Platform
platform)
arch_bits = Width -> Int
widthInBits (Platform -> Width
wordWidth Platform
platform)
size = Width -> Int
widthInBits Width
from
code Reg
dst = OrdList Instr
code1 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Reg -> Reg -> Int -> Instr
CLRLI Format
arch_fmt Reg
dst Reg
src1 (Int
arch_bits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
size)
return (Any (intFormat to) code)
getRegister' NCGConfig
_ Platform
_ (CmmMachOp MachOp
mop [CmmExpr
x, CmmExpr
y])
= case MachOp
mop of
MO_F_Eq Width
_ -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
EQQ CmmExpr
x CmmExpr
y
MO_F_Ne Width
_ -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
NE CmmExpr
x CmmExpr
y
MO_F_Gt Width
_ -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
GTT CmmExpr
x CmmExpr
y
MO_F_Ge Width
_ -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
GE CmmExpr
x CmmExpr
y
MO_F_Lt Width
_ -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
LTT CmmExpr
x CmmExpr
y
MO_F_Le Width
_ -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
LE CmmExpr
x CmmExpr
y
MO_Eq Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
EQQ Width
rep CmmExpr
x CmmExpr
y
MO_Ne Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
NE Width
rep CmmExpr
x CmmExpr
y
MO_S_Gt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
GTT Width
rep CmmExpr
x CmmExpr
y
MO_S_Ge Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
GE Width
rep CmmExpr
x CmmExpr
y
MO_S_Lt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
LTT Width
rep CmmExpr
x CmmExpr
y
MO_S_Le Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
LE Width
rep CmmExpr
x CmmExpr
y
MO_U_Gt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
GU Width
rep CmmExpr
x CmmExpr
y
MO_U_Ge Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
GEU Width
rep CmmExpr
x CmmExpr
y
MO_U_Lt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
LU Width
rep CmmExpr
x CmmExpr
y
MO_U_Le Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
LEU Width
rep CmmExpr
x CmmExpr
y
MO_F_Add Width
w -> Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float Width
w Format -> Reg -> Reg -> Reg -> Instr
FADD
MO_F_Sub Width
w -> Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float Width
w Format -> Reg -> Reg -> Reg -> Instr
FSUB
MO_F_Mul Width
w -> Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float Width
w Format -> Reg -> Reg -> Reg -> Instr
FMUL
MO_F_Quot Width
w -> Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float Width
w Format -> Reg -> Reg -> Reg -> Instr
FDIV
MO_F_Min Width
w -> Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float Width
w Format -> Reg -> Reg -> Reg -> Instr
FMIN
MO_F_Max Width
w -> Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float Width
w Format -> Reg -> Reg -> Reg -> Instr
FMAX
MO_Add Width
W32 ->
case CmmExpr
y of
CmmLit (CmmInt Integer
imm Width
immrep) | Just Imm
_ <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W32 Bool
True Integer
imm
-> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
W32 Bool
True Reg -> Reg -> RI -> Instr
ADD CmmExpr
x (CmmLit -> CmmExpr
CmmLit (CmmLit -> CmmExpr) -> CmmLit -> CmmExpr
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
imm Width
immrep)
CmmLit CmmLit
lit
-> do
(src, srcCode) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
let imm = CmmLit -> Imm
litToImm CmmLit
lit
code Reg
dst = OrdList Instr
srcCode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Reg -> Reg -> Imm -> Instr
ADDIS Reg
dst Reg
src (Imm -> Imm
HA Imm
imm),
Reg -> Reg -> RI -> Instr
ADD Reg
dst Reg
dst (Imm -> RI
RIImm (Imm -> Imm
LO Imm
imm))
]
return (Any II32 code)
CmmExpr
_ -> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
W32 Bool
True Reg -> Reg -> RI -> Instr
ADD CmmExpr
x CmmExpr
y
MO_Add Width
rep -> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Bool
True Reg -> Reg -> RI -> Instr
ADD CmmExpr
x CmmExpr
y
MO_Sub Width
rep ->
case CmmExpr
y of
CmmLit (CmmInt Integer
imm Width
immrep) | Just Imm
_ <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
rep Bool
True (-Integer
imm)
-> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Bool
True Reg -> Reg -> RI -> Instr
ADD CmmExpr
x (CmmLit -> CmmExpr
CmmLit (CmmLit -> CmmExpr) -> CmmLit -> CmmExpr
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt (-Integer
imm) Width
immrep)
CmmExpr
_ -> case CmmExpr
x of
CmmLit (CmmInt Integer
imm Width
_)
| Just Imm
_ <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
rep Bool
True Integer
imm
-> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Bool
True Reg -> Reg -> RI -> Instr
SUBFC CmmExpr
y CmmExpr
x
CmmExpr
_ -> Format
-> (Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCodeNoImm' (Width -> Format
intFormat Width
rep) Reg -> Reg -> Reg -> Instr
SUBF CmmExpr
y CmmExpr
x
MO_Mul Width
rep -> Width
-> Bool
-> (Format -> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shiftMulCode Width
rep Bool
True Format -> Reg -> Reg -> RI -> Instr
MULL CmmExpr
x CmmExpr
y
MO_S_MulMayOflo Width
rep -> do
(src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
(src2, code2) <- getSomeReg y
let
format = Width -> Format
intFormat Width
rep
code Reg
dst = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Reg -> Reg -> Reg -> Instr
MULLO Format
format Reg
dst Reg
src1 Reg
src2
, Format -> Reg -> Instr
MFOV Format
format Reg
dst
]
return (Any format code)
MO_S_Quot Width
rep -> Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
divCode Width
rep Bool
True CmmExpr
x CmmExpr
y
MO_U_Quot Width
rep -> Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
divCode Width
rep Bool
False CmmExpr
x CmmExpr
y
MO_S_Rem Width
rep -> Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
remainder Width
rep Bool
True CmmExpr
x CmmExpr
y
MO_U_Rem Width
rep -> Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
remainder Width
rep Bool
False CmmExpr
x CmmExpr
y
MO_And Width
rep -> case CmmExpr
y of
(CmmLit (CmmInt Integer
imm Width
_)) | Integer
imm Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -Integer
8 Bool -> Bool -> Bool
|| Integer
imm Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -Integer
4
-> do
(src, srcCode) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
let clear_mask = if Integer
imm Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -Integer
4 then Int
2 else Int
3
fmt = Width -> Format
intFormat Width
rep
code Reg
dst = OrdList Instr
srcCode
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Reg -> Reg -> Int -> Instr
CLRRI Format
fmt Reg
dst Reg
src Int
clear_mask)
return (Any fmt code)
CmmExpr
_ -> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Bool
False Reg -> Reg -> RI -> Instr
AND CmmExpr
x CmmExpr
y
MO_Or Width
rep -> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Bool
False Reg -> Reg -> RI -> Instr
OR CmmExpr
x CmmExpr
y
MO_Xor Width
rep -> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Bool
False Reg -> Reg -> RI -> Instr
XOR CmmExpr
x CmmExpr
y
MO_Shl Width
rep -> Width
-> Bool
-> (Format -> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shiftMulCode Width
rep Bool
False Format -> Reg -> Reg -> RI -> Instr
SL CmmExpr
x CmmExpr
y
MO_S_Shr Width
rep -> Width
-> Bool
-> (Format -> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
srCode Width
rep Bool
True Format -> Reg -> Reg -> RI -> Instr
SRA CmmExpr
x CmmExpr
y
MO_U_Shr Width
rep -> Width
-> Bool
-> (Format -> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
srCode Width
rep Bool
False Format -> Reg -> Reg -> RI -> Instr
SR CmmExpr
x CmmExpr
y
MO_V_Extract {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_V_Add {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_V_Sub {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_V_Mul {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VS_Quot {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VS_Rem {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VS_Neg {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VU_Quot {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VU_Rem {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VF_Extract {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VF_Add {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VF_Sub {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VF_Neg {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VF_Mul {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VF_Quot {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_V_Shuffle {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VF_Shuffle {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VU_Min {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VU_Max {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VS_Min {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VS_Max {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VF_Min {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VF_Max {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MachOp
_ -> String -> NatM Register
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.getRegister: no match"
where
vectorsNeedLlvm :: a
vectorsNeedLlvm =
String -> a
forall a. HasCallStack => String -> a
sorry String
"SIMD operations on PowerPC currently require the LLVM backend"
triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float Width
width Format -> Reg -> Reg -> Reg -> Instr
instr = Format
-> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCodeNoImm (Width -> Format
floatFormat Width
width) Format -> Reg -> Reg -> Reg -> Instr
instr CmmExpr
x CmmExpr
y
remainder :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
remainder :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
remainder Width
rep Bool
sgn CmmExpr
x CmmExpr
y = do
let fmt :: Format
fmt = Width -> Format
intFormat Width
rep
tmp <- Format -> NatM Reg
getNewRegNat Format
fmt
code <- remainderCode rep sgn tmp x y
return (Any fmt code)
getRegister' NCGConfig
_ Platform
_ (CmmMachOp MachOp
mop [CmmExpr
x, CmmExpr
y, CmmExpr
z])
= case MachOp
mop of
MO_FMA FMASign
variant Int
l Width
w | Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 ->
case FMASign
variant of
FMASign
FMAdd -> Width
-> (Format -> Reg -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM Register
fma_code Width
w (FMASign -> Format -> Reg -> Reg -> Reg -> Reg -> Instr
FMADD FMASign
FMAdd) CmmExpr
x CmmExpr
y CmmExpr
z
FMASign
FMSub -> Width
-> (Format -> Reg -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM Register
fma_code Width
w (FMASign -> Format -> Reg -> Reg -> Reg -> Reg -> Instr
FMADD FMASign
FMSub) CmmExpr
x CmmExpr
y CmmExpr
z
FMASign
FNMAdd -> Width
-> (Format -> Reg -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM Register
fma_code Width
w (FMASign -> Format -> Reg -> Reg -> Reg -> Reg -> Instr
FMADD FMASign
FNMAdd) CmmExpr
x CmmExpr
y CmmExpr
z
FMASign
FNMSub -> Width
-> (Format -> Reg -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM Register
fma_code Width
w (FMASign -> Format -> Reg -> Reg -> Reg -> Reg -> Instr
FMADD FMASign
FNMSub) CmmExpr
x CmmExpr
y CmmExpr
z
| Bool
otherwise
-> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_V_Insert {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MO_VF_Insert {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
MachOp
_ -> String -> NatM Register
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.getRegister: no match"
where
vectorsNeedLlvm :: a
vectorsNeedLlvm =
String -> a
forall a. HasCallStack => String -> a
sorry String
"SIMD operations on PowerPC currently require the LLVM backend"
getRegister' NCGConfig
_ Platform
_ (CmmLit (CmmInt Integer
i Width
rep))
| Just Imm
imm <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
rep Bool
True Integer
i
= let
code :: Reg -> OrdList Instr
code Reg
dst = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Reg -> Imm -> Instr
LI Reg
dst Imm
imm)
in
Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
rep) Reg -> OrdList Instr
code)
getRegister' NCGConfig
config Platform
_ (CmmLit (CmmFloat Rational
f Width
frep)) = do
lbl <- NatM CLabel
getNewLabelNat
dynRef <- cmmMakeDynamicReference config DataReference lbl
Amode addr addr_code <- getAmode D dynRef
let format = Width -> Format
floatFormat Width
frep
code Reg
dst =
Section -> RawCmmStatics -> Instr
LDATA (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl)
(CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl [CmmLit -> CmmStatic
CmmStaticLit (Rational -> Width -> CmmLit
CmmFloat Rational
f Width
frep)])
Instr -> OrdList Instr -> OrdList Instr
forall a. a -> OrdList a -> OrdList a
`consOL` (OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
format Reg
dst AddrMode
addr)
return (Any format code)
getRegister' NCGConfig
config Platform
platform (CmmLit CmmLit
lit)
| Platform -> Bool
target32Bit Platform
platform
= let rep :: CmmType
rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
platform CmmLit
lit
imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
code :: Reg -> OrdList Instr
code Reg
dst = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Reg -> Imm -> Instr
LIS Reg
dst (Imm -> Imm
HA Imm
imm),
Reg -> Reg -> RI -> Instr
ADD Reg
dst Reg
dst (Imm -> RI
RIImm (Imm -> Imm
LO Imm
imm))
]
in Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (CmmType -> Format
cmmTypeFormat CmmType
rep) Reg -> OrdList Instr
code)
| Bool
otherwise
= do lbl <- NatM CLabel
getNewLabelNat
dynRef <- cmmMakeDynamicReference config DataReference lbl
Amode addr addr_code <- getAmode D dynRef
let rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
platform CmmLit
lit
format = CmmType -> Format
cmmTypeFormat CmmType
rep
code Reg
dst =
Section -> RawCmmStatics -> Instr
LDATA (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) (CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl [CmmLit -> CmmStatic
CmmStaticLit CmmLit
lit])
Instr -> OrdList Instr -> OrdList Instr
forall a. a -> OrdList a -> OrdList a
`consOL` (OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
format Reg
dst AddrMode
addr)
return (Any format code)
getRegister' NCGConfig
_ Platform
platform CmmExpr
other = String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister(ppc)" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
other)
extendSExpr :: Width -> Width -> CmmExpr -> CmmExpr
extendSExpr :: Width -> Width -> CmmExpr -> CmmExpr
extendSExpr Width
from Width
to CmmExpr
x = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_SS_Conv Width
from Width
to) [CmmExpr
x]
extendUExpr :: Width -> Width -> CmmExpr -> CmmExpr
extendUExpr :: Width -> Width -> CmmExpr -> CmmExpr
extendUExpr Width
from Width
to CmmExpr
x = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv Width
from Width
to) [CmmExpr
x]
data Amode
= Amode AddrMode InstrBlock
data InstrForm = D | DS
getAmode :: InstrForm -> CmmExpr -> NatM Amode
getAmode :: InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
inf tree :: CmmExpr
tree@(CmmRegOff CmmReg
_ Int
_)
= InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
inf (CmmExpr -> CmmExpr
mangleIndexTree CmmExpr
tree)
getAmode InstrForm
_ (CmmMachOp (MO_Sub Width
W32) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
_)])
| Just Imm
off <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W32 Bool
True (-Integer
i)
= do
(reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
return (Amode (AddrRegImm reg off) code)
getAmode InstrForm
_ (CmmMachOp (MO_Add Width
W32) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
_)])
| Just Imm
off <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W32 Bool
True Integer
i
= do
(reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
return (Amode (AddrRegImm reg off) code)
getAmode InstrForm
D (CmmMachOp (MO_Sub Width
W64) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
_)])
| Just Imm
off <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W64 Bool
True (-Integer
i)
= do
(reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
return (Amode (AddrRegImm reg off) code)
getAmode InstrForm
D (CmmMachOp (MO_Add Width
W64) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
_)])
| Just Imm
off <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W64 Bool
True Integer
i
= do
(reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
return (Amode (AddrRegImm reg off) code)
getAmode InstrForm
DS (CmmMachOp (MO_Sub Width
W64) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
_)])
| Just Imm
off <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W64 Bool
True (-Integer
i)
= do
(reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
(reg', off', code') <-
if i `mod` 4 == 0
then 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 InstrForm
DS (CmmMachOp (MO_Add Width
W64) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
_)])
| Just Imm
off <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W64 Bool
True Integer
i
= do
(reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
(reg', off', code') <-
if i `mod` 4 == 0
then 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 InstrForm
_ (CmmMachOp (MO_Add Width
W32) [CmmExpr
x, CmmLit CmmLit
lit])
= do
platform <- NatM Platform
getPlatform
(src, srcCode) <- getSomeReg x
let imm = CmmLit -> Imm
litToImm CmmLit
lit
case () of
()
_ | OS
OSAIX <- Platform -> OS
platformOS Platform
platform
, CmmLit -> Bool
isCmmLabelType CmmLit
lit ->
Amode -> NatM Amode
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
src Imm
imm) OrdList Instr
srcCode)
| Bool
otherwise -> do
tmp <- Format -> NatM Reg
getNewRegNat Format
II32
let code = OrdList Instr
srcCode OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Imm -> Instr
ADDIS Reg
tmp Reg
src (Imm -> Imm
HA Imm
imm)
return (Amode (AddrRegImm tmp (LO imm)) code)
where
isCmmLabelType :: CmmLit -> Bool
isCmmLabelType (CmmLabel {}) = Bool
True
isCmmLabelType (CmmLabelOff {}) = Bool
True
isCmmLabelType (CmmLabelDiffOff {}) = Bool
True
isCmmLabelType CmmLit
_ = Bool
False
getAmode InstrForm
_ (CmmLit CmmLit
lit)
= do
platform <- NatM Platform
getPlatform
case platformArch platform of
Arch
ArchPPC -> do
tmp <- Format -> NatM Reg
getNewRegNat Format
II32
let imm = CmmLit -> Imm
litToImm CmmLit
lit
code = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Reg -> Imm -> Instr
LIS Reg
tmp (Imm -> Imm
HA Imm
imm))
return (Amode (AddrRegImm tmp (LO imm)) code)
Arch
_ -> do
tmp <- Format -> NatM Reg
getNewRegNat Format
II64
let imm = CmmLit -> Imm
litToImm CmmLit
lit
code = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Reg -> Imm -> Instr
LIS Reg
tmp (Imm -> Imm
HIGHESTA Imm
imm),
Reg -> Reg -> RI -> Instr
OR Reg
tmp Reg
tmp (Imm -> RI
RIImm (Imm -> Imm
HIGHERA Imm
imm)),
Format -> Reg -> Reg -> RI -> Instr
SL Format
II64 Reg
tmp Reg
tmp (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
32)),
Reg -> Reg -> Imm -> Instr
ORIS Reg
tmp Reg
tmp (Imm -> Imm
HA Imm
imm)
]
return (Amode (AddrRegImm tmp (LO imm)) code)
getAmode InstrForm
_ (CmmMachOp (MO_Add Width
W32) [CmmExpr
x, CmmExpr
y])
= do
(regX, codeX) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
(regY, codeY) <- getSomeReg y
return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
getAmode InstrForm
_ (CmmMachOp (MO_Add Width
W64) [CmmExpr
x, CmmExpr
y])
= do
(regX, codeX) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
(regY, codeY) <- getSomeReg y
return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
getAmode InstrForm
_ CmmExpr
other
= do
(reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
other
let
off = Int -> Imm
ImmInt Int
0
return (Amode (AddrRegImm reg off) code)
data CondCode
= CondCode Bool Cond InstrBlock
getCondCode :: CmmExpr -> NatM CondCode
getCondCode :: CmmExpr -> NatM CondCode
getCondCode (CmmMachOp MachOp
mop [CmmExpr
x, CmmExpr
y])
= case MachOp
mop of
MO_F_Eq Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
EQQ CmmExpr
x CmmExpr
y
MO_F_Ne Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
NE CmmExpr
x CmmExpr
y
MO_F_Gt Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
GTT CmmExpr
x CmmExpr
y
MO_F_Ge Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
GE CmmExpr
x CmmExpr
y
MO_F_Lt Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
LTT CmmExpr
x CmmExpr
y
MO_F_Le Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
LE CmmExpr
x CmmExpr
y
MO_F_Eq Width
W64 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
EQQ CmmExpr
x CmmExpr
y
MO_F_Ne Width
W64 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
NE CmmExpr
x CmmExpr
y
MO_F_Gt Width
W64 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
GTT CmmExpr
x CmmExpr
y
MO_F_Ge Width
W64 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
GE CmmExpr
x CmmExpr
y
MO_F_Lt Width
W64 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
LTT CmmExpr
x CmmExpr
y
MO_F_Le Width
W64 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
LE CmmExpr
x CmmExpr
y
MO_Eq Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
EQQ Width
rep CmmExpr
x CmmExpr
y
MO_Ne Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
NE Width
rep CmmExpr
x CmmExpr
y
MO_S_Gt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
GTT Width
rep CmmExpr
x CmmExpr
y
MO_S_Ge Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
GE Width
rep CmmExpr
x CmmExpr
y
MO_S_Lt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
LTT Width
rep CmmExpr
x CmmExpr
y
MO_S_Le Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
LE Width
rep CmmExpr
x CmmExpr
y
MO_U_Gt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
GU Width
rep CmmExpr
x CmmExpr
y
MO_U_Ge Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
GEU Width
rep CmmExpr
x CmmExpr
y
MO_U_Lt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
LU Width
rep CmmExpr
x CmmExpr
y
MO_U_Le Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
LEU Width
rep CmmExpr
x CmmExpr
y
MachOp
_ -> String -> SDoc -> NatM CondCode
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getCondCode(powerpc)" (MachOp -> SDoc
pprMachOp MachOp
mop)
getCondCode CmmExpr
_ = String -> NatM CondCode
forall a. HasCallStack => String -> a
panic String
"getCondCode(2)(powerpc)"
condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
cond Width
width CmmExpr
x CmmExpr
y = do
platform <- NatM Platform
getPlatform
condIntCode' (target32Bit platform) cond width x y
condIntCode' :: Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode' :: Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode' Bool
True Cond
cond Width
W64 CmmExpr
x CmmExpr
y
| Cond -> Bool
condUnsigned Cond
cond
= do
RegCode64 code_x x_hi x_lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
RegCode64 code_y y_hi y_lo <- iselExpr64 y
end_lbl <- getBlockIdNat
let code = OrdList Instr
code_x OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ Format -> Reg -> RI -> Instr
CMPL Format
II32 Reg
x_hi (Reg -> RI
RIReg Reg
y_hi)
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
end_lbl Maybe Bool
forall a. Maybe a
Nothing
, Format -> Reg -> RI -> Instr
CMPL Format
II32 Reg
x_lo (Reg -> RI
RIReg Reg
y_lo)
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
end_lbl Maybe Bool
forall a. Maybe a
Nothing
, BlockId -> Instr
NEWBLOCK BlockId
end_lbl
]
return (CondCode False cond code)
| Bool
otherwise
= do
RegCode64 code_x x_hi x_lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
RegCode64 code_y y_hi y_lo <- iselExpr64 y
end_lbl <- getBlockIdNat
cmp_lo <- getBlockIdNat
let code = OrdList Instr
code_x OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ Format -> Reg -> RI -> Instr
CMP Format
II32 Reg
x_hi (Reg -> RI
RIReg Reg
y_hi)
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
end_lbl Maybe Bool
forall a. Maybe a
Nothing
, Format -> Reg -> RI -> Instr
CMP Format
II32 Reg
x_hi (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
0))
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
LE BlockId
cmp_lo Maybe Bool
forall a. Maybe a
Nothing
, Format -> Reg -> RI -> Instr
CMPL Format
II32 Reg
x_lo (Reg -> RI
RIReg Reg
y_lo)
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
end_lbl Maybe Bool
forall a. Maybe a
Nothing
, BlockId -> Instr
NEWBLOCK BlockId
cmp_lo
, Format -> Reg -> RI -> Instr
CMPL Format
II32 Reg
y_lo (Reg -> RI
RIReg Reg
x_lo)
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
end_lbl Maybe Bool
forall a. Maybe a
Nothing
, BlockId -> Instr
NEWBLOCK BlockId
end_lbl
]
return (CondCode False cond code)
condIntCode' Bool
_ Cond
cond Width
_ (CmmMachOp (MO_And Width
_) [CmmExpr
x, CmmLit (CmmInt Integer
imm Width
rep)])
(CmmLit (CmmInt Integer
0 Width
_))
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Cond -> Bool
condUnsigned Cond
cond,
Just Imm
src2 <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
rep Bool
False Integer
imm
= do
(src1, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
let code' = OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> RI -> Instr
AND Reg
r0 Reg
src1 (Imm -> RI
RIImm Imm
src2)
return (CondCode False cond code')
condIntCode' Bool
_ Cond
cond Width
width CmmExpr
x (CmmLit (CmmInt Integer
y Width
rep))
| Just Imm
src2 <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
rep (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Cond -> Bool
condUnsigned Cond
cond) Integer
y
= do
let op_len :: Width
op_len = Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width
let extend :: CmmExpr -> CmmExpr
extend = if Cond -> Bool
condUnsigned Cond
cond then Width -> Width -> CmmExpr -> CmmExpr
extendUExpr Width
width Width
op_len
else Width -> Width -> CmmExpr -> CmmExpr
extendSExpr Width
width Width
op_len
(src1, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg (CmmExpr -> CmmExpr
extend CmmExpr
x)
let format = Width -> Format
intFormat Width
op_len
code' = OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
(if Cond -> Bool
condUnsigned Cond
cond then Format -> Reg -> RI -> Instr
CMPL else Format -> Reg -> RI -> Instr
CMP) Format
format Reg
src1 (Imm -> RI
RIImm Imm
src2)
return (CondCode False cond code')
condIntCode' Bool
_ Cond
cond Width
width CmmExpr
x CmmExpr
y = do
let op_len :: Width
op_len = Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width
let extend :: CmmExpr -> CmmExpr
extend = if Cond -> Bool
condUnsigned Cond
cond then Width -> Width -> CmmExpr -> CmmExpr
extendUExpr Width
width Width
op_len
else Width -> Width -> CmmExpr -> CmmExpr
extendSExpr Width
width Width
op_len
(src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg (CmmExpr -> CmmExpr
extend CmmExpr
x)
(src2, code2) <- getSomeReg (extend y)
let format = Width -> Format
intFormat Width
op_len
code' = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
(if Cond -> Bool
condUnsigned Cond
cond then Format -> Reg -> RI -> Instr
CMPL else Format -> Reg -> RI -> Instr
CMP) Format
format Reg
src1 (Reg -> RI
RIReg Reg
src2)
return (CondCode False cond code')
condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
cond CmmExpr
x CmmExpr
y = do
(src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
(src2, code2) <- getSomeReg y
let
code' = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
FCMP Reg
src1 Reg
src2
code'' = case Cond
cond of
Cond
GE -> OrdList Instr
code' OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Int -> Int -> Int -> Instr
CRNOR Int
ltbit Int
eqbit Int
gtbit
Cond
LE -> OrdList Instr
code' OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Int -> Int -> Int -> Instr
CRNOR Int
gtbit Int
eqbit Int
ltbit
Cond
_ -> OrdList Instr
code'
where
ltbit :: Int
ltbit = Int
0 ; eqbit :: Int
eqbit = Int
2 ; gtbit :: Int
gtbit = Int
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 :: Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_IntCode Format
pk CmmExpr
addr CmmExpr
src = do
(srcReg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
src
Amode dstAddr addr_code <- case pk of
Format
II64 -> InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
DS CmmExpr
addr
Format
_ -> InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
addr
return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr
assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_IntCode Format
_ CmmReg
reg CmmExpr
src
= do
platform <- NatM Platform
getPlatform
let dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg
r <- getRegister src
return $ case r of
Any Format
_ Reg -> OrdList Instr
code -> Reg -> OrdList Instr
code Reg
dst
Fixed Format
_ Reg
freg OrdList Instr
fcode -> OrdList Instr
fcode OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
MR Reg
dst Reg
freg
assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_FltCode = Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_IntCode
assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_FltCode = Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_IntCode
genJump :: CmmExpr -> [RegWithFormat] -> NatM InstrBlock
genJump :: CmmExpr -> [RegWithFormat] -> NatM (OrdList Instr)
genJump (CmmLit (CmmLabel CLabel
lbl)) [RegWithFormat]
regs
= OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CLabel -> [RegWithFormat] -> Instr
JMP CLabel
lbl [RegWithFormat]
regs)
genJump CmmExpr
tree [RegWithFormat]
gregs
= do
platform <- NatM Platform
getPlatform
genJump' tree (platformToGCP platform) gregs
genJump' :: CmmExpr -> GenCCallPlatform -> [RegWithFormat] -> NatM InstrBlock
genJump' :: CmmExpr
-> GenCCallPlatform -> [RegWithFormat] -> NatM (OrdList Instr)
genJump' CmmExpr
tree (GCP64ELF Int
1) [RegWithFormat]
regs
= do
(target,code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
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' CmmExpr
tree (GCP64ELF Int
2) [RegWithFormat]
regs
= do
(target,code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
tree
return (code
`snocOL` MR r12 target
`snocOL` MTCTR r12
`snocOL` BCTR [] Nothing regs)
genJump' CmmExpr
tree GenCCallPlatform
_ [RegWithFormat]
regs
= do
(target,code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
tree
return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing regs)
genBranch :: BlockId -> NatM InstrBlock
genBranch :: BlockId -> NatM (OrdList Instr)
genBranch = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> (BlockId -> OrdList Instr) -> BlockId -> NatM (OrdList Instr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL ([Instr] -> OrdList Instr)
-> (BlockId -> [Instr]) -> BlockId -> OrdList Instr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> [Instr]
mkJumpInstr
genCondJump
:: BlockId
-> CmmExpr
-> Maybe Bool
-> NatM InstrBlock
genCondJump :: BlockId -> CmmExpr -> Maybe Bool -> NatM (OrdList Instr)
genCondJump BlockId
id CmmExpr
bool Maybe Bool
prediction = do
CondCode _ cond code <- CmmExpr -> NatM CondCode
getCondCode CmmExpr
bool
return (code `snocOL` BCC cond id prediction)
genCCall :: ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM InstrBlock
genCCall :: ForeignTarget -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
genCCall (PrimTarget CallishMachOp
MO_AcquireFence) [CmmFormal]
_ [CmmExpr]
_
= OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
LWSYNC
genCCall (PrimTarget CallishMachOp
MO_ReleaseFence) [CmmFormal]
_ [CmmExpr]
_
= OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
LWSYNC
genCCall (PrimTarget CallishMachOp
MO_SeqCstFence) [CmmFormal]
_ [CmmExpr]
_
= OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
HWSYNC
genCCall (PrimTarget CallishMachOp
MO_Touch) [CmmFormal]
_ [CmmExpr]
_
= OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
forall a. OrdList a
nilOL
genCCall (PrimTarget (MO_Prefetch_Data Int
_)) [CmmFormal]
_ [CmmExpr]
_
= OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
forall a. OrdList a
nilOL
genCCall (PrimTarget (MO_AtomicRMW Width
width AtomicMachOp
amop)) [CmmFormal
dst] [CmmExpr
addr, CmmExpr
n]
= do let fmt :: Format
fmt = Width -> Format
intFormat Width
width
reg_dst :: Reg
reg_dst = CmmFormal -> Reg
getLocalRegReg CmmFormal
dst
(instr, n_code) <- case AtomicMachOp
amop of
AtomicMachOp
AMO_Add -> (Reg -> Reg -> RI -> Instr)
-> Bool -> Reg -> NatM (Instr, OrdList Instr)
getSomeRegOrImm Reg -> Reg -> RI -> Instr
ADD Bool
True Reg
reg_dst
AtomicMachOp
AMO_Sub -> case CmmExpr
n of
CmmLit (CmmInt Integer
i Width
_)
| Just Imm
imm <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
width Bool
True (-Integer
i)
-> (Instr, OrdList Instr) -> NatM (Instr, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Reg -> RI -> Instr
ADD Reg
reg_dst Reg
reg_dst (Imm -> RI
RIImm Imm
imm), OrdList Instr
forall a. OrdList a
nilOL)
CmmExpr
_
-> do
(n_reg, n_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
n
return (SUBF reg_dst n_reg reg_dst, n_code)
AtomicMachOp
AMO_And -> (Reg -> Reg -> RI -> Instr)
-> Bool -> Reg -> NatM (Instr, OrdList Instr)
getSomeRegOrImm Reg -> Reg -> RI -> Instr
AND Bool
False Reg
reg_dst
AtomicMachOp
AMO_Nand -> do (n_reg, n_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
n
return (NAND reg_dst reg_dst n_reg, n_code)
AtomicMachOp
AMO_Or -> (Reg -> Reg -> RI -> Instr)
-> Bool -> Reg -> NatM (Instr, OrdList Instr)
getSomeRegOrImm Reg -> Reg -> RI -> Instr
OR Bool
False Reg
reg_dst
AtomicMachOp
AMO_Xor -> (Reg -> Reg -> RI -> Instr)
-> Bool -> Reg -> NatM (Instr, OrdList Instr)
getSomeRegOrImm Reg -> Reg -> RI -> Instr
XOR Bool
False Reg
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 :: CmmExpr -> NatM Amode
getAmodeIndex (CmmMachOp (MO_Add Width
_) [CmmExpr
x, CmmExpr
y])
= do
(regX, codeX) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
(regY, codeY) <- getSomeReg y
return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
getAmodeIndex CmmExpr
other
= do
(reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
other
return (Amode (AddrRegReg r0 reg) code)
getSomeRegOrImm :: (Reg -> Reg -> RI -> Instr)
-> Bool -> Reg -> NatM (Instr, OrdList Instr)
getSomeRegOrImm Reg -> Reg -> RI -> Instr
op Bool
sign Reg
dst
= case CmmExpr
n of
CmmLit (CmmInt Integer
i Width
_) | Just Imm
imm <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
width Bool
sign Integer
i
-> (Instr, OrdList Instr) -> NatM (Instr, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Reg -> RI -> Instr
op Reg
dst Reg
dst (Imm -> RI
RIImm Imm
imm), OrdList Instr
forall a. OrdList a
nilOL)
CmmExpr
_
-> do
(n_reg, n_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
n
return (op dst dst (RIReg n_reg), n_code)
genCCall (PrimTarget (MO_AtomicRead Width
width MemoryOrdering
_)) [CmmFormal
dst] [CmmExpr
addr]
= do let fmt :: Format
fmt = Width -> Format
intFormat Width
width
reg_dst :: Reg
reg_dst = CmmFormal -> Reg
getLocalRegReg CmmFormal
dst
form :: InstrForm
form = if Width -> Int
widthInBits Width
width Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
64 then InstrForm
DS else InstrForm
D
Amode addr_reg addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
form CmmExpr
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
width MemoryOrdering
_)) [] [CmmExpr
addr, CmmExpr
val] = do
code <- Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_IntCode (Width -> Format
intFormat Width
width) CmmExpr
addr CmmExpr
val
return $ unitOL HWSYNC `appOL` code
genCCall (PrimTarget (MO_Cmpxchg Width
width)) [CmmFormal
dst] [CmmExpr
addr, CmmExpr
old, CmmExpr
new]
| Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32 Bool -> Bool -> Bool
|| Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64
= do
(old_reg, old_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
old
(new_reg, new_code) <- getSomeReg new
(addr_reg, addr_code) <- getSomeReg addr
lbl_retry <- getBlockIdNat
lbl_eq <- getBlockIdNat
lbl_end <- getBlockIdNat
let reg_dst = CmmFormal -> Reg
getLocalRegReg CmmFormal
dst
code = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ Instr
HWSYNC
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl_retry Maybe Bool
forall a. Maybe a
Nothing
, BlockId -> Instr
NEWBLOCK BlockId
lbl_retry
, Format -> Reg -> AddrMode -> Instr
LDR Format
format Reg
reg_dst (Reg -> Reg -> AddrMode
AddrRegReg Reg
r0 Reg
addr_reg)
, Format -> Reg -> RI -> Instr
CMP Format
format Reg
reg_dst (Reg -> RI
RIReg Reg
old_reg)
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
lbl_end Maybe Bool
forall a. Maybe a
Nothing
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl_eq Maybe Bool
forall a. Maybe a
Nothing
, BlockId -> Instr
NEWBLOCK BlockId
lbl_eq
, Format -> Reg -> AddrMode -> Instr
STC Format
format Reg
new_reg (Reg -> Reg -> AddrMode
AddrRegReg Reg
r0 Reg
addr_reg)
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
lbl_retry Maybe Bool
forall a. Maybe a
Nothing
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl_end Maybe Bool
forall a. Maybe a
Nothing
, BlockId -> Instr
NEWBLOCK BlockId
lbl_end
, Instr
ISYNC
]
return $ addr_code `appOL` new_code `appOL` old_code `appOL` code
where
format :: Format
format = Width -> Format
intFormat Width
width
genCCall (PrimTarget (MO_Clz Width
width)) [CmmFormal
dst] [CmmExpr
src]
= do platform <- NatM Platform
getPlatform
let reg_dst = CmmFormal -> Reg
getLocalRegReg CmmFormal
dst
if target32Bit platform && width == W64
then do
RegCode64 code vr_hi vr_lo <- iselExpr64 src
lbl1 <- getBlockIdNat
lbl2 <- getBlockIdNat
lbl3 <- getBlockIdNat
let cntlz = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Reg -> RI -> Instr
CMPL Format
II32 Reg
vr_hi (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
0))
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
lbl2 Maybe Bool
forall a. Maybe a
Nothing
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl1 Maybe Bool
forall a. Maybe a
Nothing
, BlockId -> Instr
NEWBLOCK BlockId
lbl1
, Format -> Reg -> Reg -> Instr
CNTLZ Format
II32 Reg
reg_dst Reg
vr_lo
, Reg -> Reg -> RI -> Instr
ADD Reg
reg_dst Reg
reg_dst (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
32))
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl3 Maybe Bool
forall a. Maybe a
Nothing
, BlockId -> Instr
NEWBLOCK BlockId
lbl2
, Format -> Reg -> Reg -> Instr
CNTLZ Format
II32 Reg
reg_dst Reg
vr_hi
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl3 Maybe Bool
forall a. Maybe a
Nothing
, BlockId -> Instr
NEWBLOCK BlockId
lbl3
]
return $ code `appOL` cntlz
else do
let format = if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 then Format
II64 else Format
II32
(s_reg, s_code) <- getSomeReg src
(pre, reg , post) <-
case width of
Width
W64 -> (OrdList Instr, Reg, OrdList Instr)
-> NatM (OrdList Instr, Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
forall a. OrdList a
nilOL, Reg
s_reg, OrdList Instr
forall a. OrdList a
nilOL)
Width
W32 -> (OrdList Instr, Reg, OrdList Instr)
-> NatM (OrdList Instr, Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
forall a. OrdList a
nilOL, Reg
s_reg, OrdList Instr
forall a. OrdList a
nilOL)
Width
W16 -> do
reg_tmp <- Format -> NatM Reg
getNewRegNat Format
format
return
( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 65535))
, reg_tmp
, unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-16)))
)
Width
W8 -> do
reg_tmp <- Format -> NatM Reg
getNewRegNat Format
format
return
( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 255))
, reg_tmp
, unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-24)))
)
Width
_ -> String -> NatM (OrdList Instr, Reg, OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCall: Clz wrong format"
let cntlz = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Reg -> Reg -> Instr
CNTLZ Format
format Reg
reg_dst Reg
reg)
return $ s_code `appOL` pre `appOL` cntlz `appOL` post
genCCall (PrimTarget (MO_Ctz Width
width)) [CmmFormal
dst] [CmmExpr
src]
= do platform <- NatM Platform
getPlatform
let reg_dst = CmmFormal -> Reg
getLocalRegReg CmmFormal
dst
if target32Bit platform && width == W64
then do
let format = Format
II32
RegCode64 code vr_hi 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 cnttz64 = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Reg -> RI -> Instr
CMPL Format
format Reg
vr_lo (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
0))
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
lbl2 Maybe Bool
forall a. Maybe a
Nothing
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl1 Maybe Bool
forall a. Maybe a
Nothing
, BlockId -> Instr
NEWBLOCK BlockId
lbl1
, Reg -> Reg -> RI -> Instr
ADD Reg
x' Reg
vr_hi (Imm -> RI
RIImm (Int -> Imm
ImmInt (-Int
1)))
, Reg -> Reg -> Reg -> Instr
ANDC Reg
x'' Reg
x' Reg
vr_hi
, Format -> Reg -> Reg -> Instr
CNTLZ Format
format Reg
r' Reg
x''
, Reg -> Reg -> RI -> Instr
SUBFC Reg
reg_dst Reg
r' (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
64))
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl3 Maybe Bool
forall a. Maybe a
Nothing
, BlockId -> Instr
NEWBLOCK BlockId
lbl2
]
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
cnttzlo OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl3 Maybe Bool
forall a. Maybe a
Nothing
, BlockId -> Instr
NEWBLOCK BlockId
lbl3
]
return $ code `appOL` cnttz64
else do
let format = if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 then Format
II64 else Format
II32
(s_reg, s_code) <- getSomeReg src
(reg_ctz, pre_code) <-
case width of
Width
W64 -> (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
s_reg, OrdList Instr
forall a. OrdList a
nilOL)
Width
W32 -> (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
s_reg, OrdList Instr
forall a. OrdList a
nilOL)
Width
W16 -> do
reg_tmp <- Format -> NatM Reg
getNewRegNat Format
format
return (reg_tmp, unitOL $ ORIS reg_tmp s_reg (ImmInt 1))
Width
W8 -> do
reg_tmp <- Format -> NatM Reg
getNewRegNat Format
format
return (reg_tmp, unitOL $ OR reg_tmp s_reg (RIImm (ImmInt 256)))
Width
_ -> String -> NatM (Reg, OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCall: Ctz wrong format"
ctz_code <- cnttz format reg_dst reg_ctz
return $ s_code `appOL` pre_code `appOL` ctz_code
where
cnttz :: Format -> Reg -> Reg -> NatM (OrdList Instr)
cnttz Format
format Reg
dst Reg
src = do
let format_bits :: Int
format_bits = Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Format -> Int
formatInBytes Format
format
x' <- Format -> NatM Reg
getNewRegNat Format
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 ForeignTarget
target [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
= do platform <- NatM Platform
getPlatform
case target of
PrimTarget (MO_S_QuotRem Width
width) -> Bool -> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
divOp1 Bool
True Width
width
[CmmFormal]
dest_regs [CmmExpr]
argsAndHints
PrimTarget (MO_U_QuotRem Width
width) -> Bool -> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
divOp1 Bool
False Width
width
[CmmFormal]
dest_regs [CmmExpr]
argsAndHints
PrimTarget (MO_U_QuotRem2 Width
width) -> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
divOp2 Width
width [CmmFormal]
dest_regs
[CmmExpr]
argsAndHints
PrimTarget (MO_U_Mul2 Width
width) -> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
multOp2 Width
width [CmmFormal]
dest_regs
[CmmExpr]
argsAndHints
PrimTarget (MO_Add2 Width
_) -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
add2Op [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
PrimTarget (MO_AddWordC Width
_) -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
addcOp [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
PrimTarget (MO_SubWordC Width
_) -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
subcOp [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
PrimTarget (MO_AddIntC Width
width) -> (Reg -> Reg -> Reg -> Instr)
-> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
addSubCOp Reg -> Reg -> Reg -> Instr
ADDO Width
width
[CmmFormal]
dest_regs [CmmExpr]
argsAndHints
PrimTarget (MO_SubIntC Width
width) -> (Reg -> Reg -> Reg -> Instr)
-> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
addSubCOp Reg -> Reg -> Reg -> Instr
SUBFO Width
width
[CmmFormal]
dest_regs [CmmExpr]
argsAndHints
PrimTarget CallishMachOp
MO_F64_Fabs -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
fabs [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
PrimTarget CallishMachOp
MO_F32_Fabs -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
fabs [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
ForeignTarget
_ -> do config <- NatM NCGConfig
getConfig
genCCall' config (platformToGCP platform)
target dest_regs argsAndHints
where divOp1 :: Bool -> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
divOp1 Bool
signed Width
width [CmmFormal
res_q, CmmFormal
res_r] [CmmExpr
arg_x, CmmExpr
arg_y]
= do let reg_q :: Reg
reg_q = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_q
reg_r :: Reg
reg_r = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_r
Width
-> Bool -> Reg -> CmmExpr -> CmmExpr -> NatM (Reg -> OrdList Instr)
remainderCode Width
width Bool
signed Reg
reg_q CmmExpr
arg_x CmmExpr
arg_y
NatM (Reg -> OrdList Instr) -> NatM Reg -> NatM (OrdList Instr)
forall a b. NatM (a -> b) -> NatM a -> NatM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Reg -> NatM Reg
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Reg
reg_r
divOp1 Bool
_ Width
_ [CmmFormal]
_ [CmmExpr]
_
= String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCCall: Wrong number of arguments for divOp1"
divOp2 :: Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
divOp2 Width
width [CmmFormal
res_q, CmmFormal
res_r]
[CmmExpr
arg_x_high, CmmExpr
arg_x_low, CmmExpr
arg_y]
= do let reg_q :: Reg
reg_q = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_q
reg_r :: Reg
reg_r = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_r
fmt :: Format
fmt = Width -> Format
intFormat Width
width
half :: Int
half = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Format -> Int
formatInBytes Format
fmt)
(xh_reg, xh_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
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 Width
_ [CmmFormal]
_ [CmmExpr]
_
= String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCCall: Wrong number of arguments for divOp2"
multOp2 :: Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
multOp2 Width
width [CmmFormal
res_h, CmmFormal
res_l] [CmmExpr
arg_x, CmmExpr
arg_y]
= do let reg_h :: Reg
reg_h = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_h
reg_l :: Reg
reg_l = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_l
fmt :: Format
fmt = Width -> Format
intFormat Width
width
(x_reg, x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
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 Width
_ [CmmFormal]
_ [CmmExpr]
_
= String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCall: Wrong number of arguments for multOp2"
add2Op :: [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
add2Op [CmmFormal
res_h, CmmFormal
res_l] [CmmExpr
arg_x, CmmExpr
arg_y]
= do let reg_h :: Reg
reg_h = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_h
reg_l :: Reg
reg_l = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_l
(x_reg, x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
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 [CmmFormal]
_ [CmmExpr]
_
= String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCCall: Wrong number of arguments/results for add2"
addcOp :: [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
addcOp [CmmFormal
res_r, CmmFormal
res_c] [CmmExpr
arg_x, CmmExpr
arg_y]
= [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
add2Op [CmmFormal
res_c , CmmFormal
res_r ] [CmmExpr
arg_x, CmmExpr
arg_y]
addcOp [CmmFormal]
_ [CmmExpr]
_
= String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCCall: Wrong number of arguments/results for addc"
subcOp :: [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
subcOp [CmmFormal
res_r, CmmFormal
res_c] [CmmExpr
arg_x, CmmExpr
arg_y]
= do let reg_r :: Reg
reg_r = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_r
reg_c :: Reg
reg_c = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_c
(x_reg, x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
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 [CmmFormal]
_ [CmmExpr]
_
= String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCCall: Wrong number of arguments/results for subc"
addSubCOp :: (Reg -> Reg -> Reg -> Instr)
-> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
addSubCOp Reg -> Reg -> Reg -> Instr
instr Width
width [CmmFormal
res_r, CmmFormal
res_c] [CmmExpr
arg_x, CmmExpr
arg_y]
= do let reg_r :: Reg
reg_r = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_r
reg_c :: Reg
reg_c = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_c
(x_reg, x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
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 Reg -> Reg -> Reg -> Instr
_ Width
_ [CmmFormal]
_ [CmmExpr]
_
= String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCall: Wrong number of arguments/results for addC"
fabs :: [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
fabs [CmmFormal
res] [CmmExpr
arg]
= do let res_r :: Reg
res_r = CmmFormal -> Reg
getLocalRegReg CmmFormal
res
(arg_reg, arg_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
arg
return $ arg_code `snocOL` FABS res_r arg_reg
fabs [CmmFormal]
_ [CmmExpr]
_
= String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCall: Wrong number of arguments/results for fabs"
data GenCCallPlatform = GCP32ELF | GCP64ELF !Int | GCPAIX
platformToGCP :: Platform -> GenCCallPlatform
platformToGCP :: Platform -> GenCCallPlatform
platformToGCP Platform
platform
= case Platform -> OS
platformOS Platform
platform of
OS
OSAIX -> GenCCallPlatform
GCPAIX
OS
_ -> case Platform -> Arch
platformArch Platform
platform of
Arch
ArchPPC -> GenCCallPlatform
GCP32ELF
ArchPPC_64 PPC_64ABI
ELF_V1 -> Int -> GenCCallPlatform
GCP64ELF Int
1
ArchPPC_64 PPC_64ABI
ELF_V2 -> Int -> GenCCallPlatform
GCP64ELF Int
2
Arch
_ -> String -> GenCCallPlatform
forall a. HasCallStack => String -> a
panic String
"platformToGCP: Not PowerPC"
genCCall'
:: NCGConfig
-> GenCCallPlatform
-> ForeignTarget
-> [CmmFormal]
-> [CmmActual]
-> NatM InstrBlock
genCCall' :: NCGConfig
-> GenCCallPlatform
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> NatM (OrdList Instr)
genCCall' NCGConfig
config GenCCallPlatform
gcp ForeignTarget
target [CmmFormal]
dest_regs [CmmExpr]
args
= do
(finalStack,passArgumentsCode,usedRegs) <- [(CmmExpr, CmmType, ForeignHint)]
-> [Reg]
-> [Reg]
-> Int
-> OrdList Instr
-> [Reg]
-> NatM (Int, OrdList Instr, [Reg])
passArguments
([CmmExpr]
-> [CmmType] -> [ForeignHint] -> [(CmmExpr, CmmType, ForeignHint)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [CmmExpr]
args [CmmType]
argReps [ForeignHint]
argHints)
[Reg]
allArgRegs
(Platform -> [Reg]
allFPArgRegs Platform
platform)
Int
initialStackOffset
OrdList Instr
forall a. OrdList a
nilOL []
(labelOrExpr, reduceToFF32) <- case target of
ForeignTarget (CmmLit (CmmLabel CLabel
lbl)) ForeignConvention
_ -> do
NatM ()
uses_pic_base_implicitly
(Either CLabel CmmExpr, Bool) -> NatM (Either CLabel CmmExpr, Bool)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CLabel -> Either CLabel CmmExpr
forall a b. a -> Either a b
Left CLabel
lbl, Bool
False)
ForeignTarget CmmExpr
expr ForeignConvention
_ -> do
NatM ()
uses_pic_base_implicitly
(Either CLabel CmmExpr, Bool) -> NatM (Either CLabel CmmExpr, Bool)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmExpr -> Either CLabel CmmExpr
forall a b. b -> Either a b
Right CmmExpr
expr, Bool
False)
PrimTarget CallishMachOp
mop -> CallishMachOp -> NatM (Either CLabel CmmExpr, Bool)
outOfLineMachOp CallishMachOp
mop
let codeBefore = Int -> OrdList Instr
move_sp_down Int
finalStack OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
passArgumentsCode
codeAfter = Int -> OrdList Instr
move_sp_up Int
finalStack OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Bool -> OrdList Instr
moveResult Bool
reduceToFF32
case labelOrExpr of
Left CLabel
lbl ->
OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( OrdList Instr
codeBefore
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CLabel -> [Reg] -> Instr
BL CLabel
lbl [Reg]
usedRegs
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
maybeNOP
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
codeAfter)
Right CmmExpr
dyn -> do
(dynReg, dynCode) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
dyn
case gcp of
GCP64ELF Int
1 -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( OrdList Instr
dynCode
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
codeBefore
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
ST Format
spFormat Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
40))
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II64 Reg
r11 (Reg -> Imm -> AddrMode
AddrRegImm Reg
dynReg (Int -> Imm
ImmInt Int
0))
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II64 Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
dynReg (Int -> Imm
ImmInt Int
8))
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
MTCTR Reg
r11
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II64 Reg
r11 (Reg -> Imm -> AddrMode
AddrRegImm Reg
dynReg (Int -> Imm
ImmInt Int
16))
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` [Reg] -> Instr
BCTRL [Reg]
usedRegs
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
spFormat Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
40))
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
codeAfter)
GCP64ELF Int
2 -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( OrdList Instr
dynCode
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
codeBefore
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
ST Format
spFormat Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
24))
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
MR Reg
r12 Reg
dynReg
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
MTCTR Reg
r12
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` [Reg] -> Instr
BCTRL [Reg]
usedRegs
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
spFormat Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
24))
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
codeAfter)
GenCCallPlatform
GCPAIX -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( OrdList Instr
dynCode
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
codeBefore
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
ST Format
spFormat Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
20))
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
r11 (Reg -> Imm -> AddrMode
AddrRegImm Reg
dynReg (Int -> Imm
ImmInt Int
0))
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
dynReg (Int -> Imm
ImmInt Int
4))
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
MTCTR Reg
r11
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
r11 (Reg -> Imm -> AddrMode
AddrRegImm Reg
dynReg (Int -> Imm
ImmInt Int
8))
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` [Reg] -> Instr
BCTRL [Reg]
usedRegs
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
spFormat Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
20))
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
codeAfter)
GenCCallPlatform
_ -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( OrdList Instr
dynCode
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
MTCTR Reg
dynReg
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
codeBefore
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` [Reg] -> Instr
BCTRL [Reg]
usedRegs
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
codeAfter)
where
platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
uses_pic_base_implicitly :: NatM ()
uses_pic_base_implicitly =
Bool -> NatM () -> NatM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NCGConfig -> Bool
ncgPIC NCGConfig
config Bool -> Bool -> Bool
&& Platform -> Bool
target32Bit Platform
platform) (NatM () -> NatM ()) -> NatM () -> NatM ()
forall a b. (a -> b) -> a -> b
$ do
_ <- Format -> NatM Reg
getPicBaseNat (Format -> NatM Reg) -> Format -> NatM Reg
forall a b. (a -> b) -> a -> b
$ Bool -> Format
archWordFormat Bool
True
return ()
initialStackOffset :: Int
initialStackOffset = case GenCCallPlatform
gcp of
GenCCallPlatform
GCPAIX -> Int
24
GenCCallPlatform
GCP32ELF -> Int
8
GCP64ELF Int
1 -> Int
48
GCP64ELF Int
2 -> Int
32
GenCCallPlatform
_ -> String -> Int
forall a. HasCallStack => String -> a
panic String
"genCall': unknown calling convention"
stackDelta :: Int -> Int
stackDelta Int
finalStack = case GenCCallPlatform
gcp of
GenCCallPlatform
GCPAIX ->
Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
16 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
24 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
32 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$
(CmmType -> Int) -> [CmmType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Width -> Int
widthInBytes (Width -> Int) -> (CmmType -> Width) -> CmmType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmType -> Width
typeWidth) [CmmType]
argReps
GenCCallPlatform
GCP32ELF -> Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
16 Int
finalStack
GCP64ELF Int
1 ->
Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
16 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
48 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
64 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$
(CmmType -> Int) -> [CmmType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
8 (Int -> Int) -> (CmmType -> Int) -> CmmType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Width -> Int
widthInBytes (Width -> Int) -> (CmmType -> Width) -> CmmType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmType -> Width
typeWidth)
[CmmType]
argReps
GCP64ELF Int
2 ->
Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
16 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
64 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$
(CmmType -> Int) -> [CmmType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
8 (Int -> Int) -> (CmmType -> Int) -> CmmType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Width -> Int
widthInBytes (Width -> Int) -> (CmmType -> Width) -> CmmType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmType -> Width
typeWidth)
[CmmType]
argReps
GenCCallPlatform
_ -> String -> Int
forall a. HasCallStack => String -> a
panic String
"genCall': unknown calling conv."
argReps :: [CmmType]
argReps = (CmmExpr -> CmmType) -> [CmmExpr] -> [CmmType]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform) [CmmExpr]
args
([ForeignHint]
_, [ForeignHint]
argHints) = ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints ForeignTarget
target
roundTo :: a -> a -> a
roundTo a
a a
x | a
x a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = a
x
| Bool
otherwise = a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
a a -> a -> a
forall a. Num a => a -> a -> a
- (a
x a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
a)
spFormat :: Format
spFormat = if Platform -> Bool
target32Bit Platform
platform then Format
II32 else Format
II64
move_sp_down :: Int -> OrdList Instr
move_sp_down Int
finalStack
| Int
delta Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Platform -> Int
stackFrameHeaderSize Platform
platform =
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Format -> Reg -> AddrMode -> Instr
STU Format
spFormat Reg
sp (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt (-Int
delta))),
Int -> Instr
DELTA (-Int
delta)]
| Bool
otherwise = OrdList Instr
forall a. OrdList a
nilOL
where delta :: Int
delta = Int -> Int
stackDelta Int
finalStack
move_sp_up :: Int -> OrdList Instr
move_sp_up Int
finalStack
| Int
delta Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Platform -> Int
stackFrameHeaderSize Platform
platform =
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Reg -> Reg -> RI -> Instr
ADD Reg
sp Reg
sp (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
delta)),
Int -> Instr
DELTA Int
0]
| Bool
otherwise = OrdList Instr
forall a. OrdList a
nilOL
where delta :: Int
delta = Int -> Int
stackDelta Int
finalStack
maybeNOP :: OrdList Instr
maybeNOP = case GenCCallPlatform
gcp of
GenCCallPlatform
GCP32ELF -> OrdList Instr
forall a. OrdList a
nilOL
GenCCallPlatform
GCPAIX -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
NOP
GCP64ELF Int
1 -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
NOP
GCP64ELF Int
2 -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
NOP
GenCCallPlatform
_ -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"maybeNOP: Unknown PowerPC 64-bit ABI"
passArguments :: [(CmmExpr, CmmType, ForeignHint)]
-> [Reg]
-> [Reg]
-> Int
-> OrdList Instr
-> [Reg]
-> NatM (Int, OrdList Instr, [Reg])
passArguments [] [Reg]
_ [Reg]
_ Int
stackOffset OrdList Instr
accumCode [Reg]
accumUsed = (Int, OrdList Instr, [Reg]) -> NatM (Int, OrdList Instr, [Reg])
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
stackOffset, OrdList Instr
accumCode, [Reg]
accumUsed)
passArguments ((CmmExpr
arg,CmmType
arg_ty,ForeignHint
_):[(CmmExpr, CmmType, ForeignHint)]
args) [Reg]
gprs [Reg]
fprs Int
stackOffset
OrdList Instr
accumCode [Reg]
accumUsed | CmmType -> Bool
isWord64 CmmType
arg_ty
Bool -> Bool -> Bool
&& Platform -> Bool
target32Bit (NCGConfig -> Platform
ncgPlatform NCGConfig
config) =
do
RegCode64 code vr_hi vr_lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
arg
case gcp of
GenCCallPlatform
GCPAIX ->
do let storeWord :: Reg -> [Reg] -> Int -> Instr
storeWord Reg
vr (Reg
gpr:[Reg]
_) Int
_ = Reg -> Reg -> Instr
MR Reg
gpr Reg
vr
storeWord Reg
vr [] Int
offset
= Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
vr (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
offset))
[(CmmExpr, CmmType, ForeignHint)]
-> [Reg]
-> [Reg]
-> Int
-> OrdList Instr
-> [Reg]
-> NatM (Int, OrdList Instr, [Reg])
passArguments [(CmmExpr, CmmType, ForeignHint)]
args
(Int -> [Reg] -> [Reg]
forall a. Int -> [a] -> [a]
drop Int
2 [Reg]
gprs)
[Reg]
fprs
(Int
stackOffsetInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
8)
(OrdList Instr
accumCode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> [Reg] -> Int -> Instr
storeWord Reg
vr_hi [Reg]
gprs Int
stackOffset
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> [Reg] -> Int -> Instr
storeWord Reg
vr_lo (Int -> [Reg] -> [Reg]
forall a. Int -> [a] -> [a]
drop Int
1 [Reg]
gprs) (Int
stackOffsetInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
4))
((Int -> [Reg] -> [Reg]
forall a. Int -> [a] -> [a]
take Int
2 [Reg]
gprs) [Reg] -> [Reg] -> [Reg]
forall a. [a] -> [a] -> [a]
++ [Reg]
accumUsed)
GenCCallPlatform
GCP32ELF ->
do let stackOffset' :: Int
stackOffset' = Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
8 Int
stackOffset
stackCode :: OrdList Instr
stackCode = OrdList Instr
accumCode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
vr_hi (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
stackOffset'))
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
vr_lo (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt (Int
stackOffset'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
4)))
regCode :: Reg -> Reg -> OrdList Instr
regCode Reg
hireg Reg
loreg =
OrdList Instr
accumCode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
MR Reg
hireg Reg
vr_hi
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
MR Reg
loreg Reg
vr_lo
case [Reg]
gprs of
Reg
hireg : Reg
loreg : [Reg]
regs | Int -> Bool
forall a. Integral a => a -> Bool
even ([Reg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Reg]
gprs) ->
[(CmmExpr, CmmType, ForeignHint)]
-> [Reg]
-> [Reg]
-> Int
-> OrdList Instr
-> [Reg]
-> NatM (Int, OrdList Instr, [Reg])
passArguments [(CmmExpr, CmmType, ForeignHint)]
args [Reg]
regs [Reg]
fprs Int
stackOffset
(Reg -> Reg -> OrdList Instr
regCode Reg
hireg Reg
loreg) (Reg
hireg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: Reg
loreg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
accumUsed)
Reg
_skipped : Reg
hireg : Reg
loreg : [Reg]
regs ->
[(CmmExpr, CmmType, ForeignHint)]
-> [Reg]
-> [Reg]
-> Int
-> OrdList Instr
-> [Reg]
-> NatM (Int, OrdList Instr, [Reg])
passArguments [(CmmExpr, CmmType, ForeignHint)]
args [Reg]
regs [Reg]
fprs Int
stackOffset
(Reg -> Reg -> OrdList Instr
regCode Reg
hireg Reg
loreg) (Reg
hireg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: Reg
loreg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
accumUsed)
[Reg]
_ ->
[(CmmExpr, CmmType, ForeignHint)]
-> [Reg]
-> [Reg]
-> Int
-> OrdList Instr
-> [Reg]
-> NatM (Int, OrdList Instr, [Reg])
passArguments [(CmmExpr, CmmType, ForeignHint)]
args [] [Reg]
fprs (Int
stackOffset'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
8)
OrdList Instr
stackCode [Reg]
accumUsed
GCP64ELF Int
_ -> String -> NatM (Int, OrdList Instr, [Reg])
forall a. HasCallStack => String -> a
panic String
"passArguments: 32 bit code"
passArguments ((CmmExpr
arg,CmmType
rep,ForeignHint
hint):[(CmmExpr, CmmType, ForeignHint)]
args) [Reg]
gprs [Reg]
fprs Int
stackOffset OrdList Instr
accumCode [Reg]
accumUsed
| Reg
reg : [Reg]
_ <- [Reg]
regs = do
register <- CmmExpr -> NatM Register
getRegister CmmExpr
arg_pro
let code = case Register
register of
Fixed Format
_ Reg
freg OrdList Instr
fcode -> OrdList Instr
fcode OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
MR Reg
reg Reg
freg
Any Format
_ Reg -> OrdList Instr
acode -> Reg -> OrdList Instr
acode Reg
reg
stackOffsetRes = case GenCCallPlatform
gcp of
GenCCallPlatform
GCPAIX -> Int
stackOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
stackBytes
GenCCallPlatform
GCP32ELF -> Int
stackOffset
GCP64ELF Int
_ -> Int
stackOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
stackBytes
passArguments args
(drop nGprs gprs)
(drop nFprs fprs)
stackOffsetRes
(accumCode `appOL` code)
(reg : accumUsed)
| Bool
otherwise = do
(vr, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
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 :: CmmExpr
arg_pro
| CmmType -> Bool
isBitsType CmmType
rep = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
conv_op (CmmType -> Width
typeWidth CmmType
rep) (Platform -> Width
wordWidth Platform
platform)) [CmmExpr
arg]
| Bool
otherwise = CmmExpr
arg
format_pro :: Format
format_pro
| CmmType -> Bool
isBitsType CmmType
rep = Width -> Format
intFormat (Platform -> Width
wordWidth Platform
platform)
| Bool
otherwise = CmmType -> Format
cmmTypeFormat CmmType
rep
conv_op :: Width -> Width -> MachOp
conv_op = case ForeignHint
hint of
ForeignHint
SignedHint -> Width -> Width -> MachOp
MO_SS_Conv
ForeignHint
_ -> Width -> Width -> MachOp
MO_UU_Conv
stackOffset' :: Int
stackOffset' = case GenCCallPlatform
gcp of
GenCCallPlatform
GCPAIX ->
Int
stackOffset
GenCCallPlatform
GCP32ELF
| CmmType -> Bool
isFloatType CmmType
rep Bool -> Bool -> Bool
&& CmmType -> Width
typeWidth CmmType
rep Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 ->
Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
8 Int
stackOffset
| Bool
otherwise ->
Int
stackOffset
GCP64ELF Int
_ ->
Int
stackOffset
stackOffset'' :: Int
stackOffset''
| CmmType -> Bool
isFloatType CmmType
rep Bool -> Bool -> Bool
&& CmmType -> Width
typeWidth CmmType
rep Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32 =
case GenCCallPlatform
gcp of
GCP64ELF Int
1 -> Int
stackOffset' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4
GCP64ELF Int
2 -> case Platform -> ByteOrder
platformByteOrder Platform
platform of
ByteOrder
BigEndian -> Int
stackOffset' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4
ByteOrder
LittleEndian -> Int
stackOffset'
GenCCallPlatform
_ -> Int
stackOffset'
| Bool
otherwise = Int
stackOffset'
stackSlot :: AddrMode
stackSlot = Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
stackOffset'')
(Int
nGprs, Int
nFprs, Int
stackBytes, [Reg]
regs)
= case GenCCallPlatform
gcp of
GenCCallPlatform
GCPAIX ->
case CmmType -> Format
cmmTypeFormat CmmType
rep of
Format
II8 -> (Int
1, Int
0, Int
4, [Reg]
gprs)
Format
II16 -> (Int
1, Int
0, Int
4, [Reg]
gprs)
Format
II32 -> (Int
1, Int
0, Int
4, [Reg]
gprs)
Format
FF32 -> (Int
1, Int
1, Int
4, [Reg]
fprs)
Format
FF64 -> (Int
2, Int
1, Int
8, [Reg]
fprs)
Format
II64 -> String -> (Int, Int, Int, [Reg])
forall a. HasCallStack => String -> a
panic String
"genCCall' passArguments II64"
VecFormat {}
-> String -> (Int, Int, Int, [Reg])
forall a. HasCallStack => String -> a
panic String
"genCCall' passArguments vector format"
GenCCallPlatform
GCP32ELF ->
case CmmType -> Format
cmmTypeFormat CmmType
rep of
Format
II8 -> (Int
1, Int
0, Int
4, [Reg]
gprs)
Format
II16 -> (Int
1, Int
0, Int
4, [Reg]
gprs)
Format
II32 -> (Int
1, Int
0, Int
4, [Reg]
gprs)
Format
FF32 -> (Int
0, Int
1, Int
4, [Reg]
fprs)
Format
FF64 -> (Int
0, Int
1, Int
8, [Reg]
fprs)
Format
II64 -> String -> (Int, Int, Int, [Reg])
forall a. HasCallStack => String -> a
panic String
"genCCall' passArguments II64"
VecFormat {}
-> String -> (Int, Int, Int, [Reg])
forall a. HasCallStack => String -> a
panic String
"genCCall' passArguments vector format"
GCP64ELF Int
_ ->
case CmmType -> Format
cmmTypeFormat CmmType
rep of
Format
II8 -> (Int
1, Int
0, Int
8, [Reg]
gprs)
Format
II16 -> (Int
1, Int
0, Int
8, [Reg]
gprs)
Format
II32 -> (Int
1, Int
0, Int
8, [Reg]
gprs)
Format
II64 -> (Int
1, Int
0, Int
8, [Reg]
gprs)
Format
FF32 -> (Int
1, Int
1, Int
8, [Reg]
fprs)
Format
FF64 -> (Int
1, Int
1, Int
8, [Reg]
fprs)
VecFormat {}
-> String -> (Int, Int, Int, [Reg])
forall a. HasCallStack => String -> a
panic String
"genCCall' passArguments vector format"
moveResult :: Bool -> OrdList Instr
moveResult Bool
reduceToFF32 =
case [CmmFormal]
dest_regs of
[] -> OrdList Instr
forall a. OrdList a
nilOL
[CmmFormal
dest]
| Bool
reduceToFF32 Bool -> Bool -> Bool
&& CmmType -> Bool
isFloat32 CmmType
rep -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Reg -> Reg -> Instr
FRSP Reg
r_dest Reg
f1)
| CmmType -> Bool
isFloat32 CmmType
rep Bool -> Bool -> Bool
|| CmmType -> Bool
isFloat64 CmmType
rep -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Reg -> Reg -> Instr
MR Reg
r_dest Reg
f1)
| CmmType -> Bool
isWord64 CmmType
rep Bool -> Bool -> Bool
&& Platform -> Bool
target32Bit Platform
platform
-> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Reg -> Reg -> Instr
MR (Reg -> Reg
getHiVRegFromLo Reg
r_dest) Reg
r3,
Reg -> Reg -> Instr
MR Reg
r_dest Reg
r4]
| Bool
otherwise -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Reg -> Reg -> Instr
MR Reg
r_dest Reg
r3)
where rep :: CmmType
rep = CmmReg -> CmmType
cmmRegType (CmmFormal -> CmmReg
CmmLocal CmmFormal
dest)
r_dest :: Reg
r_dest = CmmFormal -> Reg
getLocalRegReg CmmFormal
dest
[CmmFormal]
_ -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"genCCall' moveResult: Bad dest_regs"
outOfLineMachOp :: CallishMachOp -> NatM (Either CLabel CmmExpr, Bool)
outOfLineMachOp CallishMachOp
mop =
do
mopExpr <- NCGConfig -> ReferenceKind -> CLabel -> NatM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
NCGConfig -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference NCGConfig
config ReferenceKind
CallReference (CLabel -> NatM CmmExpr) -> CLabel -> NatM CmmExpr
forall a b. (a -> b) -> a -> b
$
FastString -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
functionName ForeignLabelSource
ForeignLabelInThisPackage FunctionOrData
IsFunction
let mopLabelOrExpr = case CmmExpr
mopExpr of
CmmLit (CmmLabel CLabel
lbl) -> CLabel -> Either CLabel CmmExpr
forall a b. a -> Either a b
Left CLabel
lbl
CmmExpr
_ -> CmmExpr -> Either CLabel CmmExpr
forall a b. b -> Either a b
Right CmmExpr
mopExpr
return (mopLabelOrExpr, reduce)
where
(FastString
functionName, Bool
reduce) = case CallishMachOp
mop of
CallishMachOp
MO_F32_Exp -> (String -> FastString
fsLit String
"exp", Bool
True)
CallishMachOp
MO_F32_ExpM1 -> (String -> FastString
fsLit String
"expm1", Bool
True)
CallishMachOp
MO_F32_Log -> (String -> FastString
fsLit String
"log", Bool
True)
CallishMachOp
MO_F32_Log1P -> (String -> FastString
fsLit String
"log1p", Bool
True)
CallishMachOp
MO_F32_Sqrt -> (String -> FastString
fsLit String
"sqrt", Bool
True)
CallishMachOp
MO_F32_Fabs -> (FastString, Bool)
unsupported
CallishMachOp
MO_F32_Sin -> (String -> FastString
fsLit String
"sin", Bool
True)
CallishMachOp
MO_F32_Cos -> (String -> FastString
fsLit String
"cos", Bool
True)
CallishMachOp
MO_F32_Tan -> (String -> FastString
fsLit String
"tan", Bool
True)
CallishMachOp
MO_F32_Asin -> (String -> FastString
fsLit String
"asin", Bool
True)
CallishMachOp
MO_F32_Acos -> (String -> FastString
fsLit String
"acos", Bool
True)
CallishMachOp
MO_F32_Atan -> (String -> FastString
fsLit String
"atan", Bool
True)
CallishMachOp
MO_F32_Sinh -> (String -> FastString
fsLit String
"sinh", Bool
True)
CallishMachOp
MO_F32_Cosh -> (String -> FastString
fsLit String
"cosh", Bool
True)
CallishMachOp
MO_F32_Tanh -> (String -> FastString
fsLit String
"tanh", Bool
True)
CallishMachOp
MO_F32_Pwr -> (String -> FastString
fsLit String
"pow", Bool
True)
CallishMachOp
MO_F32_Asinh -> (String -> FastString
fsLit String
"asinh", Bool
True)
CallishMachOp
MO_F32_Acosh -> (String -> FastString
fsLit String
"acosh", Bool
True)
CallishMachOp
MO_F32_Atanh -> (String -> FastString
fsLit String
"atanh", Bool
True)
CallishMachOp
MO_F64_Exp -> (String -> FastString
fsLit String
"exp", Bool
False)
CallishMachOp
MO_F64_ExpM1 -> (String -> FastString
fsLit String
"expm1", Bool
False)
CallishMachOp
MO_F64_Log -> (String -> FastString
fsLit String
"log", Bool
False)
CallishMachOp
MO_F64_Log1P -> (String -> FastString
fsLit String
"log1p", Bool
False)
CallishMachOp
MO_F64_Sqrt -> (String -> FastString
fsLit String
"sqrt", Bool
False)
CallishMachOp
MO_F64_Fabs -> (FastString, Bool)
unsupported
CallishMachOp
MO_F64_Sin -> (String -> FastString
fsLit String
"sin", Bool
False)
CallishMachOp
MO_F64_Cos -> (String -> FastString
fsLit String
"cos", Bool
False)
CallishMachOp
MO_F64_Tan -> (String -> FastString
fsLit String
"tan", Bool
False)
CallishMachOp
MO_F64_Asin -> (String -> FastString
fsLit String
"asin", Bool
False)
CallishMachOp
MO_F64_Acos -> (String -> FastString
fsLit String
"acos", Bool
False)
CallishMachOp
MO_F64_Atan -> (String -> FastString
fsLit String
"atan", Bool
False)
CallishMachOp
MO_F64_Sinh -> (String -> FastString
fsLit String
"sinh", Bool
False)
CallishMachOp
MO_F64_Cosh -> (String -> FastString
fsLit String
"cosh", Bool
False)
CallishMachOp
MO_F64_Tanh -> (String -> FastString
fsLit String
"tanh", Bool
False)
CallishMachOp
MO_F64_Pwr -> (String -> FastString
fsLit String
"pow", Bool
False)
CallishMachOp
MO_F64_Asinh -> (String -> FastString
fsLit String
"asinh", Bool
False)
CallishMachOp
MO_F64_Acosh -> (String -> FastString
fsLit String
"acosh", Bool
False)
CallishMachOp
MO_F64_Atanh -> (String -> FastString
fsLit String
"atanh", Bool
False)
CallishMachOp
MO_I64_ToI -> (String -> FastString
fsLit String
"hs_int64ToInt", Bool
False)
CallishMachOp
MO_I64_FromI -> (String -> FastString
fsLit String
"hs_intToInt64", Bool
False)
CallishMachOp
MO_W64_ToW -> (String -> FastString
fsLit String
"hs_word64ToWord", Bool
False)
CallishMachOp
MO_W64_FromW -> (String -> FastString
fsLit String
"hs_wordToWord64", Bool
False)
CallishMachOp
MO_x64_Neg -> (String -> FastString
fsLit String
"hs_neg64", Bool
False)
CallishMachOp
MO_x64_Add -> (String -> FastString
fsLit String
"hs_add64", Bool
False)
CallishMachOp
MO_x64_Sub -> (String -> FastString
fsLit String
"hs_sub64", Bool
False)
CallishMachOp
MO_x64_Mul -> (String -> FastString
fsLit String
"hs_mul64", Bool
False)
CallishMachOp
MO_I64_Quot -> (String -> FastString
fsLit String
"hs_quotInt64", Bool
False)
CallishMachOp
MO_I64_Rem -> (String -> FastString
fsLit String
"hs_remInt64", Bool
False)
CallishMachOp
MO_W64_Quot -> (String -> FastString
fsLit String
"hs_quotWord64", Bool
False)
CallishMachOp
MO_W64_Rem -> (String -> FastString
fsLit String
"hs_remWord64", Bool
False)
CallishMachOp
MO_x64_And -> (String -> FastString
fsLit String
"hs_and64", Bool
False)
CallishMachOp
MO_x64_Or -> (String -> FastString
fsLit String
"hs_or64", Bool
False)
CallishMachOp
MO_x64_Xor -> (String -> FastString
fsLit String
"hs_xor64", Bool
False)
CallishMachOp
MO_x64_Not -> (String -> FastString
fsLit String
"hs_not64", Bool
False)
CallishMachOp
MO_x64_Shl -> (String -> FastString
fsLit String
"hs_uncheckedShiftL64", Bool
False)
CallishMachOp
MO_I64_Shr -> (String -> FastString
fsLit String
"hs_uncheckedIShiftRA64", Bool
False)
CallishMachOp
MO_W64_Shr -> (String -> FastString
fsLit String
"hs_uncheckedShiftRL64", Bool
False)
CallishMachOp
MO_x64_Eq -> (String -> FastString
fsLit String
"hs_eq64", Bool
False)
CallishMachOp
MO_x64_Ne -> (String -> FastString
fsLit String
"hs_ne64", Bool
False)
CallishMachOp
MO_I64_Ge -> (String -> FastString
fsLit String
"hs_geInt64", Bool
False)
CallishMachOp
MO_I64_Gt -> (String -> FastString
fsLit String
"hs_gtInt64", Bool
False)
CallishMachOp
MO_I64_Le -> (String -> FastString
fsLit String
"hs_leInt64", Bool
False)
CallishMachOp
MO_I64_Lt -> (String -> FastString
fsLit String
"hs_ltInt64", Bool
False)
CallishMachOp
MO_W64_Ge -> (String -> FastString
fsLit String
"hs_geWord64", Bool
False)
CallishMachOp
MO_W64_Gt -> (String -> FastString
fsLit String
"hs_gtWord64", Bool
False)
CallishMachOp
MO_W64_Le -> (String -> FastString
fsLit String
"hs_leWord64", Bool
False)
CallishMachOp
MO_W64_Lt -> (String -> FastString
fsLit String
"hs_ltWord64", Bool
False)
MO_UF_Conv Width
w -> (Width -> FastString
word2FloatLabel Width
w, Bool
False)
MO_Memcpy Int
_ -> (String -> FastString
fsLit String
"memcpy", Bool
False)
MO_Memset Int
_ -> (String -> FastString
fsLit String
"memset", Bool
False)
MO_Memmove Int
_ -> (String -> FastString
fsLit String
"memmove", Bool
False)
MO_Memcmp Int
_ -> (String -> FastString
fsLit String
"memcmp", Bool
False)
CallishMachOp
MO_SuspendThread -> (String -> FastString
fsLit String
"suspendThread", Bool
False)
CallishMachOp
MO_ResumeThread -> (String -> FastString
fsLit String
"resumeThread", Bool
False)
MO_BSwap Width
w -> (Width -> FastString
bSwapLabel Width
w, Bool
False)
MO_BRev Width
w -> (Width -> FastString
bRevLabel Width
w, Bool
False)
MO_PopCnt Width
w -> (Width -> FastString
popCntLabel Width
w, Bool
False)
MO_Pdep Width
w -> (Width -> FastString
pdepLabel Width
w, Bool
False)
MO_Pext Width
w -> (Width -> FastString
pextLabel Width
w, Bool
False)
MO_Clz Width
_ -> (FastString, Bool)
unsupported
MO_Ctz Width
_ -> (FastString, Bool)
unsupported
MO_AtomicRMW {} -> (FastString, Bool)
unsupported
MO_Cmpxchg Width
w -> (Width -> FastString
cmpxchgLabel Width
w, Bool
False)
MO_Xchg Width
w -> (Width -> FastString
xchgLabel Width
w, Bool
False)
MO_AtomicRead Width
_ MemoryOrdering
_ -> (FastString, Bool)
unsupported
MO_AtomicWrite Width
_ MemoryOrdering
_ -> (FastString, Bool)
unsupported
MO_S_Mul2 {} -> (FastString, Bool)
unsupported
MO_S_QuotRem {} -> (FastString, Bool)
unsupported
MO_U_QuotRem {} -> (FastString, Bool)
unsupported
MO_U_QuotRem2 {} -> (FastString, Bool)
unsupported
MO_Add2 {} -> (FastString, Bool)
unsupported
MO_AddWordC {} -> (FastString, Bool)
unsupported
MO_SubWordC {} -> (FastString, Bool)
unsupported
MO_AddIntC {} -> (FastString, Bool)
unsupported
MO_SubIntC {} -> (FastString, Bool)
unsupported
MO_U_Mul2 {} -> (FastString, Bool)
unsupported
CallishMachOp
MO_AcquireFence -> (FastString, Bool)
unsupported
CallishMachOp
MO_ReleaseFence -> (FastString, Bool)
unsupported
CallishMachOp
MO_SeqCstFence -> (FastString, Bool)
unsupported
CallishMachOp
MO_Touch -> (FastString, Bool)
unsupported
MO_Prefetch_Data Int
_ -> (FastString, Bool)
unsupported
unsupported :: (FastString, Bool)
unsupported = String -> (FastString, Bool)
forall a. HasCallStack => String -> a
panic (String
"outOfLineCmmOp: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallishMachOp -> String
forall a. Show a => a -> String
show CallishMachOp
mop
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not supported")
genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM (OrdList Instr)
genSwitch NCGConfig
config CmmExpr
expr SwitchTargets
targets
| OS
OSAIX <- Platform -> OS
platformOS Platform
platform
= do
(reg,e_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
indexExpr
let fmt = Bool -> Format
archWordFormat (Bool -> Format) -> Bool -> Format
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit Platform
platform
sha = if Platform -> Bool
target32Bit Platform
platform then Int
2 else Int
3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
dynRef <- cmmMakeDynamicReference config DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
let code = OrdList Instr
e_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
t_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Format -> Reg -> Reg -> RI -> Instr
SL Format
fmt Reg
tmp Reg
reg (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
sha)),
Format -> Reg -> AddrMode -> Instr
LD Format
fmt Reg
tmp (Reg -> Reg -> AddrMode
AddrRegReg Reg
tableReg Reg
tmp),
Reg -> Instr
MTCTR Reg
tmp,
[Maybe BlockId] -> Maybe CLabel -> [RegWithFormat] -> Instr
BCTR [Maybe BlockId]
ids (CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
lbl) []
]
return code
| (NCGConfig -> Bool
ncgPIC NCGConfig
config) Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit Platform
platform)
= do
(reg,e_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
indexExpr
let fmt = Bool -> Format
archWordFormat (Bool -> Format) -> Bool -> Format
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit Platform
platform
sha = if Platform -> Bool
target32Bit Platform
platform then Int
2 else Int
3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
dynRef <- cmmMakeDynamicReference config DataReference lbl
(tableReg,t_code) <- getSomeReg $ dynRef
let code = OrdList Instr
e_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
t_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Format -> Reg -> Reg -> RI -> Instr
SL Format
fmt Reg
tmp Reg
reg (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
sha)),
Format -> Reg -> AddrMode -> Instr
LD Format
fmt Reg
tmp (Reg -> Reg -> AddrMode
AddrRegReg Reg
tableReg Reg
tmp),
Reg -> Reg -> RI -> Instr
ADD Reg
tmp Reg
tmp (Reg -> RI
RIReg Reg
tableReg),
Reg -> Instr
MTCTR Reg
tmp,
[Maybe BlockId] -> Maybe CLabel -> [RegWithFormat] -> Instr
BCTR [Maybe BlockId]
ids (CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
lbl) []
]
return code
| Bool
otherwise
= do
(reg,e_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
indexExpr
let fmt = Bool -> Format
archWordFormat (Bool -> Format) -> Bool -> Format
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit Platform
platform
sha = if Platform -> Bool
target32Bit Platform
platform then Int
2 else Int
3
tmp <- getNewRegNat fmt
lbl <- getNewLabelNat
let code = OrdList Instr
e_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Format -> Reg -> Reg -> RI -> Instr
SL Format
fmt Reg
tmp Reg
reg (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
sha)),
Reg -> Reg -> Imm -> Instr
ADDIS Reg
tmp Reg
tmp (Imm -> Imm
HA (CLabel -> Imm
ImmCLbl CLabel
lbl)),
Format -> Reg -> AddrMode -> Instr
LD Format
fmt Reg
tmp (Reg -> Imm -> AddrMode
AddrRegImm Reg
tmp (Imm -> Imm
LO (CLabel -> Imm
ImmCLbl CLabel
lbl))),
Reg -> Instr
MTCTR Reg
tmp,
[Maybe BlockId] -> Maybe CLabel -> [RegWithFormat] -> Instr
BCTR [Maybe BlockId]
ids (CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
lbl) []
]
return code
where
indexExpr0 :: CmmExpr
indexExpr0 = Platform -> CmmExpr -> Int -> CmmExpr
cmmOffset Platform
platform CmmExpr
expr Int
offset
indexExpr :: CmmExpr
indexExpr = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp
(Width -> Width -> MachOp
MO_UU_Conv Width
expr_w (Platform -> Width
platformWordWidth Platform
platform))
[CmmExpr
indexExpr0]
expr_w :: Width
expr_w = Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
expr
(Int
offset, [Maybe BlockId]
ids) = SwitchTargets -> (Int, [Maybe BlockId])
switchTargetsToTable SwitchTargets
targets
platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
generateJumpTableForInstr :: NCGConfig -> Instr
-> Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr NCGConfig
config (BCTR [Maybe BlockId]
ids (Just CLabel
lbl) [RegWithFormat]
_) =
let jumpTable :: [CmmStatic]
jumpTable
| (NCGConfig -> Bool
ncgPIC NCGConfig
config) Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit (Platform -> Bool) -> Platform -> Bool
forall a b. (a -> b) -> a -> b
$ NCGConfig -> Platform
ncgPlatform NCGConfig
config)
= (Maybe BlockId -> CmmStatic) -> [Maybe BlockId] -> [CmmStatic]
forall a b. (a -> b) -> [a] -> [b]
map Maybe BlockId -> CmmStatic
jumpTableEntryRel [Maybe BlockId]
ids
| Bool
otherwise = (Maybe BlockId -> CmmStatic) -> [Maybe BlockId] -> [CmmStatic]
forall a b. (a -> b) -> [a] -> [b]
map (NCGConfig -> Maybe BlockId -> CmmStatic
jumpTableEntry NCGConfig
config) [Maybe BlockId]
ids
where jumpTableEntryRel :: Maybe BlockId -> CmmStatic
jumpTableEntryRel Maybe BlockId
Nothing
= CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
0 (NCGConfig -> Width
ncgWordWidth NCGConfig
config))
jumpTableEntryRel (Just BlockId
blockid)
= CmmLit -> CmmStatic
CmmStaticLit (CLabel -> CLabel -> Int -> Width -> CmmLit
CmmLabelDiffOff CLabel
blockLabel CLabel
lbl Int
0
(NCGConfig -> Width
ncgWordWidth NCGConfig
config))
where blockLabel :: CLabel
blockLabel = BlockId -> CLabel
blockLbl BlockId
blockid
in NatCmmDecl RawCmmStatics Instr
-> Maybe (NatCmmDecl RawCmmStatics Instr)
forall a. a -> Maybe a
Just (Section -> RawCmmStatics -> NatCmmDecl RawCmmStatics Instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) (CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl [CmmStatic]
jumpTable))
generateJumpTableForInstr NCGConfig
_ Instr
_ = Maybe (NatCmmDecl RawCmmStatics Instr)
forall a. Maybe a
Nothing
condReg :: NatM CondCode -> NatM Register
condReg :: NatM CondCode -> NatM Register
condReg NatM CondCode
getCond = do
CondCode _ cond cond_code <- NatM CondCode
getCond
platform <- getPlatform
let
code Reg
dst = OrdList Instr
cond_code
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
negate_code
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Reg -> Instr
MFCR Reg
dst,
Reg -> Reg -> Int -> Int -> Int -> Instr
RLWINM Reg
dst Reg
dst (Int
bit Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
31 Int
31
]
negate_code | Bool
do_negate = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Int -> Int -> Int -> Instr
CRNOR Int
bit Int
bit Int
bit)
| Bool
otherwise = OrdList Instr
forall a. OrdList a
nilOL
(bit, do_negate) = case cond of
Cond
LTT -> (Int
0, Bool
False)
Cond
LE -> (Int
1, Bool
True)
Cond
EQQ -> (Int
2, Bool
False)
Cond
GE -> (Int
0, Bool
True)
Cond
GTT -> (Int
1, Bool
False)
Cond
NE -> (Int
2, Bool
True)
Cond
LU -> (Int
0, Bool
False)
Cond
LEU -> (Int
1, Bool
True)
Cond
GEU -> (Int
0, Bool
True)
Cond
GU -> (Int
1, Bool
False)
Cond
_ -> String -> (Int, Bool)
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.codeReg: no match"
format = Bool -> Format
archWordFormat (Bool -> Format) -> Bool -> Format
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit Platform
platform
return (Any format code)
condIntReg :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
cond Width
width CmmExpr
x CmmExpr
y = NatM CondCode -> NatM Register
condReg (Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
cond Width
width CmmExpr
x CmmExpr
y)
condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
cond CmmExpr
x CmmExpr
y = NatM CondCode -> NatM Register
condReg (Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
cond CmmExpr
x CmmExpr
y)
trivialCode
:: Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode :: Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Bool
signed Reg -> Reg -> RI -> Instr
instr CmmExpr
x (CmmLit (CmmInt Integer
y Width
_))
| Just Imm
imm <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
rep Bool
signed Integer
y
= do
(src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
let code Reg
dst = OrdList Instr
code1 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> RI -> Instr
instr Reg
dst Reg
src1 (Imm -> RI
RIImm Imm
imm)
return (Any (intFormat rep) code)
trivialCode Width
rep Bool
_ Reg -> Reg -> RI -> Instr
instr CmmExpr
x CmmExpr
y = do
(src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
(src2, code2) <- getSomeReg y
let code Reg
dst = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> RI -> Instr
instr Reg
dst Reg
src1 (Reg -> RI
RIReg Reg
src2)
return (Any (intFormat rep) code)
shiftMulCode
:: Width
-> Bool
-> (Format-> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shiftMulCode :: Width
-> Bool
-> (Format -> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shiftMulCode Width
width Bool
sign Format -> Reg -> Reg -> RI -> Instr
instr CmmExpr
x (CmmLit (CmmInt Integer
y Width
_))
| Just Imm
imm <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
width Bool
sign Integer
y
= do
(src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
let format = Width -> Format
intFormat Width
width
let ins_fmt = Width -> Format
intFormat (Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width)
let code Reg
dst = OrdList Instr
code1 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> Reg -> RI -> Instr
instr Format
ins_fmt Reg
dst Reg
src1 (Imm -> RI
RIImm Imm
imm)
return (Any format code)
shiftMulCode Width
width Bool
_ Format -> Reg -> Reg -> RI -> Instr
instr CmmExpr
x CmmExpr
y = do
(src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
(src2, code2) <- getSomeReg y
let format = Width -> Format
intFormat Width
width
let ins_fmt = Width -> Format
intFormat (Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width)
let code Reg
dst = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> Reg -> RI -> Instr
instr Format
ins_fmt Reg
dst Reg
src1 (Reg -> RI
RIReg Reg
src2)
return (Any format code)
trivialCodeNoImm' :: Format -> (Reg -> Reg -> Reg -> Instr)
-> CmmExpr -> CmmExpr -> NatM Register
trivialCodeNoImm' :: Format
-> (Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCodeNoImm' Format
format Reg -> Reg -> Reg -> Instr
instr CmmExpr
x CmmExpr
y = do
(src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
(src2, code2) <- getSomeReg y
let code Reg
dst = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Reg -> Instr
instr Reg
dst Reg
src1 Reg
src2
return (Any format code)
trivialCodeNoImm :: Format -> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr -> CmmExpr -> NatM Register
trivialCodeNoImm :: Format
-> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCodeNoImm Format
format Format -> Reg -> Reg -> Reg -> Instr
instr CmmExpr
x CmmExpr
y
= Format
-> (Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCodeNoImm' Format
format (Format -> Reg -> Reg -> Reg -> Instr
instr Format
format) CmmExpr
x CmmExpr
y
srCode :: Width -> Bool -> (Format-> Reg -> Reg -> RI -> Instr)
-> CmmExpr -> CmmExpr -> NatM Register
srCode :: Width
-> Bool
-> (Format -> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
srCode Width
width Bool
sgn Format -> Reg -> Reg -> RI -> Instr
instr CmmExpr
x (CmmLit (CmmInt Integer
y Width
_))
| Just Imm
imm <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
width Bool
sgn Integer
y
= do
let op_len :: Width
op_len = Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width
extend :: Width -> Width -> CmmExpr -> CmmExpr
extend = if Bool
sgn then Width -> Width -> CmmExpr -> CmmExpr
extendSExpr else Width -> Width -> CmmExpr -> CmmExpr
extendUExpr
(src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg (Width -> Width -> CmmExpr -> CmmExpr
extend Width
width Width
op_len CmmExpr
x)
let code Reg
dst = OrdList Instr
code1 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Reg -> Reg -> RI -> Instr
instr (Width -> Format
intFormat Width
op_len) Reg
dst Reg
src1 (Imm -> RI
RIImm Imm
imm)
return (Any (intFormat width) code)
srCode Width
width Bool
sgn Format -> Reg -> Reg -> RI -> Instr
instr CmmExpr
x CmmExpr
y = do
let op_len :: Width
op_len = Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width
extend :: Width -> Width -> CmmExpr -> CmmExpr
extend = if Bool
sgn then Width -> Width -> CmmExpr -> CmmExpr
extendSExpr else Width -> Width -> CmmExpr -> CmmExpr
extendUExpr
(src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg (Width -> Width -> CmmExpr -> CmmExpr
extend Width
width Width
op_len CmmExpr
x)
(src2, code2) <- getSomeReg (extendUExpr width op_len y)
let code Reg
dst = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Reg -> Reg -> RI -> Instr
instr (Width -> Format
intFormat Width
op_len) Reg
dst Reg
src1 (Reg -> RI
RIReg Reg
src2)
return (Any (intFormat width) code)
divCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
divCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
divCode Width
width Bool
sgn CmmExpr
x CmmExpr
y = do
let op_len :: Width
op_len = Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width
extend :: Width -> Width -> CmmExpr -> CmmExpr
extend = if Bool
sgn then Width -> Width -> CmmExpr -> CmmExpr
extendSExpr else Width -> Width -> CmmExpr -> CmmExpr
extendUExpr
(src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg (Width -> Width -> CmmExpr -> CmmExpr
extend Width
width Width
op_len CmmExpr
x)
(src2, code2) <- getSomeReg (extend width op_len y)
let code Reg
dst = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
Format -> Bool -> Reg -> Reg -> Reg -> Instr
DIV (Width -> Format
intFormat Width
op_len) Bool
sgn Reg
dst Reg
src1 Reg
src2
return (Any (intFormat width) code)
trivialUCode :: Format
-> (Reg -> Reg -> Instr)
-> CmmExpr
-> NatM Register
trivialUCode :: Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUCode Format
rep Reg -> Reg -> Instr
instr CmmExpr
x = do
(src, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
let code' Reg
dst = OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
instr Reg
dst Reg
src
return (Any rep code')
fma_code :: Width
-> (Format -> Reg -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM Register
fma_code :: Width
-> (Format -> Reg -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM Register
fma_code Width
w Format -> Reg -> Reg -> Reg -> Reg -> Instr
instr CmmExpr
ra CmmExpr
rc CmmExpr
rb = do
let rep :: Format
rep = Width -> Format
floatFormat Width
w
(src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
ra
(src2, code2) <- getSomeReg rc
(src3, code3) <- getSomeReg rb
let instrCode Reg
rt =
OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
OrdList Instr
code2 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
OrdList Instr
code3 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> Reg -> Reg -> Reg -> Instr
instr Format
rep Reg
rt Reg
src1 Reg
src2 Reg
src3
return $ Any rep instrCode
remainderCode :: Width -> Bool -> Reg -> CmmExpr -> CmmExpr
-> NatM (Reg -> InstrBlock)
remainderCode :: Width
-> Bool -> Reg -> CmmExpr -> CmmExpr -> NatM (Reg -> OrdList Instr)
remainderCode Width
rep Bool
sgn Reg
reg_q CmmExpr
arg_x CmmExpr
arg_y = do
let op_len :: Width
op_len = Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
rep
fmt :: Format
fmt = Width -> Format
intFormat Width
op_len
extend :: Width -> Width -> CmmExpr -> CmmExpr
extend = if Bool
sgn then Width -> Width -> CmmExpr -> CmmExpr
extendSExpr else Width -> Width -> CmmExpr -> CmmExpr
extendUExpr
(x_reg, x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg (Width -> Width -> CmmExpr -> CmmExpr
extend Width
rep Width
op_len CmmExpr
arg_x)
(y_reg, y_code) <- getSomeReg (extend rep op_len arg_y)
return $ \Reg
reg_r -> OrdList Instr
y_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
x_code
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Bool -> Reg -> Reg -> Reg -> Instr
DIV Format
fmt Bool
sgn Reg
reg_q Reg
x_reg Reg
y_reg
, Format -> Reg -> Reg -> RI -> Instr
MULL Format
fmt Reg
reg_r Reg
reg_q (Reg -> RI
RIReg Reg
y_reg)
, Reg -> Reg -> Reg -> Instr
SUBF Reg
reg_r Reg
reg_r Reg
x_reg
]
coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP Width
fromRep Width
toRep CmmExpr
x = do
platform <- NatM Platform
getPlatform
let arch = Platform -> Arch
platformArch Platform
platform
coerceInt2FP' arch fromRep toRep x
coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP' Arch
ArchPPC Width
fromRep Width
toRep CmmExpr
x = do
(src, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
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' Reg
dst = OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
maybe_exts OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Section -> RawCmmStatics -> Instr
LDATA (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) (RawCmmStatics -> Instr) -> RawCmmStatics -> Instr
forall a b. (a -> b) -> a -> b
$ CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl
[CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
0x43300000 Width
W32),
CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
0x80000000 Width
W32)],
Reg -> Reg -> Imm -> Instr
XORIS Reg
itmp Reg
src (Int -> Imm
ImmInt Int
0x8000),
Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
itmp (Platform -> Int -> AddrMode
spRel Platform
platform Int
3),
Reg -> Imm -> Instr
LIS Reg
itmp (Int -> Imm
ImmInt Int
0x4330),
Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
itmp (Platform -> Int -> AddrMode
spRel Platform
platform Int
2),
Format -> Reg -> AddrMode -> Instr
LD Format
FF64 Reg
ftmp (Platform -> Int -> AddrMode
spRel Platform
platform Int
2)
] OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
addr_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Format -> Reg -> AddrMode -> Instr
LD Format
FF64 Reg
dst AddrMode
addr,
Format -> Reg -> Reg -> Reg -> Instr
FSUB Format
FF64 Reg
dst Reg
ftmp Reg
dst
] OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
maybe_frsp Reg
dst
maybe_exts = case Width
fromRep of
Width
W8 -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> Reg -> Instr
EXTS Format
II8 Reg
src Reg
src
Width
W16 -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> Reg -> Instr
EXTS Format
II16 Reg
src Reg
src
Width
W32 -> OrdList Instr
forall a. OrdList a
nilOL
Width
_ -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.coerceInt2FP: no match"
maybe_frsp Reg
dst
= case Width
toRep of
Width
W32 -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Reg -> Reg -> Instr
FRSP Reg
dst Reg
dst
Width
W64 -> OrdList Instr
forall a. OrdList a
nilOL
Width
_ -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.coerceInt2FP: no match"
return (Any (floatFormat toRep) code')
coerceInt2FP' (ArchPPC_64 PPC_64ABI
_) Width
fromRep Width
toRep CmmExpr
x = do
(src, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
platform <- getPlatform
upper <- getNewRegNat II64
lower <- getNewRegNat II64
l1 <- getBlockIdNat
l2 <- getBlockIdNat
let
code' Reg
dst = OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
maybe_exts OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Format -> Reg -> AddrMode -> Instr
ST Format
II64 Reg
src (Platform -> Int -> AddrMode
spRel Platform
platform Int
3),
Format -> Reg -> AddrMode -> Instr
LD Format
FF64 Reg
dst (Platform -> Int -> AddrMode
spRel Platform
platform Int
3),
Reg -> Reg -> Instr
FCFID Reg
dst Reg
dst
] OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
maybe_frsp Reg
dst
maybe_exts
= case Width
fromRep of
Width
W8 -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> Reg -> Instr
EXTS Format
II8 Reg
src Reg
src
Width
W16 -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> Reg -> Instr
EXTS Format
II16 Reg
src Reg
src
Width
W32 -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> Reg -> Instr
EXTS Format
II32 Reg
src Reg
src
Width
W64 -> case Width
toRep of
Width
W32 -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Reg -> Reg -> RI -> Instr
SRA Format
II64 Reg
upper Reg
src (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
53))
, Format -> Reg -> Reg -> Int -> Instr
CLRLI Format
II64 Reg
lower Reg
src Int
53
, Reg -> Reg -> RI -> Instr
ADD Reg
upper Reg
upper (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
1))
, Reg -> Reg -> RI -> Instr
ADD Reg
lower Reg
lower (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
2047))
, Format -> Reg -> RI -> Instr
CMPL Format
II64 Reg
upper (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
2))
, Reg -> Reg -> RI -> Instr
OR Reg
lower Reg
lower (Reg -> RI
RIReg Reg
src)
, Format -> Reg -> Reg -> Int -> Instr
CLRRI Format
II64 Reg
lower Reg
lower Int
11
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
LTT BlockId
l2 Maybe Bool
forall a. Maybe a
Nothing
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
l1 Maybe Bool
forall a. Maybe a
Nothing
, BlockId -> Instr
NEWBLOCK BlockId
l1
, Reg -> Reg -> Instr
MR Reg
src Reg
lower
, Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
l2 Maybe Bool
forall a. Maybe a
Nothing
, BlockId -> Instr
NEWBLOCK BlockId
l2
]
Width
_ -> OrdList Instr
forall a. OrdList a
nilOL
Width
_ -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.coerceInt2FP: no match"
maybe_frsp Reg
dst
= case Width
toRep of
Width
W32 -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Reg -> Reg -> Instr
FRSP Reg
dst Reg
dst
Width
W64 -> OrdList Instr
forall a. OrdList a
nilOL
Width
_ -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.coerceInt2FP: no match"
return (Any (floatFormat toRep) code')
coerceInt2FP' Arch
_ Width
_ Width
_ CmmExpr
_ = String -> NatM Register
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.coerceInt2FP: unknown arch"
coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int Width
fromRep Width
toRep CmmExpr
x = do
platform <- NatM Platform
getPlatform
let arch = Platform -> Arch
platformArch Platform
platform
coerceFP2Int' arch fromRep toRep x
coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int' Arch
ArchPPC Width
_ Width
toRep CmmExpr
x = do
platform <- NatM Platform
getPlatform
(src, code) <- getSomeReg x
tmp <- getNewRegNat FF64
let
code' Reg
dst = OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Reg -> Reg -> Instr
FCTIWZ Reg
tmp Reg
src,
Format -> Reg -> AddrMode -> Instr
ST Format
FF64 Reg
tmp (Platform -> Int -> AddrMode
spRel Platform
platform Int
2),
Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
dst (Platform -> Int -> AddrMode
spRel Platform
platform Int
3)]
return (Any (intFormat toRep) code')
coerceFP2Int' (ArchPPC_64 PPC_64ABI
_) Width
_ Width
toRep CmmExpr
x = do
platform <- NatM Platform
getPlatform
(src, code) <- getSomeReg x
tmp <- getNewRegNat FF64
let
code' Reg
dst = OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
Reg -> Reg -> Instr
FCTIDZ Reg
tmp Reg
src,
Format -> Reg -> AddrMode -> Instr
ST Format
FF64 Reg
tmp (Platform -> Int -> AddrMode
spRel Platform
platform Int
3),
Format -> Reg -> AddrMode -> Instr
LD Format
II64 Reg
dst (Platform -> Int -> AddrMode
spRel Platform
platform Int
3)]
return (Any (intFormat toRep) code')
coerceFP2Int' Arch
_ Width
_ Width
_ CmmExpr
_ = String -> NatM Register
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.coerceFP2Int: unknown arch"