Instr.hs

-- All instructions will be rendered eventually. Thus, there's no benefit in
-- being lazy in data types.
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module GHC.CmmToAsm.RV64.Instr where

import Data.Maybe
import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.Dataflow.Label
import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Instr (RegUsage (..))
import GHC.CmmToAsm.RV64.Cond
import GHC.CmmToAsm.RV64.Regs
import GHC.CmmToAsm.Types
import GHC.CmmToAsm.Utils
import GHC.Data.FastString (LexicalFastString)
import GHC.Platform
import GHC.Platform.Reg
import GHC.Platform.Regs
import GHC.Platform.Reg.Class.Separate
import GHC.Prelude
import GHC.Stack
import GHC.Types.Unique.DSM
import GHC.Utils.Outputable
import GHC.Utils.Panic

-- | Stack frame header size in bytes.
--
-- The stack frame header is made of the values that are always saved
-- (regardless of the context.) It consists of the saved return address and a
-- pointer to the previous frame. Thus, its size is two stack frame slots which
-- equals two addresses/words (2 * 8 byte).
stackFrameHeaderSize :: Int
stackFrameHeaderSize = 2 * spillSlotSize

-- | All registers are 8 byte wide.
spillSlotSize :: Int
spillSlotSize = 8

-- | The number of bytes that the stack pointer should be aligned to.
stackAlign :: Int
stackAlign = 16

-- | The number of spill slots available without allocating more.
maxSpillSlots :: NCGConfig -> Int
maxSpillSlots config =
  ( (ncgSpillPreallocSize config - stackFrameHeaderSize)
      `div` spillSlotSize
  )
    - 1

-- | Convert a spill slot number to a *byte* offset.
spillSlotToOffset :: Int -> Int
spillSlotToOffset slot =
  stackFrameHeaderSize + spillSlotSize * slot

instance Outputable RegUsage where
  ppr (RU reads writes) = text "RegUsage(reads:" <+> ppr reads <> comma <+> text "writes:" <+> ppr writes <> char ')'

-- | Get the registers that are being used by this instruction.
-- regUsage doesn't need to do any trickery for jumps and such.
-- Just state precisely the regs read and written by that insn.
-- The consequences of control flow transfers, as far as register
-- allocation goes, are taken care of by the register allocator.
--
-- RegUsage = RU [<read regs>] [<write regs>]
regUsageOfInstr :: Platform -> Instr -> RegUsage
regUsageOfInstr platform instr = case instr of
  ANN _ i -> regUsageOfInstr platform i
  COMMENT {} -> usage ([], [])
  MULTILINE_COMMENT {} -> usage ([], [])
  PUSH_STACK_FRAME -> usage ([], [])
  POP_STACK_FRAME -> usage ([], [])
  LOCATION {} -> usage ([], [])
  DELTA {} -> usage ([], [])
  ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  MUL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  NEG dst src -> usage (regOp src, regOp dst)
  MULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  DIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  REM dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  REMU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  SUB dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  DIVU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  AND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  OR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  SRA dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  XOR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  SLL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  SRL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  MOV dst src -> usage (regOp src, regOp dst)
  -- ORI's third operand is always an immediate
  ORI dst src1 _ -> usage (regOp src1, regOp dst)
  XORI dst src1 _ -> usage (regOp src1, regOp dst)
  J_TBL _ _ t -> usage ([t], [])
  J t -> usage (regTarget t, [])
  B t -> usage (regTarget t, [])
  BCOND _ l r t -> usage (regTarget t ++ regOp l ++ regOp r, [])
  BL t ps -> usage (t : ps, callerSavedRegisters)
  CSET dst l r _ -> usage (regOp l ++ regOp r, regOp dst)
  STR _ src dst -> usage (regOp src ++ regOp dst, [])
  LDR _ dst src -> usage (regOp src, regOp dst)
  LDRU _ dst src -> usage (regOp src, regOp dst)
  FENCE _ _ -> usage ([], [])
  FCVT _variant dst src -> usage (regOp src, regOp dst)
  FABS dst src -> usage (regOp src, regOp dst)
  FMIN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  FMAX dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)
  FMA _ dst src1 src2 src3 ->
    usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)
  _ -> panic $ "regUsageOfInstr: " ++ instrCon instr
  where
    -- filtering the usage is necessary, otherwise the register
    -- allocator will try to allocate pre-defined fixed stg
    -- registers as well, as they show up.
    usage :: ([Reg], [Reg]) -> RegUsage
    usage (srcRegs, dstRegs) =
      RU
        (map mkFmt $ filter (interesting platform) srcRegs)
        (map mkFmt $ filter (interesting platform) dstRegs)

      -- SIMD NCG TODO: the format here is used for register spilling/unspilling.
      -- As the RISCV64 NCG does not currently support SIMD registers,
      -- this simple logic is OK.
    mkFmt r = RegWithFormat r fmt
      where
        fmt = case cls of
                RcInteger -> II64
                RcFloat   -> FF64
                RcVector  -> sorry "The RISCV64 NCG does not (yet) support vectors; please use -fllvm."
        cls = case r of
                RegVirtual vr -> classOfVirtualReg (platformArch platform) vr
                RegReal rr -> classOfRealReg rr

    regAddr :: AddrMode -> [Reg]
    regAddr (AddrRegImm r1 _imm) = [r1]
    regAddr (AddrReg r1) = [r1]

    regOp :: Operand -> [Reg]
    regOp (OpReg _w r1) = [r1]
    regOp (OpAddr a) = regAddr a
    regOp (OpImm _imm) = []

    regTarget :: Target -> [Reg]
    regTarget (TBlock _bid) = []
    regTarget (TReg r1) = [r1]

    -- Is this register interesting for the register allocator?
    interesting :: Platform -> Reg -> Bool
    interesting _ (RegVirtual _) = True
    interesting platform (RegReal (RealRegSingle i)) = freeReg platform i

-- | Caller-saved registers (according to calling convention)
--
-- These registers may be clobbered after a jump.
callerSavedRegisters :: [Reg]
callerSavedRegisters =
  [regSingle raRegNo]
    ++ map regSingle [t0RegNo .. t2RegNo]
    ++ map regSingle [a0RegNo .. a7RegNo]
    ++ map regSingle [t3RegNo .. t6RegNo]
    ++ map regSingle [ft0RegNo .. ft7RegNo]
    ++ map regSingle [fa0RegNo .. fa7RegNo]

-- | Apply a given mapping to all the register references in this instruction.
patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
patchRegsOfInstr instr env = case instr of
  ANN d i -> ANN d (patchRegsOfInstr i env)
  COMMENT {} -> instr
  MULTILINE_COMMENT {} -> instr
  PUSH_STACK_FRAME -> instr
  POP_STACK_FRAME -> instr
  LOCATION {} -> instr
  DELTA {} -> instr
  ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3)
  MUL o1 o2 o3 -> MUL (patchOp o1) (patchOp o2) (patchOp o3)
  NEG o1 o2 -> NEG (patchOp o1) (patchOp o2)
  MULH o1 o2 o3 -> MULH (patchOp o1) (patchOp o2) (patchOp o3)
  DIV o1 o2 o3 -> DIV (patchOp o1) (patchOp o2) (patchOp o3)
  REM o1 o2 o3 -> REM (patchOp o1) (patchOp o2) (patchOp o3)
  REMU o1 o2 o3 -> REMU (patchOp o1) (patchOp o2) (patchOp o3)
  SUB o1 o2 o3 -> SUB (patchOp o1) (patchOp o2) (patchOp o3)
  DIVU o1 o2 o3 -> DIVU (patchOp o1) (patchOp o2) (patchOp o3)
  AND o1 o2 o3 -> AND (patchOp o1) (patchOp o2) (patchOp o3)
  OR o1 o2 o3 -> OR (patchOp o1) (patchOp o2) (patchOp o3)
  SRA o1 o2 o3 -> SRA (patchOp o1) (patchOp o2) (patchOp o3)
  XOR o1 o2 o3 -> XOR (patchOp o1) (patchOp o2) (patchOp o3)
  SLL o1 o2 o3 -> SLL (patchOp o1) (patchOp o2) (patchOp o3)
  SRL o1 o2 o3 -> SRL (patchOp o1) (patchOp o2) (patchOp o3)
  MOV o1 o2 -> MOV (patchOp o1) (patchOp o2)
  -- o3 cannot be a register for ORI (always an immediate)
  ORI o1 o2 o3 -> ORI (patchOp o1) (patchOp o2) (patchOp o3)
  XORI o1 o2 o3 -> XORI (patchOp o1) (patchOp o2) (patchOp o3)
  J_TBL ids mbLbl t -> J_TBL ids mbLbl (env t)
  J t -> J (patchTarget t)
  B t -> B (patchTarget t)
  BL t ps -> BL (patchReg t) ps
  BCOND c o1 o2 t -> BCOND c (patchOp o1) (patchOp o2) (patchTarget t)
  CSET o l r c -> CSET (patchOp o) (patchOp l) (patchOp r) c
  STR f o1 o2 -> STR f (patchOp o1) (patchOp o2)
  LDR f o1 o2 -> LDR f (patchOp o1) (patchOp o2)
  LDRU f o1 o2 -> LDRU f (patchOp o1) (patchOp o2)
  FENCE o1 o2 -> FENCE o1 o2
  FCVT variant o1 o2 -> FCVT variant (patchOp o1) (patchOp o2)
  FABS o1 o2 -> FABS (patchOp o1) (patchOp o2)
  FMIN o1 o2 o3 -> FMIN (patchOp o1) (patchOp o2) (patchOp o3)
  FMAX o1 o2 o3 -> FMAX (patchOp o1) (patchOp o2) (patchOp o3)
  FMA s o1 o2 o3 o4 ->
    FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)
  _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr
  where
    patchOp :: Operand -> Operand
    patchOp (OpReg w r) = OpReg w (env r)
    patchOp (OpAddr a) = OpAddr (patchAddr a)
    patchOp opImm = opImm

    patchTarget :: Target -> Target
    patchTarget (TReg r) = TReg (env r)
    patchTarget tBlock = tBlock

    patchAddr :: AddrMode -> AddrMode
    patchAddr (AddrRegImm r1 imm) = AddrRegImm (env r1) imm
    patchAddr (AddrReg r) = AddrReg (env r)

    patchReg :: Reg -> Reg
    patchReg = env

-- | Checks whether this instruction is a jump/branch instruction.
--
-- One that can change the flow of control in a way that the
-- register allocator needs to worry about.
isJumpishInstr :: Instr -> Bool
isJumpishInstr instr = case instr of
  ANN _ i -> isJumpishInstr i
  J_TBL {} -> True
  J {} -> True
  B {} -> True
  BL {} -> True
  BCOND {} -> True
  _ -> False

canFallthroughTo :: Instr -> BlockId -> Bool
canFallthroughTo insn bid =
  case insn of
    J (TBlock target) -> bid == target
    B (TBlock target) -> bid == target
    BCOND _ _ _ (TBlock target) -> bid == target
    J_TBL targets _ _ -> all isTargetBid targets
    _ -> False
  where
    isTargetBid target = case target of
      Nothing -> True
      Just target -> target == bid

-- | Get the `BlockId`s of the jump destinations (if any)
jumpDestsOfInstr :: Instr -> [BlockId]
jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i
jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids
jumpDestsOfInstr (J t) = [id | TBlock id <- [t]]
jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]
jumpDestsOfInstr (BCOND _ _ _ t) = [id | TBlock id <- [t]]
jumpDestsOfInstr _ = []

-- | Change the destination of this (potential) jump instruction.
--
-- Used in the linear allocator when adding fixup blocks for join
-- points.
patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
patchJumpInstr instr patchF =
  case instr of
    ANN d i -> ANN d (patchJumpInstr i patchF)
    J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r
    J (TBlock bid) -> J (TBlock (patchF bid))
    B (TBlock bid) -> B (TBlock (patchF bid))
    BCOND c o1 o2 (TBlock bid) -> BCOND c o1 o2 (TBlock (patchF bid))
    _ -> panic $ "patchJumpInstr: " ++ instrCon instr

-- -----------------------------------------------------------------------------
-- Note [RISCV64 Spills and Reloads]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- We reserve @RESERVED_C_STACK_BYTES@ on the C stack for spilling and reloading
-- registers. The load and store instructions of RISCV64 address with a signed
-- 12-bit immediate + a register; machine stackpointer (sp/x2) in this case.
--
-- The @RESERVED_C_STACK_BYTES@ is 16k, so we can't always address into it in a
-- single load/store instruction. There are offsets to sp (not to be confused
-- with STG's SP!) which need a register to be calculated.
--
-- Using sp to compute the offset would violate assumptions about the stack pointer
-- pointing to the top of the stack during signal handling.  As we can't force
-- every signal to use its own stack, we have to ensure that the stack pointer
-- always points to the top of the stack, and we can't use it for computation.
--
-- So, we reserve one register (TMP) for this purpose (and other, unrelated
-- intermediate operations.) See Note [The made-up RISCV64 TMP (IP) register]

-- | Generate instructions to spill a register into a spill slot.
mkSpillInstr ::
  (HasCallStack) =>
  NCGConfig ->
  -- | register to spill
  RegWithFormat ->
  -- | current stack delta
  Int ->
  -- | spill slot to use
  Int ->
  [Instr]
mkSpillInstr _config (RegWithFormat reg _fmt) delta slot =
  case off - delta of
    imm | fitsIn12bitImm imm -> [mkStrSpImm imm]
    imm ->
      [ movImmToTmp imm,
        addSpToTmp,
        mkStrTmp
      ]
  where
    fmt = case reg of
      RegReal (RealRegSingle n) | n < d0RegNo -> II64
      _ -> FF64
    mkStrSpImm imm =
      ANN (text "Spill@" <> int (off - delta))
        $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))
    movImmToTmp imm =
      ANN (text "Spill: TMP <- " <> int imm)
        $ MOV tmp (OpImm (ImmInt imm))
    addSpToTmp =
      ANN (text "Spill: TMP <- SP + TMP ")
        $ ADD tmp tmp sp
    mkStrTmp =
      ANN (text "Spill@" <> int (off - delta))
        $ STR fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg))

    off = spillSlotToOffset slot

-- | Generate instructions to load a register from a spill slot.
mkLoadInstr ::
  NCGConfig ->
  -- | register to load
  RegWithFormat ->
  -- | current stack delta
  Int ->
  -- | spill slot to use
  Int ->
  [Instr]
mkLoadInstr _config (RegWithFormat reg _fmt) delta slot =
  case off - delta of
    imm | fitsIn12bitImm imm -> [mkLdrSpImm imm]
    imm ->
      [ movImmToTmp imm,
        addSpToTmp,
        mkLdrTmp
      ]
  where
    fmt = case reg of
      RegReal (RealRegSingle n) | n < d0RegNo -> II64
      _ -> FF64
    mkLdrSpImm imm =
      ANN (text "Reload@" <> int (off - delta))
        $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))
    movImmToTmp imm =
      ANN (text "Reload: TMP <- " <> int imm)
        $ MOV tmp (OpImm (ImmInt imm))
    addSpToTmp =
      ANN (text "Reload: TMP <- SP + TMP ")
        $ ADD tmp tmp sp
    mkLdrTmp =
      ANN (text "Reload@" <> int (off - delta))
        $ LDR fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg))

    off = spillSlotToOffset slot

-- | See if this instruction is telling us the current C stack delta
takeDeltaInstr :: Instr -> Maybe Int
takeDeltaInstr (ANN _ i) = takeDeltaInstr i
takeDeltaInstr (DELTA i) = Just i
takeDeltaInstr _ = Nothing

-- | Not real instructions.  Just meta data
isMetaInstr :: Instr -> Bool
isMetaInstr instr =
  case instr of
    ANN _ i -> isMetaInstr i
    COMMENT {} -> True
    MULTILINE_COMMENT {} -> True
    LOCATION {} -> True
    LDATA {} -> True
    NEWBLOCK {} -> True
    DELTA {} -> True
    PUSH_STACK_FRAME -> True
    POP_STACK_FRAME -> True
    _ -> False

-- | Copy the value in a register to another one.
--
-- Must work for all register classes.
mkRegRegMoveInstr :: Reg -> Reg -> Instr
mkRegRegMoveInstr src dst = ANN desc instr
  where
    desc = text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst
    instr = MOV (operandFromReg dst) (operandFromReg src)

-- | Take the source and destination from this (potential) reg -> reg move instruction
--
-- We have to be a bit careful here: A `MOV` can also mean an implicit
-- conversion. This case is filtered out.
takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr (MOV (OpReg width dst) (OpReg width' src))
  | width == width' && (isFloatReg dst == isFloatReg src) = pure (src, dst)
takeRegRegMoveInstr _ = Nothing

-- | Make an unconditional jump instruction.
mkJumpInstr :: BlockId -> [Instr]
mkJumpInstr = pure . B . TBlock

-- | Decrement @sp@ to allocate stack space.
--
-- The stack grows downwards, so we decrement the stack pointer by @n@ (bytes).
-- This is dual to `mkStackDeallocInstr`. @sp@ is the RISCV stack pointer, not
-- to be confused with the STG stack pointer.
mkStackAllocInstr :: Platform -> Int -> [Instr]
mkStackAllocInstr _platform = moveSp . negate

-- | Increment SP to deallocate stack space.
--
-- The stack grows downwards, so we increment the stack pointer by @n@ (bytes).
-- This is dual to `mkStackAllocInstr`. @sp@ is the RISCV stack pointer, not to
-- be confused with the STG stack pointer.
mkStackDeallocInstr :: Platform -> Int -> [Instr]
mkStackDeallocInstr _platform = moveSp

moveSp :: Int -> [Instr]
moveSp n
  | n == 0 = []
  | n /= 0 && fitsIn12bitImm n = pure . ANN desc $ ADD sp sp (OpImm (ImmInt n))
  | otherwise =
      -- This ends up in three effective instructions. We could get away with
      -- two for intMax12bit < n < 3 * intMax12bit by recursing once. However,
      -- this way is likely less surprising.
      [ ANN desc (MOV tmp (OpImm (ImmInt n))),
        ADD sp sp tmp
      ]
  where
    desc = text "Move SP:" <+> int n

--
-- See Note [extra spill slots] in X86/Instr.hs
--
allocMoreStack ::
  Platform ->
  Int ->
  NatCmmDecl statics GHC.CmmToAsm.RV64.Instr.Instr ->
  UniqDSM (NatCmmDecl statics GHC.CmmToAsm.RV64.Instr.Instr, [(BlockId, BlockId)])
allocMoreStack _ _ top@(CmmData _ _) = return (top, [])
allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do
  let entries = entryBlocks proc

  retargetList <- mapM (\e -> (e,) <$> newBlockId) entries

  let delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up
        where
          x = slots * spillSlotSize -- sp delta
      alloc = mkStackAllocInstr platform delta
      dealloc = mkStackDeallocInstr platform delta

      new_blockmap :: LabelMap BlockId
      new_blockmap = mapFromList retargetList

      insert_stack_insn (BasicBlock id insns)
        | Just new_blockid <- mapLookup id new_blockmap =
            [ BasicBlock id $ alloc ++ [B (TBlock new_blockid)],
              BasicBlock new_blockid block'
            ]
        | otherwise =
            [BasicBlock id block']
        where
          block' = foldr insert_dealloc [] insns

      insert_dealloc insn r = case insn of
        J {} -> dealloc ++ (insn : r)
        ANN _ e -> insert_dealloc e r
        _other
          | jumpDestsOfInstr insn /= [] ->
              patchJumpInstr insn retarget : r
        _other -> insn : r
        where
          retarget b = fromMaybe b (mapLookup b new_blockmap)

      new_code = concatMap insert_stack_insn code
  return (CmmProc info lbl live (ListGraph new_code), retargetList)

data Instr
  = -- | Comment pseudo-op
    COMMENT SDoc
  | -- | Multi-line comment pseudo-op
    MULTILINE_COMMENT SDoc
  | -- | Annotated instruction. Should print <instr> # <doc>
    ANN SDoc Instr
  | -- | Location pseudo-op @.loc@ (file, line, col, name)
    LOCATION Int Int Int LexicalFastString
  | -- | Static data spat out during code generation.
    LDATA Section RawCmmStatics
  | -- | Start a new basic block.
    --
    -- Useful during codegen, removed later. Preceding instruction should be a
    -- jump, as per the invariants for a BasicBlock (see Cmm).
    NEWBLOCK BlockId
  | -- | Specify current stack offset for benefit of subsequent passes
    DELTA Int
  | -- | Push a minimal stack frame consisting of the return address (RA) and the frame pointer (FP).
    PUSH_STACK_FRAME
  | -- | Pop the minimal stack frame of prior `PUSH_STACK_FRAME`.
    POP_STACK_FRAME
  | -- | Arithmetic addition (both integer and floating point)
    --
    -- @rd = rs1 + rs2@
    ADD Operand Operand Operand
  | -- | Arithmetic subtraction (both integer and floating point)
    --
    -- @rd = rs1 - rs2@
    SUB Operand Operand Operand
  | -- | Logical AND (integer only)
    --
    -- @rd = rs1 & rs2@
    AND Operand Operand Operand
  | -- | Logical OR (integer only)
    --
    -- @rd = rs1 | rs2@
    OR Operand Operand Operand
  | -- | Logical left shift (zero extened, integer only)
    --
    -- @rd = rs1 << rs2@
    SLL Operand Operand Operand
  | -- | Logical right shift (zero extened, integer only)
    --
    -- @rd = rs1 >> rs2@
    SRL Operand Operand Operand
  | -- | Arithmetic right shift (sign-extened, integer only)
    --
    -- @rd = rs1 >> rs2@
    SRA Operand Operand Operand
  | -- | Store to memory (both, integer and floating point)
    STR Format Operand Operand
  | -- | Load from memory (sign-extended, integer and floating point)
    LDR Format Operand Operand
  | -- | Load from memory (unsigned, integer and floating point)
    LDRU Format Operand Operand
  | -- | Arithmetic multiplication (both, integer and floating point)
    --
    -- @rd = rn × rm@
    MUL Operand Operand Operand
  | -- | Negation (both, integer and floating point)
    --
    -- @rd = -op2@
    NEG Operand Operand
  | -- | Division (both, integer and floating point)
    --
    -- @rd = rn ÷ rm@
    DIV Operand Operand Operand
  | -- | Remainder (integer only, signed)
    --
    -- @rd = rn % rm@
    REM Operand Operand Operand --
  | -- | Remainder (integer only, unsigned)
    --
    -- @rd = |rn % rm|@
    REMU Operand Operand Operand
  | -- | High part of a multiplication that doesn't fit into 64bits (integer only)
    --
    -- E.g. for a multiplication with 64bits width: @rd = (rs1 * rs2) >> 64@.
    MULH Operand Operand Operand
  | -- | Unsigned division (integer only)
    --
    -- @rd = |rn ÷ rm|@
    DIVU Operand Operand Operand
  | -- | XOR (integer only)
    --
    -- @rd = rn ⊕ op2@
    XOR Operand Operand Operand
  | -- | ORI with immediate (integer only)
    --
    -- @rd = rn | op2@
    ORI Operand Operand Operand
  | -- | OR with immediate (integer only)
    --
    -- @rd = rn ⊕ op2@
    XORI Operand Operand Operand
  | -- | Move to register (integer and floating point)
    --
    -- @rd = rn@  or  @rd = #imm@
    MOV Operand Operand
  | -- | Pseudo-op for conditional setting of a register.
    --
    -- @if(o2 cond o3) op <- 1 else op <- 0@
    CSET Operand Operand Operand Cond
    -- | Like B, but only used for non-local jumps. Used to distinguish genJumps from others.
  | J Target
  | -- | A jump instruction with data for switch/jump tables
    J_TBL [Maybe BlockId] (Maybe CLabel) Reg
  | -- | Unconditional jump (no linking)
    B Target
  | -- | Unconditional jump, links return address (sets @ra@/@x1@)
    BL Reg [Reg]
  | -- | branch with condition (integer only)
    BCOND Cond Operand Operand Target
  | -- | Fence instruction
    --
    -- Memory barrier.
    FENCE FenceType FenceType
  | -- | Floating point conversion
    FCVT FcvtVariant Operand Operand
  | -- | Floating point ABSolute value
    FABS Operand Operand

  | -- | Min
    -- dest = min(r1)
    FMIN Operand Operand Operand
  | -- | Max
    FMAX Operand Operand Operand

  | -- | Floating-point fused multiply-add instructions
    --
    -- - fmadd : d =   r1 * r2 + r3
    -- - fnmsub: d =   r1 * r2 - r3
    -- - fmsub : d = - r1 * r2 + r3
    -- - fnmadd: d = - r1 * r2 - r3
    FMA FMASign Operand Operand Operand Operand

-- | Operand of a FENCE instruction (@r@, @w@ or @rw@)
data FenceType = FenceRead | FenceWrite | FenceReadWrite

-- | Variant of a floating point conversion instruction
data FcvtVariant = FloatToFloat | IntToFloat | FloatToInt

instrCon :: Instr -> String
instrCon i =
  case i of
    COMMENT {} -> "COMMENT"
    MULTILINE_COMMENT {} -> "COMMENT"
    ANN {} -> "ANN"
    LOCATION {} -> "LOCATION"
    LDATA {} -> "LDATA"
    NEWBLOCK {} -> "NEWBLOCK"
    DELTA {} -> "DELTA"
    PUSH_STACK_FRAME {} -> "PUSH_STACK_FRAME"
    POP_STACK_FRAME {} -> "POP_STACK_FRAME"
    ADD {} -> "ADD"
    OR {} -> "OR"
    MUL {} -> "MUL"
    NEG {} -> "NEG"
    DIV {} -> "DIV"
    REM {} -> "REM"
    REMU {} -> "REMU"
    MULH {} -> "MULH"
    SUB {} -> "SUB"
    DIVU {} -> "DIVU"
    AND {} -> "AND"
    SRA {} -> "SRA"
    XOR {} -> "XOR"
    SLL {} -> "SLL"
    SRL {} -> "SRL"
    MOV {} -> "MOV"
    ORI {} -> "ORI"
    XORI {} -> "ORI"
    STR {} -> "STR"
    LDR {} -> "LDR"
    LDRU {} -> "LDRU"
    CSET {} -> "CSET"
    J_TBL {} -> "J_TBL"
    J {} -> "J"
    B {} -> "B"
    BL {} -> "BL"
    BCOND {} -> "BCOND"
    FENCE {} -> "FENCE"
    FCVT {} -> "FCVT"
    FABS {} -> "FABS"
    FMIN {} -> "FMIN"
    FMAX {} -> "FMAX"
    FMA variant _ _ _ _ ->
      case variant of
        FMAdd -> "FMADD"
        FMSub -> "FMSUB"
        FNMAdd -> "FNMADD"
        FNMSub -> "FNMSUB"

data Target
  = TBlock BlockId
  | TReg Reg

data Operand
  = -- | register
    OpReg Width Reg
  | -- | immediate value
    OpImm Imm
  | -- | memory reference
    OpAddr AddrMode
  deriving (Eq, Show)

operandFromReg :: Reg -> Operand
operandFromReg = OpReg W64

operandFromRegNo :: RegNo -> Operand
operandFromRegNo = operandFromReg . regSingle

zero, ra, sp, gp, tp, fp, tmp :: Operand
zero = operandFromReg zeroReg
ra = operandFromReg raReg
sp = operandFromReg spMachReg
gp = operandFromRegNo 3
tp = operandFromRegNo 4
fp = operandFromRegNo 8
tmp = operandFromReg tmpReg

x0, x1, x2, x3, x4, x5, x6, x7 :: Operand
x8, x9, x10, x11, x12, x13, x14, x15 :: Operand
x16, x17, x18, x19, x20, x21, x22, x23 :: Operand
x24, x25, x26, x27, x28, x29, x30, x31 :: Operand
x0 = operandFromRegNo x0RegNo
x1 = operandFromRegNo 1
x2 = operandFromRegNo 2
x3 = operandFromRegNo 3
x4 = operandFromRegNo 4
x5 = operandFromRegNo x5RegNo
x6 = operandFromRegNo 6
x7 = operandFromRegNo x7RegNo

x8 = operandFromRegNo 8

x9 = operandFromRegNo 9

x10 = operandFromRegNo x10RegNo

x11 = operandFromRegNo 11

x12 = operandFromRegNo 12

x13 = operandFromRegNo 13

x14 = operandFromRegNo 14

x15 = operandFromRegNo 15

x16 = operandFromRegNo 16

x17 = operandFromRegNo x17RegNo

x18 = operandFromRegNo 18

x19 = operandFromRegNo 19

x20 = operandFromRegNo 20

x21 = operandFromRegNo 21

x22 = operandFromRegNo 22

x23 = operandFromRegNo 23

x24 = operandFromRegNo 24

x25 = operandFromRegNo 25

x26 = operandFromRegNo 26

x27 = operandFromRegNo 27

x28 = operandFromRegNo x28RegNo

x29 = operandFromRegNo 29

x30 = operandFromRegNo 30

x31 = operandFromRegNo x31RegNo

d0, d1, d2, d3, d4, d5, d6, d7 :: Operand
d8, d9, d10, d11, d12, d13, d14, d15 :: Operand
d16, d17, d18, d19, d20, d21, d22, d23 :: Operand
d24, d25, d26, d27, d28, d29, d30, d31 :: Operand
d0 = operandFromRegNo d0RegNo
d1 = operandFromRegNo 33
d2 = operandFromRegNo 34
d3 = operandFromRegNo 35
d4 = operandFromRegNo 36
d5 = operandFromRegNo 37
d6 = operandFromRegNo 38
d7 = operandFromRegNo d7RegNo

d8 = operandFromRegNo 40

d9 = operandFromRegNo 41

d10 = operandFromRegNo d10RegNo

d11 = operandFromRegNo 43

d12 = operandFromRegNo 44

d13 = operandFromRegNo 45

d14 = operandFromRegNo 46

d15 = operandFromRegNo 47

d16 = operandFromRegNo 48

d17 = operandFromRegNo d17RegNo

d18 = operandFromRegNo 50

d19 = operandFromRegNo 51

d20 = operandFromRegNo 52

d21 = operandFromRegNo 53

d22 = operandFromRegNo 54

d23 = operandFromRegNo 55

d24 = operandFromRegNo 56

d25 = operandFromRegNo 57

d26 = operandFromRegNo 58

d27 = operandFromRegNo 59

d28 = operandFromRegNo 60

d29 = operandFromRegNo 61

d30 = operandFromRegNo 62

d31 = operandFromRegNo d31RegNo

fitsIn12bitImm :: (Num a, Ord a) => a -> Bool
fitsIn12bitImm off = off >= intMin12bit && off <= intMax12bit

intMin12bit :: (Num a) => a
intMin12bit = -2048

intMax12bit :: (Num a) => a
intMax12bit = 2047

fitsIn32bits :: (Num a, Ord a, Bits a) => a -> Bool
fitsIn32bits i = (-1 `shiftL` 31) <= i && i <= (1 `shiftL` 31 - 1)

isNbitEncodeable :: Int -> Integer -> Bool
isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)

isEncodeableInWidth :: Width -> Integer -> Bool
isEncodeableInWidth = isNbitEncodeable . widthInBits

isIntOp :: Operand -> Bool
isIntOp = not . isFloatOp

isFloatOp :: Operand -> Bool
isFloatOp (OpReg _ reg) | isFloatReg reg = True
isFloatOp _ = False

isFloatReg :: Reg -> Bool
isFloatReg (RegReal (RealRegSingle i)) | i > 31 = True
isFloatReg (RegVirtual (VirtualRegD _)) = True
isFloatReg _ = False