{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module GHC.CmmToAsm.RV64.CodeGen
  ( cmmTopCodeGen,
    generateJumpTableForInstr,
    makeFarBranches,
  )
where

import Control.Monad
import Data.Maybe
import Data.Word
import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.DebugBlock
import GHC.Cmm.Switch
import GHC.Cmm.Utils
import GHC.CmmToAsm.CPrim
import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Monad
  ( NatM,
    getBlockIdNat,
    getConfig,
    getDebugBlock,
    getFileId,
    getNewLabelNat,
    getNewRegNat,
    getPicBaseMaybeNat,
    getPlatform,
  )
import GHC.CmmToAsm.PIC
import GHC.CmmToAsm.RV64.Cond
import GHC.CmmToAsm.RV64.Instr
import GHC.CmmToAsm.RV64.Regs
import GHC.CmmToAsm.Types
import GHC.Data.FastString
import GHC.Data.OrdList
import GHC.Float
import GHC.Platform
import GHC.Platform.Reg
import GHC.Platform.Regs
import GHC.Prelude hiding (EQ)
import GHC.Types.Basic
import GHC.Types.ForeignCall
import GHC.Types.SrcLoc (srcSpanFile, srcSpanStartCol, srcSpanStartLine)
import GHC.Types.Tickish (GenTickish (..))
import GHC.Types.Unique.DSM
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
import GHC.Utils.Monad
import GHC.Utils.Outputable
import GHC.Utils.Panic

-- For an overview of an NCG's structure, see Note [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 "RV64.cmmTopCodeGen: Unexpected PIC base register (RISCV ISA does not define one)"

  let blocks = CmmGraph -> [Block CmmNode C C]
toBlockListEntryFirst CmmGraph
graph
  (nat_blocks, statics) <- mapAndUnzipM basicBlockCodeGen blocks

  let proc = LabelMap RawCmmStatics
-> CLabel
-> [GlobalRegUse]
-> ListGraph Instr
-> NatCmmDecl RawCmmStatics Instr
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
info CLabel
lab [GlobalRegUse]
live ([NatBasicBlock Instr] -> ListGraph Instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph ([NatBasicBlock Instr] -> ListGraph Instr)
-> [NatBasicBlock Instr] -> ListGraph Instr
forall a b. (a -> b) -> a -> b
$ [[NatBasicBlock Instr]] -> [NatBasicBlock Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NatBasicBlock Instr]]
nat_blocks)
      tops = NatCmmDecl RawCmmStatics Instr
proc NatCmmDecl RawCmmStatics Instr
-> [NatCmmDecl RawCmmStatics Instr]
-> [NatCmmDecl RawCmmStatics Instr]
forall a. a -> [a] -> [a]
: [[NatCmmDecl RawCmmStatics Instr]]
-> [NatCmmDecl RawCmmStatics Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NatCmmDecl RawCmmStatics Instr]]
statics

  pure tops

-- ... 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 -> BlockId
forall (x :: Extensibility). Block CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel Block CmmNode C C
block
      stmts = Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
nodes

      header_comment_instr
        | Bool
debugIsOn =
            Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL
              (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ SDoc -> Instr
MULTILINE_COMMENT
                ( [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"-- --------------------------- basicBlockCodeGen --------------------------- --\n"
                    SDoc -> SDoc -> SDoc
$+$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultDumpStyle (Platform -> Block CmmNode C C -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc (NCGConfig -> Platform
ncgPlatform NCGConfig
config) Block CmmNode C C
block)
                )
        | Bool
otherwise = OrdList Instr
forall a. OrdList a
nilOL

  -- 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 <- BlockId -> NatM (Maybe DebugBlock)
getDebugBlock (Block CmmNode C C -> BlockId
forall (x :: Extensibility). Block CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel Block CmmNode C C
block)
      case dblSourceTick =<< dbg of
        Just (SourceNote RealSrcSpan
span LexicalFastString
name) ->
          do
            fileId <- FastString -> NatM Int
getFileId (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
span)
            let line = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span; col = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
span
            pure $ unitOL $ LOCATION fileId line col name
        Maybe CmmTickish
_ -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OrdList Instr
forall a. OrdList a
nilOL

mkBlocks ::
  Instr ->
  ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) ->
  ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
mkBlocks :: forall h g.
Instr
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
mkBlocks (NEWBLOCK BlockId
id) ([Instr]
instrs, [NatBasicBlock Instr]
blocks, [GenCmmDecl RawCmmStatics h g]
statics) =
  ([], BlockId -> [Instr] -> NatBasicBlock Instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id [Instr]
instrs NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
blocks, [GenCmmDecl RawCmmStatics h g]
statics)
mkBlocks (LDATA Section
sec RawCmmStatics
dat) ([Instr]
instrs, [NatBasicBlock Instr]
blocks, [GenCmmDecl RawCmmStatics h g]
statics) =
  ([Instr]
instrs, [NatBasicBlock Instr]
blocks, Section -> RawCmmStatics -> GenCmmDecl RawCmmStatics h g
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec RawCmmStatics
dat GenCmmDecl RawCmmStatics h g
-> [GenCmmDecl RawCmmStatics h g] -> [GenCmmDecl RawCmmStatics h g]
forall a. a -> [a] -> [a]
: [GenCmmDecl RawCmmStatics h g]
statics)
mkBlocks Instr
instr ([Instr]
instrs, [NatBasicBlock Instr]
blocks, [GenCmmDecl RawCmmStatics h g]
statics) =
  (Instr
instr Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
instrs, [NatBasicBlock Instr]
blocks, [GenCmmDecl RawCmmStatics h g]
statics)

-- -----------------------------------------------------------------------------

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

-- Note [RISCV64 Jump Tables]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Jump tables are implemented by generating a table of relative addresses,
-- where each entry is the relative offset to the target block from the first
-- entry / table label (`generateJumpTableForInstr`). Using the jump table means
-- loading the entry's value and jumping to the calculated absolute address
-- (`genSwitch`).
--
-- For example, this Cmm switch
--
--   switch [1 .. 10] _s2wn::I64 {
--       case 1 : goto c347;
--       case 2 : goto c348;
--       case 3 : goto c349;
--       case 4 : goto c34a;
--       case 5 : goto c34b;
--       case 6 : goto c34c;
--       case 7 : goto c34d;
--       case 8 : goto c34e;
--       case 9 : goto c34f;
--       case 10 : goto c34g;
--   }   // CmmSwitch
--
-- leads to this jump table in Assembly
--
--   .section .rodata
--           .balign 8
--   .Ln34G:
--           .quad   0
--           .quad   .Lc347-(.Ln34G)+0
--           .quad   .Lc348-(.Ln34G)+0
--           .quad   .Lc349-(.Ln34G)+0
--           .quad   .Lc34a-(.Ln34G)+0
--           .quad   .Lc34b-(.Ln34G)+0
--           .quad   .Lc34c-(.Ln34G)+0
--           .quad   .Lc34d-(.Ln34G)+0
--           .quad   .Lc34e-(.Ln34G)+0
--           .quad   .Lc34f-(.Ln34G)+0
--           .quad   .Lc34g-(.Ln34G)+0
--
-- and this indexing code where the jump should be done (register t0 contains
-- the index)
--
--           addi t0, t0, 0 // silly move (ignore it)
--           la t1, .Ln34G // load the table's address
--           sll t0, t0, 3 // index * 8 -> offset in bytes
--           add t0, t0, t1 // address of the table's entry
--           ld t0, 0(t0) // load entry
--           add t0, t0, t1 // relative to absolute address
--           jalr zero, t0, 0 // jump to the block
--
-- In object code (disassembled) the table looks like
--
--   0000000000000000 <.Ln34G>:
--        ...
--        8: R_RISCV_ADD64        .Lc347
--        8: R_RISCV_SUB64        .Ln34G
--        10: R_RISCV_ADD64       .Lc348
--        10: R_RISCV_SUB64       .Ln34G
--        18: R_RISCV_ADD64       .Lc349
--        18: R_RISCV_SUB64       .Ln34G
--        20: R_RISCV_ADD64       .Lc34a
--        20: R_RISCV_SUB64       .Ln34G
--        28: R_RISCV_ADD64       .Lc34b
--        28: R_RISCV_SUB64       .Ln34G
--        30: R_RISCV_ADD64       .Lc34c
--        30: R_RISCV_SUB64       .Ln34G
--        38: R_RISCV_ADD64       .Lc34d
--        38: R_RISCV_SUB64       .Ln34G
--        40: R_RISCV_ADD64       .Lc34e
--        40: R_RISCV_SUB64       .Ln34G
--        48: R_RISCV_ADD64       .Lc34f
--        48: R_RISCV_SUB64       .Ln34G
--        50: R_RISCV_ADD64       .Lc34g
--        50: R_RISCV_SUB64       .Ln34G
--
-- I.e. the relative offset calculations are done by the linker via relocations.
-- This seems to be PIC compatible; at least `scanelf` (pax-utils) does not
-- complain.


-- | Generate jump to jump table target
--
-- The index into the jump table is calulated by evaluating @expr@. The
-- corresponding table entry contains the relative address to jump to (relative
-- to the jump table's first entry / the table's own label).
genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM (OrdList Instr)
genSwitch NCGConfig
config CmmExpr
expr SwitchTargets
targets = do
  (reg, fmt1, e_code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
indexExpr
  let fmt = Format
II64
  targetReg <- getNewRegNat fmt
  lbl <- getNewLabelNat
  dynRef <- cmmMakeDynamicReference config DataReference lbl
  (tableReg, fmt2, t_code) <- getSomeReg dynRef
  let code =
        [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
          [ SDoc -> Instr
COMMENT ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"indexExpr" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc) -> (CmmExpr -> [Char]) -> CmmExpr -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmExpr -> [Char]
forall a. Show a => a -> [Char]
show) CmmExpr
indexExpr),
            SDoc -> Instr
COMMENT ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"dynRef" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc) -> (CmmExpr -> [Char]) -> CmmExpr -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmExpr -> [Char]
forall a. Show a => a -> [Char]
show) CmmExpr
dynRef)
          ]
          OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
e_code
          OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
t_code
          OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
            [ SDoc -> Instr
COMMENT (FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
"Jump table for switch"),
              -- index to offset into the table (relative to tableReg)
              CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
fmt1) Reg
reg) (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
fmt1) Reg
reg) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
3))),
              -- calculate table entry address
              Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
W64 Reg
targetReg) (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
fmt1) Reg
reg) (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
fmt2) Reg
tableReg),
              -- load table entry (relative offset from tableReg (first entry) to target label)
              Format -> Operand -> Operand -> Instr
LDRU Format
II64 (Width -> Reg -> Operand
OpReg Width
W64 Reg
targetReg) (AddrMode -> Operand
OpAddr (Reg -> Imm -> AddrMode
AddrRegImm Reg
targetReg (Int -> Imm
ImmInt Int
0))),
              -- 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 BlockId] -> Maybe CLabel -> Reg -> Instr
J_TBL [Maybe BlockId]
ids (CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
lbl) Reg
targetReg
            ]
  return code
  where
    -- See Note [Sub-word subtlety during jump-table indexing] in
    -- GHC.CmmToAsm.X86.CodeGen for why we must first offset, then widen.
    indexExpr0 :: CmmExpr
indexExpr0 = Platform -> CmmExpr -> Int -> CmmExpr
cmmOffset Platform
platform CmmExpr
expr Int
offset
    -- We widen to a native-width register to sanitize the high bits
    indexExpr :: CmmExpr
indexExpr =
      MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp
        (Width -> Width -> MachOp
MO_UU_Conv Width
expr_w (Platform -> Width
platformWordWidth Platform
platform))
        [CmmExpr
indexExpr0]
    expr_w :: Width
expr_w = Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
expr
    (Int
offset, [Maybe BlockId]
ids) = SwitchTargets -> (Int, [Maybe BlockId])
switchTargetsToTable SwitchTargets
targets
    platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config

-- | Generate jump table data (if required)
--
-- The idea is to emit one table entry per case. The entry is the relative
-- address of the block to jump to (relative to the table's first entry /
-- table's own label.) The calculation itself is done by the linker.
generateJumpTableForInstr ::
  NCGConfig ->
  Instr ->
  Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr NCGConfig
config (J_TBL [Maybe BlockId]
ids (Just CLabel
lbl) Reg
_) =
  let jumpTable :: [CmmStatic]
jumpTable =
        (Maybe BlockId -> CmmStatic) -> [Maybe BlockId] -> [CmmStatic]
forall a b. (a -> b) -> [a] -> [b]
map Maybe BlockId -> CmmStatic
jumpTableEntryRel [Maybe BlockId]
ids
        where
          jumpTableEntryRel :: Maybe BlockId -> CmmStatic
jumpTableEntryRel Maybe BlockId
Nothing =
            CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
0 (NCGConfig -> Width
ncgWordWidth NCGConfig
config))
          jumpTableEntryRel (Just BlockId
blockid) =
            CmmLit -> CmmStatic
CmmStaticLit
              ( CLabel -> CLabel -> Int -> Width -> CmmLit
CmmLabelDiffOff
                  CLabel
blockLabel
                  CLabel
lbl
                  Int
0
                  (NCGConfig -> Width
ncgWordWidth NCGConfig
config)
              )
            where
              blockLabel :: CLabel
blockLabel = BlockId -> CLabel
blockLbl BlockId
blockid
   in NatCmmDecl RawCmmStatics Instr
-> Maybe (NatCmmDecl RawCmmStatics Instr)
forall a. a -> Maybe a
Just (Section -> RawCmmStatics -> NatCmmDecl RawCmmStatics Instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) (CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl [CmmStatic]
jumpTable))
generateJumpTableForInstr NCGConfig
_ Instr
_ = Maybe (NatCmmDecl RawCmmStatics Instr)
forall a. Maybe a
Nothing

-- -----------------------------------------------------------------------------
-- 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 (f :: * -> *) a. Applicative f => a -> f a
pure (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (SDoc -> Instr
COMMENT (FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
s)))
    CmmTick {} -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OrdList Instr
forall a. OrdList a
nilOL
    CmmAssign CmmReg
reg CmmExpr
src
      | CmmType -> Bool
isFloatType CmmType
ty -> Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_FltCode Format
format CmmReg
reg CmmExpr
src
      | Bool
otherwise -> Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_IntCode Format
format CmmReg
reg CmmExpr
src
      where
        ty :: CmmType
ty = CmmReg -> CmmType
cmmRegType CmmReg
reg
        format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty
    CmmStore CmmExpr
addr CmmExpr
src AlignmentSpec
_alignment
      | CmmType -> Bool
isFloatType CmmType
ty -> Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_FltCode Format
format CmmExpr
addr CmmExpr
src
      | Bool
otherwise -> Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_IntCode Format
format CmmExpr
addr CmmExpr
src
      where
        ty :: CmmType
ty = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
src
        format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty
    CmmBranch BlockId
id -> BlockId -> NatM (OrdList Instr)
genBranch BlockId
id
    -- 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 BlockId
true BlockId
false Maybe Bool
_prediction ->
      BlockId -> BlockId -> CmmExpr -> NatM (OrdList Instr)
genCondBranch BlockId
true BlockId
false CmmExpr
arg
    CmmSwitch CmmExpr
arg SwitchTargets
ids -> NCGConfig -> CmmExpr -> SwitchTargets -> NatM (OrdList Instr)
genSwitch NCGConfig
config CmmExpr
arg SwitchTargets
ids
    CmmCall {cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmExpr
arg} -> CmmExpr -> NatM (OrdList Instr)
genJump CmmExpr
arg
    CmmUnwind [(GlobalReg, Maybe CmmExpr)]
_regs -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OrdList Instr
forall a. OrdList a
nilOL
    -- Intentionally not have a default case here: If anybody adds a
    -- constructor, the compiler should force them to think about this here.
    CmmForeignCall {} -> [Char] -> SDoc -> NatM (OrdList Instr)
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"stmtToInstrs: statement should have been cps'd away" (Platform -> CmmNode e x -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmNode e x
stmt)
    CmmEntry {} -> [Char] -> SDoc -> NatM (OrdList Instr)
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"stmtToInstrs: statement should have been cps'd away" (Platform -> CmmNode e x -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmNode e x
stmt)

--------------------------------------------------------------------------------

-- | '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
_format Reg
reg OrdList Instr
code) = Format -> Reg -> OrdList Instr -> Register
Fixed Format
format' Reg
reg OrdList Instr
code
swizzleRegisterRep Format
format' (Any Format
_format Reg -> OrdList Instr
codefn) = Format -> (Reg -> OrdList Instr) -> Register
Any Format
format' Reg -> OrdList Instr
codefn

-- | Grab a `Reg` for a `CmmReg`
--
-- `LocalReg`s are assigned virtual registers (`RegVirtual`), `GlobalReg`s are
-- assigned real registers (`RegReal`). It is an error if a `GlobalReg` is not a
-- STG register.
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
      newReg <- Format -> NatM Reg
getNewRegNat Format
rep
      return (newReg, rep, code newReg)
    Fixed Format
rep Reg
reg OrdList Instr
code ->
      (Reg, Format, OrdList Instr) -> NatM (Reg, Format, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg, Format
rep, OrdList Instr
code)

-- | Compute an expression into any 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
      newReg <- Format -> NatM Reg
getNewRegNat Format
rep
      return (newReg, rep, code newReg)
    Any Format
II32 Reg -> OrdList Instr
code -> do
      newReg <- Format -> NatM Reg
getNewRegNat Format
FF32
      return (newReg, FF32, code newReg)
    Any Format
II64 Reg -> OrdList Instr
code -> do
      newReg <- Format -> NatM Reg
getNewRegNat Format
FF64
      return (newReg, FF64, code newReg)
    Any Format
_w Reg -> OrdList Instr
_code -> do
      config <- NatM NCGConfig
getConfig
      pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr)
    -- 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`
--
-- N.B. this is a partial function, because not all `CmmLit`s have an immediate
-- representation.
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

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

-- | The register width to be used for an operation on the given width
-- operand.
opRegWidth :: Width -> Width
opRegWidth :: Width -> Width
opRegWidth Width
W64 = Width
W64
opRegWidth Width
W32 = Width
W32
opRegWidth Width
W16 = Width
W32
opRegWidth Width
W8 = Width
W32
opRegWidth Width
w = [Char] -> SDoc -> Width
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"opRegWidth" ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Unsupported width" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w)

-- Note [Signed arithmetic on RISCV64]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Handling signed arithmetic on sub-word-size values on RISCV64 is a bit
-- tricky as Cmm's type system does not capture signedness. While 32-bit values
-- are fairly easy to handle due to RISCV64's 32-bit instruction variants
-- (denoted by use of %wN registers), 16- and 8-bit values require quite some
-- care.
--
-- We handle 16-and 8-bit values by using the 32-bit operations and
-- sign-/zero-extending operands and 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.
--
-- For instance, consider the program,
--
--    test(bits64 buffer)
--      bits8 a = bits8[buffer];
--      bits8 b = %mul(a, 42);
--      bits8 c = %not(b);
--      bits8 d = %shrl(c, 4::bits8);
--      return (d);
--    }
--
-- This program begins by loading `a` from memory, for which we use a
-- zero-extended byte-size load.  We next sign-extend `a` to 32-bits, and use a
-- 32-bit multiplication to compute `b`, and truncate the result back down to
-- 8-bits.
--
-- Next we compute `c`: The `%not` requires no extension of its operands, but
-- we must still truncate the result back down to 8-bits. Finally the `%shrl`
-- requires no extension and no truncate since we can assume that
-- `c` is zero-extended.
--
-- The "RISC-V Sign Extension Optimizations" LLVM tech talk presentation by
-- Craig Topper covers possible future improvements
-- (https://llvm.org/devmtg/2022-11/slides/TechTalk21-RISC-VSignExtensionOptimizations.pdf)
--
--
-- Note [Handling PIC on RV64]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- RV64 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.
--
-- rv64 assembly has a `la` (load address) pseudo-instruction, that allows
-- loading a label's address into a register. The instruction is desugared into
-- different addressing modes, e.g. PC-relative addressing:
--
-- 1: lui  rd1, %pcrel_hi(label)
--    addi rd1, %pcrel_lo(1b)
--
-- See https://sourceware.org/binutils/docs/as/RISC_002dV_002dModifiers.html,
-- PIC can be enabled/disabled through
--
--  .option pic
--
-- See https://sourceware.org/binutils/docs/as/RISC_002dV_002dDirectives.html#RISC_002dV_002dDirectives
--
-- 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 RV64. If
-- we want to distinguish between symbol loading, we need to address this through
-- the way we load it, not through a register.
--

getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
-- OPTIMIZATION WARNING: CmmExpr rewrites
-- 1. Rewrite: Reg + (-n) => Reg - n
--    TODO: this expression shouldn't even be generated to begin with.
getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat (CmmMachOp (MO_Add Width
w0) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
w1)])
  | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 =
      NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Sub Width
w0) [CmmExpr
x, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (-Integer
i) Width
w1)])
getRegister' NCGConfig
config Platform
plat (CmmMachOp (MO_Sub Width
w0) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
w1)])
  | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 =
      NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
w0) [CmmExpr
x, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (-Integer
i) Width
w1)])
-- Generic case.
getRegister' NCGConfig
config Platform
plat CmmExpr
expr =
  case CmmExpr
expr of
    CmmReg (CmmGlobal (GlobalRegUse GlobalReg
PicBaseReg CmmType
_)) ->
      -- See Note [Handling PIC on RV64]
      [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister': There's no PIC base register on RISCV" (GlobalReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr GlobalReg
PicBaseReg)
    CmmLit CmmLit
lit ->
      case CmmLit
lit of
        CmmInt Integer
0 Width
w -> Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> OrdList Instr -> Register
Fixed (Width -> Format
intFormat Width
w) Reg
zeroReg OrdList Instr
forall a. OrdList a
nilOL
        CmmInt Integer
i Width
w ->
          -- 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
           in Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
dst) Operand
imm)))
        CmmFloat Rational
0 Width
w -> do
          let op :: Operand
op = CmmLit -> Operand
litToImm' CmmLit
lit
          Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
w) (\Reg
dst -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
dst) Operand
op)))
        CmmFloat Rational
_f Width
W8 -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmLit:CmmFloat), no support for bytes" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmFloat Rational
_f Width
W16 -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmLit:CmmFloat), no support for halfs" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmFloat Rational
f Width
W32 -> do
          let word :: Word32
word = Float -> Word32
castFloatToWord32 (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
f) :: Word32
          intReg <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
W32)
          return
            ( Any
                (floatFormat W32)
                ( \Reg
dst ->
                    [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                      [ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr
                          (Instr -> Instr) -> Instr -> Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W32 Reg
intReg) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
word))),
                        Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W32 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W32 Reg
intReg)
                      ]
                )
            )
        CmmFloat Rational
f Width
W64 -> do
          let word :: Word64
word = Double -> Word64
castDoubleToWord64 (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
f) :: Word64
          intReg <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
W64)
          return
            ( Any
                (floatFormat W64)
                ( \Reg
dst ->
                    [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                      [ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr
                          (Instr -> Instr) -> Instr -> Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W64 Reg
intReg) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger (Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
word))),
                        Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
intReg)
                      ]
                )
            )
        CmmFloat Rational
_f Width
_w -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmLit:CmmFloat), unsupported float lit" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmVec [CmmLit]
_lits -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmLit:CmmVec): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmLabel CLabel
lbl -> do
          let op :: Operand
op = Imm -> Operand
OpImm (CLabel -> Imm
ImmCLbl CLabel
lbl)
              rep :: CmmType
rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
plat CmmLit
lit
              format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
rep
          Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format (\Reg
dst -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Format -> Operand -> Operand -> Instr
LDR Format
format (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) Reg
dst) Operand
op)))
        CmmLabelOff CLabel
lbl Int
off | Int -> Integer -> Bool
isNbitEncodeable Int
12 (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) -> do
          let op :: Operand
op = Imm -> Operand
OpImm (CLabel -> Int -> Imm
ImmIndex CLabel
lbl Int
off)
              rep :: CmmType
rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
plat CmmLit
lit
              format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
rep
          Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format (\Reg
dst -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Operand -> Operand -> Instr
LDR Format
format (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) Reg
dst) Operand
op))
        CmmLabelOff CLabel
lbl Int
off -> do
          let op :: Operand
op = CmmLit -> Operand
litToImm' (CLabel -> CmmLit
CmmLabel CLabel
lbl)
              rep :: CmmType
rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
plat CmmLit
lit
              format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
rep
              width :: Width
width = CmmType -> Width
typeWidth CmmType
rep
          (off_r, _off_format, off_code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg (CmmExpr -> NatM (Reg, Format, OrdList Instr))
-> CmmExpr -> NatM (Reg, Format, OrdList Instr)
forall a b. (a -> b) -> a -> b
$ CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
width)
          return
            ( Any
                format
                ( \Reg
dst ->
                    OrdList Instr
off_code
                      OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Operand -> Operand -> Instr
LDR Format
format (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) Reg
dst) Operand
op
                      OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
width Reg
dst) (Width -> Reg -> Operand
OpReg Width
width Reg
dst) (Width -> Reg -> Operand
OpReg Width
width Reg
off_r)
                )
            )
        CmmLabelDiffOff {} -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmLit:CmmLabelOff): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmBlock BlockId
_ -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmLit:CmmLabelOff): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmLit
CmmHighStackMark -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmLit:CmmLabelOff): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
    CmmLoad CmmExpr
mem CmmType
rep AlignmentSpec
_ -> do
      let format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
rep
          width :: Width
width = CmmType -> Width
typeWidth CmmType
rep
      Amode addr addr_code <- Platform -> Width -> CmmExpr -> NatM Amode
getAmode Platform
plat Width
width CmmExpr
mem
      case width of
        Width
w
          | Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
<= Width
W64 ->
              -- Load without sign-extension. See Note [Signed arithmetic on RISCV64]
              Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                ( Format -> (Reg -> OrdList Instr) -> Register
Any
                    Format
format
                    ( \Reg
dst ->
                        OrdList Instr
addr_code
                          OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Operand -> Operand -> Instr
LDRU Format
format (Width -> Reg -> Operand
OpReg Width
width Reg
dst) (AddrMode -> Operand
OpAddr AddrMode
addr)
                    )
                )
        Width
_ ->
          [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic ([Char]
"Width too big! Cannot load: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Width -> [Char]
forall a. Show a => a -> [Char]
show Width
width) (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
    CmmStackSlot Area
_ Int
_ ->
      [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (CmmStackSlot): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
    CmmReg CmmReg
reg ->
      Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ( Format -> Reg -> OrdList Instr -> Register
Fixed
            (CmmType -> Format
cmmTypeFormat (CmmReg -> CmmType
cmmRegType CmmReg
reg))
            (Platform -> CmmReg -> Reg
getRegisterReg Platform
plat CmmReg
reg)
            OrdList Instr
forall a. OrdList a
nilOL
        )
    CmmRegOff CmmReg
reg Int
off | Int -> Integer -> Bool
isNbitEncodeable Int
12 (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) -> do
      NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat
        (CmmExpr -> NatM Register) -> CmmExpr -> NatM Register
forall a b. (a -> b) -> a -> b
$ MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
width) [CmmReg -> CmmExpr
CmmReg CmmReg
reg, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
width)]
      where
        width :: Width
width = CmmType -> Width
typeWidth (CmmReg -> CmmType
cmmRegType CmmReg
reg)
    CmmRegOff CmmReg
reg Int
off -> do
      (off_r, _off_format, off_code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg (CmmExpr -> NatM (Reg, Format, OrdList Instr))
-> CmmExpr -> NatM (Reg, Format, OrdList Instr)
forall a b. (a -> b) -> a -> b
$ CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
width)
      (reg, _format, code) <- getSomeReg $ CmmReg reg
      return
        $ Any
          (intFormat width)
          ( \Reg
dst ->
              OrdList Instr
off_code
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code
                OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
width Reg
dst) (Width -> Reg -> Operand
OpReg Width
width Reg
reg) (Width -> Reg -> Operand
OpReg Width
width Reg
off_r)
          )
      where
        width :: Width
width = CmmType -> Width
typeWidth (CmmReg -> CmmType
cmmRegType CmmReg
reg)

    -- 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 ->
          let w' :: Width
w' = Width -> Width
opRegWidth Width
w
           in OrdList Instr
code
                OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                -- pseudo instruction `not` is `xori rd, rs, -1`
                SDoc -> Instr -> Instr
ann ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"not") (Operand -> Operand -> Operand -> Instr
XORI (Width -> Reg -> Operand
OpReg Width
w' Reg
dst) (Width -> Reg -> Operand
OpReg Width
w' Reg
reg) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (-Int
1))))
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
w' Width
w Reg
dst -- See Note [Signed arithmetic on RISCV64]
        MO_S_Neg Width
w -> OrdList Instr -> Width -> Reg -> NatM Register
negate OrdList Instr
code Width
w Reg
reg
        MO_F_Neg Width
w ->
          Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any
              (Width -> Format
floatFormat Width
w)
              ( \Reg
dst ->
                  OrdList Instr
code
                    OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
NEG (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg)
              )
        -- TODO: Can this case happen?
        MO_SF_Round Width
from Width
to | Width
from Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
W32 -> do
          -- extend to the smallest available representation
          (reg_x, code_x) <- Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
signExtendReg Width
from Width
W32 Reg
reg
          pure
            $ Any
              (floatFormat to)
              ( \Reg
dst ->
                  OrdList Instr
code
                    OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_x
                    OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (FcvtVariant -> Operand -> Operand -> Instr
FCVT FcvtVariant
IntToFloat (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg_x)) -- (Signed ConVerT Float)
              )
        MO_SF_Round Width
from Width
to ->
          Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any
              (Width -> Format
floatFormat Width
to)
              ( \Reg
dst ->
                  OrdList Instr
code
                    OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (FcvtVariant -> Operand -> Operand -> Instr
FCVT FcvtVariant
IntToFloat (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg)) -- (Signed ConVerT Float)
              )
        -- TODO: Can this case happen?
        MO_FS_Truncate Width
from Width
to
          | Width
to Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
W32 ->
              Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any
                  (Width -> Format
intFormat Width
to)
                  ( \Reg
dst ->
                      OrdList Instr
code
                        OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                        -- W32 is the smallest width to convert to. Decrease width afterwards.
                        CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (FcvtVariant -> Operand -> Operand -> Instr
FCVT FcvtVariant
FloatToInt (Width -> Reg -> Operand
OpReg Width
W32 Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))
                        OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtendAdjustPrecission Width
W32 Width
to Reg
dst Reg
dst -- (float convert (-> zero) signed)
                  )
        MO_FS_Truncate Width
from Width
to ->
          Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any
              (Width -> Format
intFormat Width
to)
              ( \Reg
dst ->
                  OrdList Instr
code
                    OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (FcvtVariant -> Operand -> Operand -> Instr
FCVT FcvtVariant
FloatToInt (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))
                    OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
from Width
to Reg
dst -- (float convert (-> zero) signed)
              )
        MO_UU_Conv Width
from Width
to
          | Width
from Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
<= Width
to ->
              Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any
                  (Width -> Format
intFormat Width
to)
                  ( \Reg
dst ->
                      OrdList Instr
code
                        OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
e (Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))
                  )
        MO_UU_Conv Width
from Width
to ->
          Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any
              (Width -> Format
intFormat Width
to)
              ( \Reg
dst ->
                  OrdList Instr
code
                    OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
e (Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
from Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))
                    OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
from Width
to Reg
dst
              )
        MO_SS_Conv Width
from Width
to -> Width -> Width -> Reg -> OrdList Instr -> NatM Register
forall {f :: * -> *}.
Applicative f =>
Width -> Width -> Reg -> OrdList Instr -> f Register
ss_conv Width
from Width
to Reg
reg OrdList Instr
code
        MO_FF_Conv Width
from Width
to -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
to) (\Reg
dst -> OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
e (FcvtVariant -> Operand -> Operand -> Instr
FCVT FcvtVariant
FloatToFloat (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg)))
        MO_WF_Bitcast Width
w    -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
w)  (\Reg
dst -> OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg))
        MO_FW_Bitcast Width
w    -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w)    (\Reg
dst -> OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg))

        -- Conversions
        -- TODO: Duplication with MO_UU_Conv
        MO_XX_Conv Width
from Width
to
          | Width
to Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
from ->
              Register -> NatM Register
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any
                  (Width -> Format
intFormat Width
to)
                  ( \Reg
dst ->
                      OrdList Instr
code
                        OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
e (Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
from Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))
                        OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
from Width
to Reg
dst
                  )
        MO_XX_Conv Width
_from Width
to -> Format -> Register -> Register
swizzleRegisterRep (Width -> Format
intFormat Width
to) (Register -> Register) -> NatM Register -> NatM Register
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmExpr -> NatM Register
getRegister CmmExpr
e
        MO_AlignmentCheck Int
align Width
wordWidth -> do
          reg <- NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat CmmExpr
e
          addAlignmentCheck align wordWidth reg
        MachOp
x -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic ([Char]
"getRegister' (monadic CmmMachOp): " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ MachOp -> [Char]
forall a. Show a => a -> [Char]
show MachOp
x) (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
      where
        -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits
        -- See Note [Signed arithmetic on RISCV64].
        negate :: OrdList Instr -> Width -> Reg -> NatM Register
negate OrdList Instr
code Width
w Reg
reg = do
          let w' :: Width
w' = Width -> Width
opRegWidth Width
w
          (reg', code_sx) <- Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
signExtendReg Width
w Width
w' Reg
reg
          return $ Any (intFormat w) $ \Reg
dst ->
            OrdList Instr
code
              OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_sx
              OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
NEG (Width -> Reg -> Operand
OpReg Width
w' Reg
dst) (Width -> Reg -> Operand
OpReg Width
w' Reg
reg')
              OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
w' Width
w Reg
dst

        ss_conv :: Width -> Width -> Reg -> OrdList Instr -> f Register
ss_conv Width
from Width
to Reg
reg OrdList Instr
code
          | Width
from Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
to = do
              Register -> f Register
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Register -> f Register) -> Register -> f Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) ((Reg -> OrdList Instr) -> Register)
-> (Reg -> OrdList Instr) -> Register
forall a b. (a -> b) -> a -> b
$ \Reg
dst ->
                OrdList Instr
code
                  OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend Width
from Width
to Reg
reg Reg
dst
                  OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
from Width
to Reg
dst
          | Width
from Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
to =
              Register -> f Register
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Register -> f Register) -> Register -> f Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) ((Reg -> OrdList Instr) -> Register)
-> (Reg -> OrdList Instr) -> Register
forall a b. (a -> b) -> a -> b
$ \Reg
dst ->
                OrdList Instr
code
                  OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                    [ SDoc -> Instr -> Instr
ann
                        ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"MO_SS_Conv: narrow register signed" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
reg SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
from SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
to)
                        (Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))),
                      -- signed right shift
                      Operand -> Operand -> Operand -> Instr
SRA (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))
                    ]
                  OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
from Width
to Reg
dst
          | Bool
otherwise =
              -- No conversion necessary: Just copy.
              Register -> f Register
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Register -> f Register) -> Register -> f Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
from) ((Reg -> OrdList Instr) -> Register)
-> (Reg -> OrdList Instr) -> Register
forall a b. (a -> b) -> a -> b
$ \Reg
dst ->
                OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
from Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg)
          where
            shift :: Int
shift = Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Width -> Int
widthInBits Width
from Int -> Int -> Int
forall a. Num a => a -> a -> a
- Width -> Int
widthInBits Width
to)

    -- 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'
    -- 1. Compute Reg +/- n directly.
    --    For Add/Sub we can directly encode 12bits, or 12bits lsl #12.
    CmmMachOp (MO_Add Width
w) [CmmReg CmmReg
reg, CmmLit (CmmInt Integer
n Width
_)]
      | Integer -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm Integer
n -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
w Reg
d) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
      where
        -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.
        w' :: Width
w' = Format -> Width
formatToWidth (CmmType -> Format
cmmTypeFormat (CmmReg -> CmmType
cmmRegType CmmReg
reg))
        r' :: Reg
r' = Platform -> CmmReg -> Reg
getRegisterReg Platform
plat CmmReg
reg
    CmmMachOp (MO_Sub Width
w) [CmmReg CmmReg
reg, CmmLit (CmmInt Integer
n Width
_)]
      | Integer -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm Integer
n -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SUB (Width -> Reg -> Operand
OpReg Width
w Reg
d) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
      where
        -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.
        w' :: Width
w' = Format -> Width
formatToWidth (CmmType -> Format
cmmTypeFormat (CmmReg -> CmmType
cmmRegType CmmReg
reg))
        r' :: Reg
r' = Platform -> CmmReg -> Reg
getRegisterReg Platform
plat CmmReg
reg
    CmmMachOp (MO_U_Quot Width
w) [CmmExpr
x, CmmExpr
y] | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 Bool -> Bool -> Bool
|| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W16 -> do
      (reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      (reg_y, format_y, code_y) <- getSomeReg y
      return
        $ Any
          (intFormat w)
          ( \Reg
dst ->
              OrdList Instr
code_x
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg (Format -> Width
formatToWidth Format
format_x) Width
w Reg
reg_x
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg (Format -> Width
formatToWidth Format
format_y) Width
w Reg
reg_y
                OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
DIVU (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y))
          )

    -- 2. Shifts. x << n, x >> n.
    CmmMachOp (MO_Shl Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
      | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32,
        Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n,
        Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
32 -> do
          (reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
          return
            $ Any
              (intFormat w)
              ( \Reg
dst ->
                  OrdList Instr
code_x
                    OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n)))
                    OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
w Width
w Reg
dst
              )
    CmmMachOp (MO_Shl Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
      | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64,
        Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n,
        Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
64 -> do
          (reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
          return
            $ Any
              (intFormat w)
              ( \Reg
dst ->
                  OrdList Instr
code_x
                    OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n)))
                    OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
w Width
w Reg
dst
              )
    CmmMachOp (MO_S_Shr Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)] | Integer -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm Integer
n -> do
      (reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      (reg_x', code_x') <- signExtendReg (formatToWidth format_x) w reg_x
      return
        $ Any
          (intFormat w)
          ( \Reg
dst ->
              OrdList Instr
code_x
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_x'
                OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRA (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n)))
          )
    CmmMachOp (MO_S_Shr Width
w) [CmmExpr
x, CmmExpr
y] -> do
      (reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      (reg_y, _format_y, code_y) <- getSomeReg y
      (reg_x', code_x') <- signExtendReg (formatToWidth format_x) w reg_x
      return
        $ Any
          (intFormat w)
          ( \Reg
dst ->
              OrdList Instr
code_x
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_x'
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y
                OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRA (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x') (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y))
          )
    CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
      | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8,
        Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n,
        Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
8 -> do
          (reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
          return
            $ Any
              (intFormat w)
              ( \Reg
dst ->
                  OrdList Instr
code_x
                    OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg (Format -> Width
formatToWidth Format
format_x) Width
w Reg
reg_x
                    OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n)))
              )
    CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
      | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W16,
        Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n,
        Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
16 -> do
          (reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
          return
            $ Any
              (intFormat w)
              ( \Reg
dst ->
                  OrdList Instr
code_x
                    OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg (Format -> Width
formatToWidth Format
format_x) Width
w Reg
reg_x
                    OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n)))
              )
    CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, CmmExpr
y] | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 Bool -> Bool -> Bool
|| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W16 -> do
      (reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      (reg_y, _format_y, code_y) <- getSomeReg y
      return
        $ Any
          (intFormat w)
          ( \Reg
dst ->
              OrdList Instr
code_x
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg (Format -> Width
formatToWidth Format
format_x) Width
w Reg
reg_x
                OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y))
          )
    CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
      | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32,
        Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n,
        Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
32 -> do
          (reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
          return
            $ Any
              (intFormat w)
              ( \Reg
dst ->
                  OrdList Instr
code_x
                    OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n)))
              )
    CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
n Width
_)]
      | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64,
        Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n,
        Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
64 -> do
          (reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
          return
            $ Any
              (intFormat w)
              ( \Reg
dst ->
                  OrdList Instr
code_x
                    OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n)))
              )

    -- 3. Logic &&, ||
    CmmMachOp (MO_And Width
w) [CmmReg CmmReg
reg, CmmLit (CmmInt Integer
n Width
_)]
      | Integer -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm Integer
n ->
          Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
AND (Width -> Reg -> Operand
OpReg Width
w Reg
d) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
      where
        w' :: Width
w' = Format -> Width
formatToWidth (CmmType -> Format
cmmTypeFormat (CmmReg -> CmmType
cmmRegType CmmReg
reg))
        r' :: Reg
r' = Platform -> CmmReg -> Reg
getRegisterReg Platform
plat CmmReg
reg
    CmmMachOp (MO_Or Width
w) [CmmReg CmmReg
reg, CmmLit (CmmInt Integer
n Width
_)]
      | Integer -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm Integer
n ->
          Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ORI (Width -> Reg -> Operand
OpReg Width
w Reg
d) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
      where
        w' :: Width
w' = Format -> Width
formatToWidth (CmmType -> Format
cmmTypeFormat (CmmReg -> CmmType
cmmRegType CmmReg
reg))
        r' :: Reg
r' = Platform -> CmmReg -> Reg
getRegisterReg Platform
plat CmmReg
reg

    -- Generic binary case.
    CmmMachOp MachOp
op [CmmExpr
x, CmmExpr
y] -> do
      let -- A "plain" operation.
          bitOp :: Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
bitOp Width
w Operand -> Operand -> Operand -> OrdList 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 "bitOp: incompatible"
            return
              $ Any
                (intFormat w)
                ( \Reg
dst ->
                    OrdList Instr
code_x
                      OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y
                      OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y)
                )

          -- A (potentially signed) integer operation.
          -- In the case of 8- and 16-bit signed arithmetic we must first
          -- sign-extend both arguments to 32-bits.
          -- See Note [Signed arithmetic on RISCV64].
          intOp :: Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
is_signed Width
w Operand -> Operand -> Operand -> OrdList 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"
            -- This is the width of the registers on which the operation
            -- should be performed.
            let w' = Width -> Width
opRegWidth Width
w
                signExt Reg
r
                  | Bool -> Bool
not Bool
is_signed = (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
r, OrdList Instr
forall a. OrdList a
nilOL)
                  | Bool
otherwise = Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
signExtendReg Width
w Width
w' Reg
r
            (reg_x_sx, code_x_sx) <- signExt reg_x
            (reg_y_sx, code_y_sx) <- signExt reg_y
            return $ Any (intFormat w) $ \Reg
dst ->
              OrdList Instr
code_x
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                -- sign-extend both operands
                OrdList Instr
code_x_sx
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y_sx
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w' Reg
dst) (Width -> Reg -> Operand
OpReg Width
w' Reg
reg_x_sx) (Width -> Reg -> Operand
OpReg Width
w' Reg
reg_y_sx)
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg Width
w' Width
w Reg
dst -- 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 -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ADD Operand
d Operand
x Operand
y))
        -- TODO: Handle sub-word case
        MO_Sub Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SUB Operand
d Operand
x Operand
y))
        -- N.B. We needn't sign-extend sub-word size (in)equality comparisons
        -- since we don't care about ordering.
        MO_Eq Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
bitOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
EQ))
        MO_Ne Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
bitOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
NE))
        -- Signed multiply/divide
        MO_Mul Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
MUL Operand
d Operand
x Operand
y))
        MO_S_MulMayOflo Width
w -> Width -> CmmExpr -> CmmExpr -> NatM Register
do_mul_may_oflo Width
w CmmExpr
x CmmExpr
y
        MO_S_Quot Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
DIV Operand
d Operand
x Operand
y))
        MO_S_Rem Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
REM Operand
d Operand
x Operand
y))
        -- Unsigned multiply/divide
        MO_U_Quot Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
DIVU Operand
d Operand
x Operand
y))
        MO_U_Rem Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
REMU Operand
d Operand
x Operand
y))
        -- Signed comparisons
        MO_S_Ge Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
SGE))
        MO_S_Le Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
SLE))
        MO_S_Gt Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
SGT))
        MO_S_Lt Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
SLT))
        -- Unsigned comparisons
        MO_U_Ge Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
UGE))
        MO_U_Le Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
ULE))
        MO_U_Gt Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
UGT))
        MO_U_Lt Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
ULT))
        -- 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))
        -- Floating point comparison
        MO_F_Min Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
FMIN Operand
d Operand
x Operand
y))
        MO_F_Max Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
FMAX Operand
d Operand
x Operand
y))
        MO_F_Eq Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
EQ))
        MO_F_Ne Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
NE))
        MO_F_Ge Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
FGE))
        MO_F_Le Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
FLE)) -- x <= y <=> y > x
        MO_F_Gt Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
FGT))
        MO_F_Lt Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Cond -> Instr
CSET Operand
d Operand
x Operand
y Cond
FLT)) -- x < y <=> y >= x

        -- Bitwise operations
        MO_And Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
bitOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
AND Operand
d Operand
x Operand
y))
        MO_Or Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
bitOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
OR Operand
d Operand
x Operand
y))
        MO_Xor Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
bitOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
XOR Operand
d Operand
x Operand
y))
        MO_Shl Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SLL Operand
d Operand
x Operand
y))
        MO_U_Shr Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRL Operand
d Operand
x Operand
y))
        MO_S_Shr Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SRA Operand
d Operand
x Operand
y))
        MachOp
op -> [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (unhandled dyadic CmmMachOp): " (SDoc -> NatM Register) -> SDoc -> NatM Register
forall a b. (a -> b) -> a -> b
$ MachOp -> SDoc
pprMachOp MachOp
op SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr

    -- Generic ternary case.
    CmmMachOp MachOp
op [CmmExpr
x, CmmExpr
y, CmmExpr
z] ->
      case MachOp
op of
        -- Floating-point fused multiply-add operations
        --
        -- x86 fmadd    x * y + z <=> RISCV64 fmadd : d =   r1 * r2 + r3
        -- x86 fmsub    x * y - z <=> RISCV64 fnmsub: d =   r1 * r2 - r3
        -- x86 fnmadd - x * y + z <=> RISCV64 fmsub : d = - r1 * r2 + r3
        -- x86 fnmsub - x * y - z <=> RISCV64 fnmadd: d = - r1 * r2 - r3
        MO_FMA FMASign
var Int
l Width
w
          | Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
          -> case FMASign
var of
                FMASign
FMAdd -> Width
-> (Operand -> Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
float3Op Width
w (\Operand
d Operand
n Operand
m Operand
a -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ FMASign -> Operand -> Operand -> Operand -> Operand -> Instr
FMA FMASign
FMAdd Operand
d Operand
n Operand
m Operand
a)
                FMASign
FMSub -> Width
-> (Operand -> Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
float3Op Width
w (\Operand
d Operand
n Operand
m Operand
a -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ FMASign -> Operand -> Operand -> Operand -> Operand -> Instr
FMA FMASign
FMSub Operand
d Operand
n Operand
m Operand
a)
                FMASign
FNMAdd -> Width
-> (Operand -> Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
float3Op Width
w (\Operand
d Operand
n Operand
m Operand
a -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ FMASign -> Operand -> Operand -> Operand -> Operand -> Instr
FMA FMASign
FNMSub Operand
d Operand
n Operand
m Operand
a)
                FMASign
FNMSub -> Width
-> (Operand -> Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
float3Op Width
w (\Operand
d Operand
n Operand
m Operand
a -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ FMASign -> Operand -> Operand -> Operand -> Operand -> Instr
FMA FMASign
FNMAdd Operand
d Operand
n Operand
m Operand
a)
          | Bool
otherwise
          -> [Char] -> NatM Register
forall a. HasCallStack => [Char] -> a
sorry [Char]
"The RISCV64 backend does not (yet) support vectors."
        MachOp
_ ->
          [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (unhandled ternary CmmMachOp): "
            (SDoc -> NatM Register) -> SDoc -> NatM Register
forall a b. (a -> b) -> a -> b
$ MachOp -> SDoc
pprMachOp MachOp
op
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"in"
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr
      where
        float3Op :: Width
-> (Operand -> Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
float3Op Width
w Operand -> Operand -> Operand -> Operand -> OrdList Instr
op = do
          (reg_fx, format_x, code_fx) <- HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
x
          (reg_fy, format_y, code_fy) <- getFloatReg y
          (reg_fz, format_z, code_fz) <- getFloatReg z
          massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z)
            $ text "float3Op: non-float"
          pure
            $ Any (floatFormat w)
            $ \Reg
dst ->
              OrdList Instr
code_fx
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_fy
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_fz
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fx) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fy) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fz)
    CmmMachOp MachOp
_op [CmmExpr]
_xs ->
      [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"getRegister' (variadic CmmMachOp): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
  where
    isNbitEncodeable :: Int -> Integer -> Bool
    isNbitEncodeable :: Int -> Integer -> Bool
isNbitEncodeable Int
n Integer
i = let shift :: Int
shift = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 in (-Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
shift) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< (Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
shift)
    -- 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
w CmmExpr
_x CmmExpr
_y | Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
W64 = [Char] -> SDoc -> NatM Register
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Cannot multiply larger than 64bit" (Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w)
    do_mul_may_oflo w :: Width
w@Width
W64 CmmExpr
x CmmExpr
y = do
      (reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      (reg_y, format_y, code_y) <- getSomeReg y
      -- TODO: Can't we clobber reg_x and reg_y to save registers?
      lo <- getNewRegNat II64
      hi <- getNewRegNat II64
      -- TODO: Overhaul CSET: 3rd operand isn't needed for SNEZ
      let nonSense = Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)
      pure
        $ Any
          (intFormat w)
          ( \Reg
dst ->
              OrdList Instr
code_x
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_x) Width
W64 Reg
reg_x Reg
reg_x
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_y) Width
W64 Reg
reg_y Reg
reg_y
                OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                  [ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
MULH (Width -> Reg -> Operand
OpReg Width
w Reg
hi) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y)),
                    Operand -> Operand -> Operand -> Instr
MUL (Width -> Reg -> Operand
OpReg Width
w Reg
lo) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y),
                    Operand -> Operand -> Operand -> Instr
SRA (Width -> Reg -> Operand
OpReg Width
w Reg
lo) (Width -> Reg -> Operand
OpReg Width
w Reg
lo) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Width -> Int
widthInBits Width
W64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))),
                    SDoc -> Instr -> Instr
ann
                      ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Set flag if result of MULH contains more than sign bits.")
                      (Operand -> Operand -> Operand -> Instr
XOR (Width -> Reg -> Operand
OpReg Width
w Reg
hi) (Width -> Reg -> Operand
OpReg Width
w Reg
hi) (Width -> Reg -> Operand
OpReg Width
w Reg
lo)),
                    Operand -> Operand -> Operand -> Cond -> Instr
CSET (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
hi) Operand
nonSense Cond
NE
                  ]
          )
    do_mul_may_oflo Width
w CmmExpr
x CmmExpr
y = do
      (reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      (reg_y, format_y, code_y) <- getSomeReg y
      let width_x = Format -> Width
formatToWidth Format
format_x
          width_y = Format -> Width
formatToWidth Format
format_y
      if w > width_x && w > width_y
        then
          pure
            $ Any
              (intFormat w)
              ( \Reg
dst ->
                  -- 8bit * 8bit cannot overflow 16bit
                  -- 16bit * 16bit cannot overflow 32bit
                  -- 32bit * 32bit cannot overflow 64bit
                  Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
w Reg
dst) Operand
zero (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)))
              )
        else do
          let use32BitMul = Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
<= Width
W32 Bool -> Bool -> Bool
&& Width
width_x Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
<= Width
W32 Bool -> Bool -> Bool
&& Width
width_y Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
<= Width
W32
              nonSense = Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)
          if use32BitMul
            then do
              narrowedReg <- getNewRegNat II64
              pure
                $ Any
                  (intFormat w)
                  ( \Reg
dst ->
                      OrdList Instr
code_x
                        OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_x) Width
W32 Reg
reg_x Reg
reg_x
                        OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y
                        OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_y) Width
W32 Reg
reg_y Reg
reg_y
                        OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
MUL (Width -> Reg -> Operand
OpReg Width
W32 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W32 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W32 Reg
reg_y))
                        OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtendAdjustPrecission Width
W32 Width
w Reg
dst Reg
narrowedReg
                        OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                          [ SDoc -> Instr -> Instr
ann
                              ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Check if the multiplied value fits in the narrowed register")
                              (Operand -> Operand -> Operand -> Instr
SUB (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
narrowedReg)),
                            Operand -> Operand -> Operand -> Cond -> Instr
CSET (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
dst) Operand
nonSense Cond
NE
                          ]
                  )
            else
              pure
                $ Any
                  (intFormat w)
                  ( \Reg
dst ->
                      -- Do not handle this unlikely case. Just tell that it may overflow.
                      Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
w Reg
dst) Operand
zero (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
1)))
                  )

-- | Instructions to sign-extend the value in the given register from width @w@
-- up to width @w'@.
signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
signExtendReg Width
w Width
_w' Reg
r | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 = (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reg
r, OrdList Instr
forall a. OrdList a
nilOL)
signExtendReg Width
w Width
w' Reg
r = do
  r' <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
w')
  let instrs = Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend Width
w Width
w' Reg
r Reg
r'
  pure (r', instrs)

-- | Sign extends to 64bit, if needed
--
-- Source `Reg` @r@ stays untouched, while the conversion happens on destination
-- `Reg` @r'@.
signExtend :: Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend :: Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend Width
w Width
w' Reg
_r Reg
_r' | Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
w' = [Char] -> SDoc -> OrdList Instr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"This is not a sign extension, but a truncation." (SDoc -> OrdList Instr) -> SDoc -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w'
signExtend Width
w Width
w' Reg
_r Reg
_r' | Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
W64 Bool -> Bool -> Bool
|| Width
w' Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
W64 = [Char] -> SDoc -> OrdList Instr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Unexpected width (max is 64bit):" (SDoc -> OrdList Instr) -> SDoc -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w'
signExtend Width
w Width
w' Reg
r Reg
r' | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 Bool -> Bool -> Bool
&& Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 Bool -> Bool -> Bool
&& Reg
r Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
r' = OrdList Instr
forall a. OrdList a
nilOL
signExtend Width
w Width
w' Reg
r Reg
r' | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 Bool -> Bool -> Bool
&& Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w Reg
r)
signExtend Width
w Width
w' Reg
r Reg
r'
  | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32 Bool -> Bool -> Bool
&& Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 =
      Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL
        (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ SDoc -> Instr -> Instr
ann
          ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"sign-extend register (SEXT.W)" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w')
          -- `ADDIW r r 0` is the pseudo-op SEXT.W
          (Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)))
signExtend Width
w Width
w' Reg
r Reg
r' =
  [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
    [ SDoc -> Instr -> Instr
ann
        ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"narrow register signed" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w')
        (Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))),
      -- signed (arithmetic) right shift
      Operand -> Operand -> Operand -> Instr
SRA (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))
    ]
  where
    shift :: Int
shift = Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Width -> Int
widthInBits Width
w

-- | Sign extends to 64bit, if needed and reduces the precission to the target `Width` (@w'@)
--
-- Source `Reg` @r@ stays untouched, while the conversion happens on destination
-- `Reg` @r'@.
signExtendAdjustPrecission :: Width -> Width -> Reg -> Reg -> OrdList Instr
signExtendAdjustPrecission :: Width -> Width -> Reg -> Reg -> OrdList Instr
signExtendAdjustPrecission Width
w Width
w' Reg
_r Reg
_r' | Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
W64 Bool -> Bool -> Bool
|| Width
w' Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
W64 = [Char] -> SDoc -> OrdList Instr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Unexpected width (max is 64bit):" (SDoc -> OrdList Instr) -> SDoc -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w'
signExtendAdjustPrecission Width
w Width
w' Reg
r Reg
r' | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 Bool -> Bool -> Bool
&& Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 Bool -> Bool -> Bool
&& Reg
r Reg -> Reg -> Bool
forall a. Eq a => a -> a -> Bool
== Reg
r' = OrdList Instr
forall a. OrdList a
nilOL
signExtendAdjustPrecission Width
w Width
w' Reg
r Reg
r' | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 Bool -> Bool -> Bool
&& Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w Reg
r)
signExtendAdjustPrecission Width
w Width
w' Reg
r Reg
r'
  | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32 Bool -> Bool -> Bool
&& Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 =
      Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL
        (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ SDoc -> Instr -> Instr
ann
          ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"sign-extend register (SEXT.W)" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w')
          -- `ADDIW r r 0` is the pseudo-op SEXT.W
          (Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)))
signExtendAdjustPrecission Width
w Width
w' Reg
r Reg
r'
  | Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
w' =
      [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
        [ SDoc -> Instr -> Instr
ann
            ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"narrow register signed" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w')
            (Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))),
          -- signed (arithmetic) right shift
          Operand -> Operand -> Operand -> Instr
SRA (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))
        ]
  where
    shift :: Int
shift = Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Width -> Int
widthInBits Width
w'
signExtendAdjustPrecission Width
w Width
w' Reg
r Reg
r' =
  [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
    [ SDoc -> Instr -> Instr
ann
        ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"sign extend register" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w')
        (Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))),
      -- signed (arithmetic) right shift
      Operand -> Operand -> Operand -> Instr
SRA (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))
    ]
  where
    shift :: Int
shift = Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Width -> Int
widthInBits Width
w

-- | Instructions to truncate the value in the given register from width @w@
-- to width @w'@.
--
-- In other words, it just cuts the width out of the register. N.B.: This
-- ignores signedness (no sign extension takes place)!
truncateReg :: Width -> Width -> Reg -> OrdList Instr
truncateReg :: Width -> Width -> Reg -> OrdList Instr
truncateReg Width
_w Width
w' Reg
_r | Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 = OrdList Instr
forall a. OrdList a
nilOL
truncateReg Width
_w Width
w' Reg
r | Width
w' Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
W64 = [Char] -> SDoc -> OrdList Instr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Cannot truncate to width bigger than register size (max is 64bit):" (SDoc -> OrdList Instr) -> SDoc -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (Reg -> [Char]
forall a. Show a => a -> [Char]
show Reg
r) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w'
truncateReg Width
w Width
_w' Reg
r | Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
> Width
W64 = [Char] -> SDoc -> OrdList Instr
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Unexpected register size (max is 64bit):" (SDoc -> OrdList Instr) -> SDoc -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (Reg -> [Char]
forall a. Show a => a -> [Char]
show Reg
r) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
':' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w
truncateReg Width
w Width
w' Reg
r =
  [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
    [ SDoc -> Instr -> Instr
ann
        ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"truncate register" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w')
        (Operand -> Operand -> Operand -> Instr
SLL (Width -> Reg -> Operand
OpReg Width
w' Reg
r) (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))),
      -- SHL ignores signedness!
      Operand -> Operand -> Operand -> Instr
SRL (Width -> Reg -> Operand
OpReg Width
w' Reg
r) (Width -> Reg -> Operand
OpReg Width
w Reg
r) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
shift))
    ]
  where
    shift :: Int
shift = Int
64 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Width -> Int
widthInBits Width
w'

-- | Given a 'Register', produce a new 'Register' with an instruction block
-- which will check the value for alignment. Used for @-falignment-sanitisation@.
addAlignmentCheck :: Int -> Width -> Register -> NatM Register
addAlignmentCheck :: Int -> Width -> Register -> NatM Register
addAlignmentCheck Int
align Width
wordWidth Register
reg = do
  jumpReg <- Format -> NatM Reg
getNewRegNat Format
II64
  cmpReg <- getNewRegNat II64
  okayLblId <- getBlockIdNat

  pure $ case reg of
    Fixed Format
fmt Reg
reg OrdList Instr
code -> Format -> Reg -> OrdList Instr -> Register
Fixed Format
fmt Reg
reg (OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Format -> Reg -> Reg -> BlockId -> Reg -> OrdList Instr
check Format
fmt Reg
jumpReg Reg
cmpReg BlockId
okayLblId Reg
reg)
    Any Format
fmt Reg -> OrdList Instr
f -> Format -> (Reg -> OrdList Instr) -> Register
Any Format
fmt (\Reg
reg -> Reg -> OrdList Instr
f Reg
reg OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Format -> Reg -> Reg -> BlockId -> Reg -> OrdList Instr
check Format
fmt Reg
jumpReg Reg
cmpReg BlockId
okayLblId Reg
reg)
  where
    check :: Format -> Reg -> Reg -> BlockId -> Reg -> InstrBlock
    check :: Format -> Reg -> Reg -> BlockId -> Reg -> OrdList Instr
check Format
fmt Reg
jumpReg Reg
cmpReg BlockId
okayLblId Reg
reg =
      let width :: Width
width = Format -> Width
formatToWidth Format
fmt
       in Bool -> OrdList Instr -> OrdList Instr
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Format -> Bool
isFloatFormat Format
fmt)
            (OrdList Instr -> OrdList Instr) -> OrdList Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
              [ SDoc -> Instr -> Instr
ann
                  ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Alignment check - alignment: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
align SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
", word width: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (Width -> [Char]
forall a. Show a => a -> [Char]
show Width
wordWidth))
                  (Operand -> Operand -> Operand -> Instr
AND (Width -> Reg -> Operand
OpReg Width
width Reg
cmpReg) (Width -> Reg -> Operand
OpReg Width
width Reg
reg) (Imm -> Operand
OpImm (Imm -> Operand) -> Imm -> Operand
forall a b. (a -> b) -> a -> b
$ Int -> Imm
ImmInt (Int -> Imm) -> Int -> Imm
forall a b. (a -> b) -> a -> b
$ Int
align Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)),
                Cond -> Operand -> Operand -> Target -> Instr
BCOND Cond
EQ (Width -> Reg -> Operand
OpReg Width
width Reg
cmpReg) Operand
zero (BlockId -> Target
TBlock BlockId
okayLblId),
                SDoc -> Instr
COMMENT ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Alignment check failed"),
                Format -> Operand -> Operand -> Instr
LDR Format
II64 (Width -> Reg -> Operand
OpReg Width
W64 Reg
jumpReg) (Imm -> Operand
OpImm (Imm -> Operand) -> Imm -> Operand
forall a b. (a -> b) -> a -> b
$ CLabel -> Imm
ImmCLbl CLabel
mkBadAlignmentLabel),
                Target -> Instr
B (Reg -> Target
TReg Reg
jumpReg),
                BlockId -> Instr
NEWBLOCK BlockId
okayLblId
              ]

-- -----------------------------------------------------------------------------
--  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 of loaded value
  Width ->
  CmmExpr ->
  NatM Amode
-- TODO: Specialize stuff we can destructure here.

-- LDR/STR: 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 -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm Int
off =
      Amode -> NatM Amode
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Amode -> NatM Amode) -> Amode -> NatM Amode
forall a b. (a -> b) -> a -> b
$ AddrMode -> OrdList Instr -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg' Imm
off') OrdList Instr
forall a. OrdList a
nilOL
  where
    reg' :: Reg
reg' = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg
    off' :: Imm
off' = Int -> Imm
ImmInt Int
off

-- 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')])
  | Integer -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm Integer
off =
      do
        (reg, _format, code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
        return $ Amode (AddrRegImm reg (ImmInteger off)) code
getAmode Platform
_platform Width
_ (CmmMachOp (MO_Sub Width
_w) [CmmExpr
expr, CmmLit (CmmInt Integer
off Width
_w')])
  | Integer -> Bool
forall a. (Num a, Ord a) => a -> Bool
fitsIn12bitImm (-Integer
off) =
      do
        (reg, _format, code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
        return $ Amode (AddrRegImm reg (ImmInteger (-off))) code

-- 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` STR rep (OpReg w src_reg) (OpAddr addr)
               )

assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_IntCode Format
_ CmmReg
reg CmmExpr
src =
  do
    platform <- NatM Platform
getPlatform
    let dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg
    r <- getRegister src
    return $ case r of
      Any Format
_ Reg -> OrdList Instr
code ->
        SDoc -> Instr
COMMENT ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"CmmAssign" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (CmmReg -> [Char]
forall a. Show a => a -> [Char]
show CmmReg
reg)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (CmmExpr -> [Char]
forall a. Show a => a -> [Char]
show CmmExpr
src)))
          Instr -> OrdList Instr -> OrdList Instr
forall a. a -> OrdList a -> OrdList a
`consOL` Reg -> OrdList Instr
code Reg
dst
      Fixed Format
format Reg
freg OrdList Instr
fcode ->
        SDoc -> Instr
COMMENT ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"CmmAssign" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (CmmReg -> [Char]
forall a. Show a => a -> [Char]
show CmmReg
reg)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (CmmExpr -> [Char]
forall a. Show a => a -> [Char]
show CmmExpr
src)))
          Instr -> OrdList Instr -> OrdList Instr
forall a. a -> OrdList a -> OrdList a
`consOL` ( OrdList Instr
fcode
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) Reg
dst) (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) Reg
freg)
                   )

-- 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
-- AArch64 has 26bits for targets, whereas RiscV only has 20.
-- Thus we need to distinguish between far (outside of the)
-- current compilation unit. And regular branches.
-- RiscV has ±2MB of displacement, whereas AArch64 has ±128MB.
-- Thus for most branches we can get away with encoding it
-- directly in the instruction rather than always loading the
-- address into a register and then using that to jump.
-- Under the assumption that our linked build product is less than
-- ~2*128MB of TEXT, and there are no jump that span the whole
-- TEXT segment.
-- Something where riscv's compressed instruction might come in
-- handy.
genJump :: CmmExpr {-the branch target-} -> NatM InstrBlock
genJump :: CmmExpr -> NatM (OrdList Instr)
genJump CmmExpr
expr = do
  (target, _format, code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
  return (code `appOL` unitOL (annExpr expr (B (TReg target))))

-- -----------------------------------------------------------------------------
--  Unconditional branches
genBranch :: BlockId -> NatM InstrBlock
genBranch :: BlockId -> NatM (OrdList Instr)
genBranch = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> (BlockId -> OrdList Instr) -> BlockId -> NatM (OrdList Instr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL ([Instr] -> OrdList Instr)
-> (BlockId -> [Instr]) -> BlockId -> OrdList Instr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> [Instr]
mkJumpInstr

-- -----------------------------------------------------------------------------
-- Conditional branches
genCondJump ::
  BlockId ->
  CmmExpr ->
  NatM InstrBlock
genCondJump :: BlockId -> CmmExpr -> NatM (OrdList Instr)
genCondJump BlockId
bid CmmExpr
expr = do
  case CmmExpr
expr of
    -- Optimized == 0 case.
    CmmMachOp (MO_Eq Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
0 Width
_)] -> do
      (reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      return $ code_x `snocOL` annExpr expr (BCOND EQ zero (OpReg w reg_x) (TBlock bid))

    -- Optimized /= 0 case.
    CmmMachOp (MO_Ne Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
0 Width
_)] -> do
      (reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      return $ code_x `snocOL` annExpr expr (BCOND NE zero (OpReg w reg_x) (TBlock bid))

    -- Generic case.
    CmmMachOp MachOp
mop [CmmExpr
x, CmmExpr
y] -> do
      let ubcond :: Width -> Cond -> NatM (OrdList Instr)
ubcond Width
w Cond
cmp = do
            -- compute both sides.
            (reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
            (reg_y, format_y, code_y) <- getSomeReg y
            let x' = Width -> Reg -> Operand
OpReg Width
w Reg
reg_x
                y' = Width -> Reg -> Operand
OpReg Width
w Reg
reg_y
            return $ case w of
              Width
w
                | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 Bool -> Bool -> Bool
|| Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W16 ->
                    OrdList Instr
code_x
                      OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg (Format -> Width
formatToWidth Format
format_x) Width
w Reg
reg_x
                      OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y
                      OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> OrdList Instr
truncateReg (Format -> Width
formatToWidth Format
format_y) Width
w Reg
reg_y
                      OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y
                      OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Target -> Instr
BCOND Cond
cmp Operand
x' Operand
y' (BlockId -> Target
TBlock BlockId
bid))
              Width
_ ->
                OrdList Instr
code_x
                  OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y
                  OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Target -> Instr
BCOND Cond
cmp Operand
x' Operand
y' (BlockId -> Target
TBlock BlockId
bid))

          sbcond :: Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
cmp = do
            -- compute both sides.
            (reg_x, format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
            (reg_y, format_y, code_y) <- getSomeReg y
            let x' = Width -> Reg -> Operand
OpReg Width
w Reg
reg_x
                y' = Width -> Reg -> Operand
OpReg Width
w Reg
reg_y
            return $ case w of
              Width
w
                | Width
w Width -> [Width] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Width
W8, Width
W16, Width
W32] ->
                    OrdList Instr
code_x
                      OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_x) Width
W64 Reg
reg_x Reg
reg_x
                      OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y
                      OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend (Format -> Width
formatToWidth Format
format_y) Width
W64 Reg
reg_y Reg
reg_y
                      OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Target -> Instr
BCOND Cond
cmp Operand
x' Operand
y' (BlockId -> Target
TBlock BlockId
bid)))
              Width
_ -> OrdList Instr
code_x OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Operand -> Operand -> Target -> Instr
BCOND Cond
cmp Operand
x' Operand
y' (BlockId -> Target
TBlock BlockId
bid)))

          fbcond :: Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
cmp = do
            -- ensure we get float regs
            (reg_fx, _format_fx, code_fx) <- HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
x
            (reg_fy, _format_fy, code_fy) <- getFloatReg y
            condOpReg <- OpReg W64 <$> getNewRegNat II64
            oneReg <- getNewRegNat II64
            return $ code_fx
              `appOL` code_fy
              `snocOL` annExpr expr (CSET condOpReg (OpReg w reg_fx) (OpReg w reg_fy) cmp)
              `snocOL` MOV (OpReg W64 oneReg) (OpImm (ImmInt 1))
              `snocOL` BCOND EQ condOpReg (OpReg w oneReg) (TBlock bid)

      case MachOp
mop of
        MO_F_Eq Width
w -> Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
EQ
        MO_F_Ne Width
w -> Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
NE
        MO_F_Gt Width
w -> Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
FGT
        MO_F_Ge Width
w -> Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
FGE
        MO_F_Lt Width
w -> Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
FLT
        MO_F_Le Width
w -> Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
FLE
        MO_Eq Width
w -> Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
EQ
        MO_Ne Width
w -> Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
NE
        MO_S_Gt Width
w -> Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
SGT
        MO_S_Ge Width
w -> Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
SGE
        MO_S_Lt Width
w -> Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
SLT
        MO_S_Le Width
w -> Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
SLE
        MO_U_Gt Width
w -> Width -> Cond -> NatM (OrdList Instr)
ubcond Width
w Cond
UGT
        MO_U_Ge Width
w -> Width -> Cond -> NatM (OrdList Instr)
ubcond Width
w Cond
UGE
        MO_U_Lt Width
w -> Width -> Cond -> NatM (OrdList Instr)
ubcond Width
w Cond
ULT
        MO_U_Le Width
w -> Width -> Cond -> NatM (OrdList Instr)
ubcond Width
w Cond
ULE
        MachOp
_ -> [Char] -> SDoc -> NatM (OrdList Instr)
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"RV64.genCondJump:case mop: " ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc) -> [Char] -> SDoc
forall a b. (a -> b) -> a -> b
$ CmmExpr -> [Char]
forall a. Show a => a -> [Char]
show CmmExpr
expr)
    CmmExpr
_ -> [Char] -> SDoc -> NatM (OrdList Instr)
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"RV64.genCondJump: " ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc) -> [Char] -> SDoc
forall a b. (a -> b) -> a -> b
$ CmmExpr -> [Char]
forall a. Show a => a -> [Char]
show CmmExpr
expr)

-- | Generate conditional branching instructions
--
-- This is basically an "if with else" statement.
genCondBranch ::
  -- | the true branch target
  BlockId ->
  -- | the false branch target
  BlockId ->
  -- | the condition on which to branch
  CmmExpr ->
  -- | Instructions
  NatM InstrBlock
genCondBranch :: BlockId -> BlockId -> CmmExpr -> NatM (OrdList Instr)
genCondBranch BlockId
true BlockId
false CmmExpr
expr =
  OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
appOL
    (OrdList Instr -> OrdList Instr -> OrdList Instr)
-> NatM (OrdList Instr) -> NatM (OrdList Instr -> OrdList Instr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BlockId -> CmmExpr -> NatM (OrdList Instr)
genCondJump BlockId
true CmmExpr
expr
    NatM (OrdList Instr -> OrdList Instr)
-> NatM (OrdList Instr) -> NatM (OrdList Instr)
forall a b. NatM (a -> b) -> NatM a -> NatM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BlockId -> NatM (OrdList Instr)
genBranch BlockId
false

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

-- | Generate a call to a C function.
--
-- - Integer values are passed in GP registers a0-a7.
-- - Floating point values are passed in FP registers fa0-fa7.
-- - If there are no free floating point registers, the FP values are passed in GP registers.
-- - If all GP registers are taken, the values are spilled as whole words (!) onto the stack.
-- - For integers/words, the return value is in a0.
-- - The return value is in fa0 if the return type is a floating point value.
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 target :: ForeignTarget
target@(ForeignTarget CmmExpr
expr ForeignConvention
_cconv) [CmmFormal]
dest_regs [CmmExpr]
arg_regs = do
  -- we want to pass arg_regs into allArgRegs
  -- The target :: ForeignTarget call can either
  -- be a foreign procedure with an address expr
  -- and a calling convention.
  (call_target_reg, call_target_code) <-
    -- Compute the address of the call target into a register. This
    -- addressing enables us to jump through the whole address space
    -- without further ado. PC-relative addressing would involve
    -- instructions to do similar, though.
    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 then 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, ...
          OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> [Reg] -> Instr
BL 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
  where
    -- Implementiation of the RISCV ABI calling convention.
    -- https://github.com/riscv-non-isa/riscv-elf-psabi-doc/blob/948463cd5dbebea7c1869e20146b17a2cc8fda2f/riscv-cc.adoc#integer-calling-convention
    passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)
    -- 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)
    -- 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
      -- RISCV64 Integer Calling Convention: "When passed in registers or on the
      -- stack, integer scalars narrower than XLEN bits are widened according to
      -- the sign of their type up to 32 bits, then sign-extended to XLEN bits."
      let w :: Width
w = Format -> Width
formatToWidth Format
format
          assignArg :: OrdList Instr
assignArg =
            if ForeignHint
hint ForeignHint -> ForeignHint -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignHint
SignedHint
              then
                SDoc -> Instr
COMMENT ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Pass gp argument sign-extended (SignedHint): " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r)
                  Instr -> OrdList Instr -> OrdList Instr
forall a. a -> OrdList a -> OrdList a
`consOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend Width
w Width
W64 Reg
r Reg
gpReg
              else
                [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                  [ SDoc -> Instr
COMMENT ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Pass gp argument sign-extended (SignedHint): " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r),
                    Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
gpReg) (Width -> Reg -> Operand
OpReg Width
w Reg
r)
                  ]
          accumCode' :: OrdList Instr
accumCode' =
            OrdList Instr
accumCode
              OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_r
              OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
assignArg
      [Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments [Reg]
gpRegs [Reg]
fpRegs [(Reg, Format, ForeignHint, OrdList Instr)]
args Int
stackSpaceWords (Reg
gpReg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
accumRegs) OrdList Instr
accumCode'

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

    -- 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
STR Format
format (Width -> Reg -> Operand
OpReg Width
w Reg
r) (AddrMode -> Operand
OpAddr (Reg -> Imm -> AddrMode
AddrRegImm Reg
spMachReg (Int -> Imm
ImmInt Int
spOffet)))
          stackCode :: OrdList Instr
stackCode =
            if ForeignHint
hint ForeignHint -> ForeignHint -> Bool
forall a. Eq a => a -> a -> Bool
== ForeignHint
SignedHint
              then
                OrdList Instr
code_r
                  OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Width -> Width -> Reg -> Reg -> OrdList Instr
signExtend Width
w Width
W64 Reg
r Reg
tmpReg
                  OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` SDoc -> Instr -> Instr
ann ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Pass signed argument (size " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
") on the stack: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
tmpReg) Instr
str
              else
                OrdList Instr
code_r
                  OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` SDoc -> Instr -> Instr
ann ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Pass unsigned argument (size " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
") on the stack: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r) Instr
str
      [Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments [] [] [(Reg, Format, ForeignHint, OrdList Instr)]
args (Int
stackSpaceWords Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Reg]
accumRegs (OrdList Instr
stackCode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
accumCode)

    -- 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
STR Format
format (Width -> Reg -> Operand
OpReg Width
w Reg
r) (AddrMode -> Operand
OpAddr (Reg -> Imm -> AddrMode
AddrRegImm Reg
spMachReg (Int -> Imm
ImmInt Int
spOffet)))
          stackCode :: OrdList Instr
stackCode =
            OrdList Instr
code_r
              OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` SDoc -> Instr -> Instr
ann ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Pass argument (size " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
") on the stack: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r) Instr
str
      [Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments [] [Reg]
fpRegs [(Reg, Format, ForeignHint, OrdList Instr)]
args (Int
stackSpaceWords Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Reg]
accumRegs (OrdList Instr
stackCode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
accumCode)

    -- 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
genCCall (PrimTarget CallishMachOp
mop) [CmmFormal]
dest_regs [CmmExpr]
arg_regs = do
  case CallishMachOp
mop of
    CallishMachOp
MO_F32_Fabs
      | [CmmExpr
arg_reg] <- [CmmExpr]
arg_regs,
        [CmmFormal
dest_reg] <- [CmmFormal]
dest_regs ->
          Width
-> (Operand -> Operand -> OrdList Instr)
-> CmmExpr
-> CmmFormal
-> NatM (OrdList Instr)
unaryFloatOp Width
W32 (\Operand
d Operand
x -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
FABS Operand
d Operand
x) CmmExpr
arg_reg CmmFormal
dest_reg
    CallishMachOp
MO_F64_Fabs
      | [CmmExpr
arg_reg] <- [CmmExpr]
arg_regs,
        [CmmFormal
dest_reg] <- [CmmFormal]
dest_regs ->
          Width
-> (Operand -> Operand -> OrdList Instr)
-> CmmExpr
-> CmmFormal
-> NatM (OrdList Instr)
unaryFloatOp Width
W64 (\Operand
d Operand
x -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
FABS Operand
d Operand
x) CmmExpr
arg_reg CmmFormal
dest_reg
    -- 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
    -- Memory Ordering
    -- The related C functions are:
    -- #include <stdatomic.h>
    -- atomic_thread_fence(memory_order_acquire);
    -- atomic_thread_fence(memory_order_release);
    -- atomic_thread_fence(memory_order_seq_cst);
    CallishMachOp
MO_AcquireFence -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (FenceType -> FenceType -> Instr
FENCE FenceType
FenceRead FenceType
FenceReadWrite))
    CallishMachOp
MO_ReleaseFence -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (FenceType -> FenceType -> Instr
FENCE FenceType
FenceReadWrite FenceType
FenceWrite))
    CallishMachOp
MO_SeqCstFence -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (FenceType -> FenceType -> Instr
FENCE FenceType
FenceReadWrite FenceType
FenceReadWrite))
    CallishMachOp
MO_Touch -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OrdList Instr
forall a. OrdList a
nilOL -- 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
    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)
    -- Atomic read-modify-write.
    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
          -- Analog to the related MachOps (above)
          -- The related C functions are:
          -- #include <stdatomic.h>
          -- __atomic_load_n(&a, __ATOMIC_ACQUIRE);
          -- __atomic_load_n(&a, __ATOMIC_SEQ_CST);
          let instrs = case MemoryOrdering
ord of
                MemoryOrdering
MemOrderRelaxed -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ SDoc -> Instr -> Instr
ann SDoc
moDescr (Format -> Operand -> Operand -> Instr
LDR (Width -> Format
intFormat Width
w) (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (AddrMode -> Operand
OpAddr (AddrMode -> Operand) -> AddrMode -> Operand
forall a b. (a -> b) -> a -> b
$ Reg -> AddrMode
AddrReg Reg
p))
                MemoryOrdering
MemOrderAcquire ->
                  [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                    [ SDoc -> Instr -> Instr
ann SDoc
moDescr (Format -> Operand -> Operand -> Instr
LDR (Width -> Format
intFormat Width
w) (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (AddrMode -> Operand
OpAddr (AddrMode -> Operand) -> AddrMode -> Operand
forall a b. (a -> b) -> a -> b
$ Reg -> AddrMode
AddrReg Reg
p)),
                      FenceType -> FenceType -> Instr
FENCE FenceType
FenceRead FenceType
FenceReadWrite
                    ]
                MemoryOrdering
MemOrderSeqCst ->
                  [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                    [ SDoc -> Instr -> Instr
ann SDoc
moDescr (FenceType -> FenceType -> Instr
FENCE FenceType
FenceReadWrite FenceType
FenceReadWrite),
                      Format -> Operand -> Operand -> Instr
LDR (Width -> Format
intFormat Width
w) (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (AddrMode -> Operand
OpAddr (AddrMode -> Operand) -> AddrMode -> Operand
forall a b. (a -> b) -> a -> b
$ Reg -> AddrMode
AddrReg Reg
p),
                      FenceType -> FenceType -> Instr
FENCE FenceType
FenceRead FenceType
FenceReadWrite
                    ]
                MemoryOrdering
MemOrderRelease -> [Char] -> OrdList Instr
forall a. HasCallStack => [Char] -> a
panic ([Char] -> OrdList Instr) -> [Char] -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected MemOrderRelease on an AtomicRead: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CallishMachOp -> [Char]
forall a. Show a => a -> [Char]
show CallishMachOp
mo
              dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst_reg)
              moDescr = ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc)
-> (CallishMachOp -> [Char]) -> CallishMachOp -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallishMachOp -> [Char]
forall a. Show a => a -> [Char]
show) CallishMachOp
mo
              code = OrdList Instr
code_p OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
instrs
          return code
      | Bool
otherwise -> [Char] -> NatM (OrdList Instr)
forall a. HasCallStack => [Char] -> a
panic [Char]
"mal-formed AtomicRead"
    mo :: CallishMachOp
mo@(MO_AtomicWrite Width
w MemoryOrdering
ord)
      | [CmmExpr
p_reg, CmmExpr
val_reg] <- [CmmExpr]
arg_regs -> do
          (p, _fmt_p, code_p) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
p_reg
          (val, fmt_val, code_val) <- getSomeReg val_reg
          -- Analog to the related MachOps (above)
          -- The related C functions are:
          -- #include <stdatomic.h>
          -- __atomic_store_n(&a, 23, __ATOMIC_SEQ_CST);
          -- __atomic_store_n(&a, 23, __ATOMIC_RELEASE);
          let instrs = case MemoryOrdering
ord of
                MemoryOrdering
MemOrderRelaxed -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ SDoc -> Instr -> Instr
ann SDoc
moDescr (Format -> Operand -> Operand -> Instr
STR Format
fmt_val (Width -> Reg -> Operand
OpReg Width
w Reg
val) (AddrMode -> Operand
OpAddr (AddrMode -> Operand) -> AddrMode -> Operand
forall a b. (a -> b) -> a -> b
$ Reg -> AddrMode
AddrReg Reg
p))
                MemoryOrdering
MemOrderSeqCst ->
                  [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                    [ SDoc -> Instr -> Instr
ann SDoc
moDescr (FenceType -> FenceType -> Instr
FENCE FenceType
FenceReadWrite FenceType
FenceWrite),
                      Format -> Operand -> Operand -> Instr
STR Format
fmt_val (Width -> Reg -> Operand
OpReg Width
w Reg
val) (AddrMode -> Operand
OpAddr (AddrMode -> Operand) -> AddrMode -> Operand
forall a b. (a -> b) -> a -> b
$ Reg -> AddrMode
AddrReg Reg
p),
                      FenceType -> FenceType -> Instr
FENCE FenceType
FenceReadWrite FenceType
FenceReadWrite
                    ]
                MemoryOrdering
MemOrderRelease ->
                  [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                    [ SDoc -> Instr -> Instr
ann SDoc
moDescr (FenceType -> FenceType -> Instr
FENCE FenceType
FenceReadWrite FenceType
FenceWrite),
                      Format -> Operand -> Operand -> Instr
STR Format
fmt_val (Width -> Reg -> Operand
OpReg Width
w Reg
val) (AddrMode -> Operand
OpAddr (AddrMode -> Operand) -> AddrMode -> Operand
forall a b. (a -> b) -> a -> b
$ Reg -> AddrMode
AddrReg Reg
p)
                    ]
                MemoryOrdering
MemOrderAcquire -> [Char] -> OrdList Instr
forall a. HasCallStack => [Char] -> a
panic ([Char] -> OrdList Instr) -> [Char] -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected MemOrderAcquire on an AtomicWrite" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CallishMachOp -> [Char]
forall a. Show a => a -> [Char]
show CallishMachOp
mo
              moDescr = ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc)
-> (CallishMachOp -> [Char]) -> CallishMachOp -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallishMachOp -> [Char]
forall a. Show a => a -> [Char]
show) CallishMachOp
mo
              code =
                OrdList Instr
code_p
                  OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_val
                  OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
instrs
          pure code
      | Bool
otherwise -> [Char] -> NatM (OrdList Instr)
forall a. HasCallStack => [Char] -> a
panic [Char]
"mal-formed AtomicWrite"
    MO_AtomicRMW Width
w AtomicMachOp
amop -> FastString -> NatM (OrdList Instr)
mkCCall (Width -> AtomicMachOp -> FastString
atomicRMWLabel Width
w AtomicMachOp
amop)
    MO_Cmpxchg Width
w -> FastString -> NatM (OrdList Instr)
mkCCall (Width -> FastString
cmpxchgLabel Width
w)
    -- -- Should be an AtomicRMW variant eventually.
    -- -- Sequential consistent.
    -- TODO: this should be implemented properly!
    MO_Xchg Width
w -> FastString -> NatM (OrdList Instr)
mkCCall (Width -> FastString
xchgLabel Width
w)
  where
    unsupported :: (Show a) => a -> b
    unsupported :: forall a b. Show a => a -> b
unsupported a
mop =
      [Char] -> b
forall a. HasCallStack => [Char] -> a
panic
        ( [Char]
"outOfLineCmmOp: "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
mop
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" not supported here"
        )
    mkCCall :: FastString -> NatM InstrBlock
    mkCCall :: FastString -> NatM (OrdList Instr)
mkCCall FastString
name = do
      config <- NatM NCGConfig
getConfig
      target <-
        cmmMakeDynamicReference config CallReference
          $ mkForeignLabel name ForeignLabelInThisPackage IsFunction
      let cconv = CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [ForeignHint
NoHint] [ForeignHint
NoHint] CmmReturnInfo
CmmMayReturn
      genCCall (ForeignTarget target cconv) dest_regs arg_regs

    unaryFloatOp :: Width
-> (Operand -> Operand -> OrdList Instr)
-> CmmExpr
-> CmmFormal
-> NatM (OrdList Instr)
unaryFloatOp Width
w Operand -> Operand -> OrdList Instr
op CmmExpr
arg_reg CmmFormal
dest_reg = do
      platform <- NatM Platform
getPlatform
      (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg
      let dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dest_reg)
      let code = OrdList Instr
code_fx OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fx)
      pure code

{- Note [RISCV64 far jumps]
~~~~~~~~~~~~~~~~~~~~~~~~~~~

RISCV64 conditional jump instructions can only encode an offset of +/-4KiB
(12bits) which is usually enough but can be exceeded in edge cases. In these
cases we will replace:

  b.cond <cond> foo

with the sequence:

  b.cond <cond> <lbl_true>
  b <lbl_false>
  <lbl_true>:
  la reg foo
  b reg
  <lbl_false>:

and

  b foo

with the sequence:

  la reg foo
  b reg

Compared to AArch64 the target label is loaded to a register, because
unconditional jump instructions can only address +/-1MiB. The LA
pseudo-instruction will be replaced by up to two real instructions, ensuring
correct addressing.

One could surely find more efficient replacements, taking PC-relative addressing
into account. This could be a future improvement. (As far branches are pretty
rare, one might question and measure the value of such improvement.)

RISCV has many pseudo-instructions which emit more than one real instructions.
Thus, we count the real instructions after the Assembler has seen them.

We make some simplifications in the name of performance which can result in
overestimating jump <-> label offsets:

\* To avoid having to recalculate the label offsets once we replaced a jump we simply
  assume all label jumps will be expanded to a three instruction far jump sequence.
\* For labels associated with a info table we assume the info table is 64byte large.
  Most info tables are smaller than that but it means we don't have to distinguish
  between multiple types of info tables.

In terms of implementation we walk the instruction stream at least once calculating
label offsets, and if we determine during this that the functions body is big enough
to potentially contain out of range jumps we walk the instructions a second time, replacing
out of range jumps with the sequence of instructions described above.

-}

-- | A conditional jump to a far target
--
-- By loading the far target into a register for the jump, we can address the
-- whole memory range.
genCondFarJump :: (MonadGetUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock
genCondFarJump :: forall (m :: * -> *).
MonadGetUnique m =>
Cond -> Operand -> Operand -> BlockId -> m (OrdList Instr)
genCondFarJump Cond
cond Operand
op1 Operand
op2 BlockId
far_target = do
  skip_lbl_id <- m BlockId
forall (m :: * -> *). MonadGetUnique m => m BlockId
newBlockId
  jmp_lbl_id <- newBlockId

  -- TODO: We can improve this by inverting the condition
  -- but it's not quite trivial since we don't know if we
  -- need to consider float orderings.
  -- So we take the hit of the additional jump in the false
  -- case for now.
  return
    $ toOL
      [ ann (text "Conditional far jump to: " <> ppr far_target)
          $ BCOND cond op1 op2 (TBlock jmp_lbl_id),
        B (TBlock skip_lbl_id),
        NEWBLOCK jmp_lbl_id,
        LDR II64 (OpReg W64 tmpReg) (OpImm (ImmCLbl (blockLbl far_target))),
        B (TReg tmpReg),
        NEWBLOCK skip_lbl_id
      ]

-- | An unconditional jump to a far target
--
-- By loading the far target into a register for the jump, we can address the
-- whole memory range.
genFarJump :: (MonadGetUnique m) => BlockId -> m InstrBlock
genFarJump :: forall (m :: * -> *).
MonadGetUnique m =>
BlockId -> m (OrdList Instr)
genFarJump BlockId
far_target =
  OrdList Instr -> m (OrdList Instr)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    (OrdList Instr -> m (OrdList Instr))
-> OrdList Instr -> m (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
      [ SDoc -> Instr -> Instr
ann ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Unconditional far jump to: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
far_target)
          (Instr -> Instr) -> Instr -> Instr
forall a b. (a -> b) -> a -> b
$ Format -> Operand -> Operand -> Instr
LDR Format
II64 (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmpReg) (Imm -> Operand
OpImm (CLabel -> Imm
ImmCLbl (BlockId -> CLabel
blockLbl BlockId
far_target))),
        Target -> Instr
B (Reg -> Target
TReg Reg
tmpReg)
      ]

-- See Note [RISCV64 far jumps]
data BlockInRange = InRange | NotInRange BlockId

-- See Note [RISCV64 far jumps]
makeFarBranches ::
  Platform ->
  LabelMap RawCmmStatics ->
  [NatBasicBlock Instr] ->
  UniqDSM [NatBasicBlock Instr]
makeFarBranches :: Platform
-> LabelMap RawCmmStatics
-> [NatBasicBlock Instr]
-> UniqDSM [NatBasicBlock Instr]
makeFarBranches {- only used when debugging -} Platform
_platform LabelMap RawCmmStatics
statics [NatBasicBlock Instr]
basic_blocks = do
  -- All offsets/positions are counted in multiples of 4 bytes (the size of RISCV64 instructions)
  -- That is an offset of 1 represents a 4-byte/one instruction offset.
  let (Int
func_size, LabelMap Int
lblMap) = ((Int, LabelMap Int) -> NatBasicBlock Instr -> (Int, LabelMap Int))
-> (Int, LabelMap Int)
-> [NatBasicBlock Instr]
-> (Int, LabelMap Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, LabelMap Int) -> NatBasicBlock Instr -> (Int, LabelMap Int)
calc_lbl_positions (Int
0, LabelMap Int
forall v. LabelMap v
mapEmpty) [NatBasicBlock Instr]
basic_blocks
  if Int
func_size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
max_jump_dist
    then [NatBasicBlock Instr] -> UniqDSM [NatBasicBlock Instr]
forall a. a -> UniqDSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [NatBasicBlock Instr]
basic_blocks
    else do
      (_, blocks) <- (Int
 -> NatBasicBlock Instr -> UniqDSM (Int, [NatBasicBlock Instr]))
-> Int
-> [NatBasicBlock Instr]
-> UniqDSM (Int, [[NatBasicBlock Instr]])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM (LabelMap Int
-> Int
-> NatBasicBlock Instr
-> UniqDSM (Int, [NatBasicBlock Instr])
replace_blk LabelMap Int
lblMap) Int
0 [NatBasicBlock Instr]
basic_blocks
      pure $ concat blocks
  where
    -- pprTrace "lblMap" (ppr lblMap) $ basic_blocks

    -- 2^11, 12 bit immediate with one bit is reserved for the sign
    max_jump_dist :: Int
max_jump_dist = Int
2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
11 :: Int) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 :: Int
    -- Currently all inline info tables fit into 64 bytes.
    max_info_size :: Int
max_info_size = Int
16 :: Int
    long_bc_jump_size :: Int
long_bc_jump_size = Int
5 :: Int
    long_b_jump_size :: Int
long_b_jump_size = Int
2 :: Int

    -- Replace out of range conditional jumps with unconditional jumps.
    replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr])
    replace_blk :: LabelMap Int
-> Int
-> NatBasicBlock Instr
-> UniqDSM (Int, [NatBasicBlock Instr])
replace_blk !LabelMap Int
m !Int
pos (BasicBlock BlockId
lbl [Instr]
instrs) = do
      -- Account for a potential info table before the label.
      let !block_pos :: Int
block_pos = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ BlockId -> Int
infoTblSize_maybe BlockId
lbl
      (!pos', instrs') <- (Int -> Instr -> UniqDSM (Int, [Instr]))
-> Int -> [Instr] -> UniqDSM (Int, [[Instr]])
forall (m :: * -> *) (t :: * -> *) acc x y.
(Monad m, Traversable t) =>
(acc -> x -> m (acc, y)) -> acc -> t x -> m (acc, t y)
mapAccumLM (LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])
replace_jump LabelMap Int
m) Int
block_pos [Instr]
instrs
      let instrs'' = [[Instr]] -> [Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Instr]]
instrs'
      -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary.
      let (top, split_blocks, no_data) = foldr mkBlocks ([], [], []) instrs''
      -- There should be no data in the instruction stream at this point
      massert (null no_data)

      let final_blocks = BlockId -> [Instr] -> NatBasicBlock Instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
lbl [Instr]
top NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
split_blocks
      pure (pos', final_blocks)

    replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])
    replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])
replace_jump !LabelMap Int
m !Int
pos Instr
instr = do
      case Instr
instr of
        ANN SDoc
ann Instr
instr -> do
          LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])
replace_jump LabelMap Int
m Int
pos Instr
instr UniqDSM (Int, [Instr])
-> ((Int, [Instr]) -> UniqDSM (Int, [Instr]))
-> UniqDSM (Int, [Instr])
forall a b. UniqDSM a -> (a -> UniqDSM b) -> UniqDSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            (Int
_, []) -> [Char] -> UniqDSM (Int, [Instr])
forall a. HasCallStack => [Char] -> a
error [Char]
"RV64:replace_jump"
            (Int
idx, Instr
instr' : [Instr]
instrs') ->
              (Int, [Instr]) -> UniqDSM (Int, [Instr])
forall a. a -> UniqDSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
idx, SDoc -> Instr -> Instr
ANN SDoc
ann Instr
instr' Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
instrs')
        BCOND Cond
cond Operand
op1 Operand
op2 Target
t ->
          case LabelMap Int -> Target -> Int -> BlockInRange
target_in_range LabelMap Int
m Target
t Int
pos of
            BlockInRange
InRange -> (Int, [Instr]) -> UniqDSM (Int, [Instr])
forall a. a -> UniqDSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Instr -> Int
instr_size Instr
instr, [Instr
instr])
            NotInRange BlockId
far_target -> do
              jmp_code <- Cond -> Operand -> Operand -> BlockId -> UniqDSM (OrdList Instr)
forall (m :: * -> *).
MonadGetUnique m =>
Cond -> Operand -> Operand -> BlockId -> m (OrdList Instr)
genCondFarJump Cond
cond Operand
op1 Operand
op2 BlockId
far_target
              pure (pos + instr_size instr, fromOL jmp_code)
        B Target
t ->
          case LabelMap Int -> Target -> Int -> BlockInRange
target_in_range LabelMap Int
m Target
t Int
pos of
            BlockInRange
InRange -> (Int, [Instr]) -> UniqDSM (Int, [Instr])
forall a. a -> UniqDSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Instr -> Int
instr_size Instr
instr, [Instr
instr])
            NotInRange BlockId
far_target -> do
              jmp_code <- BlockId -> UniqDSM (OrdList Instr)
forall (m :: * -> *).
MonadGetUnique m =>
BlockId -> m (OrdList Instr)
genFarJump BlockId
far_target
              pure (pos + instr_size instr, fromOL jmp_code)
        Instr
_ -> (Int, [Instr]) -> UniqDSM (Int, [Instr])
forall a. a -> UniqDSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Instr -> Int
instr_size Instr
instr, [Instr
instr])

    target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange
    target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange
target_in_range LabelMap Int
m Target
target Int
src =
      case Target
target of
        (TReg {}) -> BlockInRange
InRange
        (TBlock BlockId
bid) -> LabelMap Int -> Int -> BlockId -> BlockInRange
block_in_range LabelMap Int
m Int
src BlockId
bid

    block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange
    block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange
block_in_range LabelMap Int
m Int
src_pos BlockId
dest_lbl =
      case BlockId -> LabelMap Int -> Maybe Int
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
dest_lbl LabelMap Int
m of
        Maybe Int
Nothing ->
          [Char] -> SDoc -> BlockInRange -> BlockInRange
forall a. [Char] -> SDoc -> a -> a
pprTrace [Char]
"not in range" (BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
dest_lbl)
            (BlockInRange -> BlockInRange) -> BlockInRange -> BlockInRange
forall a b. (a -> b) -> a -> b
$ BlockId -> BlockInRange
NotInRange BlockId
dest_lbl
        Just Int
dest_pos ->
          if Int -> Int
forall a. Num a => a -> a
abs (Int
dest_pos Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
src_pos) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
max_jump_dist
            then BlockInRange
InRange
            else BlockId -> BlockInRange
NotInRange BlockId
dest_lbl

    calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int)
    calc_lbl_positions :: (Int, LabelMap Int) -> NatBasicBlock Instr -> (Int, LabelMap Int)
calc_lbl_positions (Int
pos, LabelMap Int
m) (BasicBlock BlockId
lbl [Instr]
instrs) =
      let !pos' :: Int
pos' = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ BlockId -> Int
infoTblSize_maybe BlockId
lbl
       in ((Int, LabelMap Int) -> Instr -> (Int, LabelMap Int))
-> (Int, LabelMap Int) -> [Instr] -> (Int, LabelMap Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)
instr_pos (Int
pos', BlockId -> Int -> LabelMap Int -> LabelMap Int
forall v. BlockId -> v -> LabelMap v -> LabelMap v
mapInsert BlockId
lbl Int
pos' LabelMap Int
m) [Instr]
instrs

    instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)
    instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)
instr_pos (Int
pos, LabelMap Int
m) Instr
instr = (Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Instr -> Int
instr_size Instr
instr, LabelMap Int
m)

    infoTblSize_maybe :: BlockId -> Int
infoTblSize_maybe BlockId
bid =
      case BlockId -> LabelMap RawCmmStatics -> Maybe RawCmmStatics
forall a. BlockId -> LabelMap a -> Maybe a
mapLookup BlockId
bid LabelMap RawCmmStatics
statics of
        Maybe RawCmmStatics
Nothing -> Int
0 :: Int
        Just RawCmmStatics
_info_static -> Int
max_info_size

    instr_size :: Instr -> Int
    instr_size :: Instr -> Int
instr_size Instr
i = case Instr
i of
      COMMENT {} -> Int
0
      MULTILINE_COMMENT {} -> Int
0
      ANN SDoc
_ Instr
instr -> Instr -> Int
instr_size Instr
instr
      LOCATION {} -> Int
0
      DELTA {} -> Int
0
      -- At this point there should be no NEWBLOCK in the instruction stream (pos, mapInsert bid pos m)
      NEWBLOCK {} -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
panic [Char]
"mkFarBranched - Unexpected"
      LDATA {} -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
panic [Char]
"mkFarBranched - Unexpected"
      Instr
PUSH_STACK_FRAME -> Int
4
      Instr
POP_STACK_FRAME -> Int
4
      ADD {} -> Int
1
      MUL {} -> Int
1
      MULH {} -> Int
1
      NEG {} -> Int
1
      DIV {} -> Int
1
      REM {} -> Int
1
      REMU {} -> Int
1
      SUB {} -> Int
1
      DIVU {} -> Int
1
      AND {} -> Int
1
      OR {} -> Int
1
      SRA {} -> Int
1
      XOR {} -> Int
1
      SLL {} -> Int
1
      SRL {} -> Int
1
      MOV {} -> Int
2
      ORI {} -> Int
1
      XORI {} -> Int
1
      CSET {} -> Int
2
      STR {} -> Int
1
      LDR {} -> Int
3
      LDRU {} -> Int
1
      FENCE {} -> Int
1
      FCVT {} -> Int
1
      FABS {} -> Int
1
      FMIN {} -> Int
1
      FMAX {} -> Int
1
      FMA {} -> Int
1
      -- estimate the subsituted size for jumps to lables
      -- jumps to registers have size 1
      BCOND {} -> Int
long_bc_jump_size
      B (TBlock BlockId
_) -> Int
long_b_jump_size
      B (TReg Reg
_) -> Int
1
      BL Reg
_ [Reg]
_ -> Int
1
      J_TBL {} -> Int
1