{-# language GADTs #-}
{-# language LambdaCase #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE OverloadedStrings #-}
module GHC.CmmToAsm.LA64.CodeGen (
      cmmTopCodeGen
    , generateJumpTableForInstr
)

where

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.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,
    getConfig,
    getDebugBlock,
    getFileId,
    getNewLabelNat,
    getNewRegNat,
    getPicBaseMaybeNat,
    getPlatform,
  )
import GHC.CmmToAsm.PIC
import GHC.CmmToAsm.LA64.Cond
import GHC.CmmToAsm.LA64.Instr
import GHC.CmmToAsm.LA64.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.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Cmm.Dataflow.Label()
import GHC.Utils.Monad
import Control.Monad
import GHC.Types.Unique.DSM()

-- [General layout of an NCG]
cmmTopCodeGen ::
  RawCmmDecl ->
  NatM [NatCmmDecl RawCmmStatics Instr]
-- Thus we'll have to deal with either CmmProc ...
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 "LA64.cmmTopCodeGen: Unexpected PIC base register"

  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

-- ... or CmmData.
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] -- no translation, we just use CmmStatic

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 -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
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

  -- Generate location directive `.loc` (DWARF debug location info)
  loc_instrs <- genLocInstrs

  -- Generate other instructions
  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

      -- TODO: Then x86 backend runs @verifyBasicBlock@ here. How important it is to
      -- have a valid CFG is an open question: This and the AArch64 and PPC NCGs
      -- work fine without it.

      -- Code generation may introduce new basic block boundaries, which are
      -- indicated by the NEWBLOCK instruction. We must split up the instruction
      -- stream into basic blocks again. Also, we extract LDATAs here too.
      (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 <- Label -> NatM (Maybe DebugBlock)
getDebugBlock (Block CmmNode C C -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
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 Label
id) ([Instr]
instrs, [NatBasicBlock Instr]
blocks, [GenCmmDecl RawCmmStatics h g]
statics) =
  ([], Label -> [Instr] -> NatBasicBlock Instr
forall i. Label -> [i] -> GenBasicBlock i
BasicBlock Label
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)

-- -----------------------------------------------------------------------------
-- | Utilities

-- | Annotate an `Instr` with a `SDoc` comment
ann :: SDoc -> Instr -> Instr
ann :: SDoc -> Instr -> Instr
ann SDoc
doc Instr
instr {- debugIsOn -} = SDoc -> Instr -> Instr
ANN SDoc
doc Instr
instr
{-# INLINE ann #-}

-- Using pprExpr will hide the AST, @ANN@ will end up in the assembly with
-- -dppr-debug.  The idea is that we can trivially see how a cmm expression
-- ended up producing the assembly we see.  By having the verbatim AST printed
-- we can simply check the patterns that were matched to arrive at the assembly
-- we generated.
--
-- pprExpr will hide a lot of noise of the underlying data structure and print
-- the expression into something that can be easily read by a human. However
-- going back to the exact CmmExpr representation can be laborious and adds
-- indirections to find the matches that lead to the assembly.
--
-- An improvement oculd be to have
--
--    (pprExpr genericPlatform e) <> parens (text. show e)
--
-- to have the best of both worlds.
--
-- Note: debugIsOn is too restrictive, it only works for debug compilers.
-- However, we do not only want to inspect this for debug compilers. Ideally
-- we'd have a check for -dppr-debug here already, such that we don't even
-- generate the ANN expressions. However, as they are lazy, they shouldn't be
-- forced until we actually force them, and without -dppr-debug they should
-- never end up being forced.
annExpr :: CmmExpr -> Instr -> Instr
annExpr :: CmmExpr -> Instr -> Instr
annExpr CmmExpr
e {- debugIsOn -} = 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)
-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr
-- annExpr _ instr = instr
{-# INLINE annExpr #-}

-- -----------------------------------------------------------------------------
-- Generating a table-branch
-- The index into the jump table is calulated by evaluating @expr@. The
-- corresponding table entry contains the address to jump to.
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
  targetReg <- getNewRegNat II64
  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"),
              -- index to offset into the table (relative to tableReg)
              CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg) (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
fmt1) Reg
reg) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
3))),
              -- calculate table entry address
              Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
W64 Reg
targetReg) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg) (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
fmt2) Reg
tableReg),
              -- load table entry (relative offset from tableReg (first entry) to target label)
              Format -> Operand -> Operand -> Instr
LDU Format
II64 (Width -> Reg -> Operand
OpReg Width
W64 Reg
targetReg) (AddrMode -> Operand
OpAddr (Reg -> Imm -> AddrMode
AddrRegImm Reg
targetReg (Int -> Imm
ImmInt Int
0))),
              -- calculate absolute address of the target label
              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),
              -- prepare jump to target label
              [Maybe Label] -> Maybe CLabel -> Reg -> Instr
J_TBL [Maybe Label]
bids (CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
lbl) Reg
targetReg
            ]
  return code
  where
    platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
    expr_w :: Width
expr_w = Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
expr
    indexExpr0 :: CmmExpr
indexExpr0 = Platform -> CmmExpr -> Int -> CmmExpr
cmmOffset Platform
platform CmmExpr
expr Int
offset
    -- Widen to a native-width register(addressing modes)
    indexExpr :: CmmExpr
indexExpr = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp
        (Width -> Width -> MachOp
MO_UU_Conv Width
expr_w (Platform -> Width
platformWordWidth Platform
platform))
        [CmmExpr
indexExpr0]
    (Int
offset, [Maybe Label]
bids) = SwitchTargets -> (Int, [Maybe Label])
switchTargetsToTable SwitchTargets
targets


-- Generate jump table data (if required)
--
-- Relies on PIC relocations. The idea is to emit one table entry per case. The
-- entry is the label of the block to jump to. This will be relocated to be the
-- address of the jump target.
generateJumpTableForInstr ::
  NCGConfig ->
  Instr ->
  Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr NCGConfig
config (J_TBL [Maybe Label]
ids (Just CLabel
lbl) Reg
_) =
  let jumpTable :: [CmmStatic]
jumpTable =
        (Maybe Label -> CmmStatic) -> [Maybe Label] -> [CmmStatic]
forall a b. (a -> b) -> [a] -> [b]
map Maybe Label -> CmmStatic
jumpTableEntryRel [Maybe Label]
ids
        where
          jumpTableEntryRel :: Maybe Label -> CmmStatic
jumpTableEntryRel Maybe Label
Nothing =
            CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
0 (NCGConfig -> Width
ncgWordWidth NCGConfig
config))
          jumpTableEntryRel (Just Label
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 = Label -> CLabel
blockLbl Label
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

-- -----------------------------------------------------------------------------
-- Top-level of the instruction selector
stmtsToInstrs ::
  -- | Cmm Statements
  [CmmNode O O] ->
  -- | Resulting instruction
  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 ->
  -- | Resulting instructions
  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 (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL

    CmmAssign CmmReg
reg CmmExpr
src
      | CmmType -> Bool
isFloatType CmmType
ty         -> Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_FltCode Format
format CmmReg
reg CmmExpr
src
      | 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 Label
id          -> Label -> NatM (OrdList Instr)
genBranch Label
id

    --We try to arrange blocks such that the likely branch is the fallthrough
    --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.
    CmmCondBranch CmmExpr
arg Label
true Label
false Maybe Bool
_prediction ->
        Label -> Label -> CmmExpr -> NatM (OrdList Instr)
genCondBranch Label
true Label
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

    CmmNode e x
_ ->  [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)

-- | 'InstrBlock's are the insn sequences generated by the insn selectors.
--  They are really trees of insns to facilitate fast appending, where a
--  left-to-right traversal yields the insns in the correct order.
type InstrBlock =
  OrdList Instr

-- | Register's passed up the tree.
--  If the stix code forces the register to live in a pre-decided machine
--  register, it comes out as @Fixed@; otherwise, it comes out as @Any@, and the
--  parent can decide which register to put it in.
data Register
  = Fixed Format Reg InstrBlock
  | Any Format (Reg -> InstrBlock)

-- | Sometimes we need to change the Format of a register. Primarily during
--  conversion.
swizzleRegisterRep :: Format -> Register -> Register
swizzleRegisterRep :: Format -> Register -> Register
swizzleRegisterRep Format
format' (Fixed Format
_ Reg
reg OrdList Instr
code) = Format -> Reg -> OrdList Instr -> Register
Fixed Format
format' Reg
reg OrdList Instr
code
swizzleRegisterRep Format
format' (Any Format
_ Reg -> OrdList Instr
codefn) = Format -> (Reg -> OrdList Instr) -> Register
Any Format
format' Reg -> OrdList Instr
codefn

-- | Grab a `Reg` for a `CmmReg`
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)

-- General things for putting together code sequences

-- | Compute an expression into any register
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
        tmp <- Format -> NatM Reg
getNewRegNat Format
rep
        return (tmp, rep, code tmp)
    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)

-- | Compute an expression into any floating-point register

-- | Compute an expression into floating point register
--  If the initial expression is not a floating-point expression, finally move
--  the result into a floating-point register.
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
      tmp <- Format -> NatM Reg
getNewRegNat Format
rep
      return (tmp, rep, code tmp)
    Any Format
II32 Reg -> OrdList Instr
code -> do
      tmp <- Format -> NatM Reg
getNewRegNat Format
FF32
      return (tmp, FF32, code tmp)
    Any Format
II64 Reg -> OrdList Instr
code -> do
      tmp <- Format -> NatM Reg
getNewRegNat Format
FF64
      return (tmp, FF64, code tmp)
    Any Format
_w Reg -> OrdList Instr
_code -> do
      config <- NatM NCGConfig
getConfig
      pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr)
    -- can't do much for fixed.
    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)

-- | Map `CmmLit` to `OpImm`
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

-- Handling PIC on LA64
-- Commonly, `PIC` means of `position independent code`, that to say, the execution
-- of code does not be influenced by Load_address. Through PC-Relative addressing
-- or GOT addressing, both can be used to implement `PIC`.
--
-- For LoongArch's common compiler(GCC, Clang), they generate PIC code by default
-- without condition. The command option `-fPIC` dicates to generate code for
-- shared-library. If not just specified for shared-library, another option `-fPIE`
-- was be created.
--
-- Like RV64, LA64 does not have a special PIC register, the general approach is to
-- simply do PC-relative addressing or go through the GOT. There is assembly support
-- for both.
--
-- LA64 assembly has many `la*` (load address) pseudo-instructions, that allows
-- loading a symbols's address into a register. These instructions is desugared into
-- different addressing modes. See following:
--
-- la        rd, label + addend  -> Load global symbol
-- la.global rd, label + addend  -> Same as `la`
-- la.local  rd, label + addend  -> Load local symbol
-- la.pcrel  rd, label + addend
-- la.got    rd, label
-- la.abs    rd, label + addend
--
-- `la` is alias of `la.global`. Commonly recommended use `la.local` and `la.global`.
--
-- PC-relative addressing:
--   pcalau12i $a0, %pc_hi20(a)
--   addi.d    $a0, $a0, %pc_lo12(a)
--
-- GOT addressing:
--   pcalau12i $a0, %got_pc_hi20(global_a)
--   ld.d      $a0, $a0, %got_pc_lo12(global_a)
--
-- PIC can be enabled/disabled through:
--  .option pic
--
-- CmmGlobal @PicBaseReg@'s are generated in @GHC.CmmToAsm.PIC@ in the
-- @cmmMakePicReference@.  This is in turn called from @cmmMakeDynamicReference@
-- also in @Cmm.CmmToAsm.PIC@ from where it is also exported.  There are two
-- callsites for this. One is in this module to produce the @target@ in @genCCall@
-- the other is in @GHC.CmmToAsm@ in @cmmExprNative@.
--
-- Conceptually we do not want any special PicBaseReg to be used on LA64. If
-- we want to distinguish between symbol loading, we need to address this through
-- the way we load it, not through a register.

-- Compute a `CmmExpr` into a `Register`
getRegister :: CmmExpr -> NatM Register
getRegister :: CmmExpr -> NatM Register
getRegister CmmExpr
e = do
  config <- NatM NCGConfig
getConfig
  getRegister' config (ncgPlatform config) e

-- Signed arithmetic on LoongArch64
--
-- Handling signed arithmetic on sub-word-size values on LA64 is a bit tricky
-- as Cmm's type system does not capture signedness. While 32- and 64-bit
-- values are fairly easy to handle due to LA64's 32- and 64-bit instructions
-- with responding register, 8- and 16-bit values require quite some care.
--
-- For LoongArch64, EXT.W.[B/H] will sign-extend 8- and 16-bit to 64-bit.
-- However, it is best to use EXT instruction only if the input and
-- output data widths are fully determined.
--
-- We handle 16-and 8-bit values by using the following two steps:
--  1. Sign- or Zero-extending operands.
--  2. Truncate results as necessary.
--
-- For simplicity we maintain the invariant that a register containing a
-- sub-word-size value always contains the zero-extended form of that value
-- in between operations.

getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register

-- OPTIMIZATION WARNING: CmmExpr rewrites
-- Maybe we can do more?
-- 1. Rewrite: Reg + (-i) => Reg - i
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)])

-- 2. Rewrite: Reg - (-i) => Reg + i
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)])

-- Generic case.
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]
"getRegisterReg-memory" (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 -> do
          -- narrowU is important: Negative immediates may be
          -- sign-extended on load!
          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
          Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
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
          tmp <- 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
tmp) (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
tmp)
                                                      ]))
        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
          tmp <- 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
tmp) (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
tmp)
                                                      ]))

        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
LD 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
LD 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
LD 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
W64 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 Label
_ -> [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. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Width
W8, Width
W16, Width
W32, Width
W64] ->
            -- Load without sign-extension.
            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
LDU 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]
"Unknown width to 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
W64 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)

    -- Handle MO_RelaxedRead as a normal CmmLoad, to allow
    -- non-trivial addressing modes to be used.
    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)

    -- for MachOps, see GHC.Cmm.MachOp
    -- For CmmMachOp, see GHC.Cmm.Expr
    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 ->
          OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
          -- pseudo instruction `not dst rd` is `nor dst, r0, rd`
          Width -> Width -> Reg -> OrdList Instr
truncateReg (Format -> Width
formatToWidth Format
format) Width
W64 Reg
reg OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
          -- At this point an 8- or 16-bit value would be zero-extended
          -- to 64-bits. Truncate back down the final width.
          SDoc -> Instr -> Instr
ann ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"not") (Operand -> Operand -> Operand -> Instr
NOR (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg) Operand
zero) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
          Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst

        MO_S_Neg Width
w -> OrdList Instr -> Width -> Reg -> NatM Register
forall {m :: * -> *}.
Monad m =>
OrdList Instr -> Width -> Reg -> m 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
FNEG (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg))

        -- Floating convertion oprations
        -- Float -> Float
        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` Operand -> Operand -> Instr
FCVT (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))

        -- Signed int -> Float
        MO_SF_Round 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` Operand -> Operand -> Instr
SCVTF (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))

        -- Float -> Signed int
        MO_FS_Truncate Width
from Width
to | Width
from Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32 -> do
            tmp <- Format -> NatM Reg
getNewRegNat Format
FF32
            return $ Any (intFormat to) (\Reg
dst -> OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Operand -> Instr
FCVTZS (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
tmp) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))

        MO_FS_Truncate Width
from Width
to | Width
from Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64-> do
            tmp <- Format -> NatM Reg
getNewRegNat Format
FF64
            return $ Any (intFormat to) (\Reg
dst -> OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Operand -> Instr
FCVTZS (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
tmp) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))

        -- unsigned int -> unsigned int
        MO_UU_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
intFormat Width
to) (\Reg
dst ->
          OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Operand -> Operand -> Operand -> Operand -> Instr
BSTRPICK Format
II64 (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Width -> Int
widthToInt (Width -> Width -> Width
forall a. Ord a => a -> a -> a
min Width
from Width
to) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0))
                                                          )

        -- Signed int -> Signed int
        MO_SS_Conv Width
from Width
to -> Width -> Width -> Reg -> OrdList Instr -> NatM Register
forall {m :: * -> *}.
Monad m =>
Width -> Width -> Reg -> OrdList Instr -> m Register
ss_conv Width
from Width
to Reg
reg OrdList Instr
code

        -- int -> int
        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_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))

        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
        -- In the case of 32- or 16- or 8-bit values we need to sign-extend to 64-bits
        negate :: OrdList Instr -> Width -> Reg -> m Register
negate OrdList Instr
code Width
w Reg
reg = do
            Register -> m Register
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> m Register) -> Register -> m 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 ->
                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
w Width
W64 Reg
reg Reg
reg OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                Operand -> Operand -> Instr
NEG (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst

        ss_conv :: Width -> Width -> Reg -> OrdList Instr -> m Register
ss_conv Width
from Width
to Reg
reg OrdList Instr
code =
            Register -> m Register
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> m Register) -> Register -> m 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
W64 Reg
reg Reg
dst OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                -- At this point an 8- or 16-bit value would be sign-extended
                -- to 64-bits. Truncate back down the final width.
                Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
to Reg
dst


-- Dyadic machops:
    --
    -- The general idea is:
    -- compute x<i> <- x
    -- compute x<j> <- y
    -- OP x<r>, x<i>, x<j>
    --
    -- TODO: for now we'll only implement the 64bit versions. And rely on the
    --      fallthrough to alert us if things go wrong!
    -- OPTIMIZATION WARNING: Dyadic CmmMachOp destructuring
    -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg
    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) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
      | 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]
      , Int -> Int -> Bool
fitsInNbits Int
12 (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) -> 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 -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_x) Width
W64 Reg
reg_x 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
ADD (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) ))) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_Sub Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
      | 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]
      , Int -> Int -> Bool
fitsInNbits Int
12 (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) -> 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 -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_x) Width
W64 Reg
reg_x 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
SUB (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) ))) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_Add Width
w) [CmmReg CmmReg
reg, CmmLit (CmmInt Integer
n Width
_)]
      | 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]
      , Int -> Int -> Bool
fitsInNbits Int
12 (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) -> do
      let 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
      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 ->
                                    Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend Width
w' Width
W64 Reg
r' Reg
r' OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                    CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) ))) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_Sub Width
w) [CmmReg CmmReg
reg, CmmLit (CmmInt Integer
n Width
_)]
      | 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]
      , Int -> Int -> Bool
fitsInNbits Int
12 (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) -> do
      let 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
      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 ->
                                    Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend Width
w' Width
W64 Reg
r' Reg
r' OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                    CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SUB (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) ))) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_U_Quot Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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
W64 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
W64 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
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    -- 2. Shifts.
    CmmMachOp (MO_Shl Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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 -> 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 -> 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
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 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
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Width
W8, Width
W16, 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
< Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Int
widthInBits Width
w) -> 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 -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_x) Width
W64 Reg
reg_x 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
SLL (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) ))) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    -- MO_S_Shr: signed-shift-right
    CmmMachOp (MO_S_Shr Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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 -> 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 -> 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
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )
    CmmMachOp (MO_S_Shr Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
      | 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]
      , Int -> Int -> Bool
fitsInNbits Int
12 (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) -> 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 -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_x) Width
W64 Reg
reg_x 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
SRA (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) ))) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                  )

    -- MO_U_Shr: unsigned-shift-right
    CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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
W64 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
W64 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
SRL (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )
    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
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Width
W8, Width
W16, 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
< Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Int
widthInBits Width
w) -> 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
W64 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
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) ))) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    -- 3. Logic &&, ||
    -- andi Instr's Imm-operand is zero-extended.
    CmmMachOp (MO_And Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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
W64 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
W64 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
AND (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_And Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
      | 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] -> 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
W64 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
AND (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) ))) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_Or Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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
W64 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
W64 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
OR (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_Or Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
      | 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] -> 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
W64 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
OR (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) ))) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_Xor Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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
W64 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
W64 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
XOR (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_Xor Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
      | 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] -> 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
W64 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
XOR (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) ))) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    -- CSET commands register operand being W64.
    CmmMachOp (MO_Eq Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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 -> 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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                    CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
EQ (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_Ne Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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 -> 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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                    CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
NE (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_S_Lt Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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 -> 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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                    CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
SLT (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_S_Le Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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 -> 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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                    CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
SLE (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_S_Ge Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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 -> 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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                    CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
SGE (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_S_Gt Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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 -> 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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                    CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
SGT (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_U_Lt Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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
W64 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
W64 Reg
reg_y OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                    CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
ULT (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_U_Le Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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
W64 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
W64 Reg
reg_y OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                    CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
ULE (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_U_Ge Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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
W64 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
W64 Reg
reg_y OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                    CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
UGE (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )

    CmmMachOp (MO_U_Gt Width
w) [CmmExpr
x, CmmExpr
y]
      | 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] -> 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
W64 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
W64 Reg
reg_y OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                    CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
UGT (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                                    Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                 )


    -- Generic binary case.
    CmmMachOp MachOp
op [CmmExpr
x, CmmExpr
y] -> do
      let
          -- A (potentially signed) integer operation.
          -- In the case of 8-, 16- and 32-bit signed arithmetic we must first
          -- sign-extend all arguments to 64-bits.
          -- TODO: can be simplified.
          intOp :: Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
is_signed Width
w Operand -> Operand -> Operand -> Instr
op = do
              -- compute x<m> <- x
              -- compute x<o> <- y
              -- <OP> x<n>, x<m>, x<o>
              (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
W64
              -- This is the width of the registers on which the operation
              -- should be performed.
              if not is_signed
                then 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`
                      -- zero-extend both operands
                      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`
                      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`
                      Operand -> Operand -> Operand -> 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) 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 -- truncate back to the operand's original width
                else 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`
                      -- sign-extend both operands
                      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`
                      Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_x) Width
W64 Reg
reg_y Reg
reg_y OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                      Operand -> Operand -> Operand -> 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) 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 -- truncate back to the operand's original width

          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))

          -- need a special one for conditionals, as they return ints
          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
        -- Integer operations
        -- Add/Sub should only be Integer Options.
        MO_Add Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y ->  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 -> Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y ->  CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SUB Operand
d Operand
x Operand
y))

        -- Signed multiply/divide/remain
        MO_Mul Width
w          -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> 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 -> Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> 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 -> Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
MOD Operand
d Operand
x Operand
y))

        -- Unsigned divide/remain
        MO_U_Quot Width
w  -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> 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 -> Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
MODU Operand
d Operand
x Operand
y))

        MO_Eq   Width
w    -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
False  Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
EQ Operand
d Operand
x Operand
y))
        MO_Ne   Width
w    -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
False  Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
NE Operand
d Operand
x Operand
y))

        -- Signed comparisons
        MO_S_Ge Width
w    -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
True  Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
SGE Operand
d Operand
x Operand
y))
        MO_S_Le Width
w    -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
True  Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
SLE Operand
d Operand
x Operand
y))
        MO_S_Gt Width
w    -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
True  Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
SGT Operand
d Operand
x Operand
y))
        MO_S_Lt Width
w    -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
True  Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
SLT Operand
d Operand
x Operand
y))

        -- Unsigned comparisons
        MO_U_Ge Width
w    -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
UGE Operand
d Operand
x Operand
y))
        MO_U_Le Width
w    -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
ULE Operand
d Operand
x Operand
y))
        MO_U_Gt Width
w    -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
UGT Operand
d Operand
x Operand
y))
        MO_U_Lt Width
w    -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
ULT Operand
d Operand
x Operand
y))

        -- Floating point arithmetic
        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))

        -- Floating point comparison
        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 (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
EQ Operand
d Operand
x Operand
y))
        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 (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
NE Operand
d Operand
x Operand
y))
        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 (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
FGE Operand
d Operand
x Operand
y))
        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 (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
FLE Operand
d Operand
x Operand
y))
        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 (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
FGT Operand
d Operand
x Operand
y))
        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 (Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
FLT Operand
d Operand
x Operand
y))

        MO_Shl   Width
w   -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> 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 -> Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> 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 -> Instr)
-> NatM Register
intOp Bool
True  Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRA Operand
d Operand
x Operand
y))

        -- Bitwise operations
        MO_And   Width
w   -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
AND Operand
d Operand
x Operand
y))
        MO_Or    Width
w   -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
OR Operand
d Operand
x Operand
y))
        MO_Xor   Width
w   -> Bool
-> Width
-> (Operand -> Operand -> Operand -> Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
XOR 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

    -- Generic ternary case.
    CmmMachOp MachOp
op [CmmExpr
x, CmmExpr
y, CmmExpr
z] ->
      case MachOp
op of

        -- Floating-point fused multiply-add operations
        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
    -- N.B. MUL does not set the overflow flag.
    -- Return 0 when the operation cannot overflow, /= 0 otherwise
    do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
    do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
do_mul_may_oflo 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
      return $ Any (intFormat W64) (\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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
        Operand -> Operand -> Operand -> Instr
MULH (Width -> Reg -> Operand
OpReg Width
W64 Reg
hi) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x)  (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
        Operand -> Operand -> Operand -> Instr
MUL  (Width -> Reg -> Operand
OpReg Width
W64 Reg
lo) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x)  (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
        Operand -> Operand -> Operand -> Instr
SRA  (Width -> Reg -> Operand
OpReg Width
W64 Reg
lo) (Width -> Reg -> Operand
OpReg Width
W64 Reg
lo)     (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
63)) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
        Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
NE (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
hi)  (Width -> Reg -> Operand
OpReg Width
W64 Reg
lo)
                                 )

    do_mul_may_oflo Width
W32 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
        tmp1 <- getNewRegNat II64
        tmp2 <- getNewRegNat II64
        return $ Any (intFormat W32) (\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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Operand -> Operand -> Instr
MULW (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp1) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp2) (Width -> Reg -> Operand
OpReg Width
W32 Reg
tmp1) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
NE (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp1)  (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp2) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
W32 Reg
dst
                                     )

    -- General case
    do_mul_may_oflo Width
w CmmExpr
x CmmExpr
y = do
      -- Assert: 8bit * 8bit cannot overflow 16bit, and so on.
      (reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      (reg_y, format_y, code_y) <- getSomeReg y
      tmp1 <- getNewRegNat II64
      tmp2 <- getNewRegNat II64
      let width_x = Format -> Width
formatToWidth Format
format_x
          width_y = Format -> Width
formatToWidth Format
format_y
          extend Reg
dst Reg
src =
            case Width
w of
              Width
W8  -> Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W32 Reg
src) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0))
              Width
W16 -> Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W32 Reg
src) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0))
              Width
_   -> [Char] -> Instr
forall a. HasCallStack => [Char] -> a
panic [Char]
"Must be in [W8, W16, W32]!"
          extract Width
width Reg
dst Reg
src =
            case Width
width of
              Width
W8  -> Operand -> Operand -> Instr
EXT (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W8 Reg
src)
              Width
W16 -> Operand -> Operand -> Instr
EXT (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W16 Reg
src)
              Width
W32 -> Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W32 Reg
src) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0))
              Width
_   -> [Char] -> Instr
forall a. HasCallStack => [Char] -> a
panic [Char]
"Must be in [W8, W16, W32]!"

      case w of
        Width
w | (Width
width_x Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
w) Bool -> Bool -> Bool
&& (Width
width_y Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< 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 ->
            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) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)))
                                     )
        Width
w | 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 ->
            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
W32) (\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`
                -- signExtend [W8, W16] register to W64 and then SLL
                -- nil for W32
                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`
                Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_y) Width
W64 Reg
reg_y Reg
reg_y OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                Reg -> Reg -> Instr
extend Reg
reg_x Reg
reg_x OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                Reg -> Reg -> Instr
extend Reg
reg_y Reg
reg_y OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                -- 64-bits MUL
                Operand -> Operand -> Operand -> Instr
MUL (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp1) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W64 Reg
reg_y) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                -- extract valid result via result's width
                -- slli.w for W32, otherwise ext.w.[b, h]
                Width -> Reg -> Reg -> Instr
extract Width
w Reg
tmp2 Reg
tmp1 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                Cond -> Operand -> Operand -> Operand -> Instr
CSET Cond
NE (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp1)  (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp2) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                Width -> Width -> Reg -> OrdList Instr
truncateReg Width
W64 Width
w Reg
dst
                                        )

        -- Should it be happened?
        Width
_ ->
          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 ->
            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) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
1))))

-- Sign-extend the value in the given register from width @w@
-- up to width @w'@.
-- TODO: Is there room for optimization?
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]
"Sign-extend Error: 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'
  | 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]
"Sign-extend Error: from/to register width greater than 64-bit." (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'
  | 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
  | 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)
  | 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
$ Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
W64 Reg
r') (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0))
  -- Sign-extend W8 and W16 to W64.
  | 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] = 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
EXT (Width -> Reg -> Operand
OpReg Width
W64 Reg
r') (Width -> Reg -> Operand
OpReg Width
w 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
W32 = 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)
  | Bool
otherwise = [Char] -> SDoc -> OrdList Instr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"signExtend: Unexpected width: " (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'

-- | Instructions to truncate the value in the given register from width @w@
-- down to 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. 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]
"Tructate Error: from/to register width greater than 64-bit." (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'
  | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
w' = OrdList Instr
forall a. OrdList a
nilOL
  | Width
w Width -> Width -> Bool
forall a. Eq 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]
"truncateReg: " 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')
        (Format -> Operand -> Operand -> Operand -> Operand -> Instr
BSTRPICK Format
II64 (Width -> Reg -> Operand
OpReg Width
w' Reg
r) (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift)) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)))
    ]
  | Bool
otherwise = [Char] -> SDoc -> OrdList Instr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"truncateReg: Unexpected width: " (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'
  where
    shift :: Int
shift = (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Width -> Int
widthInBits Width
w) (Width -> Int
widthInBits Width
w')) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

--  The 'Amode' type: Memory addressing modes passed up the tree.
data Amode = Amode AddrMode InstrBlock

-- | Provide the value of a `CmmExpr` with an `Amode`
--  N.B. this function should be used to provide operands to load and store
--  instructions with signed 12bit wide immediates (S & I types). For other
--  immediate sizes and formats (e.g. B type uses multiples of 2) this function
--  would need to be adjusted.
getAmode :: Platform
         -> Width     -- ^ width of loaded value
         -> CmmExpr
         -> NatM Amode

-- LD/ST: Immediate can be represented with 12bits
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 -> Int -> Bool
fitsInNbits Int
12 (Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral 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

-- For Stores we often see something like this:
-- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2)
-- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ]
-- for `n` in range.
getAmode Platform
_platform Width
_ (CmmMachOp (MO_Add Width
_w) [CmmExpr
expr, CmmLit (CmmInt Integer
off Width
_w')])
  | Int -> Int -> Bool
fitsInNbits Int
12 (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral 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')])
  | Int -> Int -> Bool
fitsInNbits Int
12 (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (-Integer
off))
  = do (reg, _format, code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
       return $ Amode (AddrRegImm reg (ImmInteger (-off))) code

-- Generic case
getAmode Platform
_platform Width
_ CmmExpr
expr
  = do (reg, _format, code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
       return $ Amode (AddrReg reg) code

-- -----------------------------------------------------------------------------
-- Generating assignments

-- Assignments are really at the heart of the whole code generation
-- business.  Almost all top-level nodes of any real importance are
-- assignments, which correspond to loads, stores, or register
-- transfers.  If we're really lucky, some of the register transfers
-- will go away, because we can use the destination register to
-- complete the code generation for the right hand side.  This only
-- fails when the right hand side is forced into a fixed register
-- (e.g. the result of a call).

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`  ST 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)
                                               )

-- Let's treat Floating point stuff
-- as integer code for now. Opaque.
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

-- Jumps
genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
-- `b label` may be optimal, but not the right one in some scenarios.
-- genJump expr@(CmmLit (CmmLabel lbl))
--   = return $ unitOL (annExpr expr (J (TLabel lbl)))
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 (J (TReg target))))

-- -----------------------------------------------------------------------------
--  Unconditional branches
genBranch :: BlockId -> NatM InstrBlock
genBranch :: Label -> 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))
-> (Label -> OrdList Instr) -> Label -> 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)
-> (Label -> [Instr]) -> Label -> OrdList Instr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> [Instr]
mkJumpInstr

-- -----------------------------------------------------------------------------
-- Conditional branches
genCondJump
    :: BlockId
    -> CmmExpr
    -> NatM InstrBlock
genCondJump :: Label -> CmmExpr -> NatM (OrdList Instr)
genCondJump Label
bid CmmExpr
expr = do
    case CmmExpr
expr of
      -- Optimized == 0 case.
      CmmMachOp (MO_Eq Width
W64) [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`
          BEQZ (OpReg W64 reg_x) (TBlock bid)
      CmmMachOp (MO_Eq Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
0 Width
_)]
        | 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] -> do
        (reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
        return $
          code_x `appOL`
          signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL`
          BEQZ (OpReg W64 reg_x) (TBlock bid)

      -- Optimized /= 0 case.
      CmmMachOp (MO_Ne Width
W64) [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 (BNEZ (OpReg W64 reg_x) (TBlock bid)))
      CmmMachOp (MO_Ne Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
0 Width
_)]
        | 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] -> do
        (reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
        return $
          code_x `appOL`
          signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL`
          BNEZ (OpReg W64 reg_x) (TBlock bid)

      -- Generic case.
      CmmMachOp MachOp
mop [CmmExpr
x, CmmExpr
y] -> do

        let ubcond :: Width -> Cond -> NatM (OrdList Instr)
ubcond Width
w Cond
cmp | 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] = 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_t <- getNewRegNat (intFormat W64)
              return $
                code_x `appOL`
                truncateReg (formatToWidth format_x) W64 reg_x  `appOL`
                code_y `appOL`
                truncateReg (formatToWidth format_y) W64 reg_y  `snocOL`
                MOV (OpReg W64 reg_t) (OpImm (ImmInt 12)) `snocOL`
                BCOND cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) (OpReg W64 reg_t)
            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
              reg_t <- getNewRegNat (intFormat W64)
              return $
                code_x `appOL`
                code_y `snocOL`
                MOV (OpReg W64 reg_t) (OpImm (ImmInt 12)) `snocOL`
                BCOND cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) (OpReg W64 reg_t)


            sbcond :: Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
cmp | 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] = 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_t <- getNewRegNat (intFormat W64)
              return $
                code_x `appOL`
                signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`
                code_y `appOL`
                signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`
                MOV (OpReg W64 reg_t) (OpImm (ImmInt 13)) `snocOL`
                BCOND cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) (OpReg W64 reg_t)

            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
              reg_t <- getNewRegNat (intFormat W64)
              return $
                code_x `appOL`
                code_y `snocOL`
                MOV (OpReg W64 reg_t) (OpImm (ImmInt 13)) `snocOL`
                BCOND cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid) (OpReg W64 reg_t)


            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
              rst <- OpReg W64 <$> getNewRegNat II64
              oneReg <- OpReg W64 <$> getNewRegNat II64
              reg_t <- getNewRegNat (intFormat W64)
              return $
                code_fx `appOL`
                code_fy `snocOL`
                MOV (OpReg W64 reg_t) (OpImm (ImmInt 14)) `snocOL`
                CSET cmp rst (OpReg w reg_fx) (OpReg w reg_fy) `snocOL`
                MOV oneReg (OpImm (ImmInt 1)) `snocOL`
                BCOND EQ rst oneReg (TBlock bid) (OpReg W64 reg_t)


        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]
"LA64.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]
"LA64.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)


-- | Generate conditional branching instructions
-- This is basically an "if with else" statement.
genCondBranch ::
  BlockId ->
  BlockId ->
  CmmExpr ->
  NatM InstrBlock
genCondBranch :: Label -> Label -> CmmExpr -> NatM (OrdList Instr)
genCondBranch Label
true Label
false CmmExpr
expr = do
  b1 <- Label -> CmmExpr -> NatM (OrdList Instr)
genCondJump Label
true CmmExpr
expr
  b2 <- genBranch false
  return (b1 `appOL` b2)

-- -----------------------------------------------------------------------------
{-
Generating C calls

Generate a call to a C function:

GARs: 8 general-purpose registers $a0 - $a7, where $a0 and $a1 are also used for
integral values.
FARs: 8 floating-point registers $fa0 - $fa7, where $fa0 and $fa1 are also used
for returning values.

An argument is passed using the stack only when no appropriate argument register
is available.

Subroutines should ensure that the initial values of the general-purpose registers
$s0 - $s9 and floating-point registers $fs0 - $fs7 are preserved across the call.

At the entry of a procedure call, the return address of the call site is stored
in $ra. A branch jump to this address should be the last instruction executed in
the called procedure.

The on-stack part of the structure and scalar arguments are aligned to the greater
of the type alignment and GRLEN bits, except when this alignment is larger than
 the 16-byte stack alignment. In this case, the part of the argument should be
16-byte-aligned.

In a procedure call, GARs / FARs are generally only used for passing non-floating
-point / floating-point argument data, respectively. However, the floating-point
member of a structure or union argument, or a vector/floating-point argument
wider than FRLEN may be passed in a GAR.
-}

genCCall
    :: ForeignTarget      -- function to call
    -> [CmmFormal]        -- where to put the result
    -> [CmmActual]        -- arguments (of mixed type)
    -> NatM InstrBlock

-- TODO: Specialize where we can.
-- Generic impl
genCCall :: ForeignTarget -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
genCCall ForeignTarget
target [CmmFormal]
dest_regs [CmmExpr]
arg_regs = do
  case ForeignTarget
target of
    -- The target :: ForeignTarget call can either
    -- be a foreign procedure with an address expr
    -- and a calling convention.
    ForeignTarget CmmExpr
expr ForeignConvention
_cconv -> do
--      (call_target, call_target_code) <- case expr of
--        -- if this is a label, let's just directly to it.  This will produce the
--        -- correct CALL relocation for BL.
--        (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL)
--        -- if it's not a label, let's compute the expression into a
--        -- register and jump to that.
--        _ -> 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)
      -- compute the code and register logic for all arg_regs.
      -- this will give us the format information to match on.
      arg_regs' <- mapM getSomeReg arg_regs

      -- Now this is stupid.  Our Cmm expressions doesn't carry the proper sizes
      -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in
      -- STG; this thenn breaks packing of stack arguments, if we need to pack
      -- for the pcs, e.g. darwinpcs.  Option one would be to fix the Int type
      -- in Cmm proper. Option two, which we choose here is to use extended Hint
      -- information to contain the size information and use that when packing
      -- arguments, spilled onto the stack.
      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 -- compute the label (possibly into a register)
              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 -- put the arguments into x0, ...
              -- `snocOL` BL call_target passRegs -- branch and link (C calls aren't tail calls, but return)
              OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Target -> [Reg] -> Instr
BL (Reg -> Target
TReg Reg
call_target_reg) [Reg]
passRegs -- branch and link (C calls aren't tail calls, but return)
              OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
readResultsCode -- parse the results into registers
              OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Int -> OrdList Instr
moveStackUp (Int
stackSpaceWords)
      return code

    PrimTarget 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
    PrimTarget 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

    -- or a possibly side-effecting machine operation
    -- mop :: CallishMachOp (see GHC.Cmm.MachOp)
    PrimTarget CallishMachOp
mop -> do
      -- We'll need config to construct forien targets
      case CallishMachOp
mop of
        -- 64 bit float ops
        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"

        -- 32 bit float ops
        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"

        -- 64-bit primops
        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"

        -- Conversion
        MO_UF_Conv Width
w        -> FastString -> NatM (OrdList Instr)
mkCCall (Width -> FastString
word2FloatLabel Width
w)

        -- Optional MachOps
        -- These are enabled/disabled by backend flags: GHC.StgToCmm.Config
        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

        MO_VS_Quot {} -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_VS_Rem {}  -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_VU_Quot {} -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_VU_Rem {}  -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        CallishMachOp
MO_I64X2_Min -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        CallishMachOp
MO_I64X2_Max -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        CallishMachOp
MO_W64X2_Min -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        CallishMachOp
MO_W64X2_Max -> CallishMachOp -> NatM (OrdList Instr)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop

        -- Memory Ordering
        -- A hint value of 0 is mandatory by default, and it indicates a fully functional synchronization barrier.
        -- Only after all previous load/store access operations are completely executed, the DBAR 0 instruction can be executed;
        -- and only after the execution of DBAR 0 is completed, all subsequent load/store access operations can be executed.

        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 (BarrierType -> Instr
DBAR BarrierType
Hint0))
        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 (BarrierType -> Instr
DBAR BarrierType
Hint0))
        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 (BarrierType -> Instr
DBAR BarrierType
Hint0))

        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 -- Keep variables live (when using interior pointers)
        -- Prefetch
        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 -- Prefetch hint.

        -- Memory copy/set/move/cmp, with alignment for optimization

        -- TODO Optimize and use e.g. quad registers to move memory around instead
        -- of offloading this to memcpy. For small memcpys we can utilize
        -- the 128bit quad registers in NEON to move block of bytes around.
        -- Might also make sense of small memsets? Use xzr? What's the function
        -- call overhead?
        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
LD (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
LD (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)),
                                                BarrierType -> Instr
DBAR BarrierType
Hint0
                                              ]
                      MemoryOrdering
MemOrderSeqCst -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                                                SDoc -> Instr -> Instr
ann SDoc
moDescr (BarrierType -> Instr
DBAR BarrierType
Hint0),
                                                Format -> Operand -> Operand -> Instr
LD (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),
                                                BarrierType -> Instr
DBAR BarrierType
Hint0
                                              ]
                      MemoryOrdering
_ -> [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
              pure 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
ST 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
MemOrderRelease -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                                                SDoc -> Instr -> Instr
ann SDoc
moDescr (BarrierType -> Instr
DBAR BarrierType
Hint0),
                                                Format -> Operand -> Operand -> Instr
ST 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 (BarrierType -> Instr
DBAR BarrierType
Hint0),
                                                Format -> Operand -> Operand -> Instr
ST 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),
                                                BarrierType -> Instr
DBAR BarrierType
Hint0
                                              ]
                      MemoryOrdering
_ ->  [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

    -- Implementiation of the LoongArch ABI calling convention.
    -- https://github.com/loongson/la-abi-specs/blob/release/lapcs.adoc#passing-arguments
    passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)

    -- 1. Base case: no more arguments to pass (left)
    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)

    -- 2. Still have GP regs, and we want to pass an GP argument.
    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
          ext :: Instr
ext
            -- Specifically, LoongArch64's ABI requires that the caller
            -- sign-extend arguments which are smaller than 64-bits.
            | 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]
            = case Width
w of
              Width
W8  -> Operand -> Operand -> Instr
EXT (Width -> Reg -> Operand
OpReg Width
W64 Reg
gpReg) (Width -> Reg -> Operand
OpReg Width
w Reg
r)
              Width
W16 -> Operand -> Operand -> Instr
EXT (Width -> Reg -> Operand
OpReg Width
W64 Reg
gpReg) (Width -> Reg -> Operand
OpReg Width
w Reg
r)
              Width
W32 -> Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
W64 Reg
gpReg) (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0))
              Width
_ -> [Char] -> Instr
forall a. HasCallStack => [Char] -> a
panic [Char]
"Unexpected width(Here w < W64)!"
            | Bool
otherwise
            = 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 gp argument: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r) Instr
ext

      [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'

    -- 3. Still have FP regs, and we want to pass an FP argument.
    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'

    -- 4. No mor regs left to pass. Must pass on stack.
    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
ST 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` (Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
tmpReg) (Width -> Reg -> Operand
OpReg Width
w Reg
r))
              OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
w Width
W64 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

      [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)

    -- 5. Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.
    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
ST 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)

   -- 6. Still have gpRegs left, but want to pass a FP argument. Must be passed in gpReg then.
    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
      -- gp/fp reg -> dst
      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`
            -- truncate, otherwise an unexpectedly big value might be used in upfollowing calculations
            truncateReg W64 w r_dst

    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