{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module GHC.CmmToAsm.RV64.CodeGen
( cmmTopCodeGen,
generateJumpTableForInstr,
makeFarBranches,
)
where
import Control.Monad
import Data.Maybe
import Data.Word
import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.DebugBlock
import GHC.Cmm.Switch
import GHC.Cmm.Utils
import GHC.CmmToAsm.CPrim
import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Monad
( NatM,
getBlockIdNat,
getConfig,
getDebugBlock,
getFileId,
getNewLabelNat,
getNewRegNat,
getPicBaseMaybeNat,
getPlatform,
)
import GHC.CmmToAsm.PIC
import GHC.CmmToAsm.RV64.Cond
import GHC.CmmToAsm.RV64.Instr
import GHC.CmmToAsm.RV64.Regs
import GHC.CmmToAsm.Types
import GHC.Data.FastString
import GHC.Data.OrdList
import GHC.Float
import GHC.Platform
import GHC.Platform.Reg
import GHC.Platform.Regs
import GHC.Prelude hiding (EQ)
import GHC.Types.Basic
import GHC.Types.ForeignCall
import GHC.Types.SrcLoc (srcSpanFile, srcSpanStartCol, srcSpanStartLine)
import GHC.Types.Tickish (GenTickish (..))
import GHC.Types.Unique.DSM
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic
cmmTopCodeGen ::
RawCmmDecl ->
NatM [NatCmmDecl RawCmmStatics Instr]
cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl RawCmmStatics Instr]
cmmTopCodeGen _cmm :: RawCmmDecl
_cmm@(CmmProc LabelMap RawCmmStatics
info CLabel
lab [GlobalRegUse]
live CmmGraph
graph) = do
picBaseMb <- NatM (Maybe Reg)
getPicBaseMaybeNat
when (isJust picBaseMb) $ panic "RV64.cmmTopCodeGen: Unexpected PIC base register (RISCV ISA does not define one)"
let blocks = CmmGraph -> [Block CmmNode C C]
toBlockListEntryFirst CmmGraph
graph
(nat_blocks, statics) <- mapAndUnzipM basicBlockCodeGen blocks
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
pure tops
cmmTopCodeGen (CmmData Section
sec RawCmmStatics
dat) = [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [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 :: Block CmmNode C C
-> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr])
basicBlockCodeGen Block CmmNode C C
block = do
config <- NatM NCGConfig
getConfig
let (_, nodes, tail) = blockSplit block
id = Block CmmNode C C -> BlockId
forall (x :: Extensibility). Block CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel Block CmmNode C C
block
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
header_comment_instr
| Bool
debugIsOn =
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL
(Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ SDoc -> Instr
MULTILINE_COMMENT
( [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"-- --------------------------- basicBlockCodeGen --------------------------- --\n"
SDoc -> SDoc -> SDoc
$+$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle (Platform -> Block CmmNode C C -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc (NCGConfig -> Platform
ncgPlatform NCGConfig
config) Block CmmNode C C
block)
)
| Bool
otherwise = OrdList Instr
forall a. OrdList a
nilOL
loc_instrs <- genLocInstrs
mid_instrs <- stmtsToInstrs stmts
(!tail_instrs) <- stmtToInstrs tail
let instrs = OrdList Instr
header_comment_instr OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` 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
(top, other_blocks, statics) = foldrOL mkBlocks ([], [], []) instrs
return (BasicBlock id top : other_blocks, statics)
where
genLocInstrs :: NatM (OrdList Instr)
genLocInstrs :: NatM (OrdList Instr)
genLocInstrs = do
dbg <- BlockId -> NatM (Maybe DebugBlock)
getDebugBlock (Block CmmNode C C -> BlockId
forall (x :: Extensibility). Block CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel Block CmmNode C C
block)
case dblSourceTick =<< dbg of
Just (SourceNote RealSrcSpan
span LexicalFastString
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
pure $ unitOL $ LOCATION fileId line col name
Maybe CmmTickish
_ -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OrdList Instr
forall a. OrdList a
nilOL
mkBlocks ::
Instr ->
([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) ->
([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
mkBlocks :: forall h g.
Instr
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
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
dat GenCmmDecl 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
instr Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
instrs, [NatBasicBlock Instr]
blocks, [GenCmmDecl RawCmmStatics h g]
statics)
ann :: SDoc -> Instr -> Instr
ann :: SDoc -> Instr -> Instr
ann SDoc
doc Instr
instr = SDoc -> Instr -> Instr
ANN SDoc
doc Instr
instr
{-# INLINE ann #-}
annExpr :: CmmExpr -> Instr -> Instr
annExpr :: CmmExpr -> Instr -> Instr
annExpr CmmExpr
e = SDoc -> Instr -> Instr
ANN ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc) -> (CmmExpr -> [Char]) -> CmmExpr -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmExpr -> [Char]
forall a. Show a => a -> [Char]
show (CmmExpr -> SDoc) -> CmmExpr -> SDoc
forall a b. (a -> b) -> a -> b
$ CmmExpr
e)
{-# INLINE annExpr #-}
genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM (OrdList Instr)
genSwitch NCGConfig
config CmmExpr
expr SwitchTargets
targets = do
(reg, fmt1, e_code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
indexExpr
let fmt = Format
II64
targetReg <- getNewRegNat fmt
lbl <- getNewLabelNat
dynRef <- cmmMakeDynamicReference config DataReference lbl
(tableReg, fmt2, t_code) <- getSomeReg dynRef
let code =
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ SDoc -> Instr
COMMENT ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"indexExpr" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc) -> (CmmExpr -> [Char]) -> CmmExpr -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmExpr -> [Char]
forall a. Show a => a -> [Char]
show) CmmExpr
indexExpr),
SDoc -> Instr
COMMENT ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"dynRef" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc) -> (CmmExpr -> [Char]) -> CmmExpr -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmExpr -> [Char]
forall a. Show a => a -> [Char]
show) CmmExpr
dynRef)
]
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` 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
[ SDoc -> Instr
COMMENT (FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
"Jump table for switch"),
CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
fmt1) Reg
reg) (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
fmt1) Reg
reg) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
3))),
Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
W64 Reg
targetReg) (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
fmt1) Reg
reg) (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
fmt2) Reg
tableReg),
Format -> Operand -> Operand -> Instr
LDRU Format
II64 (Width -> Reg -> Operand
OpReg Width
W64 Reg
targetReg) (AddrMode -> Operand
OpAddr (Reg -> Imm -> AddrMode
AddrRegImm Reg
targetReg (Int -> Imm
ImmInt Int
0))),
Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
W64 Reg
targetReg) (Width -> Reg -> Operand
OpReg Width
W64 Reg
targetReg) (Width -> Reg -> Operand
OpReg Width
W64 Reg
tableReg),
[Maybe BlockId] -> Maybe CLabel -> Reg -> Instr
J_TBL [Maybe BlockId]
ids (CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
lbl) Reg
targetReg
]
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 (J_TBL [Maybe BlockId]
ids (Just CLabel
lbl) Reg
_) =
let jumpTable :: [CmmStatic]
jumpTable =
(Maybe BlockId -> CmmStatic) -> [Maybe BlockId] -> [CmmStatic]
forall a b. (a -> b) -> [a] -> [b]
map Maybe BlockId -> CmmStatic
jumpTableEntryRel [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
stmtsToInstrs ::
[CmmNode O O] ->
NatM InstrBlock
stmtsToInstrs :: [CmmNode O O] -> NatM (OrdList Instr)
stmtsToInstrs [CmmNode O O]
stmts = [OrdList Instr] -> OrdList Instr
forall a. [OrdList a] -> OrdList a
concatOL ([OrdList Instr] -> OrdList Instr)
-> NatM [OrdList Instr] -> NatM (OrdList Instr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CmmNode O O -> NatM (OrdList Instr))
-> [CmmNode O O] -> 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 O O -> NatM (OrdList Instr)
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> NatM (OrdList Instr)
stmtToInstrs [CmmNode O O]
stmts
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
CmmUnsafeForeignCall ForeignTarget
target [CmmFormal]
result_regs [CmmExpr]
args ->
ForeignTarget -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
genCCall ForeignTarget
target [CmmFormal]
result_regs [CmmExpr]
args
CmmComment FastString
s -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (SDoc -> Instr
COMMENT (FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
s)))
CmmTick {} -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
| 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
| 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
CmmBranch BlockId
id -> BlockId -> NatM (OrdList Instr)
genBranch BlockId
id
CmmCondBranch CmmExpr
arg BlockId
true BlockId
false Maybe Bool
_prediction ->
BlockId -> BlockId -> CmmExpr -> NatM (OrdList Instr)
genCondBranch BlockId
true BlockId
false CmmExpr
arg
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} -> CmmExpr -> NatM (OrdList Instr)
genJump CmmExpr
arg
CmmUnwind [(GlobalReg, Maybe CmmExpr)]
_regs -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OrdList Instr
forall a. OrdList a
nilOL
CmmForeignCall {} -> [Char] -> SDoc -> NatM (OrdList Instr)
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"stmtToInstrs: statement should have been cps'd away" (Platform -> CmmNode e x -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmNode e x
stmt)
CmmEntry {} -> [Char] -> SDoc -> NatM (OrdList Instr)
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"stmtToInstrs: statement should have been cps'd away" (Platform -> CmmNode e x -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmNode e x
stmt)
type InstrBlock =
OrdList Instr
data Register
= Fixed Format Reg InstrBlock
| Any Format (Reg -> InstrBlock)
swizzleRegisterRep :: Format -> Register -> Register
swizzleRegisterRep :: Format -> Register -> Register
swizzleRegisterRep Format
format' (Fixed Format
_format Reg
reg OrdList Instr
code) = Format -> Reg -> OrdList Instr -> Register
Fixed Format
format' Reg
reg OrdList Instr
code
swizzleRegisterRep Format
format' (Any Format
_format Reg -> OrdList Instr
codefn) = Format -> (Reg -> OrdList Instr) -> Register
Any Format
format' Reg -> OrdList Instr
codefn
getRegisterReg :: Platform -> CmmReg -> Reg
getRegisterReg :: Platform -> CmmReg -> Reg
getRegisterReg Platform
_ (CmmLocal (LocalReg Unique
u CmmType
pk)) =
VirtualReg -> Reg
RegVirtual (VirtualReg -> Reg) -> VirtualReg -> Reg
forall a b. (a -> b) -> a -> b
$ Unique -> Format -> VirtualReg
mkVirtualReg Unique
u (CmmType -> Format
cmmTypeFormat CmmType
pk)
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 -> [Char] -> SDoc -> Reg
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"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)
getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock)
getSomeReg :: CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr = do
r <- CmmExpr -> NatM Register
getRegister CmmExpr
expr
case r of
Any Format
rep Reg -> OrdList Instr
code -> do
newReg <- Format -> NatM Reg
getNewRegNat Format
rep
return (newReg, rep, code newReg)
Fixed Format
rep Reg
reg OrdList Instr
code ->
(Reg, Format, OrdList Instr) -> NatM (Reg, Format, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg, Format
rep, OrdList Instr
code)
getFloatReg :: (HasCallStack) => CmmExpr -> NatM (Reg, Format, InstrBlock)
getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
expr = do
r <- CmmExpr -> NatM Register
getRegister CmmExpr
expr
case r of
Any Format
rep Reg -> OrdList Instr
code | Format -> Bool
isFloatFormat Format
rep -> do
newReg <- Format -> NatM Reg
getNewRegNat Format
rep
return (newReg, rep, code newReg)
Any Format
II32 Reg -> OrdList Instr
code -> do
newReg <- Format -> NatM Reg
getNewRegNat Format
FF32
return (newReg, FF32, code newReg)
Any Format
II64 Reg -> OrdList Instr
code -> do
newReg <- Format -> NatM Reg
getNewRegNat Format
FF64
return (newReg, FF64, code newReg)
Any Format
_w Reg -> OrdList Instr
_code -> do
config <- NatM NCGConfig
getConfig
pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr)
Fixed Format
rep Reg
reg OrdList Instr
code ->
(Reg, Format, OrdList Instr) -> NatM (Reg, Format, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg, Format
rep, OrdList Instr
code)
litToImm' :: CmmLit -> Operand
litToImm' :: CmmLit -> Operand
litToImm' = Imm -> Operand
OpImm (Imm -> Operand) -> (CmmLit -> Imm) -> CmmLit -> Operand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmLit -> Imm
litToImm
getRegister :: CmmExpr -> NatM Register
getRegister :: CmmExpr -> NatM Register
getRegister CmmExpr
e = do
config <- NatM NCGConfig
getConfig
getRegister' config (ncgPlatform config) e
opRegWidth :: Width -> Width
opRegWidth :: Width -> Width
opRegWidth Width
W64 = Width
W64
opRegWidth Width
W32 = Width
W32
opRegWidth Width
W16 = Width
W32
opRegWidth Width
W8 = Width
W32
opRegWidth Width
w = [Char] -> SDoc -> Width
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"opRegWidth" ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Unsupported width" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w)
getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat (CmmMachOp (MO_Add Width
w0) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
w1)])
| Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 =
NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Sub Width
w0) [CmmExpr
x, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (-Integer
i) Width
w1)])
getRegister' NCGConfig
config Platform
plat (CmmMachOp (MO_Sub Width
w0) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
w1)])
| Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 =
NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
w0) [CmmExpr
x, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (-Integer
i) Width
w1)])
getRegister' NCGConfig
config Platform
plat CmmExpr
expr =
case CmmExpr
expr of
CmmReg (CmmGlobal (GlobalRegUse GlobalReg
PicBaseReg CmmType
_)) ->
[Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister': There's no PIC base register on RISCV" (GlobalReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr GlobalReg
PicBaseReg)
CmmLit CmmLit
lit ->
case CmmLit
lit of
CmmInt Integer
0 Width
w -> Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> OrdList Instr -> Register
Fixed (Width -> Format
intFormat Width
w) Reg
zeroReg OrdList Instr
forall a. OrdList a
nilOL
CmmInt Integer
i Width
w ->
let imm :: Operand
imm = Imm -> Operand
OpImm (Imm -> Operand) -> (Integer -> Imm) -> Integer -> Operand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Imm
ImmInteger (Integer -> Operand) -> Integer -> Operand
forall a b. (a -> b) -> a -> b
$ Width -> Integer -> Integer
narrowU Width
w Integer
i
in Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
dst) Operand
imm)))
CmmFloat Rational
0 Width
w -> do
let op :: Operand
op = CmmLit -> Operand
litToImm' CmmLit
lit
Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
w) (\Reg
dst -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
dst) Operand
op)))
CmmFloat Rational
_f Width
W8 -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmLit:CmmFloat), no support for bytes" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
CmmFloat Rational
_f Width
W16 -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmLit:CmmFloat), no support for halfs" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
CmmFloat Rational
f Width
W32 -> do
let word :: Word32
word = Float -> Word32
castFloatToWord32 (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
f) :: Word32
intReg <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
W32)
return
( Any
(floatFormat W32)
( \Reg
dst ->
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr
(Instr -> Instr) -> Instr -> Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W32 Reg
intReg) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
word))),
Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W32 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W32 Reg
intReg)
]
)
)
CmmFloat Rational
f Width
W64 -> do
let word :: Word64
word = Double -> Word64
castDoubleToWord64 (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
f) :: Word64
intReg <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
W64)
return
( Any
(floatFormat W64)
( \Reg
dst ->
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr
(Instr -> Instr) -> Instr -> Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W64 Reg
intReg) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
word))),
Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
intReg)
]
)
)
CmmFloat Rational
_f Width
_w -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmLit:CmmFloat), unsupported float lit" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
CmmVec [CmmLit]
_lits -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmLit:CmmVec): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
CmmLabel CLabel
lbl -> do
let op :: Operand
op = Imm -> Operand
OpImm (CLabel -> Imm
ImmCLbl CLabel
lbl)
rep :: CmmType
rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
plat CmmLit
lit
format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
rep
Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format (\Reg
dst -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Format -> Operand -> Operand -> Instr
LDR Format
format (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) Reg
dst) Operand
op)))
CmmLabelOff CLabel
lbl Int
off | Int -> Integer -> Bool
isNbitEncodeable Int
12 (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) -> do
let op :: Operand
op = Imm -> Operand
OpImm (CLabel -> Int -> Imm
ImmIndex CLabel
lbl Int
off)
rep :: CmmType
rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
plat CmmLit
lit
format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
rep
Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format (\Reg
dst -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Operand -> Operand -> Instr
LDR Format
format (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) Reg
dst) Operand
op))
CmmLabelOff CLabel
lbl Int
off -> do
let op :: Operand
op = CmmLit -> Operand
litToImm' (CLabel -> CmmLit
CmmLabel CLabel
lbl)
rep :: CmmType
rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
plat CmmLit
lit
format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
rep
width :: Width
width = CmmType -> Width
typeWidth CmmType
rep
(off_r, _off_format, off_code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg (CmmExpr -> NatM (Reg, Format, OrdList Instr))
-> CmmExpr -> NatM (Reg, Format, OrdList Instr)
forall a b. (a -> b) -> a -> b
$ CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
width)
return
( Any
format
( \Reg
dst ->
OrdList Instr
off_code
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Operand -> Operand -> Instr
LDR Format
format (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) Reg
dst) Operand
op
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
width Reg
dst) (Width -> Reg -> Operand
OpReg Width
width Reg
dst) (Width -> Reg -> Operand
OpReg Width
width Reg
off_r)
)
)
CmmLabelDiffOff {} -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmLit:CmmLabelOff): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
CmmBlock BlockId
_ -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmLit:CmmLabelOff): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
CmmLit
CmmHighStackMark -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmLit:CmmLabelOff): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
CmmLoad CmmExpr
mem CmmType
rep AlignmentSpec
_ -> do
let format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
rep
width :: Width
width = CmmType -> Width
typeWidth CmmType
rep
Amode addr addr_code <- Platform -> Width -> CmmExpr -> NatM Amode
getAmode Platform
plat Width
width CmmExpr
mem
case width of
Width
w
| Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
<= Width
W64 ->
Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( Format -> (Reg -> OrdList Instr) -> Register
Any
Format
format
( \Reg
dst ->
OrdList Instr
addr_code
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Operand -> Operand -> Instr
LDRU Format
format (Width -> Reg -> Operand
OpReg Width
width Reg
dst) (AddrMode -> Operand
OpAddr AddrMode
addr)
)
)
Width
_ ->
[Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic ([Char]
"Width too big! Cannot load: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Width -> [Char]
forall a. Show a => a -> [Char]
show Width
width) (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
CmmStackSlot Area
_ Int
_ ->
[Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmStackSlot): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
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
plat CmmReg
reg)
OrdList Instr
forall a. OrdList a
nilOL
)
CmmRegOff CmmReg
reg Int
off | Int -> Integer -> Bool
isNbitEncodeable Int
12 (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) -> do
NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat
(CmmExpr -> NatM Register) -> CmmExpr -> NatM Register
forall a b. (a -> b) -> a -> b
$ 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)
CmmRegOff CmmReg
reg Int
off -> do
(off_r, _off_format, off_code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg (CmmExpr -> NatM (Reg, Format, OrdList Instr))
-> CmmExpr -> NatM (Reg, Format, OrdList Instr)
forall a b. (a -> b) -> a -> b
$ CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
width)
(reg, _format, code) <- getSomeReg $ CmmReg reg
return
$ Any
(intFormat width)
( \Reg
dst ->
OrdList Instr
off_code
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` Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
width Reg
dst) (Width -> Reg -> Operand
OpReg Width
width Reg
reg) (Width -> Reg -> Operand
OpReg Width
width Reg
off_r)
)
where
width :: Width
width = CmmType -> Width
typeWidth (CmmReg -> CmmType
cmmRegType CmmReg
reg)
CmmMachOp (MO_RelaxedRead Width
w) [CmmExpr
e] ->
CmmExpr -> NatM Register
getRegister (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad CmmExpr
e (Width -> CmmType
cmmBits Width
w) AlignmentSpec
NaturallyAligned)
CmmMachOp MachOp
op [CmmExpr
e] -> do
(reg, _format, code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
e
case op of
MO_Not Width
w -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) ((Reg -> OrdList Instr) -> Register)
-> (Reg -> OrdList Instr) -> Register
forall a b. (a -> b) -> a -> b
$ \Reg
dst ->
let w' :: Width
w' = Width -> Width
opRegWidth Width
w
in OrdList Instr
code
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
SDoc -> Instr -> Instr
ann ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"not") (Operand -> Operand -> Operand -> Instr
XORI (Width -> Reg -> Operand
OpReg Width
w' Reg
dst) (Width -> Reg -> Operand
OpReg Width
w' Reg
reg) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (-Int
1))))
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
w' Width
w Reg
dst
MO_S_Neg Width
w -> OrdList Instr -> Width -> Reg -> NatM Register
negate OrdList Instr
code Width
w Reg
reg
MO_F_Neg Width
w ->
Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return
(Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any
(Width -> Format
floatFormat Width
w)
( \Reg
dst ->
OrdList Instr
code
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
NEG (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg)
)
MO_SF_Round Width
from Width
to | Width
from Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
W32 -> do
(reg_x, code_x) <- Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
signExtendReg Width
from Width
W32 Reg
reg
pure
$ Any
(floatFormat to)
( \Reg
dst ->
OrdList Instr
code
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_x
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (FcvtVariant -> Operand -> Operand -> Instr
FCVT FcvtVariant
IntToFloat (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg_x))
)
MO_SF_Round Width
from Width
to ->
Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any
(Width -> Format
floatFormat Width
to)
( \Reg
dst ->
OrdList Instr
code
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (FcvtVariant -> Operand -> Operand -> Instr
FCVT FcvtVariant
IntToFloat (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))
)
MO_FS_Truncate Width
from Width
to
| Width
to Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
W32 ->
Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any
(Width -> Format
intFormat Width
to)
( \Reg
dst ->
OrdList Instr
code
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (FcvtVariant -> Operand -> Operand -> Instr
FCVT FcvtVariant
FloatToInt (Width -> Reg -> Operand
OpReg Width
W32 Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtendAdjustPrecission Width
W32 Width
to Reg
dst Reg
dst
)
MO_FS_Truncate Width
from Width
to ->
Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any
(Width -> Format
intFormat Width
to)
( \Reg
dst ->
OrdList Instr
code
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (FcvtVariant -> Operand -> Operand -> Instr
FCVT FcvtVariant
FloatToInt (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
from Width
to Reg
dst
)
MO_UU_Conv Width
from Width
to
| Width
from Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
<= Width
to ->
Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any
(Width -> Format
intFormat Width
to)
( \Reg
dst ->
OrdList Instr
code
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
e (Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))
)
MO_UU_Conv Width
from Width
to ->
Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any
(Width -> Format
intFormat Width
to)
( \Reg
dst ->
OrdList Instr
code
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
e (Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
from Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
from Width
to Reg
dst
)
MO_SS_Conv Width
from Width
to -> Width -> Width -> Reg -> OrdList Instr -> NatM Register
forall {f :: * -> *}.
Applicative f =>
Width -> Width -> Reg -> OrdList Instr -> f Register
ss_conv Width
from Width
to Reg
reg OrdList Instr
code
MO_FF_Conv Width
from Width
to -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
to) (\Reg
dst -> OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
e (FcvtVariant -> Operand -> Operand -> Instr
FCVT FcvtVariant
FloatToFloat (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg)))
MO_WF_Bitcast Width
w -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
w) (\Reg
dst -> OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg))
MO_FW_Bitcast Width
w -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg))
MO_XX_Conv Width
from Width
to
| Width
to Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
from ->
Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any
(Width -> Format
intFormat Width
to)
( \Reg
dst ->
OrdList Instr
code
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
e (Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
from Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
from Width
to Reg
dst
)
MO_XX_Conv Width
_from Width
to -> Format -> Register -> Register
swizzleRegisterRep (Width -> Format
intFormat Width
to) (Register -> Register) -> NatM Register -> NatM Register
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmExpr -> NatM Register
getRegister CmmExpr
e
MO_AlignmentCheck Int
align Width
wordWidth -> do
reg <- NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat CmmExpr
e
addAlignmentCheck align wordWidth reg
MachOp
x -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic ([Char]
"getRegister' (monadic CmmMachOp): " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ MachOp -> [Char]
forall a. Show a => a -> [Char]
show MachOp
x) (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
where
negate :: OrdList Instr -> Width -> Reg -> NatM Register
negate OrdList Instr
code Width
w Reg
reg = do
let w' :: Width
w' = Width -> Width
opRegWidth Width
w
(reg', code_sx) <- Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
signExtendReg Width
w Width
w' Reg
reg
return $ Any (intFormat w) $ \Reg
dst ->
OrdList Instr
code
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_sx
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
NEG (Width -> Reg -> Operand
OpReg Width
w' Reg
dst) (Width -> Reg -> Operand
OpReg Width
w' Reg
reg')
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
w' Width
w Reg
dst
ss_conv :: Width -> Width -> Reg -> OrdList Instr -> f Register
ss_conv Width
from Width
to Reg
reg OrdList Instr
code
| Width
from Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
to = do
Register -> f Register
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Register -> f Register) -> Register -> f Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) ((Reg -> OrdList Instr) -> Register)
-> (Reg -> OrdList Instr) -> Register
forall a b. (a -> b) -> a -> b
$ \Reg
dst ->
OrdList Instr
code
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend Width
from Width
to Reg
reg Reg
dst
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
from Width
to Reg
dst
| Width
from Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
to =
Register -> f Register
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Register -> f Register) -> Register -> f Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) ((Reg -> OrdList Instr) -> Register)
-> (Reg -> OrdList Instr) -> Register
forall a b. (a -> b) -> a -> b
$ \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
[ SDoc -> Instr -> Instr
ann
([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"MO_SS_Conv: narrow register signed" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
reg SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
from SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
to)
(Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))),
Operand -> Operand -> Operand -> Instr
SRA (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))
]
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
from Width
to Reg
dst
| Bool
otherwise =
Register -> f Register
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Register -> f Register) -> Register -> f Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
from) ((Reg -> OrdList Instr) -> Register)
-> (Reg -> OrdList Instr) -> Register
forall a b. (a -> b) -> a -> b
$ \Reg
dst ->
OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
from Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg)
where
shift :: Int
shift = Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Width -> Int
widthInBits Width
from Int -> Int -> Int
forall a. Num a => a -> a -> a
- Width -> Int
widthInBits Width
to)
CmmMachOp (MO_Add Width
_) [expr' :: CmmExpr
expr'@(CmmReg (CmmGlobal GlobalRegUse
_r)), CmmLit (CmmInt Integer
0 Width
_)] -> NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat CmmExpr
expr'
CmmMachOp (MO_Sub Width
_) [expr' :: CmmExpr
expr'@(CmmReg (CmmGlobal GlobalRegUse
_r)), CmmLit (CmmInt Integer
0 Width
_)] -> NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat CmmExpr
expr'
CmmMachOp (MO_Add Width
w) [CmmReg CmmReg
reg, CmmLit (CmmInt Integer
n Width
_)]
| Integer -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm Integer
n -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
w Reg
d) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
where
w' :: Width
w' = Format -> Width
formatToWidth (CmmType -> Format
cmmTypeFormat (CmmReg -> CmmType
cmmRegType CmmReg
reg))
r' :: Reg
r' = Platform -> CmmReg -> Reg
getRegisterReg Platform
plat CmmReg
reg
CmmMachOp (MO_Sub Width
w) [CmmReg CmmReg
reg, CmmLit (CmmInt Integer
n Width
_)]
| Integer -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm Integer
n -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SUB (Width -> Reg -> Operand
OpReg Width
w Reg
d) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
where
w' :: Width
w' = Format -> Width
formatToWidth (CmmType -> Format
cmmTypeFormat (CmmReg -> CmmType
cmmRegType CmmReg
reg))
r' :: Reg
r' = Platform -> CmmReg -> Reg
getRegisterReg Platform
plat CmmReg
reg
CmmMachOp (MO_U_Quot Width
w) [CmmExpr
x, CmmExpr
y] | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 Bool -> Bool -> Bool
|| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W16 -> do
(reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
(reg_y, format_y, code_y) <- getSomeReg y
return
$ Any
(intFormat w)
( \Reg
dst ->
OrdList Instr
code_x
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg (Format -> Width
formatToWidth Format
format_x) Width
w Reg
reg_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` Width -> Width -> Reg -> OrdList Instr
truncateReg (Format -> Width
formatToWidth Format
format_y) Width
w Reg
reg_y
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
DIVU (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y))
)
CmmMachOp (MO_Shl Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32,
Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n,
Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
32 -> do
(reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
return
$ Any
(intFormat w)
( \Reg
dst ->
OrdList Instr
code_x
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n)))
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
w Width
w Reg
dst
)
CmmMachOp (MO_Shl Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64,
Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n,
Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
64 -> do
(reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
return
$ Any
(intFormat w)
( \Reg
dst ->
OrdList Instr
code_x
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n)))
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
w Width
w Reg
dst
)
CmmMachOp (MO_S_Shr Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)] | Integer -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm Integer
n -> do
(reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
(reg_x', code_x') <- signExtendReg (formatToWidth format_x) w reg_x
return
$ Any
(intFormat w)
( \Reg
dst ->
OrdList Instr
code_x
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_x'
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRA (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n)))
)
CmmMachOp (MO_S_Shr Width
w) [CmmExpr
x, CmmExpr
y] -> do
(reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
(reg_y, _format_y, code_y) <- getSomeReg y
(reg_x', code_x') <- signExtendReg (formatToWidth format_x) w reg_x
return
$ Any
(intFormat w)
( \Reg
dst ->
OrdList Instr
code_x
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` 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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRA (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x') (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y))
)
CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8,
Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n,
Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
8 -> do
(reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
return
$ Any
(intFormat w)
( \Reg
dst ->
OrdList Instr
code_x
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg (Format -> Width
formatToWidth Format
format_x) Width
w Reg
reg_x
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n)))
)
CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W16,
Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n,
Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
16 -> do
(reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
return
$ Any
(intFormat w)
( \Reg
dst ->
OrdList Instr
code_x
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg (Format -> Width
formatToWidth Format
format_x) Width
w Reg
reg_x
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n)))
)
CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, CmmExpr
y] | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 Bool -> Bool -> Bool
|| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W16 -> do
(reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
(reg_y, _format_y, code_y) <- getSomeReg y
return
$ Any
(intFormat w)
( \Reg
dst ->
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` Width -> Width -> Reg -> OrdList Instr
truncateReg (Format -> Width
formatToWidth Format
format_x) Width
w Reg
reg_x
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y))
)
CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32,
Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n,
Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
32 -> do
(reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
return
$ Any
(intFormat w)
( \Reg
dst ->
OrdList Instr
code_x
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n)))
)
CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64,
Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n,
Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
64 -> do
(reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
return
$ Any
(intFormat w)
( \Reg
dst ->
OrdList Instr
code_x
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n)))
)
CmmMachOp (MO_And Width
w) [CmmReg CmmReg
reg, CmmLit (CmmInt Integer
n Width
_)]
| Integer -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm Integer
n ->
Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
AND (Width -> Reg -> Operand
OpReg Width
w Reg
d) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
where
w' :: Width
w' = Format -> Width
formatToWidth (CmmType -> Format
cmmTypeFormat (CmmReg -> CmmType
cmmRegType CmmReg
reg))
r' :: Reg
r' = Platform -> CmmReg -> Reg
getRegisterReg Platform
plat CmmReg
reg
CmmMachOp (MO_Or Width
w) [CmmReg CmmReg
reg, CmmLit (CmmInt Integer
n Width
_)]
| Integer -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm Integer
n ->
Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ORI (Width -> Reg -> Operand
OpReg Width
w Reg
d) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
where
w' :: Width
w' = Format -> Width
formatToWidth (CmmType -> Format
cmmTypeFormat (CmmReg -> CmmType
cmmRegType CmmReg
reg))
r' :: Reg
r' = Platform -> CmmReg -> Reg
getRegisterReg Platform
plat CmmReg
reg
CmmMachOp MachOp
op [CmmExpr
x, CmmExpr
y] -> do
let
bitOp :: Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
bitOp Width
w Operand -> Operand -> Operand -> OrdList Instr
op = do
(reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
(reg_y, format_y, code_y) <- getSomeReg y
massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOp: incompatible"
return
$ Any
(intFormat w)
( \Reg
dst ->
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` Operand -> Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y)
)
intOp :: Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
is_signed Width
w Operand -> Operand -> Operand -> OrdList Instr
op = do
(reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
(reg_y, format_y, code_y) <- getSomeReg y
massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"
let w' = Width -> Width
opRegWidth Width
w
signExt Reg
r
| Bool -> Bool
not Bool
is_signed = (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
r, OrdList Instr
forall a. OrdList a
nilOL)
| Bool
otherwise = Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
signExtendReg Width
w Width
w' Reg
r
(reg_x_sx, code_x_sx) <- signExt reg_x
(reg_y_sx, code_y_sx) <- signExt reg_y
return $ Any (intFormat w) $ \Reg
dst ->
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`
OrdList Instr
code_x_sx
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y_sx
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w' Reg
dst) (Width -> Reg -> Operand
OpReg Width
w' Reg
reg_x_sx) (Width -> Reg -> Operand
OpReg Width
w' Reg
reg_y_sx)
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
w' Width
w Reg
dst
floatOp :: Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatOp Width
w Operand -> Operand -> Operand -> OrdList Instr
op = do
(reg_fx, format_x, code_fx) <- HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
x
(reg_fy, format_y, code_fy) <- getFloatReg y
massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatOp: non-float"
return
$ Any
(floatFormat w)
( \Reg
dst ->
OrdList Instr
code_fx
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_fy
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fx) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fy)
)
floatCond :: Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w Operand -> Operand -> Operand -> OrdList Instr
op = do
(reg_fx, format_x, code_fx) <- HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
x
(reg_fy, format_y, code_fy) <- getFloatReg y
massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatCond: non-float"
return
$ Any
(intFormat w)
( \Reg
dst ->
OrdList Instr
code_fx
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_fy
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fx) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fy)
)
case MachOp
op of
MO_Add Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ADD Operand
d Operand
x Operand
y))
MO_Sub Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SUB Operand
d Operand
x Operand
y))
MO_Eq Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
bitOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
EQ))
MO_Ne Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
bitOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
NE))
MO_Mul Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
MUL Operand
d Operand
x Operand
y))
MO_S_MulMayOflo Width
w -> Width -> CmmExpr -> CmmExpr -> NatM Register
do_mul_may_oflo Width
w CmmExpr
x CmmExpr
y
MO_S_Quot Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
DIV Operand
d Operand
x Operand
y))
MO_S_Rem Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
REM Operand
d Operand
x Operand
y))
MO_U_Quot Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
DIVU Operand
d Operand
x Operand
y))
MO_U_Rem Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
REMU Operand
d Operand
x Operand
y))
MO_S_Ge Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
SGE))
MO_S_Le Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
SLE))
MO_S_Gt Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
SGT))
MO_S_Lt Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
SLT))
MO_U_Ge Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
UGE))
MO_U_Le Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
ULE))
MO_U_Gt Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
UGT))
MO_U_Lt Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
ULT))
MO_F_Add Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ADD Operand
d Operand
x Operand
y))
MO_F_Sub Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SUB Operand
d Operand
x Operand
y))
MO_F_Mul Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
MUL Operand
d Operand
x Operand
y))
MO_F_Quot Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
DIV Operand
d Operand
x Operand
y))
MO_F_Min Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
FMIN Operand
d Operand
x Operand
y))
MO_F_Max Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
FMAX Operand
d Operand
x Operand
y))
MO_F_Eq Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
EQ))
MO_F_Ne Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
NE))
MO_F_Ge Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
FGE))
MO_F_Le Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
FLE))
MO_F_Gt Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
FGT))
MO_F_Lt Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
FLT))
MO_And Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
bitOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
AND Operand
d Operand
x Operand
y))
MO_Or Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
bitOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
OR Operand
d Operand
x Operand
y))
MO_Xor Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
bitOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
XOR Operand
d Operand
x Operand
y))
MO_Shl Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SLL Operand
d Operand
x Operand
y))
MO_U_Shr Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRL Operand
d Operand
x Operand
y))
MO_S_Shr Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRA Operand
d Operand
x Operand
y))
MachOp
op -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (unhandled dyadic CmmMachOp): " (SDoc -> NatM Register) -> SDoc -> NatM Register
forall a b. (a -> b) -> a -> b
$ MachOp -> SDoc
pprMachOp MachOp
op SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr
CmmMachOp MachOp
op [CmmExpr
x, CmmExpr
y, CmmExpr
z] ->
case MachOp
op of
MO_FMA FMASign
var Int
l Width
w
| Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
-> case FMASign
var of
FMASign
FMAdd -> Width
-> (Operand -> Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
float3Op Width
w (\Operand
d Operand
n Operand
m Operand
a -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ FMASign -> Operand -> Operand -> Operand -> Operand -> Instr
FMA FMASign
FMAdd Operand
d Operand
n Operand
m Operand
a)
FMASign
FMSub -> Width
-> (Operand -> Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
float3Op Width
w (\Operand
d Operand
n Operand
m Operand
a -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ FMASign -> Operand -> Operand -> Operand -> Operand -> Instr
FMA FMASign
FMSub Operand
d Operand
n Operand
m Operand
a)
FMASign
FNMAdd -> Width
-> (Operand -> Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
float3Op Width
w (\Operand
d Operand
n Operand
m Operand
a -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ FMASign -> Operand -> Operand -> Operand -> Operand -> Instr
FMA FMASign
FNMSub Operand
d Operand
n Operand
m Operand
a)
FMASign
FNMSub -> Width
-> (Operand -> Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
float3Op Width
w (\Operand
d Operand
n Operand
m Operand
a -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ FMASign -> Operand -> Operand -> Operand -> Operand -> Instr
FMA FMASign
FNMAdd Operand
d Operand
n Operand
m Operand
a)
| Bool
otherwise
-> [Char] -> NatM Register
forall a. HasCallStack => [Char] -> a
sorry [Char]
"The RISCV64 backend does not (yet) support vectors."
MachOp
_ ->
[Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (unhandled ternary CmmMachOp): "
(SDoc -> NatM Register) -> SDoc -> NatM Register
forall a b. (a -> b) -> a -> b
$ MachOp -> SDoc
pprMachOp MachOp
op
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"in"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr
where
float3Op :: Width
-> (Operand -> Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
float3Op Width
w Operand -> Operand -> Operand -> Operand -> OrdList Instr
op = do
(reg_fx, format_x, code_fx) <- HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
x
(reg_fy, format_y, code_fy) <- getFloatReg y
(reg_fz, format_z, code_fz) <- getFloatReg z
massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z)
$ text "float3Op: non-float"
pure
$ Any (floatFormat w)
$ \Reg
dst ->
OrdList Instr
code_fx
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_fy
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_fz
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fx) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fy) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fz)
CmmMachOp MachOp
_op [CmmExpr]
_xs ->
[Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (variadic CmmMachOp): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
where
isNbitEncodeable :: Int -> Integer -> Bool
isNbitEncodeable :: Int -> Integer -> Bool
isNbitEncodeable Int
n Integer
i = let shift :: Int
shift = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 in (-Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
shift) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< (Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
shift)
do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
do_mul_may_oflo Width
w CmmExpr
_x CmmExpr
_y | Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
W64 = [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Cannot multiply larger than 64bit" (Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w)
do_mul_may_oflo w :: Width
w@Width
W64 CmmExpr
x CmmExpr
y = do
(reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
(reg_y, format_y, code_y) <- getSomeReg y
lo <- getNewRegNat II64
hi <- getNewRegNat II64
let nonSense = Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)
pure
$ Any
(intFormat w)
( \Reg
dst ->
OrdList Instr
code_x
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_x) Width
W64 Reg
reg_x Reg
reg_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` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_y) Width
W64 Reg
reg_y Reg
reg_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
[ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
MULH (Width -> Reg -> Operand
OpReg Width
w Reg
hi) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y)),
Operand -> Operand -> Operand -> Instr
MUL (Width -> Reg -> Operand
OpReg Width
w Reg
lo) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y),
Operand -> Operand -> Operand -> Instr
SRA (Width -> Reg -> Operand
OpReg Width
w Reg
lo) (Width -> Reg -> Operand
OpReg Width
w Reg
lo) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Width -> Int
widthInBits Width
W64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))),
SDoc -> Instr -> Instr
ann
([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Set flag if result of MULH contains more than sign bits.")
(Operand -> Operand -> Operand -> Instr
XOR (Width -> Reg -> Operand
OpReg Width
w Reg
hi) (Width -> Reg -> Operand
OpReg Width
w Reg
hi) (Width -> Reg -> Operand
OpReg Width
w Reg
lo)),
Operand -> Operand -> Operand -> Cond -> Instr
CSET (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
hi) Operand
nonSense Cond
NE
]
)
do_mul_may_oflo Width
w CmmExpr
x CmmExpr
y = do
(reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
(reg_y, format_y, code_y) <- getSomeReg y
let width_x = Format -> Width
formatToWidth Format
format_x
width_y = Format -> Width
formatToWidth Format
format_y
if w > width_x && w > width_y
then
pure
$ Any
(intFormat w)
( \Reg
dst ->
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
w Reg
dst) Operand
zero (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)))
)
else do
let use32BitMul = Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
<= Width
W32 Bool -> Bool -> Bool
&& Width
width_x Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
<= Width
W32 Bool -> Bool -> Bool
&& Width
width_y Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
<= Width
W32
nonSense = Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)
if use32BitMul
then do
narrowedReg <- getNewRegNat II64
pure
$ Any
(intFormat w)
( \Reg
dst ->
OrdList Instr
code_x
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_x) Width
W32 Reg
reg_x Reg
reg_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` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_y) Width
W32 Reg
reg_y Reg
reg_y
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
MUL (Width -> Reg -> Operand
OpReg Width
W32 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W32 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W32 Reg
reg_y))
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtendAdjustPrecission Width
W32 Width
w Reg
dst Reg
narrowedReg
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ SDoc -> Instr -> Instr
ann
([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Check if the multiplied value fits in the narrowed register")
(Operand -> Operand -> Operand -> Instr
SUB (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
narrowedReg)),
Operand -> Operand -> Operand -> Cond -> Instr
CSET (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
dst) Operand
nonSense Cond
NE
]
)
else
pure
$ Any
(intFormat w)
( \Reg
dst ->
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
w Reg
dst) Operand
zero (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
1)))
)
signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
signExtendReg Width
w Width
_w' Reg
r | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 = (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reg
r, OrdList Instr
forall a. OrdList a
nilOL)
signExtendReg Width
w Width
w' Reg
r = do
r' <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
w')
let instrs = Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend Width
w Width
w' Reg
r Reg
r'
pure (r', instrs)
signExtend :: Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend :: Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend Width
w Width
w' Reg
_r Reg
_r' | Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
w' = [Char] -> SDoc -> OrdList Instr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"This is not a sign extension, but a truncation." (SDoc -> OrdList Instr) -> SDoc -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w'
signExtend Width
w Width
w' Reg
_r Reg
_r' | Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
W64 Bool -> Bool -> Bool
|| Width
w' Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
W64 = [Char] -> SDoc -> OrdList Instr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Unexpected width (max is 64bit):" (SDoc -> OrdList Instr) -> SDoc -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w'
signExtend Width
w Width
w' Reg
r Reg
r' | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 Bool -> Bool -> Bool
&& Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 Bool -> Bool -> Bool
&& Reg
r Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
r' = OrdList Instr
forall a. OrdList a
nilOL
signExtend Width
w Width
w' Reg
r Reg
r' | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 Bool -> Bool -> Bool
&& Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w Reg
r)
signExtend Width
w Width
w' Reg
r Reg
r'
| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32 Bool -> Bool -> Bool
&& Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 =
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL
(Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ SDoc -> Instr -> Instr
ann
([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"sign-extend register (SEXT.W)" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w')
(Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)))
signExtend Width
w Width
w' Reg
r Reg
r' =
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ SDoc -> Instr -> Instr
ann
([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"narrow register signed" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w')
(Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))),
Operand -> Operand -> Operand -> Instr
SRA (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))
]
where
shift :: Int
shift = Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Width -> Int
widthInBits Width
w
signExtendAdjustPrecission :: Width -> Width -> Reg -> Reg -> OrdList Instr
signExtendAdjustPrecission :: Width -> Width -> Reg -> Reg -> OrdList Instr
signExtendAdjustPrecission Width
w Width
w' Reg
_r Reg
_r' | Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
W64 Bool -> Bool -> Bool
|| Width
w' Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
W64 = [Char] -> SDoc -> OrdList Instr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Unexpected width (max is 64bit):" (SDoc -> OrdList Instr) -> SDoc -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w'
signExtendAdjustPrecission Width
w Width
w' Reg
r Reg
r' | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 Bool -> Bool -> Bool
&& Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 Bool -> Bool -> Bool
&& Reg
r Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
r' = OrdList Instr
forall a. OrdList a
nilOL
signExtendAdjustPrecission Width
w Width
w' Reg
r Reg
r' | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 Bool -> Bool -> Bool
&& Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w Reg
r)
signExtendAdjustPrecission Width
w Width
w' Reg
r Reg
r'
| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32 Bool -> Bool -> Bool
&& Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 =
Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL
(Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ SDoc -> Instr -> Instr
ann
([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"sign-extend register (SEXT.W)" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w')
(Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)))
signExtendAdjustPrecission Width
w Width
w' Reg
r Reg
r'
| Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
w' =
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ SDoc -> Instr -> Instr
ann
([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"narrow register signed" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w')
(Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))),
Operand -> Operand -> Operand -> Instr
SRA (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))
]
where
shift :: Int
shift = Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Width -> Int
widthInBits Width
w'
signExtendAdjustPrecission Width
w Width
w' Reg
r Reg
r' =
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ SDoc -> Instr -> Instr
ann
([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"sign extend register" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w')
(Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))),
Operand -> Operand -> Operand -> Instr
SRA (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))
]
where
shift :: Int
shift = Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Width -> Int
widthInBits Width
w
truncateReg :: Width -> Width -> Reg -> OrdList Instr
truncateReg :: Width -> Width -> Reg -> OrdList Instr
truncateReg Width
_w Width
w' Reg
_r | Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 = OrdList Instr
forall a. OrdList a
nilOL
truncateReg Width
_w Width
w' Reg
r | Width
w' Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
W64 = [Char] -> SDoc -> OrdList Instr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Cannot truncate to width bigger than register size (max is 64bit):" (SDoc -> OrdList Instr) -> SDoc -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (Reg -> [Char]
forall a. Show a => a -> [Char]
show Reg
r) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w'
truncateReg Width
w Width
_w' Reg
r | Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
W64 = [Char] -> SDoc -> OrdList Instr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Unexpected register size (max is 64bit):" (SDoc -> OrdList Instr) -> SDoc -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (Reg -> [Char]
forall a. Show a => a -> [Char]
show Reg
r) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w
truncateReg Width
w Width
w' Reg
r =
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ SDoc -> Instr -> Instr
ann
([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"truncate register" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w')
(Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
w' Reg
r) (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))),
Operand -> Operand -> Operand -> Instr
SRL (Width -> Reg -> Operand
OpReg Width
w' Reg
r) (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))
]
where
shift :: Int
shift = Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Width -> Int
widthInBits Width
w'
addAlignmentCheck :: Int -> Width -> Register -> NatM Register
addAlignmentCheck :: Int -> Width -> Register -> NatM Register
addAlignmentCheck Int
align Width
wordWidth Register
reg = do
jumpReg <- Format -> NatM Reg
getNewRegNat Format
II64
cmpReg <- getNewRegNat II64
okayLblId <- getBlockIdNat
pure $ case reg of
Fixed Format
fmt Reg
reg OrdList Instr
code -> Format -> Reg -> OrdList Instr -> Register
Fixed Format
fmt Reg
reg (OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Format -> Reg -> Reg -> BlockId -> Reg -> OrdList Instr
check Format
fmt Reg
jumpReg Reg
cmpReg BlockId
okayLblId Reg
reg)
Any Format
fmt Reg -> OrdList Instr
f -> Format -> (Reg -> OrdList Instr) -> Register
Any Format
fmt (\Reg
reg -> Reg -> OrdList Instr
f Reg
reg OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Format -> Reg -> Reg -> BlockId -> Reg -> OrdList Instr
check Format
fmt Reg
jumpReg Reg
cmpReg BlockId
okayLblId Reg
reg)
where
check :: Format -> Reg -> Reg -> BlockId -> Reg -> InstrBlock
check :: Format -> Reg -> Reg -> BlockId -> Reg -> OrdList Instr
check Format
fmt Reg
jumpReg Reg
cmpReg BlockId
okayLblId Reg
reg =
let width :: Width
width = Format -> Width
formatToWidth Format
fmt
in Bool -> OrdList Instr -> OrdList Instr
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Format -> Bool
isFloatFormat Format
fmt)
(OrdList Instr -> OrdList Instr) -> OrdList Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ SDoc -> Instr -> Instr
ann
([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Alignment check - alignment: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
align SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
", word width: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (Width -> [Char]
forall a. Show a => a -> [Char]
show Width
wordWidth))
(Operand -> Operand -> Operand -> Instr
AND (Width -> Reg -> Operand
OpReg Width
width Reg
cmpReg) (Width -> Reg -> Operand
OpReg Width
width Reg
reg) (Imm -> Operand
OpImm (Imm -> Operand) -> Imm -> Operand
forall a b. (a -> b) -> a -> b
$ Int -> Imm
ImmInt (Int -> Imm) -> Int -> Imm
forall a b. (a -> b) -> a -> b
$ Int
align Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)),
Cond -> Operand -> Operand -> Target -> Instr
BCOND Cond
EQ (Width -> Reg -> Operand
OpReg Width
width Reg
cmpReg) Operand
zero (BlockId -> Target
TBlock BlockId
okayLblId),
SDoc -> Instr
COMMENT ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Alignment check failed"),
Format -> Operand -> Operand -> Instr
LDR Format
II64 (Width -> Reg -> Operand
OpReg Width
W64 Reg
jumpReg) (Imm -> Operand
OpImm (Imm -> Operand) -> Imm -> Operand
forall a b. (a -> b) -> a -> b
$ CLabel -> Imm
ImmCLbl CLabel
mkBadAlignmentLabel),
Target -> Instr
B (Reg -> Target
TReg Reg
jumpReg),
BlockId -> Instr
NEWBLOCK BlockId
okayLblId
]
data Amode = Amode AddrMode InstrBlock
getAmode ::
Platform ->
Width ->
CmmExpr ->
NatM Amode
getAmode :: Platform -> Width -> CmmExpr -> NatM Amode
getAmode Platform
platform Width
w (CmmRegOff CmmReg
reg Int
off)
| Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
<= Width
W64,
Int -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm Int
off =
Amode -> NatM Amode
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Amode -> NatM Amode) -> Amode -> NatM Amode
forall a b. (a -> b) -> a -> b
$ AddrMode -> OrdList Instr -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg' Imm
off') OrdList Instr
forall a. OrdList a
nilOL
where
reg' :: Reg
reg' = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg
off' :: Imm
off' = Int -> Imm
ImmInt Int
off
getAmode Platform
_platform Width
_ (CmmMachOp (MO_Add Width
_w) [CmmExpr
expr, CmmLit (CmmInt Integer
off Width
_w')])
| Integer -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm Integer
off =
do
(reg, _format, code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
return $ Amode (AddrRegImm reg (ImmInteger off)) code
getAmode Platform
_platform Width
_ (CmmMachOp (MO_Sub Width
_w) [CmmExpr
expr, CmmLit (CmmInt Integer
off Width
_w')])
| Integer -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm (-Integer
off) =
do
(reg, _format, code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
return $ Amode (AddrRegImm reg (ImmInteger (-off))) code
getAmode Platform
_platform Width
_ CmmExpr
expr =
do
(reg, _format, code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
return $ Amode (AddrReg reg) 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
rep CmmExpr
addrE CmmExpr
srcE =
do
(src_reg, _format, code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
srcE
platform <- getPlatform
let w = Format -> Width
formatToWidth Format
rep
Amode addr addr_code <- getAmode platform w addrE
return $ COMMENT (text "CmmStore" <+> parens (text (show addrE)) <+> parens (text (show srcE)))
`consOL` ( code
`appOL` addr_code
`snocOL` STR rep (OpReg w src_reg) (OpAddr addr)
)
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 ->
SDoc -> Instr
COMMENT ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"CmmAssign" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (CmmReg -> [Char]
forall a. Show a => a -> [Char]
show CmmReg
reg)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (CmmExpr -> [Char]
forall a. Show a => a -> [Char]
show CmmExpr
src)))
Instr -> OrdList Instr -> OrdList Instr
forall a. a -> OrdList a -> OrdList a
`consOL` Reg -> OrdList Instr
code Reg
dst
Fixed Format
format Reg
freg OrdList Instr
fcode ->
SDoc -> Instr
COMMENT ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"CmmAssign" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (CmmReg -> [Char]
forall a. Show a => a -> [Char]
show CmmReg
reg)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (CmmExpr -> [Char]
forall a. Show a => a -> [Char]
show CmmExpr
src)))
Instr -> OrdList Instr -> OrdList Instr
forall a. a -> OrdList a -> OrdList a
`consOL` ( OrdList Instr
fcode
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) Reg
dst) (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) 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 -> NatM InstrBlock
genJump :: CmmExpr -> NatM (OrdList Instr)
genJump CmmExpr
expr = do
(target, _format, code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
return (code `appOL` unitOL (annExpr expr (B (TReg target))))
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 ->
NatM InstrBlock
genCondJump :: BlockId -> CmmExpr -> NatM (OrdList Instr)
genCondJump BlockId
bid CmmExpr
expr = do
case CmmExpr
expr of
CmmMachOp (MO_Eq Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
0 Width
_)] -> do
(reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
return $ code_x `snocOL` annExpr expr (BCOND EQ zero (OpReg w reg_x) (TBlock bid))
CmmMachOp (MO_Ne Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
0 Width
_)] -> do
(reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
return $ code_x `snocOL` annExpr expr (BCOND NE zero (OpReg w reg_x) (TBlock bid))
CmmMachOp MachOp
mop [CmmExpr
x, CmmExpr
y] -> do
let ubcond :: Width -> Cond -> NatM (OrdList Instr)
ubcond Width
w Cond
cmp = do
(reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
(reg_y, format_y, code_y) <- getSomeReg y
let x' = Width -> Reg -> Operand
OpReg Width
w Reg
reg_x
y' = Width -> Reg -> Operand
OpReg Width
w Reg
reg_y
return $ case w of
Width
w
| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 Bool -> Bool -> Bool
|| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W16 ->
OrdList Instr
code_x
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg (Format -> Width
formatToWidth Format
format_x) Width
w Reg
reg_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` Width -> Width -> Reg -> OrdList Instr
truncateReg (Format -> Width
formatToWidth Format
format_y) Width
w Reg
reg_y
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Target -> Instr
BCOND Cond
cmp Operand
x' Operand
y' (BlockId -> Target
TBlock BlockId
bid))
Width
_ ->
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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Target -> Instr
BCOND Cond
cmp Operand
x' Operand
y' (BlockId -> Target
TBlock BlockId
bid))
sbcond :: Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
cmp = do
(reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
(reg_y, format_y, code_y) <- getSomeReg y
let x' = Width -> Reg -> Operand
OpReg Width
w Reg
reg_x
y' = Width -> Reg -> Operand
OpReg Width
w Reg
reg_y
return $ case w of
Width
w
| Width
w Width -> [Width] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Width
W8, Width
W16, Width
W32] ->
OrdList Instr
code_x
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_x) Width
W64 Reg
reg_x Reg
reg_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` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_y) Width
W64 Reg
reg_y Reg
reg_y
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Target -> Instr
BCOND Cond
cmp Operand
x' Operand
y' (BlockId -> Target
TBlock BlockId
bid)))
Width
_ -> 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
unitOL (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Target -> Instr
BCOND Cond
cmp Operand
x' Operand
y' (BlockId -> Target
TBlock BlockId
bid)))
fbcond :: Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
cmp = do
(reg_fx, _format_fx, code_fx) <- HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
x
(reg_fy, _format_fy, code_fy) <- getFloatReg y
condOpReg <- OpReg W64 <$> getNewRegNat II64
oneReg <- getNewRegNat II64
return $ code_fx
`appOL` code_fy
`snocOL` annExpr expr (CSET condOpReg (OpReg w reg_fx) (OpReg w reg_fy) cmp)
`snocOL` MOV (OpReg W64 oneReg) (OpImm (ImmInt 1))
`snocOL` BCOND EQ condOpReg (OpReg w oneReg) (TBlock bid)
case MachOp
mop of
MO_F_Eq Width
w -> Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
EQ
MO_F_Ne Width
w -> Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
NE
MO_F_Gt Width
w -> Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
FGT
MO_F_Ge Width
w -> Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
FGE
MO_F_Lt Width
w -> Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
FLT
MO_F_Le Width
w -> Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
FLE
MO_Eq Width
w -> Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
EQ
MO_Ne Width
w -> Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
NE
MO_S_Gt Width
w -> Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
SGT
MO_S_Ge Width
w -> Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
SGE
MO_S_Lt Width
w -> Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
SLT
MO_S_Le Width
w -> Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
SLE
MO_U_Gt Width
w -> Width -> Cond -> NatM (OrdList Instr)
ubcond Width
w Cond
UGT
MO_U_Ge Width
w -> Width -> Cond -> NatM (OrdList Instr)
ubcond Width
w Cond
UGE
MO_U_Lt Width
w -> Width -> Cond -> NatM (OrdList Instr)
ubcond Width
w Cond
ULT
MO_U_Le Width
w -> Width -> Cond -> NatM (OrdList Instr)
ubcond Width
w Cond
ULE
MachOp
_ -> [Char] -> SDoc -> NatM (OrdList Instr)
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"RV64.genCondJump:case mop: " ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc) -> [Char] -> SDoc
forall a b. (a -> b) -> a -> b
$ CmmExpr -> [Char]
forall a. Show a => a -> [Char]
show CmmExpr
expr)
CmmExpr
_ -> [Char] -> SDoc -> NatM (OrdList Instr)
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"RV64.genCondJump: " ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc) -> [Char] -> SDoc
forall a b. (a -> b) -> a -> b
$ CmmExpr -> [Char]
forall a. Show a => a -> [Char]
show CmmExpr
expr)
genCondBranch ::
BlockId ->
BlockId ->
CmmExpr ->
NatM InstrBlock
genCondBranch :: BlockId -> BlockId -> CmmExpr -> NatM (OrdList Instr)
genCondBranch BlockId
true BlockId
false CmmExpr
expr =
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
appOL
(OrdList Instr -> OrdList Instr -> OrdList Instr)
-> NatM (OrdList Instr) -> NatM (OrdList Instr -> OrdList Instr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> CmmExpr -> NatM (OrdList Instr)
genCondJump BlockId
true CmmExpr
expr
NatM (OrdList Instr -> OrdList Instr)
-> NatM (OrdList Instr) -> 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
<*> BlockId -> NatM (OrdList Instr)
genBranch BlockId
false
genCCall ::
ForeignTarget ->
[CmmFormal] ->
[CmmActual] ->
NatM InstrBlock
genCCall :: ForeignTarget -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
genCCall target :: ForeignTarget
target@(ForeignTarget CmmExpr
expr ForeignConvention
_cconv) [CmmFormal]
dest_regs [CmmExpr]
arg_regs = do
(call_target_reg, call_target_code) <-
do
(reg, _format, reg_code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
pure (reg, reg_code)
arg_regs' <- mapM getSomeReg arg_regs
let (_res_hints, arg_hints) = foreignTargetHints target
arg_regs'' = ((Reg, Format, OrdList Instr)
-> ForeignHint -> (Reg, Format, ForeignHint, OrdList Instr))
-> [(Reg, Format, OrdList Instr)]
-> [ForeignHint]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Reg
r, Format
f, OrdList Instr
c) ForeignHint
h -> (Reg
r, Format
f, ForeignHint
h, OrdList Instr
c)) [(Reg, Format, OrdList Instr)]
arg_regs' [ForeignHint]
arg_hints
(stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL
readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL
let moveStackDown Int
0 =
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ Instr
PUSH_STACK_FRAME,
Int -> Instr
DELTA (-Int
16)
]
moveStackDown Int
i | Int -> Bool
forall a. Integral a => a -> Bool
odd Int
i = Int -> OrdList Instr
moveStackDown (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
moveStackDown Int
i =
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ Instr
PUSH_STACK_FRAME,
Operand -> Operand -> Operand -> Instr
SUB (Width -> Reg -> Operand
OpReg Width
W64 Reg
spMachReg) (Width -> Reg -> Operand
OpReg Width
W64 Reg
spMachReg) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i))),
Int -> Instr
DELTA (-Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
16)
]
moveStackUp Int
0 =
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ Instr
POP_STACK_FRAME,
Int -> Instr
DELTA Int
0
]
moveStackUp Int
i | Int -> Bool
forall a. Integral a => a -> Bool
odd Int
i = Int -> OrdList Instr
moveStackUp (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
moveStackUp Int
i =
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
W64 Reg
spMachReg) (Width -> Reg -> Operand
OpReg Width
W64 Reg
spMachReg) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i))),
Instr
POP_STACK_FRAME,
Int -> Instr
DELTA Int
0
]
let code =
OrdList Instr
call_target_code
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Int -> OrdList Instr
moveStackDown Int
stackSpaceWords
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
passArgumentsCode
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> [Reg] -> Instr
BL Reg
call_target_reg [Reg]
passRegs
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
readResultsCode
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Int -> OrdList Instr
moveStackUp Int
stackSpaceWords
return code
where
passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)
passArguments :: [Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments [Reg]
_ [Reg]
_ [] Int
stackSpaceWords [Reg]
accumRegs OrdList Instr
accumCode = (Int, [Reg], OrdList Instr) -> NatM (Int, [Reg], OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
stackSpaceWords, [Reg]
accumRegs, OrdList Instr
accumCode)
passArguments (Reg
gpReg : [Reg]
gpRegs) [Reg]
fpRegs ((Reg
r, Format
format, ForeignHint
hint, OrdList Instr
code_r) : [(Reg, Format, ForeignHint, OrdList Instr)]
args) Int
stackSpaceWords [Reg]
accumRegs OrdList Instr
accumCode | Format -> Bool
isIntFormat Format
format = do
let w :: Width
w = Format -> Width
formatToWidth Format
format
assignArg :: OrdList Instr
assignArg =
if ForeignHint
hint ForeignHint -> ForeignHint -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignHint
SignedHint
then
SDoc -> Instr
COMMENT ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Pass gp argument sign-extended (SignedHint): " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r)
Instr -> OrdList Instr -> OrdList Instr
forall a. a -> OrdList a -> OrdList a
`consOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend Width
w Width
W64 Reg
r Reg
gpReg
else
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ SDoc -> Instr
COMMENT ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Pass gp argument sign-extended (SignedHint): " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r),
Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
gpReg) (Width -> Reg -> Operand
OpReg Width
w Reg
r)
]
accumCode' :: OrdList Instr
accumCode' =
OrdList Instr
accumCode
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_r
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
assignArg
[Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments [Reg]
gpRegs [Reg]
fpRegs [(Reg, Format, ForeignHint, OrdList Instr)]
args Int
stackSpaceWords (Reg
gpReg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
accumRegs) OrdList Instr
accumCode'
passArguments [Reg]
gpRegs (Reg
fpReg : [Reg]
fpRegs) ((Reg
r, Format
format, ForeignHint
_hint, OrdList Instr
code_r) : [(Reg, Format, ForeignHint, OrdList Instr)]
args) Int
stackSpaceWords [Reg]
accumRegs OrdList Instr
accumCode | Format -> Bool
isFloatFormat Format
format = do
let w :: Width
w = Format -> Width
formatToWidth Format
format
mov :: Instr
mov = Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
fpReg) (Width -> Reg -> Operand
OpReg Width
w Reg
r)
accumCode' :: OrdList Instr
accumCode' =
OrdList Instr
accumCode
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_r
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` SDoc -> Instr -> Instr
ann ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Pass fp argument: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r) Instr
mov
[Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments [Reg]
gpRegs [Reg]
fpRegs [(Reg, Format, ForeignHint, OrdList Instr)]
args Int
stackSpaceWords (Reg
fpReg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
accumRegs) OrdList Instr
accumCode'
passArguments [] [] ((Reg
r, Format
format, ForeignHint
hint, OrdList Instr
code_r) : [(Reg, Format, ForeignHint, OrdList Instr)]
args) Int
stackSpaceWords [Reg]
accumRegs OrdList Instr
accumCode = do
let w :: Width
w = Format -> Width
formatToWidth Format
format
spOffet :: Int
spOffet = Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
stackSpaceWords
str :: Instr
str = Format -> Operand -> Operand -> Instr
STR Format
format (Width -> Reg -> Operand
OpReg Width
w Reg
r) (AddrMode -> Operand
OpAddr (Reg -> Imm -> AddrMode
AddrRegImm Reg
spMachReg (Int -> Imm
ImmInt Int
spOffet)))
stackCode :: OrdList Instr
stackCode =
if ForeignHint
hint ForeignHint -> ForeignHint -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignHint
SignedHint
then
OrdList Instr
code_r
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend Width
w Width
W64 Reg
r Reg
tmpReg
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` SDoc -> Instr -> Instr
ann ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Pass signed argument (size " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
") on the stack: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
tmpReg) Instr
str
else
OrdList Instr
code_r
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` SDoc -> Instr -> Instr
ann ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Pass unsigned argument (size " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
") on the stack: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r) Instr
str
[Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments [] [] [(Reg, Format, ForeignHint, OrdList Instr)]
args (Int
stackSpaceWords Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Reg]
accumRegs (OrdList Instr
stackCode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
accumCode)
passArguments [] [Reg]
fpRegs ((Reg
r, Format
format, ForeignHint
_hint, OrdList Instr
code_r) : [(Reg, Format, ForeignHint, OrdList Instr)]
args) Int
stackSpaceWords [Reg]
accumRegs OrdList Instr
accumCode | Format -> Bool
isIntFormat Format
format = do
let w :: Width
w = Format -> Width
formatToWidth Format
format
spOffet :: Int
spOffet = Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
stackSpaceWords
str :: Instr
str = Format -> Operand -> Operand -> Instr
STR Format
format (Width -> Reg -> Operand
OpReg Width
w Reg
r) (AddrMode -> Operand
OpAddr (Reg -> Imm -> AddrMode
AddrRegImm Reg
spMachReg (Int -> Imm
ImmInt Int
spOffet)))
stackCode :: OrdList Instr
stackCode =
OrdList Instr
code_r
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` SDoc -> Instr -> Instr
ann ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Pass argument (size " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
") on the stack: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r) Instr
str
[Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments [] [Reg]
fpRegs [(Reg, Format, ForeignHint, OrdList Instr)]
args (Int
stackSpaceWords Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Reg]
accumRegs (OrdList Instr
stackCode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
accumCode)
passArguments (Reg
gpReg : [Reg]
gpRegs) [] ((Reg
r, Format
format, ForeignHint
_hint, OrdList Instr
code_r) : [(Reg, Format, ForeignHint, OrdList Instr)]
args) Int
stackSpaceWords [Reg]
accumRegs OrdList Instr
accumCode | Format -> Bool
isFloatFormat Format
format = do
let w :: Width
w = Format -> Width
formatToWidth Format
format
mov :: Instr
mov = Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
gpReg) (Width -> Reg -> Operand
OpReg Width
w Reg
r)
accumCode' :: OrdList Instr
accumCode' =
OrdList Instr
accumCode
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_r
OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` SDoc -> Instr -> Instr
ann ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Pass fp argument in gpReg: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r) Instr
mov
[Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments [Reg]
gpRegs [] [(Reg, Format, ForeignHint, OrdList Instr)]
args Int
stackSpaceWords (Reg
gpReg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
accumRegs) OrdList Instr
accumCode'
passArguments [Reg]
_ [Reg]
_ [(Reg, Format, ForeignHint, OrdList Instr)]
_ Int
_ [Reg]
_ OrdList Instr
_ = [Char] -> SDoc -> NatM (Int, [Reg], OrdList Instr)
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"passArguments" ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"invalid state")
readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg] -> InstrBlock -> NatM InstrBlock
readResults :: [Reg]
-> [Reg]
-> [CmmFormal]
-> [Reg]
-> OrdList Instr
-> NatM (OrdList Instr)
readResults [Reg]
_ [Reg]
_ [] [Reg]
_ OrdList Instr
accumCode = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
accumCode
readResults [] [Reg]
_ [CmmFormal]
_ [Reg]
_ OrdList Instr
_ = do
platform <- NatM Platform
getPlatform
pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target)
readResults [Reg]
_ [] [CmmFormal]
_ [Reg]
_ OrdList Instr
_ = do
platform <- NatM Platform
getPlatform
pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target)
readResults (Reg
gpReg : [Reg]
gpRegs) (Reg
fpReg : [Reg]
fpRegs) (CmmFormal
dst : [CmmFormal]
dsts) [Reg]
accumRegs OrdList Instr
accumCode = do
platform <- NatM Platform
getPlatform
let rep = CmmReg -> CmmType
cmmRegType (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
format = CmmType -> Format
cmmTypeFormat CmmType
rep
w = CmmReg -> Width
cmmRegWidth (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
r_dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
if isFloatFormat format
then readResults (gpReg : gpRegs) fpRegs dsts (fpReg : accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg))
else
readResults gpRegs (fpReg : fpRegs) dsts (gpReg : accumRegs)
$ accumCode
`snocOL` MOV (OpReg w r_dst) (OpReg w gpReg)
`appOL`
truncateReg W64 w r_dst
genCCall (PrimTarget CallishMachOp
mop) [CmmFormal]
dest_regs [CmmExpr]
arg_regs = do
case CallishMachOp
mop of
CallishMachOp
MO_F32_Fabs
| [CmmExpr
arg_reg] <- [CmmExpr]
arg_regs,
[CmmFormal
dest_reg] <- [CmmFormal]
dest_regs ->
Width
-> (Operand -> Operand -> OrdList Instr)
-> CmmExpr
-> CmmFormal
-> NatM (OrdList Instr)
unaryFloatOp Width
W32 (\Operand
d Operand
x -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
FABS Operand
d Operand
x) CmmExpr
arg_reg CmmFormal
dest_reg
CallishMachOp
MO_F64_Fabs
| [CmmExpr
arg_reg] <- [CmmExpr]
arg_regs,
[CmmFormal
dest_reg] <- [CmmFormal]
dest_regs ->
Width
-> (Operand -> Operand -> OrdList Instr)
-> CmmExpr
-> CmmFormal
-> NatM (OrdList Instr)
unaryFloatOp Width
W64 (\Operand
d Operand
x -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
FABS Operand
d Operand
x) CmmExpr
arg_reg CmmFormal
dest_reg
CallishMachOp
MO_F64_Pwr -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"pow"
CallishMachOp
MO_F64_Sin -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"sin"
CallishMachOp
MO_F64_Cos -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"cos"
CallishMachOp
MO_F64_Tan -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"tan"
CallishMachOp
MO_F64_Sinh -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"sinh"
CallishMachOp
MO_F64_Cosh -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"cosh"
CallishMachOp
MO_F64_Tanh -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"tanh"
CallishMachOp
MO_F64_Asin -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"asin"
CallishMachOp
MO_F64_Acos -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"acos"
CallishMachOp
MO_F64_Atan -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"atan"
CallishMachOp
MO_F64_Asinh -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"asinh"
CallishMachOp
MO_F64_Acosh -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"acosh"
CallishMachOp
MO_F64_Atanh -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"atanh"
CallishMachOp
MO_F64_Log -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"log"
CallishMachOp
MO_F64_Log1P -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"log1p"
CallishMachOp
MO_F64_Exp -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"exp"
CallishMachOp
MO_F64_ExpM1 -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"expm1"
CallishMachOp
MO_F64_Fabs -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"fabs"
CallishMachOp
MO_F64_Sqrt -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"sqrt"
CallishMachOp
MO_F32_Pwr -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"powf"
CallishMachOp
MO_F32_Sin -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"sinf"
CallishMachOp
MO_F32_Cos -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"cosf"
CallishMachOp
MO_F32_Tan -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"tanf"
CallishMachOp
MO_F32_Sinh -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"sinhf"
CallishMachOp
MO_F32_Cosh -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"coshf"
CallishMachOp
MO_F32_Tanh -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"tanhf"
CallishMachOp
MO_F32_Asin -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"asinf"
CallishMachOp
MO_F32_Acos -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"acosf"
CallishMachOp
MO_F32_Atan -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"atanf"
CallishMachOp
MO_F32_Asinh -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"asinhf"
CallishMachOp
MO_F32_Acosh -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"acoshf"
CallishMachOp
MO_F32_Atanh -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"atanhf"
CallishMachOp
MO_F32_Log -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"logf"
CallishMachOp
MO_F32_Log1P -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"log1pf"
CallishMachOp
MO_F32_Exp -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"expf"
CallishMachOp
MO_F32_ExpM1 -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"expm1f"
CallishMachOp
MO_F32_Fabs -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"fabsf"
CallishMachOp
MO_F32_Sqrt -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"sqrtf"
CallishMachOp
MO_I64_ToI -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_int64ToInt"
CallishMachOp
MO_I64_FromI -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_intToInt64"
CallishMachOp
MO_W64_ToW -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_word64ToWord"
CallishMachOp
MO_W64_FromW -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_wordToWord64"
CallishMachOp
MO_x64_Neg -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_neg64"
CallishMachOp
MO_x64_Add -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_add64"
CallishMachOp
MO_x64_Sub -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_sub64"
CallishMachOp
MO_x64_Mul -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_mul64"
CallishMachOp
MO_I64_Quot -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_quotInt64"
CallishMachOp
MO_I64_Rem -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_remInt64"
CallishMachOp
MO_W64_Quot -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_quotWord64"
CallishMachOp
MO_W64_Rem -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_remWord64"
CallishMachOp
MO_x64_And -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_and64"
CallishMachOp
MO_x64_Or -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_or64"
CallishMachOp
MO_x64_Xor -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_xor64"
CallishMachOp
MO_x64_Not -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_not64"
CallishMachOp
MO_x64_Shl -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_uncheckedShiftL64"
CallishMachOp
MO_I64_Shr -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_uncheckedIShiftRA64"
CallishMachOp
MO_W64_Shr -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_uncheckedShiftRL64"
CallishMachOp
MO_x64_Eq -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_eq64"
CallishMachOp
MO_x64_Ne -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_ne64"
CallishMachOp
MO_I64_Ge -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_geInt64"
CallishMachOp
MO_I64_Gt -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_gtInt64"
CallishMachOp
MO_I64_Le -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_leInt64"
CallishMachOp
MO_I64_Lt -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_ltInt64"
CallishMachOp
MO_W64_Ge -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_geWord64"
CallishMachOp
MO_W64_Gt -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_gtWord64"
CallishMachOp
MO_W64_Le -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_leWord64"
CallishMachOp
MO_W64_Lt -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"hs_ltWord64"
MO_UF_Conv Width
w -> FastString -> NatM (OrdList Instr)
mkCCall (Width -> FastString
word2FloatLabel Width
w)
MO_S_Mul2 Width
_w -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
MO_S_QuotRem Width
_w -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
MO_U_QuotRem Width
_w -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
MO_U_QuotRem2 Width
_w -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
MO_Add2 Width
_w -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
MO_AddWordC Width
_w -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
MO_SubWordC Width
_w -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
MO_AddIntC Width
_w -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
MO_SubIntC Width
_w -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
MO_U_Mul2 Width
_w -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
CallishMachOp
MO_AcquireFence -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (FenceType -> FenceType -> Instr
FENCE FenceType
FenceRead FenceType
FenceReadWrite))
CallishMachOp
MO_ReleaseFence -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (FenceType -> FenceType -> Instr
FENCE FenceType
FenceReadWrite FenceType
FenceWrite))
CallishMachOp
MO_SeqCstFence -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (FenceType -> FenceType -> Instr
FENCE FenceType
FenceReadWrite FenceType
FenceReadWrite))
CallishMachOp
MO_Touch -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OrdList Instr
forall a. OrdList a
nilOL
MO_Prefetch_Data Int
_n -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OrdList Instr
forall a. OrdList a
nilOL
MO_Memcpy Int
_align -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"memcpy"
MO_Memset Int
_align -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"memset"
MO_Memmove Int
_align -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"memmove"
MO_Memcmp Int
_align -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"memcmp"
CallishMachOp
MO_SuspendThread -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"suspendThread"
CallishMachOp
MO_ResumeThread -> FastString -> NatM (OrdList Instr)
mkCCall FastString
"resumeThread"
MO_PopCnt Width
w -> FastString -> NatM (OrdList Instr)
mkCCall (Width -> FastString
popCntLabel Width
w)
MO_Pdep Width
w -> FastString -> NatM (OrdList Instr)
mkCCall (Width -> FastString
pdepLabel Width
w)
MO_Pext Width
w -> FastString -> NatM (OrdList Instr)
mkCCall (Width -> FastString
pextLabel Width
w)
MO_Clz Width
w -> FastString -> NatM (OrdList Instr)
mkCCall (Width -> FastString
clzLabel Width
w)
MO_Ctz Width
w -> FastString -> NatM (OrdList Instr)
mkCCall (Width -> FastString
ctzLabel Width
w)
MO_BSwap Width
w -> FastString -> NatM (OrdList Instr)
mkCCall (Width -> FastString
bSwapLabel Width
w)
MO_BRev Width
w -> FastString -> NatM (OrdList Instr)
mkCCall (Width -> FastString
bRevLabel Width
w)
mo :: CallishMachOp
mo@(MO_AtomicRead Width
w MemoryOrdering
ord)
| [CmmExpr
p_reg] <- [CmmExpr]
arg_regs,
[CmmFormal
dst_reg] <- [CmmFormal]
dest_regs -> do
(p, _fmt_p, code_p) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
p_reg
platform <- getPlatform
let instrs = case MemoryOrdering
ord of
MemoryOrdering
MemOrderRelaxed -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ SDoc -> Instr -> Instr
ann SDoc
moDescr (Format -> Operand -> Operand -> Instr
LDR (Width -> Format
intFormat Width
w) (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (AddrMode -> Operand
OpAddr (AddrMode -> Operand) -> AddrMode -> Operand
forall a b. (a -> b) -> a -> b
$ Reg -> AddrMode
AddrReg Reg
p))
MemoryOrdering
MemOrderAcquire ->
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ SDoc -> Instr -> Instr
ann SDoc
moDescr (Format -> Operand -> Operand -> Instr
LDR (Width -> Format
intFormat Width
w) (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (AddrMode -> Operand
OpAddr (AddrMode -> Operand) -> AddrMode -> Operand
forall a b. (a -> b) -> a -> b
$ Reg -> AddrMode
AddrReg Reg
p)),
FenceType -> FenceType -> Instr
FENCE FenceType
FenceRead FenceType
FenceReadWrite
]
MemoryOrdering
MemOrderSeqCst ->
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ SDoc -> Instr -> Instr
ann SDoc
moDescr (FenceType -> FenceType -> Instr
FENCE FenceType
FenceReadWrite FenceType
FenceReadWrite),
Format -> Operand -> Operand -> Instr
LDR (Width -> Format
intFormat Width
w) (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (AddrMode -> Operand
OpAddr (AddrMode -> Operand) -> AddrMode -> Operand
forall a b. (a -> b) -> a -> b
$ Reg -> AddrMode
AddrReg Reg
p),
FenceType -> FenceType -> Instr
FENCE FenceType
FenceRead FenceType
FenceReadWrite
]
MemoryOrdering
MemOrderRelease -> [Char] -> OrdList Instr
forall a. HasCallStack => [Char] -> a
panic ([Char] -> OrdList Instr) -> [Char] -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected MemOrderRelease on an AtomicRead: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CallishMachOp -> [Char]
forall a. Show a => a -> [Char]
show CallishMachOp
mo
dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst_reg)
moDescr = ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc)
-> (CallishMachOp -> [Char]) -> CallishMachOp -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallishMachOp -> [Char]
forall a. Show a => a -> [Char]
show) CallishMachOp
mo
code = OrdList Instr
code_p OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
instrs
return code
| Bool
otherwise -> [Char] -> NatM (OrdList Instr)
forall a. HasCallStack => [Char] -> a
panic [Char]
"mal-formed AtomicRead"
mo :: CallishMachOp
mo@(MO_AtomicWrite Width
w MemoryOrdering
ord)
| [CmmExpr
p_reg, CmmExpr
val_reg] <- [CmmExpr]
arg_regs -> do
(p, _fmt_p, code_p) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
p_reg
(val, fmt_val, code_val) <- getSomeReg val_reg
let instrs = case MemoryOrdering
ord of
MemoryOrdering
MemOrderRelaxed -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ SDoc -> Instr -> Instr
ann SDoc
moDescr (Format -> Operand -> Operand -> Instr
STR Format
fmt_val (Width -> Reg -> Operand
OpReg Width
w Reg
val) (AddrMode -> Operand
OpAddr (AddrMode -> Operand) -> AddrMode -> Operand
forall a b. (a -> b) -> a -> b
$ Reg -> AddrMode
AddrReg Reg
p))
MemoryOrdering
MemOrderSeqCst ->
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ SDoc -> Instr -> Instr
ann SDoc
moDescr (FenceType -> FenceType -> Instr
FENCE FenceType
FenceReadWrite FenceType
FenceWrite),
Format -> Operand -> Operand -> Instr
STR Format
fmt_val (Width -> Reg -> Operand
OpReg Width
w Reg
val) (AddrMode -> Operand
OpAddr (AddrMode -> Operand) -> AddrMode -> Operand
forall a b. (a -> b) -> a -> b
$ Reg -> AddrMode
AddrReg Reg
p),
FenceType -> FenceType -> Instr
FENCE FenceType
FenceReadWrite FenceType
FenceReadWrite
]
MemoryOrdering
MemOrderRelease ->
[Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ SDoc -> Instr -> Instr
ann SDoc
moDescr (FenceType -> FenceType -> Instr
FENCE FenceType
FenceReadWrite FenceType
FenceWrite),
Format -> Operand -> Operand -> Instr
STR Format
fmt_val (Width -> Reg -> Operand
OpReg Width
w Reg
val) (AddrMode -> Operand
OpAddr (AddrMode -> Operand) -> AddrMode -> Operand
forall a b. (a -> b) -> a -> b
$ Reg -> AddrMode
AddrReg Reg
p)
]
MemoryOrdering
MemOrderAcquire -> [Char] -> OrdList Instr
forall a. HasCallStack => [Char] -> a
panic ([Char] -> OrdList Instr) -> [Char] -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected MemOrderAcquire on an AtomicWrite" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CallishMachOp -> [Char]
forall a. Show a => a -> [Char]
show CallishMachOp
mo
moDescr = ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc)
-> (CallishMachOp -> [Char]) -> CallishMachOp -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallishMachOp -> [Char]
forall a. Show a => a -> [Char]
show) CallishMachOp
mo
code =
OrdList Instr
code_p
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_val
OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
instrs
pure code
| Bool
otherwise -> [Char] -> NatM (OrdList Instr)
forall a. HasCallStack => [Char] -> a
panic [Char]
"mal-formed AtomicWrite"
MO_AtomicRMW Width
w AtomicMachOp
amop -> FastString -> NatM (OrdList Instr)
mkCCall (Width -> AtomicMachOp -> FastString
atomicRMWLabel Width
w AtomicMachOp
amop)
MO_Cmpxchg Width
w -> FastString -> NatM (OrdList Instr)
mkCCall (Width -> FastString
cmpxchgLabel Width
w)
MO_Xchg Width
w -> FastString -> NatM (OrdList Instr)
mkCCall (Width -> FastString
xchgLabel Width
w)
where
unsupported :: (Show a) => a -> b
unsupported :: forall a b. Show a => a -> b
unsupported a
mop =
[Char] -> b
forall a. HasCallStack => [Char] -> a
panic
( [Char]
"outOfLineCmmOp: "
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
mop
[Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" not supported here"
)
mkCCall :: FastString -> NatM InstrBlock
mkCCall :: FastString -> NatM (OrdList Instr)
mkCCall FastString
name = do
config <- NatM NCGConfig
getConfig
target <-
cmmMakeDynamicReference config CallReference
$ mkForeignLabel name ForeignLabelInThisPackage IsFunction
let cconv = CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [ForeignHint
NoHint] [ForeignHint
NoHint] CmmReturnInfo
CmmMayReturn
genCCall (ForeignTarget target cconv) dest_regs arg_regs
unaryFloatOp :: Width
-> (Operand -> Operand -> OrdList Instr)
-> CmmExpr
-> CmmFormal
-> NatM (OrdList Instr)
unaryFloatOp Width
w Operand -> Operand -> OrdList Instr
op CmmExpr
arg_reg CmmFormal
dest_reg = do
platform <- NatM Platform
getPlatform
(reg_fx, _format_x, code_fx) <- getFloatReg arg_reg
let dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dest_reg)
let code = OrdList Instr
code_fx OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fx)
pure code
genCondFarJump :: (MonadGetUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock
genCondFarJump :: forall (m :: * -> *).
MonadGetUnique m =>
Cond -> Operand -> Operand -> BlockId -> m (OrdList Instr)
genCondFarJump Cond
cond Operand
op1 Operand
op2 BlockId
far_target = do
skip_lbl_id <- m BlockId
forall (m :: * -> *). MonadGetUnique m => m BlockId
newBlockId
jmp_lbl_id <- newBlockId
return
$ toOL
[ ann (text "Conditional far jump to: " <> ppr far_target)
$ BCOND cond op1 op2 (TBlock jmp_lbl_id),
B (TBlock skip_lbl_id),
NEWBLOCK jmp_lbl_id,
LDR II64 (OpReg W64 tmpReg) (OpImm (ImmCLbl (blockLbl far_target))),
B (TReg tmpReg),
NEWBLOCK skip_lbl_id
]
genFarJump :: (MonadGetUnique m) => BlockId -> m InstrBlock
genFarJump :: forall (m :: * -> *).
MonadGetUnique m =>
BlockId -> m (OrdList Instr)
genFarJump BlockId
far_target =
OrdList Instr -> m (OrdList Instr)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
(OrdList Instr -> m (OrdList Instr))
-> OrdList Instr -> m (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
[ SDoc -> Instr -> Instr
ann ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Unconditional far jump to: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
far_target)
(Instr -> Instr) -> Instr -> Instr
forall a b. (a -> b) -> a -> b
$ Format -> Operand -> Operand -> Instr
LDR Format
II64 (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmpReg) (Imm -> Operand
OpImm (CLabel -> Imm
ImmCLbl (BlockId -> CLabel
blockLbl BlockId
far_target))),
Target -> Instr
B (Reg -> Target
TReg Reg
tmpReg)
]
data BlockInRange = InRange | NotInRange BlockId
makeFarBranches ::
Platform ->
LabelMap RawCmmStatics ->
[NatBasicBlock Instr] ->
UniqDSM [NatBasicBlock Instr]
makeFarBranches :: Platform
-> LabelMap RawCmmStatics
-> [NatBasicBlock Instr]
-> UniqDSM [NatBasicBlock Instr]
makeFarBranches Platform
_platform LabelMap RawCmmStatics
statics [NatBasicBlock Instr]
basic_blocks = do
let (Int
func_size, LabelMap Int
lblMap) = ((Int, LabelMap Int) -> NatBasicBlock Instr -> (Int, LabelMap Int))
-> (Int, LabelMap Int)
-> [NatBasicBlock Instr]
-> (Int, LabelMap Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, LabelMap Int) -> NatBasicBlock Instr -> (Int, LabelMap Int)
calc_lbl_positions (Int
0, LabelMap Int
forall v. LabelMap v
mapEmpty) [NatBasicBlock Instr]
basic_blocks
if Int
func_size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
max_jump_dist
then [NatBasicBlock Instr] -> UniqDSM [NatBasicBlock Instr]
forall a. a -> UniqDSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [NatBasicBlock Instr]
basic_blocks
else do
(_, blocks) <- (Int
-> NatBasicBlock Instr -> UniqDSM (Int, [NatBasicBlock Instr]))
-> Int
-> [NatBasicBlock Instr]
-> UniqDSM (Int, [[NatBasicBlock Instr]])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM (LabelMap Int
-> Int
-> NatBasicBlock Instr
-> UniqDSM (Int, [NatBasicBlock Instr])
replace_blk LabelMap Int
lblMap) Int
0 [NatBasicBlock Instr]
basic_blocks
pure $ concat blocks
where
max_jump_dist :: Int
max_jump_dist = Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
11 :: Int) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 :: Int
max_info_size :: Int
max_info_size = Int
16 :: Int
long_bc_jump_size :: Int
long_bc_jump_size = Int
5 :: Int
long_b_jump_size :: Int
long_b_jump_size = Int
2 :: Int
replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr])
replace_blk :: LabelMap Int
-> Int
-> NatBasicBlock Instr
-> UniqDSM (Int, [NatBasicBlock Instr])
replace_blk !LabelMap Int
m !Int
pos (BasicBlock BlockId
lbl [Instr]
instrs) = do
let !block_pos :: Int
block_pos = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ BlockId -> Int
infoTblSize_maybe BlockId
lbl
(!pos', instrs') <- (Int -> Instr -> UniqDSM (Int, [Instr]))
-> Int -> [Instr] -> UniqDSM (Int, [[Instr]])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM (LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])
replace_jump LabelMap Int
m) Int
block_pos [Instr]
instrs
let instrs'' = [[Instr]] -> [Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Instr]]
instrs'
let (top, split_blocks, no_data) = foldr mkBlocks ([], [], []) instrs''
massert (null no_data)
let final_blocks = BlockId -> [Instr] -> NatBasicBlock Instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
lbl [Instr]
top NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
split_blocks
pure (pos', final_blocks)
replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])
replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])
replace_jump !LabelMap Int
m !Int
pos Instr
instr = do
case Instr
instr of
ANN SDoc
ann Instr
instr -> do
LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])
replace_jump LabelMap Int
m Int
pos Instr
instr UniqDSM (Int, [Instr])
-> ((Int, [Instr]) -> UniqDSM (Int, [Instr]))
-> UniqDSM (Int, [Instr])
forall a b. UniqDSM a -> (a -> UniqDSM b) -> UniqDSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(Int
_, []) -> [Char] -> UniqDSM (Int, [Instr])
forall a. HasCallStack => [Char] -> a
error [Char]
"RV64:replace_jump"
(Int
idx, Instr
instr' : [Instr]
instrs') ->
(Int, [Instr]) -> UniqDSM (Int, [Instr])
forall a. a -> UniqDSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
idx, SDoc -> Instr -> Instr
ANN SDoc
ann Instr
instr' Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
instrs')
BCOND Cond
cond Operand
op1 Operand
op2 Target
t ->
case LabelMap Int -> Target -> Int -> BlockInRange
target_in_range LabelMap Int
m Target
t Int
pos of
BlockInRange
InRange -> (Int, [Instr]) -> UniqDSM (Int, [Instr])
forall a. a -> UniqDSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Instr -> Int
instr_size Instr
instr, [Instr
instr])
NotInRange BlockId
far_target -> do
jmp_code <- Cond -> Operand -> Operand -> BlockId -> UniqDSM (OrdList Instr)
forall (m :: * -> *).
MonadGetUnique m =>
Cond -> Operand -> Operand -> BlockId -> m (OrdList Instr)
genCondFarJump Cond
cond Operand
op1 Operand
op2 BlockId
far_target
pure (pos + instr_size instr, fromOL jmp_code)
B Target
t ->
case LabelMap Int -> Target -> Int -> BlockInRange
target_in_range LabelMap Int
m Target
t Int
pos of
BlockInRange
InRange -> (Int, [Instr]) -> UniqDSM (Int, [Instr])
forall a. a -> UniqDSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Instr -> Int
instr_size Instr
instr, [Instr
instr])
NotInRange BlockId
far_target -> do
jmp_code <- BlockId -> UniqDSM (OrdList Instr)
forall (m :: * -> *).
MonadGetUnique m =>
BlockId -> m (OrdList Instr)
genFarJump BlockId
far_target
pure (pos + instr_size instr, fromOL jmp_code)
Instr
_ -> (Int, [Instr]) -> UniqDSM (Int, [Instr])
forall a. a -> UniqDSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Instr -> Int
instr_size Instr
instr, [Instr
instr])
target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange
target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange
target_in_range LabelMap Int
m Target
target Int
src =
case Target
target of
(TReg {}) -> BlockInRange
InRange
(TBlock BlockId
bid) -> LabelMap Int -> Int -> BlockId -> BlockInRange
block_in_range LabelMap Int
m Int
src BlockId
bid
block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange
block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange
block_in_range LabelMap Int
m Int
src_pos BlockId
dest_lbl =
case BlockId -> LabelMap Int -> Maybe Int
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
dest_lbl LabelMap Int
m of
Maybe Int
Nothing ->
[Char] -> SDoc -> BlockInRange -> BlockInRange
forall a. [Char] -> SDoc -> a -> a
pprTrace [Char]
"not in range" (BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
dest_lbl)
(BlockInRange -> BlockInRange) -> BlockInRange -> BlockInRange
forall a b. (a -> b) -> a -> b
$ BlockId -> BlockInRange
NotInRange BlockId
dest_lbl
Just Int
dest_pos ->
if Int -> Int
forall a. Num a => a -> a
abs (Int
dest_pos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
src_pos) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
max_jump_dist
then BlockInRange
InRange
else BlockId -> BlockInRange
NotInRange BlockId
dest_lbl
calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int)
calc_lbl_positions :: (Int, LabelMap Int) -> NatBasicBlock Instr -> (Int, LabelMap Int)
calc_lbl_positions (Int
pos, LabelMap Int
m) (BasicBlock BlockId
lbl [Instr]
instrs) =
let !pos' :: Int
pos' = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ BlockId -> Int
infoTblSize_maybe BlockId
lbl
in ((Int, LabelMap Int) -> Instr -> (Int, LabelMap Int))
-> (Int, LabelMap Int) -> [Instr] -> (Int, LabelMap Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)
instr_pos (Int
pos', BlockId -> Int -> LabelMap Int -> LabelMap Int
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
lbl Int
pos' LabelMap Int
m) [Instr]
instrs
instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)
instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)
instr_pos (Int
pos, LabelMap Int
m) Instr
instr = (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Instr -> Int
instr_size Instr
instr, LabelMap Int
m)
infoTblSize_maybe :: BlockId -> Int
infoTblSize_maybe BlockId
bid =
case BlockId -> LabelMap RawCmmStatics -> Maybe RawCmmStatics
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
bid LabelMap RawCmmStatics
statics of
Maybe RawCmmStatics
Nothing -> Int
0 :: Int
Just RawCmmStatics
_info_static -> Int
max_info_size
instr_size :: Instr -> Int
instr_size :: Instr -> Int
instr_size Instr
i = case Instr
i of
COMMENT {} -> Int
0
MULTILINE_COMMENT {} -> Int
0
ANN SDoc
_ Instr
instr -> Instr -> Int
instr_size Instr
instr
LOCATION {} -> Int
0
DELTA {} -> Int
0
NEWBLOCK {} -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
panic [Char]
"mkFarBranched - Unexpected"
LDATA {} -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
panic [Char]
"mkFarBranched - Unexpected"
Instr
PUSH_STACK_FRAME -> Int
4
Instr
POP_STACK_FRAME -> Int
4
ADD {} -> Int
1
MUL {} -> Int
1
MULH {} -> Int
1
NEG {} -> Int
1
DIV {} -> Int
1
REM {} -> Int
1
REMU {} -> Int
1
SUB {} -> Int
1
DIVU {} -> Int
1
AND {} -> Int
1
OR {} -> Int
1
SRA {} -> Int
1
XOR {} -> Int
1
SLL {} -> Int
1
SRL {} -> Int
1
MOV {} -> Int
2
ORI {} -> Int
1
XORI {} -> Int
1
CSET {} -> Int
2
STR {} -> Int
1
LDR {} -> Int
3
LDRU {} -> Int
1
FENCE {} -> Int
1
FCVT {} -> Int
1
FABS {} -> Int
1
FMIN {} -> Int
1
FMAX {} -> Int
1
FMA {} -> Int
1
BCOND {} -> Int
long_bc_jump_size
B (TBlock BlockId
_) -> Int
long_b_jump_size
B (TReg Reg
_) -> Int
1
BL Reg
_ [Reg]
_ -> Int
1
J_TBL {} -> Int
1