{-# language GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
module GHC.CmmToAsm.AArch64.CodeGen (
      cmmTopCodeGen
    , generateJumpTableForInstr
    , makeFarBranches
)

where

-- NCG stuff:
import GHC.Prelude hiding (EQ)

import Data.Word

import GHC.Platform.Regs
import GHC.CmmToAsm.AArch64.Instr
import GHC.CmmToAsm.AArch64.Regs
import GHC.CmmToAsm.AArch64.Cond

import GHC.CmmToAsm.CPrim
import GHC.Cmm.DebugBlock
import GHC.CmmToAsm.Monad
   ( NatM, getNewRegNat
   , getPicBaseMaybeNat, getPlatform, getConfig
   , getDebugBlock, getFileId
   )
-- import GHC.CmmToAsm.Instr
import GHC.CmmToAsm.PIC
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Config
import GHC.CmmToAsm.Types
import GHC.Platform.Reg
import GHC.Platform

-- Our intermediate code:
import GHC.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.Cmm.CLabel
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Graph
import GHC.Types.Tickish ( GenTickish(..) )
import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )
import GHC.Types.Unique.Supply

-- The rest:
import GHC.Data.OrdList
import GHC.Utils.Outputable

import Control.Monad    ( mapAndUnzipM, foldM )
import Data.Maybe
import GHC.Float

import GHC.Types.Basic
import GHC.Types.ForeignCall
import GHC.Data.FastString
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Monad (mapAccumLM)

-- Note [General layout of an NCG]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- @cmmTopCodeGen@ will be our main entry point to code gen.  Here we'll get
-- @RawCmmDecl@; see GHC.Cmm
--
--   RawCmmDecl = GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
--
--   GenCmmDecl d h g = CmmProc h CLabel [GlobalReg] g
--                    | CmmData Section d
--
-- As a result we want to transform this to a list of @NatCmmDecl@, which is
-- defined @GHC.CmmToAsm.Instr@ as
--
--   type NatCmmDecl statics instr
--        = GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr)
--
-- Thus well' turn
--   GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph
-- into
--   [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) (ListGraph Instr)]
--
-- where @CmmGraph@ is
--
--   type CmmGraph = GenCmmGraph CmmNode
--   data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
--   type CmmBlock = Block CmmNode C C
--
-- and @ListGraph Instr@ is
--
--   newtype ListGraph i = ListGraph [GenBasicBlock i]
--   data GenBasicBlock i = BasicBlock BlockId [i]

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 [GlobalReg]
live CmmGraph
graph) = do
  -- do
  --   traceM $ "-- -------------------------- cmmTopGen (CmmProc) -------------------------- --\n"
  --         ++ showSDocUnsafe (ppr cmm)

  let blocks :: [Block CmmNode C C]
blocks = CmmGraph -> [Block CmmNode C C]
toBlockListEntryFirst CmmGraph
graph
  (nat_blocks,statics) <- (Block CmmNode C C
 -> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr]))
-> [Block CmmNode C C]
-> NatM
     ([[NatBasicBlock Instr]], [[NatCmmDecl RawCmmStatics Instr]])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM Block CmmNode C C
-> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr])
basicBlockCodeGen [Block CmmNode C C]
blocks
  picBaseMb <- getPicBaseMaybeNat

  let proc = LabelMap RawCmmStatics
-> CLabel
-> [GlobalReg]
-> ListGraph Instr
-> NatCmmDecl RawCmmStatics Instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
info CLabel
lab [GlobalReg]
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

  case picBaseMb of
      Just Reg
_picBase -> String -> NatM [NatCmmDecl RawCmmStatics Instr]
forall a. HasCallStack => String -> a
panic String
"AArch64.cmmTopCodeGen: picBase not implemented"
      Maybe Reg
Nothing -> [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return [NatCmmDecl RawCmmStatics Instr]
tops

-- ... or CmmData.
cmmTopCodeGen _cmm :: RawCmmDecl
_cmm@(CmmData Section
sec RawCmmStatics
dat) = do
  -- do
  --   traceM $ "-- -------------------------- cmmTopGen (CmmData) -------------------------- --\n"
  --         ++ showSDocUnsafe (ppr cmm)
  [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Section -> RawCmmStatics -> NatCmmDecl RawCmmStatics Instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec RawCmmStatics
dat] -- 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
  -- do
  --   traceM $ "-- --------------------------- basicBlockCodeGen --------------------------- --\n"
  --         ++ showSDocUnsafe (ppr block)
  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 (
          String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-- --------------------------- 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
  dbg <- getDebugBlock (entryLabel block)
  loc_instrs <- case dblSourceTick =<< dbg of
    Just (SourceNote RealSrcSpan
span (LexicalFastString FastString
name))
      -> do fileId <- FastString -> NatM Int
getFileId (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
span)
            let line = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span; col = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
span
            return $ unitOL $ LOCATION fileId line col (unpackFS name)
    Maybe CmmTickish
_ -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts
  (!tail_instrs,_) <- stmtToInstrs mid_bid 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 run @verifyBasicBlock@ here and inserts
  --      unwinding info. See Ticket 19913
  -- 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 may extract
  -- LDATAs here too (if they are implemented by AArch64 again - See
  -- PPC how to do that.)
  let
        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs

  return (BasicBlock id top : other_blocks, statics)

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 Instr
instr ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl RawCmmStatics h g]
statics)
  = (Instr
instrInstr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:[Instr]
instrs, [NatBasicBlock Instr]
blocks, [GenCmmDecl RawCmmStatics h g]
statics)
-- -----------------------------------------------------------------------------
-- | Utilities
ann :: SDoc -> Instr -> Instr
ann :: SDoc -> Instr -> Instr
ann SDoc
doc Instr
instr {- debugIsOn -} = SDoc -> Instr -> Instr
ANN SDoc
doc Instr
instr
-- ann _ 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 Instr
instr {- debugIsOn -} = SDoc -> Instr -> Instr
ANN (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> (CmmExpr -> String) -> CmmExpr -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmExpr -> String
forall a. Show a => a -> String
show (CmmExpr -> SDoc) -> CmmExpr -> SDoc
forall a b. (a -> b) -> a -> b
$ CmmExpr
e) Instr
instr
-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr
-- annExpr _ instr = instr
{-# INLINE annExpr #-}

-- -----------------------------------------------------------------------------
-- Generating a table-branch

-- TODO jump tables would be a lot faster, but we'll use bare bones for now.
-- this is usually done by sticking the jump table ids into an instruction
-- and then have the @generateJumpTableForInstr@ callback produce the jump
-- table as a static.
--
-- See Ticket 19912
--
-- data SwitchTargets =
--    SwitchTargets
--        Bool                       -- Signed values
--        (Integer, Integer)         -- Range
--        (Maybe Label)              -- Default value
--        (M.Map Integer Label)      -- The branches
--
-- Non Jumptable plan:
-- xE <- expr
--
genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch :: CmmExpr -> SwitchTargets -> NatM (OrdList Instr)
genSwitch CmmExpr
expr SwitchTargets
targets = do -- pprPanic "genSwitch" (ppr expr)
  (reg, format, code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
  let w = Format -> Width
formatToWidth Format
format
  let mkbranch OrdList Instr
acc (Integer
key, BlockId
bid) = do
        (keyReg, _format, code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg (CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
key Width
w))
        return $ code `appOL`
                 toOL [ CMP (OpReg w reg) (OpReg w keyReg)
                      , BCOND EQ (TBlock bid)
                      ] `appOL` acc
      def_code = case SwitchTargets -> Maybe BlockId
switchTargetsDefault SwitchTargets
targets of
        Just BlockId
bid -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Target -> Instr
B (BlockId -> Target
TBlock BlockId
bid))
        Maybe BlockId
Nothing  -> OrdList Instr
forall a. OrdList a
nilOL

  switch_code <- foldM mkbranch nilOL (switchTargetsCases targets)
  return $ code `appOL` switch_code `appOL` def_code

-- We don't do jump tables for now, see Ticket 19912
generateJumpTableForInstr :: NCGConfig -> Instr
  -> Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr NCGConfig
_ Instr
_ = Maybe (NatCmmDecl RawCmmStatics Instr)
forall a. Maybe a
Nothing

-- -----------------------------------------------------------------------------
-- Top-level of the instruction selector

-- See Note [Keeping track of the current block] for why
-- we pass the BlockId.
stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.
              -> [CmmNode O O] -- ^ Cmm Statement
              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction
stmtsToInstrs :: BlockId -> [CmmNode O O] -> NatM (OrdList Instr, BlockId)
stmtsToInstrs BlockId
bid [CmmNode O O]
stmts =
    BlockId
-> [CmmNode O O] -> OrdList Instr -> NatM (OrdList Instr, BlockId)
forall {e :: Extensibility} {x :: Extensibility}.
BlockId
-> [CmmNode e x] -> OrdList Instr -> NatM (OrdList Instr, BlockId)
go BlockId
bid [CmmNode O O]
stmts OrdList Instr
forall a. OrdList a
nilOL
  where
    go :: BlockId
-> [CmmNode e x] -> OrdList Instr -> NatM (OrdList Instr, BlockId)
go BlockId
bid  []        OrdList Instr
instrs = (OrdList Instr, BlockId) -> NatM (OrdList Instr, BlockId)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
instrs,BlockId
bid)
    go BlockId
bid (CmmNode e x
s:[CmmNode e x]
stmts)  OrdList Instr
instrs = do
      (instrs',bid') <- BlockId -> CmmNode e x -> NatM (OrdList Instr, Maybe BlockId)
forall (e :: Extensibility) (x :: Extensibility).
BlockId -> CmmNode e x -> NatM (OrdList Instr, Maybe BlockId)
stmtToInstrs BlockId
bid CmmNode e x
s
      -- If the statement introduced a new block, we use that one
      let !newBid = BlockId -> Maybe BlockId -> BlockId
forall a. a -> Maybe a -> a
fromMaybe BlockId
bid Maybe BlockId
bid'
      go newBid stmts (instrs `appOL` instrs')

-- | `bid` refers to the current block and is used to update the CFG
--   if new blocks are inserted in the control flow.
-- See Note [Keeping track of the current block] for more details.
stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.
             -> CmmNode e x
             -> NatM (InstrBlock, Maybe BlockId)
             -- ^ Instructions, and bid of new block if successive
             -- statements are placed in a different basic block.
stmtToInstrs :: forall (e :: Extensibility) (x :: Extensibility).
BlockId -> CmmNode e x -> NatM (OrdList Instr, Maybe BlockId)
stmtToInstrs BlockId
bid CmmNode e x
stmt = do
  -- traceM $ "-- -------------------------- stmtToInstrs -------------------------- --\n"
  --     ++ showSDocUnsafe (ppr stmt)
  platform <- NatM Platform
getPlatform
  case stmt of
    CmmUnsafeForeignCall ForeignTarget
target [CmmFormal]
result_regs [CmmExpr]
args
       -> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> BlockId
-> NatM (OrdList Instr, Maybe BlockId)
genCCall ForeignTarget
target [CmmFormal]
result_regs [CmmExpr]
args BlockId
bid

    CmmNode e x
_ -> (,Maybe BlockId
forall a. Maybe a
Nothing) (OrdList Instr -> (OrdList Instr, Maybe BlockId))
-> NatM (OrdList Instr) -> NatM (OrdList Instr, Maybe BlockId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case CmmNode e x
stmt of
      CmmComment FastString
s   -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (SDoc -> Instr
COMMENT (FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
s)))
      CmmTick {}     -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL

      CmmAssign CmmReg
reg CmmExpr
src
        | CmmType -> Bool
isFloatType CmmType
ty         -> Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_FltCode Format
format CmmReg
reg CmmExpr
src
        | Bool
otherwise              -> Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_IntCode Format
format CmmReg
reg CmmExpr
src
          where ty :: CmmType
ty = CmmReg -> CmmType
cmmRegType CmmReg
reg
                format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty

      CmmStore CmmExpr
addr CmmExpr
src AlignmentSpec
_alignment
        | CmmType -> Bool
isFloatType CmmType
ty         -> Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_FltCode Format
format CmmExpr
addr CmmExpr
src
        | Bool
otherwise              -> Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_IntCode Format
format CmmExpr
addr CmmExpr
src
          where ty :: CmmType
ty = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
src
                format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty

      CmmBranch 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 -> BlockId -> CmmExpr -> NatM (OrdList Instr)
genCondBranch BlockId
bid BlockId
true BlockId
false CmmExpr
arg

      CmmSwitch CmmExpr
arg SwitchTargets
ids -> CmmExpr -> SwitchTargets -> NatM (OrdList Instr)
genSwitch 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 (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL

      CmmNode e x
_ -> String -> SDoc -> NatM (OrdList Instr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"stmtToInstrs: statement should have been cps'd away" (Platform -> CmmNode e x -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmNode e x
stmt)

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

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

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

-- | Grab the Reg for a CmmReg
getRegisterReg :: Platform -> CmmReg -> Reg

getRegisterReg :: Platform -> CmmReg -> Reg
getRegisterReg Platform
_ (CmmLocal (LocalReg Unique
u CmmType
pk))
  = VirtualReg -> Reg
RegVirtual (VirtualReg -> Reg) -> VirtualReg -> Reg
forall a b. (a -> b) -> a -> b
$ Unique -> Format -> VirtualReg
mkVirtualReg Unique
u (CmmType -> Format
cmmTypeFormat CmmType
pk)

getRegisterReg Platform
platform (CmmGlobal reg :: GlobalRegUse
reg@(GlobalRegUse GlobalReg
mid CmmType
_))
  = case Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe Platform
platform GlobalReg
mid of
        Just RealReg
reg -> RealReg -> Reg
RegReal RealReg
reg
        Maybe RealReg
Nothing  -> String -> SDoc -> Reg
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegisterReg-memory" (CmmReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CmmReg -> SDoc) -> CmmReg -> SDoc
forall a b. (a -> b) -> a -> b
$ GlobalRegUse -> CmmReg
CmmGlobal GlobalRegUse
reg)
        -- By this stage, the only MagicIds remaining should be the
        -- ones which map to a real machine register on this
        -- platform.  Hence if it's not mapped to a registers something
        -- went wrong earlier in the pipeline.
-- | Convert a BlockId to some CmmStatic data
-- TODO: Add JumpTable Logic, see Ticket 19912
-- jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic
-- jumpTableEntry config Nothing   = CmmStaticLit (CmmInt 0 (ncgWordWidth config))
-- jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
--     where blockLabel = blockLbl blockid

-- -----------------------------------------------------------------------------
-- General things for putting together code sequences

-- | The dual to getAnyReg: compute an expression into a register, but
--      we don't mind which one it is.
getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock)
getSomeReg :: CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr = do
  r <- CmmExpr -> NatM Register
getRegister CmmExpr
expr
  case r of
    Any Format
rep Reg -> OrdList Instr
code -> do
        tmp <- Format -> NatM Reg
getNewRegNat Format
rep
        return (tmp, rep, code tmp)
    Fixed Format
rep Reg
reg OrdList Instr
code ->
        (Reg, Format, OrdList Instr) -> NatM (Reg, Format, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg, Format
rep, OrdList Instr
code)

{- Note [Aarch64 immediates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Aarch64 with it's fixed width instruction encoding uses leftover space for
immediates.
If you want the full rundown consult the arch reference document:
"Arm® Architecture Reference Manual" - "C3.4 Data processing - immediate"

The gist of it is that different instructions allow for different immediate encodings.
The ones we care about for better code generation are:

* Simple but potentially repeated bit-patterns for logic instructions.
* 16bit numbers shifted by multiples of 16.
* 12 bit numbers optionally shifted by 12 bits.

It might seem like the ISA allows for 64bit immediates but this isn't the case.
Rather there are some instruction aliases which allow for large unencoded immediates
which will then be transalted to one of the immediate encodings implicitly.

For example mov x1, #0x10000 is allowed but will be assembled to movz x1, #0x1, lsl #16
-}

-- | Move (wide immediate)
-- Allows for 16bit immediate which can be shifted by 0/16/32/48 bits.
-- Used with MOVZ,MOVN, MOVK
-- See Note [Aarch64 immediates]
getMovWideImm :: Integer -> Width -> Maybe Operand
getMovWideImm :: Integer -> Width -> Maybe Operand
getMovWideImm Integer
n Width
w
  -- TODO: Handle sign extension/negatives
  | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0
  = Maybe Operand
forall a. Maybe a
Nothing
  -- Fits in 16 bits
  | Word64
sized_n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
2Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
16 :: Int)
  = Operand -> Maybe Operand
forall a. a -> Maybe a
Just (Operand -> Maybe Operand) -> Operand -> Maybe Operand
forall a b. (a -> b) -> a -> b
$ Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
truncated)

  -- 0x0000 0000 xxxx 0000
  | Int
trailing_zeros Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
16 Bool -> Bool -> Bool
&& Word64
sized_n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
2Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
32 :: Int)
  = Operand -> Maybe Operand
forall a. a -> Maybe a
Just (Operand -> Maybe Operand) -> Operand -> Maybe Operand
forall a b. (a -> b) -> a -> b
$ Imm -> ShiftMode -> Int -> Operand
OpImmShift (Integer -> Imm
ImmInteger (Integer -> Imm) -> Integer -> Imm
forall a b. (a -> b) -> a -> b
$ Integer
truncated Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) ShiftMode
SLSL Int
16

  -- 0x 0000 xxxx 0000 0000
  | Int
trailing_zeros Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
32 Bool -> Bool -> Bool
&& Word64
sized_n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
2Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
48 :: Int)
  = Operand -> Maybe Operand
forall a. a -> Maybe a
Just (Operand -> Maybe Operand) -> Operand -> Maybe Operand
forall a b. (a -> b) -> a -> b
$ Imm -> ShiftMode -> Int -> Operand
OpImmShift (Integer -> Imm
ImmInteger (Integer -> Imm) -> Integer -> Imm
forall a b. (a -> b) -> a -> b
$ Integer
truncated Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
32) ShiftMode
SLSL Int
32

  -- 0x xxxx 0000 0000 0000
  | Int
trailing_zeros Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
48
  = Operand -> Maybe Operand
forall a. a -> Maybe a
Just (Operand -> Maybe Operand) -> Operand -> Maybe Operand
forall a b. (a -> b) -> a -> b
$ Imm -> ShiftMode -> Int -> Operand
OpImmShift (Integer -> Imm
ImmInteger (Integer -> Imm) -> Integer -> Imm
forall a b. (a -> b) -> a -> b
$ Integer
truncated Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
48) ShiftMode
SLSL Int
48

  | Bool
otherwise
  = Maybe Operand
forall a. Maybe a
Nothing
  where
    truncated :: Integer
truncated = Width -> Integer -> Integer
narrowU Width
w Integer
n
    sized_n :: Word64
sized_n = Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
truncated :: Word64
    trailing_zeros :: Int
trailing_zeros = Word64 -> Int
forall b. FiniteBits b => b -> Int
countTrailingZeros Word64
sized_n

-- | Arithmetic(immediate)
--  Allows for 12bit immediates which can be shifted by 0 or 12 bits.
-- Used with ADD, ADDS, SUB, SUBS, CMP
-- See Note [Aarch64 immediates]
getArithImm :: Integer -> Width -> Maybe Operand
getArithImm :: Integer -> Width -> Maybe Operand
getArithImm Integer
n Width
w
  -- TODO: Handle sign extension
  | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0
  = Maybe Operand
forall a. Maybe a
Nothing
  -- Fits in 16 bits
  -- Fits in 12 bits
  | Word64
sized_n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
2Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
12::Int)
  = Operand -> Maybe Operand
forall a. a -> Maybe a
Just (Operand -> Maybe Operand) -> Operand -> Maybe Operand
forall a b. (a -> b) -> a -> b
$ Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
truncated)

  -- 12 bits shifted by 12 places.
  | Int
trailing_zeros Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
12 Bool -> Bool -> Bool
&& Word64
sized_n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
2Word64 -> Int -> Word64
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
24::Int)
  = Operand -> Maybe Operand
forall a. a -> Maybe a
Just (Operand -> Maybe Operand) -> Operand -> Maybe Operand
forall a b. (a -> b) -> a -> b
$ Imm -> ShiftMode -> Int -> Operand
OpImmShift (Integer -> Imm
ImmInteger (Integer -> Imm) -> Integer -> Imm
forall a b. (a -> b) -> a -> b
$ Integer
truncated Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
12) ShiftMode
SLSL Int
12

  | Bool
otherwise
  = Maybe Operand
forall a. Maybe a
Nothing
  where
    sized_n :: Word64
sized_n = Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
truncated :: Word64
    truncated :: Integer
truncated = Width -> Integer -> Integer
narrowU Width
w Integer
n
    trailing_zeros :: Int
trailing_zeros = Word64 -> Int
forall b. FiniteBits b => b -> Int
countTrailingZeros Word64
sized_n

-- |  Logical (immediate)
-- Allows encoding of some repeated bitpatterns
-- Used with AND, EOR, ORR
-- and their aliases which includes at least MOV (bitmask immediate)
-- See Note [Aarch64 immediates]
getBitmaskImm :: Integer -> Width -> Maybe Operand
getBitmaskImm :: Integer -> Width -> Maybe Operand
getBitmaskImm Integer
n Width
w
  | Width -> Integer -> Bool
isAArch64Bitmask (Width -> Width
opRegWidth Width
w) Integer
truncated = Operand -> Maybe Operand
forall a. a -> Maybe a
Just (Operand -> Maybe Operand) -> Operand -> Maybe Operand
forall a b. (a -> b) -> a -> b
$ Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
truncated)
  | Bool
otherwise = Maybe Operand
forall a. Maybe a
Nothing
  where
    truncated :: Integer
truncated = Width -> Integer -> Integer
narrowU Width
w Integer
n

-- | Load/store immediate.
-- Depends on the width of the store to some extent.
isOffsetImm :: Int -> Width -> Bool
isOffsetImm :: Int -> Width -> Bool
isOffsetImm Int
off Width
w
  -- 8 bits + sign for unscaled offsets
  | -Int
256 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
off, Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
255 = Bool
True
  -- Offset using 12-bit positive immediate, scaled by width
  -- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4
  -- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8
  -- 16-bit: 0 .. 8188, 8-bit: 0 -- 4095
  | Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
off, Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
4096 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
byte_width, Int
off Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
byte_width Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Bool
True
  | Bool
otherwise = Bool
False
  where
    byte_width :: Int
byte_width = Width -> Int
widthInBytes Width
w




-- TODO OPT: we might be able give getRegister
--          a hint, what kind of register we want.
getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock)
getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
expr = do
  r <- CmmExpr -> NatM Register
getRegister CmmExpr
expr
  case r of
    Any Format
rep Reg -> OrdList Instr
code | Format -> Bool
isFloatFormat Format
rep -> do
      tmp <- Format -> NatM Reg
getNewRegNat Format
rep
      return (tmp, rep, code tmp)
    Any Format
II32 Reg -> OrdList Instr
code -> do
      tmp <- Format -> NatM Reg
getNewRegNat Format
FF32
      return (tmp, FF32, code tmp)
    Any Format
II64 Reg -> OrdList Instr
code -> do
      tmp <- Format -> NatM Reg
getNewRegNat Format
FF64
      return (tmp, FF64, code tmp)
    Any Format
_w Reg -> OrdList Instr
_code -> do
      config <- NatM NCGConfig
getConfig
      pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr)
    -- can't do much for fixed.
    Fixed Format
rep Reg
reg OrdList Instr
code ->
      (Reg, Format, OrdList Instr) -> NatM (Reg, Format, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg, Format
rep, OrdList Instr
code)

-- TODO: TODO, bounds. We can't put any immediate
-- value in. They are constrained.
-- See Ticket 19911
litToImm' :: CmmLit -> NatM (Operand, InstrBlock)
litToImm' :: CmmLit -> NatM (Operand, OrdList Instr)
litToImm' CmmLit
lit = (Operand, OrdList Instr) -> NatM (Operand, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Imm -> Operand
OpImm (CmmLit -> Imm
litToImm CmmLit
lit), OrdList Instr
forall a. OrdList a
nilOL)

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  -- x
opRegWidth Width
W32 = Width
W32  -- w
opRegWidth Width
W16 = Width
W32  -- w
opRegWidth Width
W8  = Width
W32  -- w
opRegWidth Width
w   = String -> SDoc -> Width
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"opRegWidth" (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"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 AArch64]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Handling signed arithmetic on sub-word-size values on AArch64 is a bit
-- tricky as Cmm's type system does not capture signedness. While 32-bit values
-- are fairly easy to handle due to AArch64'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.
--
-- TODO:
--   Don't use Width in Operands
--   Instructions should rather carry a RegWidth
--
-- Note [Handling PIC on AArch64]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- AArch64 does not have a special PIC register, the general approach is to
-- simply go through the GOT, and there is assembly support for this:
--
--   // Load the address of 'sym' from the GOT using ADRP and LDR (used for
--   // position-independent code on AArch64):
--   adrp x0, #:got:sym
--   ldr x0, [x0, #:got_lo12:sym]
--
-- See also: https://developer.arm.com/documentation/dui0774/i/armclang-integrated-assembler-directives/assembly-expressions
--
-- 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 AArch64. 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
_))
      -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegisterReg-memory" (GlobalReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr (GlobalReg -> SDoc) -> GlobalReg -> SDoc
forall a b. (a -> b) -> a -> b
$ GlobalReg
PicBaseReg)
    CmmLit CmmLit
lit
      -> case CmmLit
lit of

        -- Use wzr xzr for CmmInt 0 if the width matches up, otherwise do a move.
        -- TODO: Reenable after https://gitlab.haskell.org/ghc/ghc/-/issues/23632 is fixed.
        -- CmmInt 0 W32 -> do
        --   let format = intFormat W32
        --   return (Fixed format reg_zero (unitOL $ (COMMENT ((text . show $ expr))) ))
        -- CmmInt 0 W64 -> do
        --   let format = intFormat W64
        --   return (Fixed format reg_zero (unitOL $ (COMMENT ((text . show $ expr))) ))
        CmmInt Integer
i Width
W8 | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 -> do
          Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
W8) (\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
W8 Reg
dst) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger (Width -> Integer -> Integer
narrowU Width
W8 Integer
i))))))
        CmmInt Integer
i Width
W16 | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 -> do
          Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
W16) (\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
W16 Reg
dst) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger (Width -> Integer -> Integer
narrowU Width
W16 Integer
i))))))

        CmmInt Integer
i Width
W8  -> do
          Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
W8) (\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
W8 Reg
dst) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger (Width -> Integer -> Integer
narrowU Width
W8 Integer
i))))))
        CmmInt Integer
i Width
W16 -> do
          Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
W16) (\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
W16 Reg
dst) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger (Width -> Integer -> Integer
narrowU Width
W16 Integer
i))))))

        -- We need to be careful to not shorten this for negative literals.
        -- Those need the upper bits set. We'd either have to explicitly sign
        -- or figure out something smarter. Lowered to
        -- `MOV dst XZR`
        CmmInt Integer
i Width
w | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0
                   , Just Operand
imm_op <- Integer -> Width -> Maybe Operand
getMovWideImm Integer
i Width
w -> do
          Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Instr
MOVZ (Width -> Reg -> Operand
OpReg Width
w Reg
dst) Operand
imm_op)))

        CmmInt Integer
i Width
w | Int -> Integer -> Bool
isNbitEncodeable Int
16 Integer
i, Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 -> do
          Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W16 Reg
dst) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
i)))))

        CmmInt Integer
i Width
w | Int -> Integer -> Bool
isNbitEncodeable Int
32 Integer
i, Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 -> do
          let  half0 :: Int
half0 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Word16)
               half1 :: Int
half1 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) :: Word16)
          Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
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
dst) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
half0))
                                                  , Operand -> Operand -> Instr
MOVK (Width -> Reg -> Operand
OpReg Width
W32 Reg
dst) (Imm -> ShiftMode -> Int -> Operand
OpImmShift (Int -> Imm
ImmInt Int
half1) ShiftMode
SLSL Int
16)
                                                  ]))
        -- fallback for W32
        CmmInt Integer
i Width
W32 -> do
          let  half0 :: Int
half0 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Word16)
               half1 :: Int
half1 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) :: Word16)
          Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
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
dst) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
half0))
                                                    , Operand -> Operand -> Instr
MOVK (Width -> Reg -> Operand
OpReg Width
W32 Reg
dst) (Imm -> ShiftMode -> Int -> Operand
OpImmShift (Int -> Imm
ImmInt Int
half1) ShiftMode
SLSL Int
16)
                                                    ]))
        -- anything else
        CmmInt Integer
i Width
W64 -> do
          let  half0 :: Int
half0 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Word16)
               half1 :: Int
half1 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) :: Word16)
               half2 :: Int
half2 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
32) :: Word16)
               half3 :: Int
half3 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
48) :: Word16)
          Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
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
dst) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
half0))
                                                    , Operand -> Operand -> Instr
MOVK (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Imm -> ShiftMode -> Int -> Operand
OpImmShift (Int -> Imm
ImmInt Int
half1) ShiftMode
SLSL Int
16)
                                                    , Operand -> Operand -> Instr
MOVK (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Imm -> ShiftMode -> Int -> Operand
OpImmShift (Int -> Imm
ImmInt Int
half2) ShiftMode
SLSL Int
32)
                                                    , Operand -> Operand -> Instr
MOVK (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Imm -> ShiftMode -> Int -> Operand
OpImmShift (Int -> Imm
ImmInt Int
half3) ShiftMode
SLSL Int
48)
                                                    ]))
        CmmInt Integer
_i Width
rep -> do
          (op, imm_code) <- CmmLit -> NatM (Operand, OrdList Instr)
litToImm' CmmLit
lit
          return (Any (intFormat rep) (\Reg
dst -> OrdList Instr
imm_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
rep Reg
dst) Operand
op)))

        -- floatToBytes (fromRational f)
        CmmFloat Rational
0 Width
w   -> do
          (op, imm_code) <- CmmLit -> NatM (Operand, OrdList Instr)
litToImm' CmmLit
lit
          return (Any (floatFormat w) (\Reg
dst -> OrdList Instr
imm_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` 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  -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"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 -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"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
              half0 :: Int
half0 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
word :: Word16)
              half1 :: Int
half1 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
word Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) :: Word16)
          tmp <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
W32)
          return (Any (floatFormat W32) (\Reg
dst -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr
                                                      (Instr -> Instr) -> Instr -> Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W32 Reg
tmp) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
half0))
                                                      , Operand -> Operand -> Instr
MOVK (Width -> Reg -> Operand
OpReg Width
W32 Reg
tmp) (Imm -> ShiftMode -> Int -> Operand
OpImmShift (Int -> Imm
ImmInt Int
half1) ShiftMode
SLSL Int
16)
                                                      , Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W32 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W32 Reg
tmp)
                                                      ]))
        CmmFloat Rational
f Width
W64 -> do
          let word :: Word64
word = Double -> Word64
castDoubleToWord64 (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
f) :: Word64
              half0 :: Int
half0 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
word :: Word16)
              half1 :: Int
half1 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
word Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) :: Word16)
              half2 :: Int
half2 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
word Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32) :: Word16)
              half3 :: Int
half3 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
word Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
48) :: Word16)
          tmp <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
W64)
          return (Any (floatFormat W64) (\Reg
dst -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr
                                                      (Instr -> Instr) -> Instr -> Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
half0))
                                                      , Operand -> Operand -> Instr
MOVK (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp) (Imm -> ShiftMode -> Int -> Operand
OpImmShift (Int -> Imm
ImmInt Int
half1) ShiftMode
SLSL Int
16)
                                                      , Operand -> Operand -> Instr
MOVK (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp) (Imm -> ShiftMode -> Int -> Operand
OpImmShift (Int -> Imm
ImmInt Int
half2) ShiftMode
SLSL Int
32)
                                                      , Operand -> Operand -> Instr
MOVK (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp) (Imm -> ShiftMode -> Int -> Operand
OpImmShift (Int -> Imm
ImmInt Int
half3) ShiftMode
SLSL Int
48)
                                                      , Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp)
                                                      ]))
        CmmFloat Rational
_f Width
_w -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"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]
_ -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmVec): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmLabel CLabel
_lbl -> do
          (op, imm_code) <- CmmLit -> NatM (Operand, OrdList Instr)
litToImm' CmmLit
lit
          let rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
plat CmmLit
lit
              format = CmmType -> Format
cmmTypeFormat CmmType
rep
          return (Any format (\Reg
dst -> OrdList Instr
imm_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Instr -> Instr) -> Instr -> 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 | Int -> Integer -> Bool
isNbitEncodeable Int
12 (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) -> do
          (op, imm_code) <- CmmLit -> NatM (Operand, OrdList Instr)
litToImm' CmmLit
lit
          let rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
plat CmmLit
lit
              format = CmmType -> Format
cmmTypeFormat CmmType
rep
          return (Any format (\Reg
dst -> OrdList Instr
imm_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))

        CmmLabelOff CLabel
lbl Int
off -> do
          (op, imm_code) <- CmmLit -> NatM (Operand, OrdList Instr)
litToImm' (CLabel -> CmmLit
CmmLabel CLabel
lbl)
          let rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
plat CmmLit
lit
              format = CmmType -> Format
cmmTypeFormat CmmType
rep
              width = CmmType -> Width
typeWidth CmmType
rep
          (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width)
          return (Any format (\Reg
dst -> OrdList Instr
imm_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` 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 CLabel
_ CLabel
_ Int
_ Width
_ -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmLabelOff): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmBlock BlockId
_ -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmLabelOff): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmLit
CmmHighStackMark -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"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
      Amode addr addr_code <- Platform -> Width -> CmmExpr -> NatM Amode
getAmode Platform
plat (CmmType -> Width
typeWidth CmmType
rep) CmmExpr
mem
      let format = CmmType -> Format
cmmTypeFormat CmmType
rep
      return (Any format (\Reg
dst -> OrdList Instr
addr_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) (AddrMode -> Operand
OpAddr AddrMode
addr)))
    CmmStackSlot Area
_ Int
_
      -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"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 ->
      -- If we got here we will load the address into a register either way. So we might as well just expand
      -- and re-use the existing code path to handle "reg + off".
      let !width :: Width
width = CmmReg -> Width
cmmRegWidth CmmReg
reg
      in NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat (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)])

    -- for MachOps, see GHC.Cmm.MachOp
    -- For CmmMachOp, see GHC.Cmm.Expr

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

    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`
                Operand -> Operand -> Instr
MVN (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 -- See Note [Signed arithmetic on AArch64]

        MO_S_Neg Width
w -> OrdList Instr -> Width -> Reg -> NatM Register
negate OrdList Instr
code Width
w Reg
reg
        MO_F_Neg Width
w -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
w) (\Reg
dst -> OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
NEG (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg))

        MO_SF_Conv Width
from Width
to -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
to) (\Reg
dst -> OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
SCVTF (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))  -- (Signed ConVerT Float)
        MO_FS_Conv Width
from Width
to -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) (\Reg
dst -> OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
FCVTZS (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg)) -- (float convert (-> zero) signed)

        -- TODO this is very hacky
        -- Note, UBFM and SBFM expect source and target register to be of the same size, so we'll use @max from to@
        -- UBFM will set the high bits to 0. SBFM will copy the sign (sign extend).
        MO_UU_Conv Width
from Width
to -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) (\Reg
dst -> OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Operand -> Operand -> Instr
UBFM (Width -> Reg -> Operand
OpReg (Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
from Width
to) Reg
dst) (Width -> Reg -> Operand
OpReg (Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
from Width
to) Reg
reg) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)) (Width -> Operand
toImm (Width -> Width -> Width
forall a. Ord a => a -> a -> a
min Width
from Width
to)))
        MO_SS_Conv Width
from Width
to -> Width -> Width -> Reg -> OrdList Instr -> NatM Register
forall {m :: * -> *}.
Monad m =>
Width -> Width -> Reg -> OrdList Instr -> m Register
ss_conv Width
from Width
to Reg
reg OrdList Instr
code
        MO_FF_Conv Width
from Width
to -> Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
to) (\Reg
dst -> OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
FCVT (Width -> Reg -> Operand
OpReg Width
to Reg
dst) (Width -> Reg -> Operand
OpReg Width
from Reg
reg))

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

        MachOp
_ -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (monadic CmmMachOp):" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
      where
        toImm :: Width -> Operand
toImm Width
W8 =  (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
7))
        toImm Width
W16 = (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
15))
        toImm Width
W32 = (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
31))
        toImm Width
W64 = (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
63))
        toImm Width
W128 = (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
127))
        toImm Width
W256 = (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
255))
        toImm Width
W512 = (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
511))

        -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits
        -- See Note [Signed arithmetic on AArch64].
        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 -> m Register
ss_conv Width
from Width
to Reg
reg OrdList Instr
code =
            let w' :: Width
w' = Width -> Width
opRegWidth (Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
from Width
to)
            in Register -> m Register
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> m Register) -> Register -> m Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) ((Reg -> OrdList Instr) -> Register)
-> (Reg -> OrdList Instr) -> Register
forall a b. (a -> b) -> a -> b
$ \Reg
dst ->
                OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                Operand -> Operand -> Operand -> Operand -> Instr
SBFM (Width -> Reg -> Operand
OpReg Width
w' Reg
dst) (Width -> Reg -> Operand
OpReg Width
w' Reg
reg) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)) (Width -> Operand
toImm (Width -> Width -> Width
forall a. Ord a => a -> a -> a
min Width
from Width
to)) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                -- At this point an 8- or 16-bit value would be sign-extended
                -- to 32-bits. Truncate back down the final width.
                Width -> Width -> Reg -> OrdList Instr
truncateReg Width
w' Width
to Reg
dst

    -- Dyadic machops:
    --
    -- The general idea is:
    -- compute x<i> <- x
    -- compute x<j> <- y
    -- OP x<r>, x<i>, x<j>
    --
    -- TODO: for now we'll only implement the 64bit versions. And rely on the
    --      fallthrough to alert us if things go wrong!
    -- OPTIMIZATION WARNING: Dyadic CmmMachOp destructuring
    -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg
    CmmMachOp (MO_Add Width
_) [expr' :: CmmExpr
expr'@(CmmReg (CmmGlobal GlobalRegUse
_r)), CmmLit (CmmInt Integer
0 Width
_)] -> NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat CmmExpr
expr'
    CmmMachOp (MO_Sub Width
_) [expr' :: CmmExpr
expr'@(CmmReg (CmmGlobal GlobalRegUse
_r)), CmmLit (CmmInt Integer
0 Width
_)] -> NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat CmmExpr
expr'
    -- Immediates are handled via `getArithImm` in the generic code path.

    CmmMachOp (MO_U_Quot Width
w) [CmmExpr
x, CmmExpr
y] | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 -> 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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Instr
UXTB (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x)) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                                                        (Operand -> Operand -> Instr
UXTB (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y)) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                                                        (Operand -> Operand -> Operand -> Instr
UDIV (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_Quot Width
w) [CmmExpr
x, CmmExpr
y] | 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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Instr
UXTH (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x)) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                                                        (Operand -> Operand -> Instr
UXTH (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y)) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                                                        (Operand -> Operand -> Operand -> Instr
UDIV (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 Bool -> Bool -> Bool
|| 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
< Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Int
widthInBits Width
w) -> do
      (reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      return $ Any (intFormat w) (\Reg
dst -> OrdList Instr
code_x OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
LSL (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, (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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Operand -> Instr
SBFX (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)) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger (Integer
8Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
n)))))
    CmmMachOp (MO_S_Shr Width
w) [CmmExpr
x, CmmExpr
y] | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W8 -> 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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Instr
SXTB (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x)) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                                                         (Operand -> Operand -> Operand -> Instr
ASR (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_S_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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Operand -> Instr
SBFX (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)) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger (Integer
16Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-Integer
n)))))
    CmmMachOp (MO_S_Shr Width
w) [CmmExpr
x, CmmExpr
y] | 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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Instr
SXTH (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x)) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                                                         (Operand -> Operand -> Operand -> Instr
ASR (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_S_Shr Width
w) [CmmExpr
x, (CmmLit (CmmInt Integer
n Width
_))]
      | 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
      , Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n, Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Int
widthInBits Width
w) -> do
      (reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      return $ Any (intFormat w) (\Reg
dst -> OrdList Instr
code_x OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ASR (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
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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Operand -> Instr
UBFX (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)) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger (Integer
8Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-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 -> 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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Instr
UXTB (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x)) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                                                        (Operand -> Operand -> Operand -> Instr
ASR (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
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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Operand -> Instr
UBFX (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)) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger (Integer
16Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
-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
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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Instr
UXTH (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x))
                                                                OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` (Operand -> Operand -> Operand -> Instr
ASR (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 Bool -> Bool -> Bool
|| 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
< Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Width -> Int
widthInBits Width
w) -> do
      (reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      return $ Any (intFormat w) (\Reg
dst -> OrdList Instr
code_x OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
LSR (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
_)] | Width -> Integer -> Bool
isAArch64Bitmask (Width -> Width
opRegWidth Width
w') (Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral 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
_)] | Width -> Integer -> Bool
isAArch64Bitmask (Width -> Width
opRegWidth Width
w') (Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral 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
ORR (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
      -- alright, so we have an operation, and two expressions. And we want to essentially do
      -- ensure we get float regs (TODO(Ben): What?)
      let withTempIntReg :: Width -> (Operand -> NatM b) -> NatM b
withTempIntReg Width
w Operand -> NatM b
op = Width -> Reg -> Operand
OpReg Width
w (Reg -> Operand) -> NatM Reg -> NatM Operand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
w) NatM Operand -> (Operand -> NatM b) -> NatM b
forall a b. NatM a -> (a -> NatM b) -> NatM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Operand -> NatM b
op
          -- withTempFloatReg w op = OpReg w <$> getNewRegNat (floatFormat w) >>= op

          -- A "plain" operation.
          bitOpImm :: Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> (Integer -> Width -> Maybe Operand)
-> NatM Register
bitOpImm Width
w Operand -> Operand -> Operand -> OrdList Instr
op Integer -> Width -> Maybe Operand
encode_imm = 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
            (op_y, format_y, code_y) <- case y of
              CmmLit (CmmInt Integer
n Width
w)
                | Just Operand
imm_operand_y <- Integer -> Width -> Maybe Operand
encode_imm Integer
n Width
w
                -> (Operand, Format, OrdList Instr)
-> NatM (Operand, Format, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Operand
imm_operand_y, Width -> Format
intFormat Width
w, OrdList Instr
forall a. OrdList a
nilOL)
              CmmExpr
_ -> do
                  (reg_y, format_y, code_y) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
y
                  return (OpReg w reg_y, format_y, code_y)
            massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOpImm: 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) Operand
op_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 AArch64].
          intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register)
          intOpImm :: Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> (Integer -> Width -> Maybe Operand)
-> NatM Register
intOpImm {- is signed -} Bool
True  Width
w Operand -> Operand -> Operand -> OrdList Instr
op Integer -> Width -> Maybe Operand
_encode_imm = Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w Operand -> Operand -> Operand -> OrdList Instr
op
          intOpImm                 Bool
False Width
w Operand -> Operand -> Operand -> OrdList Instr
op  Integer -> Width -> Maybe Operand
encode_imm = 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
              (op_y, format_y, code_y) <- case y of
                CmmLit (CmmInt Integer
n Width
w)
                  | Just Operand
imm_operand_y <- Integer -> Width -> Maybe Operand
encode_imm Integer
n Width
w
                  -> (Operand, Format, OrdList Instr)
-> NatM (Operand, Format, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Operand
imm_operand_y, Width -> Format
intFormat Width
w, OrdList Instr
forall a. OrdList a
nilOL)
                CmmExpr
_ -> do
                    (reg_y, format_y, code_y) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
y
                    return (OpReg w reg_y, format_y, code_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
              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) (Operand
op_y) OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                  Width -> Width -> Reg -> OrdList Instr
truncateReg Width
w' Width
w Reg
dst -- truncate back to the operand's original width

          -- 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 AArch64].
          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)
-> (Integer -> Width -> Maybe Operand)
-> NatM Register
intOpImm 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)) Integer -> Width -> Maybe Operand
getArithImm
        -- TODO: Handle sub-word case
        MO_Sub Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> (Integer -> Width -> Maybe Operand)
-> NatM Register
intOpImm 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)) Integer -> Width -> Maybe Operand
getArithImm

        -- Note [CSET]
        -- ~~~~~~~~~~~
        -- Setting conditional flags: the architecture internally knows the
        -- following flag bits.  And based on thsoe comparisons as in the
        -- table below.
        --
        --    31  30  29  28
        --  .---+---+---+---+-- - -
        --  | N | Z | C | V |
        --  '---+---+---+---+-- - -
        --  Negative
        --  Zero
        --  Carry
        --  oVerflow
        --
        --  .------+-------------------------------------+-----------------+----------.
        --  | Code | Meaning                             | Flags           | Encoding |
        --  |------+-------------------------------------+-----------------+----------|
        --  |  EQ  | Equal                               | Z = 1           | 0000     |
        --  |  NE  | Not Equal                           | Z = 0           | 0001     |
        --  |  HI  | Unsigned Higher                     | C = 1 && Z = 0  | 1000     |
        --  |  HS  | Unsigned Higher or Same             | C = 1           | 0010     |
        --  |  LS  | Unsigned Lower or Same              | C = 0 || Z = 1  | 1001     |
        --  |  LO  | Unsigned Lower                      | C = 0           | 0011     |
        --  |  GT  | Signed Greater Than                 | Z = 0 && N = V  | 1100     |
        --  |  GE  | Signed Greater Than or Equal        | N = V           | 1010     |
        --  |  LE  | Signed Less Than or Equal           | Z = 1 || N /= V | 1101     |
        --  |  LT  | Signed Less Than                    | N /= V          | 1011     |
        --  |  CS  | Carry Set (Unsigned Overflow)       | C = 1           | 0010     |
        --  |  CC  | Carry Clear (No Unsigned Overflow)  | C = 0           | 0011     |
        --  |  VS  | Signed Overflow                     | V = 1           | 0110     |
        --  |  VC  | No Signed Overflow                  | V = 0           | 0111     |
        --  |  MI  | Minus, Negative                     | N = 1           | 0100     |
        --  |  PL  | Plus, Positive or Zero (!)          | N = 0           | 0101     |
        --  |  AL  | Always                              | Any             | 1110     |
        --  |  NV  | Never                               | Any             | 1111     |
        --- '-------------------------------------------------------------------------'

        -- 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)
-> (Integer -> Width -> Maybe Operand)
-> NatM Register
bitOpImm Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
EQ ]) Integer -> Width -> Maybe Operand
getArithImm
        MO_Ne Width
w     -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> (Integer -> Width -> Maybe Operand)
-> NatM Register
bitOpImm Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
NE ]) Integer -> Width -> Maybe Operand
getArithImm

        -- 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
$ 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
$ Operand -> Operand -> Operand -> Instr
SDIV Operand
d Operand
x Operand
y)

        -- No native rem instruction. So we'll compute the following
        -- Rd  <- Rx / Ry             | 2 <- 7 / 3      -- SDIV Rd Rx Ry
        -- Rd' <- Rx - Rd * Ry        | 1 <- 7 - 2 * 3  -- MSUB Rd' Rd Ry Rx
        --        |     '---|----------------|---'   |
        --        |         '----------------|-------'
        --        '--------------------------'
        -- Note the swap in Rx and Ry.
        MO_S_Rem Width
w -> Width -> (Operand -> NatM Register) -> NatM Register
forall {b}. Width -> (Operand -> NatM b) -> NatM b
withTempIntReg Width
w ((Operand -> NatM Register) -> NatM Register)
-> (Operand -> NatM Register) -> NatM Register
forall a b. (a -> b) -> a -> b
$ \Operand
t ->
                      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
toOL [ Operand -> Operand -> Operand -> Instr
SDIV Operand
t Operand
x Operand
y, Operand -> Operand -> Operand -> Operand -> Instr
MSUB Operand
d Operand
t Operand
y Operand
x ])

        -- 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
$ Operand -> Operand -> Operand -> Instr
UDIV Operand
d Operand
x Operand
y)
        MO_U_Rem Width
w  -> Width -> (Operand -> NatM Register) -> NatM Register
forall {b}. Width -> (Operand -> NatM b) -> NatM b
withTempIntReg Width
w ((Operand -> NatM Register) -> NatM Register)
-> (Operand -> NatM Register) -> NatM Register
forall a b. (a -> b) -> a -> b
$ \Operand
t ->
                       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
toOL [ Operand -> Operand -> Operand -> Instr
UDIV Operand
t Operand
x Operand
y, Operand -> Operand -> Operand -> Operand -> Instr
MSUB Operand
d Operand
t Operand
y Operand
x ])

        -- Signed comparisons -- see Note [CSET]
        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
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d 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
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d 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
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d 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
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
SLT ])

        -- Unsigned comparisons
        MO_U_Ge Width
w     -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> (Integer -> Width -> Maybe Operand)
-> NatM Register
intOpImm Bool
False Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
UGE ]) Integer -> Width -> Maybe Operand
getArithImm
        MO_U_Le Width
w     -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> (Integer -> Width -> Maybe Operand)
-> NatM Register
intOpImm Bool
False Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
ULE ]) Integer -> Width -> Maybe Operand
getArithImm
        MO_U_Gt Width
w     -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> (Integer -> Width -> Maybe Operand)
-> NatM Register
intOpImm Bool
False Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
UGT ]) Integer -> Width -> Maybe Operand
getArithImm
        MO_U_Lt Width
w     -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> (Integer -> Width -> Maybe Operand)
-> NatM Register
intOpImm Bool
False Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
ULT ]) Integer -> Width -> Maybe Operand
getArithImm

        -- 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
$ 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
$ 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
$ 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
$ Operand -> Operand -> Operand -> Instr
SDIV Operand
d Operand
x Operand
y)

        -- Floating point comparison
        MO_F_Eq Width
w    -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d 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
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
NE ])

        -- careful with the floating point operations.
        -- SLE is effectively LE or unordered (NaN)
        -- SLT is the same. ULE, and ULT will not return true for NaN.
        -- This is a bit counter-intuitive. Don't let yourself be fooled by
        -- the S/U prefix for floats, it's only meaningful for integers.
        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
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
OGE ])
        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
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
OLE ]) -- 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
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
OGT ])
        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
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
OLT ]) -- x < y <=> y >= x

        -- Bitwise operations
        MO_And   Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> (Integer -> Width -> Maybe Operand)
-> NatM Register
bitOpImm 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
$ Operand -> Operand -> Operand -> Instr
AND Operand
d Operand
x Operand
y) Integer -> Width -> Maybe Operand
getBitmaskImm
        MO_Or    Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> (Integer -> Width -> Maybe Operand)
-> NatM Register
bitOpImm 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
$ Operand -> Operand -> Operand -> Instr
ORR Operand
d Operand
x Operand
y) Integer -> Width -> Maybe Operand
getBitmaskImm
        MO_Xor   Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> (Integer -> Width -> Maybe Operand)
-> NatM Register
bitOpImm 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
$ Operand -> Operand -> Operand -> Instr
EOR Operand
d Operand
x Operand
y) Integer -> Width -> Maybe Operand
getBitmaskImm
        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
$ Operand -> Operand -> Operand -> Instr
LSL 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
$ Operand -> Operand -> Operand -> Instr
LSR 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
$ Operand -> Operand -> Operand -> Instr
ASR Operand
d Operand
x Operand
y)

        -- TODO

        MachOp
op -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"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
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"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 <=> AArch64 fmadd : d =   r1 * r2 + r3
        -- x86 fmsub    x * y - z <=> AArch64 fnmsub: d =   r1 * r2 - r3
        -- x86 fnmadd - x * y + z <=> AArch64 fmsub : d = - r1 * r2 + r3
        -- x86 fnmsub - x * y - z <=> AArch64 fnmadd: d = - r1 * r2 - r3

        MO_FMA FMASign
var Width
w -> 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
FNMSub 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
FMSub  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)

        MachOp
_ -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"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
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"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"
            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`
                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
      -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"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_bits Integer
i = let shift :: Int
shift = Int
n_bits 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.
    -- These implementations are based on output from GCC 11.
    do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
    do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
do_mul_may_oflo w :: Width
w@Width
W64 CmmExpr
x CmmExpr
y = do
        (reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
        (reg_y, _format_y, code_y) <- getSomeReg y
        lo <- getNewRegNat II64
        hi <- getNewRegNat II64
        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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            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) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Operand -> Operand -> Instr
SMULH (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) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Operand -> Instr
CMP (Width -> Reg -> Operand
OpReg Width
w Reg
hi) (Width -> Reg -> ShiftMode -> Int -> Operand
OpRegShift Width
w Reg
lo ShiftMode
SASR Int
63) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Cond -> Instr
CSET (Width -> Reg -> Operand
OpReg Width
w Reg
dst) Cond
NE)

    do_mul_may_oflo Width
W32 CmmExpr
x CmmExpr
y = do
        (reg_x, _format_x, code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
        (reg_y, _format_y, code_y) <- getSomeReg y
        tmp1 <- getNewRegNat II64
        tmp2 <- getNewRegNat II64
        return $ Any (intFormat W32) (\Reg
dst ->
            OrdList Instr
code_x OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            OrdList Instr
code_y OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Operand -> Operand -> Instr
SMULL (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp1) (Width -> Reg -> Operand
OpReg Width
W32 Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
W32 Reg
reg_y) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Operand -> Operand -> Instr
ASR (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp2) (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp1) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
31)) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Operand -> Instr
CMP (Width -> Reg -> Operand
OpReg Width
W32 Reg
tmp2) (Width -> Reg -> ShiftMode -> Int -> Operand
OpRegShift Width
W32 Reg
tmp1 ShiftMode
SASR Int
31) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Cond -> Instr
CSET (Width -> Reg -> Operand
OpReg Width
W32 Reg
dst) 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
        tmp1 <- getNewRegNat II32
        tmp2 <- getNewRegNat II32
        let extend Reg
dst Reg
arg =
              case Width
w of
                Width
W16 -> Operand -> Operand -> Instr
SXTH (Width -> Reg -> Operand
OpReg Width
W32 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W32 Reg
arg)
                Width
W8  -> Operand -> Operand -> Instr
SXTB (Width -> Reg -> Operand
OpReg Width
W32 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W32 Reg
arg)
                Width
_   -> String -> Instr
forall a. HasCallStack => String -> a
panic String
"unreachable"
            cmp_ext_mode =
              case Width
w of
                Width
W16 -> ExtMode
EUXTH
                Width
W8  -> ExtMode
EUXTB
                Width
_   -> String -> ExtMode
forall a. HasCallStack => String -> a
panic String
"unreachable"
            width = Width -> Int
widthInBits Width
w
            opInt = Imm -> Operand
OpImm (Imm -> Operand) -> (Int -> Imm) -> Int -> Operand
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Imm
ImmInt

        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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Reg -> Reg -> Instr
extend Reg
tmp1 Reg
reg_x OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Reg -> Reg -> Instr
extend Reg
tmp2 Reg
reg_y OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Operand -> Operand -> Instr
MUL (Width -> Reg -> Operand
OpReg Width
W32 Reg
tmp1) (Width -> Reg -> Operand
OpReg Width
W32 Reg
tmp1) (Width -> Reg -> Operand
OpReg Width
W32 Reg
tmp2) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Operand -> Operand -> Operand -> Instr
SBFX (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp2) (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp1) (Int -> Operand
opInt (Int -> Operand) -> Int -> Operand
forall a b. (a -> b) -> a -> b
$ Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> Operand
opInt Int
1) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Operand -> Operand -> Operand -> Instr
UBFX (Width -> Reg -> Operand
OpReg Width
W32 Reg
tmp1) (Width -> Reg -> Operand
OpReg Width
W32 Reg
tmp1) (Int -> Operand
opInt Int
width) (Int -> Operand
opInt Int
width) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Operand -> Instr
CMP (Width -> Reg -> Operand
OpReg Width
W32 Reg
tmp1) (Width -> Reg -> ExtMode -> Int -> Operand
OpRegExt Width
W32 Reg
tmp2 ExtMode
cmp_ext_mode Int
0) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Cond -> Instr
CSET (Width -> Reg -> Operand
OpReg Width
w Reg
dst) Cond
NE)

-- | Is a given number encodable as a bitmask immediate?
--
-- https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly
isAArch64Bitmask :: Width -> Integer -> Bool
-- N.B. zero and ~0 are not encodable as bitmask immediates
isAArch64Bitmask :: Width -> Integer -> Bool
isAArch64Bitmask Width
width Integer
n =
  Bool -> Bool -> Bool
forall a. HasCallStack => Bool -> a -> a
assert (Width
width Width -> [Width] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Width
W32,Width
W64]) (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
  case Integer
n of
    Integer
0 -> Bool
False
    Integer
_ | Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Integer
forall a. Bits a => Int -> a
bit (Width -> Int
widthInBits Width
width) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1
      -> Bool
False -- 1111...1111
      | Bool
otherwise
      -> (Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 Bool -> Bool -> Bool
&& Int -> Bool
check Int
64) Bool -> Bool -> Bool
|| Int -> Bool
check Int
32 Bool -> Bool -> Bool
|| Int -> Bool
check Int
16 Bool -> Bool -> Bool
|| Int -> Bool
check Int
8
  where
    -- Check whether @n@ can be represented as a subpattern of the given
    -- width.
    check :: Int -> Bool
check Int
width
      | Word64 -> Bool
hasOneRun Word64
subpat =
          let n' :: Integer
n' = Word64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64 -> Word64
mkPat Int
width Word64
subpat)
          in Integer
n Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
n'
      | Bool
otherwise = Bool
False
      where
        subpat :: Word64
        subpat :: Word64
subpat = Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
n Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. (Int -> Integer
forall a. Bits a => Int -> a
bit Int
width Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1))

    -- Construct a bit-pattern from a repeated subpatterns the given width.
    mkPat :: Int -> Word64 -> Word64
    mkPat :: Int -> Word64 -> Word64
mkPat Int
width Word64
subpat =
        (Word64 -> Word64 -> Word64) -> Word64 -> [Word64] -> Word64
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
(.|.) Word64
0 [ Word64
subpat Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` Int
p | Int
p <- [Int
0, Int
width..Int
63] ]

    -- Does the given number's bit representation match the regular expression
    -- @0*1*0*@?
    hasOneRun :: Word64 -> Bool
    hasOneRun :: Word64 -> Bool
hasOneRun Word64
m =
        Int
64 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Word64 -> Int
forall a. Bits a => a -> Int
popCount Word64
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word64 -> Int
forall b. FiniteBits b => b -> Int
countLeadingZeros Word64
m Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word64 -> Int
forall b. FiniteBits b => b -> Int
countTrailingZeros Word64
m

-- | 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 =
    case Width
w of
      Width
W64 -> NatM (Reg, OrdList Instr)
noop
      Width
W32
        | Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32 -> NatM (Reg, OrdList Instr)
noop
        | Bool
otherwise -> (Operand -> Operand -> Instr) -> NatM (Reg, OrdList Instr)
extend Operand -> Operand -> Instr
SXTH
      Width
W16           -> (Operand -> Operand -> Instr) -> NatM (Reg, OrdList Instr)
extend Operand -> Operand -> Instr
SXTH
      Width
W8            -> (Operand -> Operand -> Instr) -> NatM (Reg, OrdList Instr)
extend Operand -> Operand -> Instr
SXTB
      Width
_             -> String -> NatM (Reg, OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"intOp"
  where
    noop :: NatM (Reg, OrdList Instr)
noop = (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)
    extend :: (Operand -> Operand -> Instr) -> NatM (Reg, OrdList Instr)
extend Operand -> Operand -> Instr
instr = do
        r' <- Format -> NatM Reg
getNewRegNat Format
II64
        return (r', unitOL $ instr (OpReg w' r') (OpReg w' r))

-- | Instructions to truncate the value in the given register from width @w@
-- down to width @w'@.
truncateReg :: Width -> Width -> Reg -> OrdList Instr
truncateReg :: Width -> Width -> Reg -> OrdList Instr
truncateReg Width
w Width
w' Reg
r =
    case Width
w of
      Width
W64 -> OrdList Instr
forall a. OrdList a
nilOL
      Width
W32
        | Width
w' Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32 -> OrdList Instr
forall a. OrdList a
nilOL
      Width
_   -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Operand -> Instr
UBFM (Width -> Reg -> Operand
OpReg Width
w Reg
r)
                           (Width -> Reg -> Operand
OpReg Width
w Reg
r)
                           (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0))
                           (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
$ Width -> Int
widthInBits Width
w' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

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

getAmode :: Platform
         -> Width     -- ^ width of loaded value
         -> CmmExpr
         -> NatM Amode
-- TODO: Specialize stuff we can destructure here.

-- OPTIMIZATION WARNING: Addressing modes.
-- Addressing options:
getAmode :: Platform -> Width -> CmmExpr -> NatM Amode
getAmode Platform
platform Width
w (CmmRegOff CmmReg
reg Int
off)
  | Int -> Width -> Bool
isOffsetImm Int
off Width
w
  = 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
w (CmmMachOp (MO_Add Width
_w) [CmmExpr
expr, CmmLit (CmmInt Integer
off Width
_w')])
  | Int -> Width -> Bool
isOffsetImm (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
off) Width
w
  = do (reg, _format, code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
       return $ Amode (AddrRegImm reg (ImmInteger off)) code

getAmode Platform
_platform Width
w (CmmMachOp (MO_Sub Width
_w) [CmmExpr
expr, CmmLit (CmmInt Integer
off Width
_w')])
  | Int -> Width -> Bool
isOffsetImm (Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ -Integer
off) Width
w
  = 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 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CmmAssign" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text (CmmReg -> String
forall a. Show a => a -> String
show CmmReg
reg)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text (CmmExpr -> String
forall a. Show a => a -> String
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 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CmmAssign" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text (CmmReg -> String
forall a. Show a => a -> String
show CmmReg
reg)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text (CmmExpr -> String
forall a. Show a => a -> String
show CmmExpr
src))) Instr -> OrdList Instr -> OrdList Instr
forall a. a -> OrdList a -> OrdList a
`consOL` (OrdList Instr
fcode OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) Reg
dst) (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) Reg
freg))

-- Let's treat Floating point stuff
-- as integer code for now. Opaque.
assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_FltCode = Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_IntCode
assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_FltCode = Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_IntCode

-- -----------------------------------------------------------------------------
-- Jumps

genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock
genJump :: CmmExpr -> NatM (OrdList Instr)
genJump expr :: CmmExpr
expr@(CmmLit (CmmLabel CLabel
lbl))
  = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Target -> Instr
J (CLabel -> Target
TLabel CLabel
lbl)))

genJump CmmExpr
expr = do
    (target, _format, code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
    return (code `appOL` unitOL (annExpr expr (J (TReg target))))

-- -----------------------------------------------------------------------------
--  Unconditional branches
genBranch :: BlockId -> NatM InstrBlock
genBranch :: 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 (CBZ (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 (CBNZ (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
W8  -> OrdList Instr
code_x OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
UXTB Operand
x' Operand
x', Operand -> Operand -> Instr
UXTB Operand
y' Operand
y', Operand -> Operand -> Instr
CMP Operand
x' Operand
y', (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Target -> Instr
BCOND Cond
cmp (BlockId -> Target
TBlock BlockId
bid))) ]
                  Width
W16 -> OrdList Instr
code_x OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
UXTH Operand
x' Operand
x', Operand -> Operand -> Instr
UXTH Operand
y' Operand
y', Operand -> Operand -> Instr
CMP Operand
x' Operand
y', (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Target -> Instr
BCOND Cond
cmp (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
toOL [                         Operand -> Operand -> Instr
CMP Operand
x' Operand
y', (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Target -> Instr
BCOND Cond
cmp (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
W8  -> OrdList Instr
code_x OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
SXTB Operand
x' Operand
x', Operand -> Operand -> Instr
SXTB Operand
y' Operand
y', Operand -> Operand -> Instr
CMP Operand
x' Operand
y', (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Target -> Instr
BCOND Cond
cmp (BlockId -> Target
TBlock BlockId
bid))) ]
                  Width
W16 -> OrdList Instr
code_x OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
SXTH Operand
x' Operand
x', Operand -> Operand -> Instr
SXTH Operand
y' Operand
y', Operand -> Operand -> Instr
CMP Operand
x' Operand
y', (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Target -> Instr
BCOND Cond
cmp (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
toOL [                         Operand -> Operand -> Instr
CMP Operand
x' Operand
y', (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Target -> Instr
BCOND Cond
cmp (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
              return $ code_fx `appOL` code_fy `snocOL` CMP (OpReg w reg_fx) (OpReg w reg_fy) `snocOL` (annExpr expr (BCOND cmp (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
OGT
          MO_F_Ge Width
w -> Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
OGE
          MO_F_Lt Width
w -> Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
OLT
          MO_F_Le Width
w -> Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
OLE

          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
_ -> String -> SDoc -> NatM (OrdList Instr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"AArch64.genCondJump:case mop: " (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ CmmExpr -> String
forall a. Show a => a -> String
show CmmExpr
expr)
      CmmExpr
_ -> String -> SDoc -> NatM (OrdList Instr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"AArch64.genCondJump: " (String -> SDoc
forall doc. IsLine doc => String -> doc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ CmmExpr -> String
forall a. Show a => a -> String
show CmmExpr
expr)

-- A conditional jump with at least +/-128M jump range
genCondFarJump :: MonadUnique m => Cond -> Target -> m InstrBlock
genCondFarJump :: forall (m :: * -> *).
MonadUnique m =>
Cond -> Target -> m (OrdList Instr)
genCondFarJump Cond
cond Target
far_target = do
  skip_lbl_id <- m BlockId
forall (m :: * -> *). MonadUnique 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 [ BCOND cond (TBlock jmp_lbl_id)
                , B (TBlock skip_lbl_id)
                , NEWBLOCK jmp_lbl_id
                , B far_target
                , NEWBLOCK skip_lbl_id]

genCondBranch
    :: BlockId      -- the source of the jump
    -> BlockId      -- the true branch target
    -> BlockId      -- the false branch target
    -> CmmExpr      -- the condition on which to branch
    -> NatM InstrBlock -- Instructions

genCondBranch :: BlockId -> BlockId -> BlockId -> CmmExpr -> NatM (OrdList Instr)
genCondBranch BlockId
_ BlockId
true BlockId
false CmmExpr
expr = do
  b1 <- BlockId -> CmmExpr -> NatM (OrdList Instr)
genCondJump BlockId
true CmmExpr
expr
  b2 <- genBranch false
  return (b1 `appOL` b2)

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

-- Now the biggest nightmare---calls.  Most of the nastiness is buried in
-- @get_arg@, which moves the arguments to the correct registers/stack
-- locations.  Apart from that, the code is easy.
--
-- As per *convention*:
-- x0-x7:   (volatile) argument registers
-- x8:      (volatile) indirect result register / Linux syscall no
-- x9-x15:  (volatile) caller saved regs
-- x16,x17: (volatile) intra-procedure-call registers
-- x18:     (volatile) platform register. don't use for portability
-- x19-x28: (non-volatile) callee save regs
-- x29:     (non-volatile) frame pointer
-- x30:                    link register
-- x31:                    stack pointer / zero reg
--
-- Thus, this is what a c function will expect. Find the arguments in x0-x7,
-- anything above that on the stack.  We'll ignore c functions with more than
-- 8 arguments for now.  Sorry.
--
-- We need to make sure we preserve x9-x15, don't want to touch x16, x17.

-- Note [PLT vs GOT relocations]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- When linking objects together, we may need to lookup foreign references. That
-- is symbolic references to functions or values in other objects. When
-- compiling the object, we can not know where those elements will end up in
-- memory (relative to the current location). Thus the use of symbols. There
-- are two types of items we are interested, code segments we want to jump to
-- and continue execution there (functions, ...), and data items we want to look
-- up (strings, numbers, ...). For functions we can use the fact that we can use
-- an intermediate jump without visibility to the programs execution.  If we
-- want to jump to a function that is simply too far away to reach for the B/BL
-- instruction, we can create a small piece of code that loads the full target
-- address and jumps to that on demand. Say f wants to call g, however g is out
-- of range for a direct jump, we can create a function h in range for f, that
-- will load the address of g, and jump there. The area where we construct h
-- is called the Procedure Linking Table (PLT), we have essentially replaced
-- f -> g with f -> h -> g.  This is fine for function calls.  However if we
-- want to lookup values, this trick doesn't work, so we need something else.
-- We will instead reserve a slot in memory, and have a symbol pointing to that
-- slot. Now what we essentially do is, we reference that slot, and expect that
-- slot to hold the final resting address of the data we are interested in.
-- Thus what that symbol really points to is the location of the final data.
-- The block of memory where we hold all those slots is the Global Offset Table
-- (GOT).  Instead of x <- $foo, we now do y <- $fooPtr, and x <- [$y].
--
-- For JUMP/CALLs we have 26bits (+/- 128MB), for conditional branches we only
-- have 19bits (+/- 1MB).  Symbol lookups are also within +/- 1MB, thus for most
-- of the LOAD/STOREs we'd want to use adrp, and add to compute a value within
-- 4GB of the PC, and load that.  For anything outside of that range, we'd have
-- to go through the GOT.
--
--  adrp x0, <symbol>
--  add x0, :lo:<symbol>
--
-- will compute the address of <symbol> int x0 if <symbol> is within 4GB of the
-- PC.
--
-- If we want to get the slot in the global offset table (GOT), we can do this:
--
--   adrp x0, #:got:<symbol>
--   ldr x0, [x0, #:got_lo12:<symbol>]
--
-- this will compute the address anywhere in the addressable 64bit space into
-- x0, by loading the address from the GOT slot.
--
-- To actually get the value of <symbol>, we'd need to ldr x0, x0 still, which
-- for the first case can be optimized to use ldr x0, [x0, #:lo12:<symbol>]
-- instead of the add instruction.
--
-- As the memory model for AArch64 for PIC is considered to be +/- 4GB, we do
-- not need to go through the GOT, unless we want to address the full address
-- range within 64bit.

genCCall
    :: ForeignTarget      -- function to call
    -> [CmmFormal]        -- where to put the result
    -> [CmmActual]        -- arguments (of mixed type)
    -> BlockId            -- The block we are in
    -> NatM (InstrBlock, Maybe BlockId)
-- TODO: Specialize where we can.
-- Generic impl
genCCall :: ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> BlockId
-> NatM (OrdList Instr, Maybe BlockId)
genCCall ForeignTarget
target [CmmFormal]
dest_regs [CmmExpr]
arg_regs BlockId
bid = do
  -- we want to pass arg_regs into allArgRegs
  -- pprTraceM "genCCall target" (ppr target)
  -- pprTraceM "genCCall formal" (ppr dest_regs)
  -- pprTraceM "genCCall actual" (ppr arg_regs)

  case ForeignTarget
target of
    -- The target :: ForeignTarget call can either
    -- be a foreign procedure with an address expr
    -- and a calling convention.
    ForeignTarget CmmExpr
expr ForeignConvention
_cconv -> do
      (call_target, call_target_code) <- case CmmExpr
expr of
        -- if this is a label, let's just directly to it.  This will produce the
        -- correct CALL relocation for BL...
        (CmmLit (CmmLabel CLabel
lbl)) -> (Target, OrdList Instr) -> NatM (Target, OrdList Instr)
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CLabel -> Target
TLabel CLabel
lbl, OrdList Instr
forall a. OrdList a
nilOL)
        -- ... if it's not a label--well--let's compute the expression into a
        -- register and jump to that. See Note [PLT vs GOT relocations]
        CmmExpr
_ -> do (reg, _format, reg_code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
                pure (TReg reg, reg_code)
      -- compute the code and register logic for all arg_regs.
      -- this will give us the format information to match on.
      arg_regs' <- mapM getSomeReg arg_regs

      -- Now this is stupid.  Our Cmm expressions doesn't carry the proper sizes
      -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in
      -- STG; this thenn breaks packing of stack arguments, if we need to pack
      -- for the pcs, e.g. darwinpcs.  Option one would be to fix the Int type
      -- in Cmm proper. Option two, which we choose here is to use extended Hint
      -- information to contain the size information and use that when packing
      -- arguments, spilled onto the stack.
      let (_res_hints, arg_hints) = foreignTargetHints target
          arg_regs'' = ((Reg, Format, OrdList Instr)
 -> ForeignHint -> (Reg, Format, ForeignHint, OrdList Instr))
-> [(Reg, Format, OrdList Instr)]
-> [ForeignHint]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Reg
r, Format
f, OrdList Instr
c) ForeignHint
h -> (Reg
r,Format
f,ForeignHint
h,OrdList Instr
c)) [(Reg, Format, OrdList Instr)]
arg_regs' [ForeignHint]
arg_hints

      platform <- getPlatform
      let packStack = Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSDarwin

      (stackSpace', passRegs, passArgumentsCode) <- passArguments packStack allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL

      -- if we pack the stack, we may need to adjust to multiple of 8byte.
      -- if we don't pack the stack, it will always be multiple of 8.
      let stackSpace = if Int
stackSpace' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
                       then Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
stackSpace' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                       else Int
stackSpace'

      (returnRegs, 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 (Int -> Reg
regSingle Int
31)) (Width -> Reg -> Operand
OpReg Width
W64 (Int -> Reg
regSingle Int
31)) (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 (Int -> Reg
regSingle Int
31)) (Width -> Reg -> Operand
OpReg Width
W64 (Int -> Reg
regSingle Int
31)) (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
stackSpace Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8)
            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 -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Target -> [Reg] -> [Reg] -> Instr
BL Target
call_target [Reg]
passRegs [Reg]
returnRegs) -- branch and link.
            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
stackSpace Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8)
      return (code, Nothing)

    PrimTarget CallishMachOp
MO_F32_Fabs
      | [CmmExpr
arg_reg] <- [CmmExpr]
arg_regs, [CmmFormal
dest_reg] <- [CmmFormal]
dest_regs ->
        Width
-> (Operand -> Operand -> OrdList Instr)
-> CmmExpr
-> CmmFormal
-> NatM (OrdList Instr, Maybe BlockId)
forall {a}.
Width
-> (Operand -> Operand -> OrdList Instr)
-> CmmExpr
-> CmmFormal
-> NatM (OrdList Instr, Maybe a)
unaryFloatOp Width
W32 (\Operand
d Operand
x -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
FABS Operand
d Operand
x) CmmExpr
arg_reg CmmFormal
dest_reg
    PrimTarget CallishMachOp
MO_F64_Fabs
      | [CmmExpr
arg_reg] <- [CmmExpr]
arg_regs, [CmmFormal
dest_reg] <- [CmmFormal]
dest_regs ->
        Width
-> (Operand -> Operand -> OrdList Instr)
-> CmmExpr
-> CmmFormal
-> NatM (OrdList Instr, Maybe BlockId)
forall {a}.
Width
-> (Operand -> Operand -> OrdList Instr)
-> CmmExpr
-> CmmFormal
-> NatM (OrdList Instr, Maybe a)
unaryFloatOp Width
W64 (\Operand
d Operand
x -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
FABS Operand
d Operand
x) CmmExpr
arg_reg CmmFormal
dest_reg

    -- or a possibly side-effecting machine operation
    -- mop :: CallishMachOp (see GHC.Cmm.MachOp)
    PrimTarget CallishMachOp
mop -> do
      -- We'll need config to construct forien targets
      case CallishMachOp
mop of
        -- 64 bit float ops
        CallishMachOp
MO_F64_Pwr   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"pow"

        CallishMachOp
MO_F64_Sin   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"sin"
        CallishMachOp
MO_F64_Cos   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"cos"
        CallishMachOp
MO_F64_Tan   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"tan"

        CallishMachOp
MO_F64_Sinh  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"sinh"
        CallishMachOp
MO_F64_Cosh  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"cosh"
        CallishMachOp
MO_F64_Tanh  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"tanh"

        CallishMachOp
MO_F64_Asin  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"asin"
        CallishMachOp
MO_F64_Acos  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"acos"
        CallishMachOp
MO_F64_Atan  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"atan"

        CallishMachOp
MO_F64_Asinh -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"asinh"
        CallishMachOp
MO_F64_Acosh -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"acosh"
        CallishMachOp
MO_F64_Atanh -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"atanh"

        CallishMachOp
MO_F64_Log   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"log"
        CallishMachOp
MO_F64_Log1P -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"log1p"
        CallishMachOp
MO_F64_Exp   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"exp"
        CallishMachOp
MO_F64_ExpM1 -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"expm1"
        CallishMachOp
MO_F64_Fabs  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"fabs"
        CallishMachOp
MO_F64_Sqrt  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"sqrt"

        -- 32 bit float ops
        CallishMachOp
MO_F32_Pwr   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"powf"

        CallishMachOp
MO_F32_Sin   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"sinf"
        CallishMachOp
MO_F32_Cos   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"cosf"
        CallishMachOp
MO_F32_Tan   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"tanf"
        CallishMachOp
MO_F32_Sinh  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"sinhf"
        CallishMachOp
MO_F32_Cosh  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"coshf"
        CallishMachOp
MO_F32_Tanh  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"tanhf"
        CallishMachOp
MO_F32_Asin  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"asinf"
        CallishMachOp
MO_F32_Acos  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"acosf"
        CallishMachOp
MO_F32_Atan  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"atanf"
        CallishMachOp
MO_F32_Asinh -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"asinhf"
        CallishMachOp
MO_F32_Acosh -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"acoshf"
        CallishMachOp
MO_F32_Atanh -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"atanhf"
        CallishMachOp
MO_F32_Log   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"logf"
        CallishMachOp
MO_F32_Log1P -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"log1pf"
        CallishMachOp
MO_F32_Exp   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"expf"
        CallishMachOp
MO_F32_ExpM1 -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"expm1f"
        CallishMachOp
MO_F32_Fabs  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"fabsf"
        CallishMachOp
MO_F32_Sqrt  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"sqrtf"

        -- 64-bit primops
        CallishMachOp
MO_I64_ToI   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_int64ToInt"
        CallishMachOp
MO_I64_FromI -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_intToInt64"
        CallishMachOp
MO_W64_ToW   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_word64ToWord"
        CallishMachOp
MO_W64_FromW -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_wordToWord64"
        CallishMachOp
MO_x64_Neg   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_neg64"
        CallishMachOp
MO_x64_Add   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_add64"
        CallishMachOp
MO_x64_Sub   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_sub64"
        CallishMachOp
MO_x64_Mul   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_mul64"
        CallishMachOp
MO_I64_Quot  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_quotInt64"
        CallishMachOp
MO_I64_Rem   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_remInt64"
        CallishMachOp
MO_W64_Quot  -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_quotWord64"
        CallishMachOp
MO_W64_Rem   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_remWord64"
        CallishMachOp
MO_x64_And   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_and64"
        CallishMachOp
MO_x64_Or    -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_or64"
        CallishMachOp
MO_x64_Xor   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_xor64"
        CallishMachOp
MO_x64_Not   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_not64"
        CallishMachOp
MO_x64_Shl   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_uncheckedShiftL64"
        CallishMachOp
MO_I64_Shr   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_uncheckedIShiftRA64"
        CallishMachOp
MO_W64_Shr   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_uncheckedShiftRL64"
        CallishMachOp
MO_x64_Eq    -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_eq64"
        CallishMachOp
MO_x64_Ne    -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_ne64"
        CallishMachOp
MO_I64_Ge    -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_geInt64"
        CallishMachOp
MO_I64_Gt    -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_gtInt64"
        CallishMachOp
MO_I64_Le    -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_leInt64"
        CallishMachOp
MO_I64_Lt    -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_ltInt64"
        CallishMachOp
MO_W64_Ge    -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_geWord64"
        CallishMachOp
MO_W64_Gt    -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_gtWord64"
        CallishMachOp
MO_W64_Le    -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_leWord64"
        CallishMachOp
MO_W64_Lt    -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"hs_ltWord64"

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

        -- Arithmatic
        -- These are not supported on X86, so I doubt they are used much.
        MO_S_Mul2     Width
_w -> CallishMachOp -> NatM (OrdList Instr, Maybe BlockId)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_S_QuotRem  Width
_w -> CallishMachOp -> NatM (OrdList Instr, Maybe BlockId)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_U_QuotRem  Width
_w -> CallishMachOp -> NatM (OrdList Instr, Maybe BlockId)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_U_QuotRem2 Width
_w -> CallishMachOp -> NatM (OrdList Instr, Maybe BlockId)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_Add2       Width
_w -> CallishMachOp -> NatM (OrdList Instr, Maybe BlockId)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_AddWordC   Width
_w -> CallishMachOp -> NatM (OrdList Instr, Maybe BlockId)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_SubWordC   Width
_w -> CallishMachOp -> NatM (OrdList Instr, Maybe BlockId)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_AddIntC    Width
_w -> CallishMachOp -> NatM (OrdList Instr, Maybe BlockId)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_SubIntC    Width
_w -> CallishMachOp -> NatM (OrdList Instr, Maybe BlockId)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_U_Mul2     Width
_w -> CallishMachOp -> NatM (OrdList Instr, Maybe BlockId)
forall a b. Show a => a -> b
unsupported CallishMachOp
mop

        -- Memory Ordering
        CallishMachOp
MO_AcquireFence     ->  (OrdList Instr, Maybe BlockId)
-> NatM (OrdList Instr, Maybe BlockId)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
DMBISH, Maybe BlockId
forall a. Maybe a
Nothing)
        CallishMachOp
MO_ReleaseFence     ->  (OrdList Instr, Maybe BlockId)
-> NatM (OrdList Instr, Maybe BlockId)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
DMBISH, Maybe BlockId
forall a. Maybe a
Nothing)
        CallishMachOp
MO_SeqCstFence      ->  (OrdList Instr, Maybe BlockId)
-> NatM (OrdList Instr, Maybe BlockId)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
DMBISH, Maybe BlockId
forall a. Maybe a
Nothing)
        CallishMachOp
MO_Touch            ->  (OrdList Instr, Maybe BlockId)
-> NatM (OrdList Instr, Maybe BlockId)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
forall a. OrdList a
nilOL, Maybe BlockId
forall a. Maybe a
Nothing) -- Keep variables live (when using interior pointers)
        -- Prefetch
        MO_Prefetch_Data Int
_n -> (OrdList Instr, Maybe BlockId)
-> NatM (OrdList Instr, Maybe BlockId)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
forall a. OrdList a
nilOL, Maybe BlockId
forall a. Maybe a
Nothing) -- Prefetch hint.

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

        -- TODO Optimize and use e.g. quad registers to move memory around instead
        -- of offloading this to memcpy. For small memcpys we can utilize
        -- the 128bit quad registers in NEON to move block of bytes around.
        -- Might also make sense of small memsets? Use xzr? What's the function
        -- call overhead?
        MO_Memcpy  Int
_align   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"memcpy"
        MO_Memset  Int
_align   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"memset"
        MO_Memmove Int
_align   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"memmove"
        MO_Memcmp  Int
_align   -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"memcmp"

        CallishMachOp
MO_SuspendThread    -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"suspendThread"
        CallishMachOp
MO_ResumeThread     -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
"resumeThread"

        MO_PopCnt Width
w         -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall (Width -> FastString
popCntLabel Width
w)
        MO_Pdep Width
w           -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall (Width -> FastString
pdepLabel Width
w)
        MO_Pext Width
w           -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall (Width -> FastString
pextLabel Width
w)
        MO_Clz Width
w            -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall (Width -> FastString
clzLabel Width
w)
        MO_Ctz Width
w            -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall (Width -> FastString
ctzLabel Width
w)
        MO_BSwap Width
w          -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall (Width -> FastString
bSwapLabel Width
w)
        MO_BRev Width
w           -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall (Width -> FastString
bRevLabel Width
w)

        -- -- Atomic read-modify-write.
        MO_AtomicRead Width
w MemoryOrdering
ord
          | [CmmExpr
p_reg] <- [CmmExpr]
arg_regs
          , [CmmFormal
dst_reg] <- [CmmFormal]
dest_regs -> do
              (p, _fmt_p, code_p) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
p_reg
              platform <- getPlatform
              let instr = case MemoryOrdering
ord of
                      MemoryOrdering
MemOrderRelaxed -> Format -> Operand -> Operand -> Instr
LDR
                      MemoryOrdering
_               -> Format -> Operand -> Operand -> Instr
LDAR
                  dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst_reg)
                  code =
                    OrdList Instr
code_p OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                    Format -> Operand -> Operand -> Instr
instr (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)
              return (code, Nothing)
          | Bool
otherwise -> String -> NatM (OrdList Instr, Maybe BlockId)
forall a. HasCallStack => String -> a
panic String
"mal-formed AtomicRead"
        MO_AtomicWrite Width
w MemoryOrdering
ord
          | [CmmExpr
p_reg, CmmExpr
val_reg] <- [CmmExpr]
arg_regs -> do
              (p, _fmt_p, code_p) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
p_reg
              (val, fmt_val, code_val) <- getSomeReg val_reg
              let instr = case MemoryOrdering
ord of
                      MemoryOrdering
MemOrderRelaxed -> Format -> Operand -> Operand -> Instr
STR
                      MemoryOrdering
_               -> Format -> Operand -> Operand -> Instr
STLR
                  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 -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                    Format -> Operand -> Operand -> Instr
instr 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)
              return (code, Nothing)
          | Bool
otherwise -> String -> NatM (OrdList Instr, Maybe BlockId)
forall a. HasCallStack => String -> a
panic String
"mal-formed AtomicWrite"
        MO_AtomicRMW Width
w AtomicMachOp
amop -> FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall (Width -> AtomicMachOp -> FastString
atomicRMWLabel Width
w AtomicMachOp
amop)
        MO_Cmpxchg Width
w        -> FastString -> NatM (OrdList Instr, Maybe BlockId)
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, Maybe BlockId)
mkCCall (Width -> FastString
xchgLabel Width
w)

  where
    unsupported :: Show a => a -> b
    unsupported :: forall a b. Show a => a -> b
unsupported a
mop = String -> b
forall a. HasCallStack => String -> a
panic (String
"outOfLineCmmOp: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
mop
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not supported here")
    mkCCall :: FastString -> NatM (InstrBlock, Maybe BlockId)
    mkCCall :: FastString -> NatM (OrdList Instr, Maybe BlockId)
mkCCall FastString
name = do
      config <- NatM NCGConfig
getConfig
      target <- cmmMakeDynamicReference config CallReference $
          mkForeignLabel name Nothing 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 bid

    -- TODO: Optimize using paired stores and loads (STP, LDP). It is
    -- automatically done by the allocator for us. However it's not optimal,
    -- as we'd rather want to have control over
    --     all spill/load registers, so we can optimize with instructions like
    --       STP xA, xB, [sp, #-16]!
    --     and
    --       LDP xA, xB, sp, #16
    --
    passArguments :: Bool -> [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)
    passArguments :: Bool
-> [Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments Bool
_packStack [Reg]
_ [Reg]
_ [] Int
stackSpace [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
stackSpace, [Reg]
accumRegs, OrdList Instr
accumCode)
    -- passArguments _ _ [] accumCode stackSpace | isEven stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * stackSpace))
    -- passArguments _ _ [] accumCode stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * (stackSpace + 1)))
    -- passArguments [] fpRegs (arg0:arg1:args) stack accumCode = do
    --   -- allocate this on the stack
    --   (r0, format0, code_r0) <- getSomeReg arg0
    --   (r1, format1, code_r1) <- getSomeReg arg1
    --   let w0 = formatToWidth format0
    --       w1 = formatToWidth format1
    --       stackCode = unitOL $ STP (OpReg w0 r0) (OpReg w1 R1), (OpAddr (AddrRegImm x31 (ImmInt (stackSpace * 8)))
    --   passArguments gpRegs (fpReg:fpRegs) args (stackCode `appOL` accumCode)

      -- float promotion.
      -- According to
      --  ISO/IEC 9899:2018
      --  Information technology — Programming languages — C
      --
      -- e.g.
      -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1124.pdf
      -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1256.pdf
      --
      -- GHC would need to know the prototype.
      --
      -- > If the expression that denotes the called function has a type that does not include a
      -- > prototype, the integer promotions are performed on each argument, and arguments that
      -- > have type float are promoted to double.
      --
      -- As we have no way to get prototypes for C yet, we'll *not* promote this
      -- which is in line with the x86_64 backend :(
      --
      -- See the encode_values.cmm test.
      --
      -- We would essentially need to insert an FCVT (OpReg W64 fpReg) (OpReg W32 fpReg)
      -- if w == W32.  But *only* if we don't have a prototype m(
      --
      -- For AArch64 specificies see: https://developer.arm.com/docs/ihi0055/latest/procedure-call-standard-for-the-arm-64-bit-architecture
      --
    -- Still have GP regs, and we want to pass an GP argument.

    -- AArch64-Darwin: stack packing and alignment
    --
    -- According to the "Writing ARM64 Code for Apple Platforms" document form
    -- Apple, specifically the section "Handle Data Types and Data Alignment Properly"
    -- we need to not only pack, but also align arguments on the stack.
    --
    -- Data type   Size (in bytes)   Natural alignment (in bytes)
    -- BOOL, bool  1                 1
    -- char        1                 1
    -- short       2                 2
    -- int         4                 4
    -- long        8                 8
    -- long long   8                 8
    -- pointer     8                 8
    -- size_t      8                 8
    -- NSInteger   8                 8
    -- CFIndex     8                 8
    -- fpos_t      8                 8
    -- off_t       8                 8
    --
    -- We can see that types are aligned by their sizes so the easiest way to
    -- guarantee alignment during packing seems to be to pad to a multiple of the
    -- size we want to pack. Failure to get this right can result in pretty
    -- subtle bugs, e.g. #20137.

    passArguments Bool
pack (Reg
gpReg:[Reg]
gpRegs) [Reg]
fpRegs ((Reg
r, Format
format, ForeignHint
hint, OrdList Instr
code_r):[(Reg, Format, ForeignHint, OrdList Instr)]
args) Int
stackSpace [Reg]
accumRegs OrdList Instr
accumCode | Format -> Bool
isIntFormat Format
format = do
      platform <- NatM Platform
getPlatform
      let w = Format -> Width
formatToWidth Format
format
          mov
            -- Specifically, Darwin/AArch64's ABI requires that the caller
            -- sign-extend arguments which are smaller than 32-bits.
            | Width
w Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
< Width
W32
            , Platform -> Bool
platformCConvNeedsExtension Platform
platform
            , ForeignHint
SignedHint <- ForeignHint
hint
            = case Width
w of
                Width
W8  -> Operand -> Operand -> Instr
SXTB (Width -> Reg -> Operand
OpReg Width
W64 Reg
gpReg) (Width -> Reg -> Operand
OpReg Width
w Reg
r)
                Width
W16 -> Operand -> Operand -> Instr
SXTH (Width -> Reg -> Operand
OpReg Width
W64 Reg
gpReg) (Width -> Reg -> Operand
OpReg Width
w Reg
r)
                Width
_   -> String -> Instr
forall a. HasCallStack => String -> a
panic String
"impossible"
            | Bool
otherwise
            = Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
gpReg) (Width -> Reg -> Operand
OpReg Width
w Reg
r)
          accumCode' = OrdList Instr
accumCode OrdList Instr -> 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 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Pass gp argument: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r) Instr
mov
      passArguments pack gpRegs fpRegs args stackSpace (gpReg:accumRegs) accumCode'

    -- Still have FP regs, and we want to pass an FP argument.
    passArguments Bool
pack [Reg]
gpRegs (Reg
fpReg:[Reg]
fpRegs) ((Reg
r, Format
format, ForeignHint
_hint, OrdList Instr
code_r):[(Reg, Format, ForeignHint, OrdList Instr)]
args) Int
stackSpace [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 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"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
      Bool
-> [Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments Bool
pack [Reg]
gpRegs [Reg]
fpRegs [(Reg, Format, ForeignHint, OrdList Instr)]
args Int
stackSpace (Reg
fpRegReg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
:[Reg]
accumRegs) OrdList Instr
accumCode'

    -- No mor regs left to pass. Must pass on stack.
    passArguments Bool
pack [] [] ((Reg
r, Format
format, ForeignHint
_hint, OrdList Instr
code_r):[(Reg, Format, ForeignHint, OrdList Instr)]
args) Int
stackSpace [Reg]
accumRegs OrdList Instr
accumCode = do
      let w :: Width
w = Format -> Width
formatToWidth Format
format
          bytes :: Int
bytes = Width -> Int
widthInBits Width
w Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
          space :: Int
space = if Bool
pack then Int
bytes else Int
8
          stackSpace' :: Int
stackSpace' | Bool
pack Bool -> Bool -> Bool
&& Int
stackSpace Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
space Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Int
stackSpace Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
space Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
stackSpace Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
space)
                      | Bool
otherwise                           = Int
stackSpace
          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 (Int -> Reg
regSingle Int
31) (Int -> Imm
ImmInt Int
stackSpace')))
          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 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"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
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
") 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
      Bool
-> [Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments Bool
pack [] [] [(Reg, Format, ForeignHint, OrdList Instr)]
args (Int
stackSpace'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
space) [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 Bool
pack [] [Reg]
fpRegs ((Reg
r, Format
format, ForeignHint
_hint, OrdList Instr
code_r):[(Reg, Format, ForeignHint, OrdList Instr)]
args) Int
stackSpace [Reg]
accumRegs OrdList Instr
accumCode | Format -> Bool
isIntFormat Format
format = do
      let w :: Width
w = Format -> Width
formatToWidth Format
format
          bytes :: Int
bytes = Width -> Int
widthInBits Width
w Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
          space :: Int
space = if Bool
pack then Int
bytes else Int
8
          stackSpace' :: Int
stackSpace' | Bool
pack Bool -> Bool -> Bool
&& Int
stackSpace Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
space Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Int
stackSpace Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
space Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
stackSpace Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
space)
                      | Bool
otherwise                           = Int
stackSpace
          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 (Int -> Reg
regSingle Int
31) (Int -> Imm
ImmInt Int
stackSpace')))
          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 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"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
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
") 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
      Bool
-> [Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments Bool
pack [] [Reg]
fpRegs [(Reg, Format, ForeignHint, OrdList Instr)]
args (Int
stackSpace'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
space) [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 on the stack then.
    passArguments Bool
pack [Reg]
gpRegs [] ((Reg
r, Format
format, ForeignHint
_hint, OrdList Instr
code_r):[(Reg, Format, ForeignHint, OrdList Instr)]
args) Int
stackSpace [Reg]
accumRegs OrdList Instr
accumCode | Format -> Bool
isFloatFormat Format
format = do
      let w :: Width
w = Format -> Width
formatToWidth Format
format
          bytes :: Int
bytes = Width -> Int
widthInBits Width
w Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
          space :: Int
space = if Bool
pack then Int
bytes else Int
8
          stackSpace' :: Int
stackSpace' | Bool
pack Bool -> Bool -> Bool
&& Int
stackSpace Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
space Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Int
stackSpace Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
space Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
stackSpace Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
space)
                      | Bool
otherwise                           = Int
stackSpace
          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 (Int -> Reg
regSingle Int
31) (Int -> Imm
ImmInt Int
stackSpace')))
          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 (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"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
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
") 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
      Bool
-> [Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments Bool
pack [Reg]
gpRegs [] [(Reg, Format, ForeignHint, OrdList Instr)]
args (Int
stackSpace'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
space) [Reg]
accumRegs (OrdList Instr
stackCode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
accumCode)

    passArguments Bool
_ [Reg]
_ [Reg]
_ [(Reg, Format, ForeignHint, OrdList Instr)]
_ Int
_ [Reg]
_ OrdList Instr
_ = String -> SDoc -> NatM (Int, [Reg], OrdList Instr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"passArguments" (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"invalid state")

    readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM ([Reg], InstrBlock)
    readResults :: [Reg]
-> [Reg]
-> [CmmFormal]
-> [Reg]
-> OrdList Instr
-> NatM ([Reg], OrdList Instr)
readResults [Reg]
_ [Reg]
_ [] [Reg]
accumRegs OrdList Instr
accumCode = ([Reg], OrdList Instr) -> NatM ([Reg], OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Reg]
accumRegs, 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))

    unaryFloatOp :: Width
-> (Operand -> Operand -> OrdList Instr)
-> CmmExpr
-> CmmFormal
-> NatM (OrdList Instr, Maybe a)
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)
      return (code, Nothing)

{- Note [AArch64 far jumps]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
AArch conditional jump instructions can only encode an offset of +/-1MB
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>:
  b foo
  <lbl_false>:

Note the encoding of the `b` instruction still limits jumps to
+/-128M offsets, but that seems like an acceptable limitation.

Since AArch64 instructions are all of equal length we can reasonably estimate jumps
in range by counting the instructions between a jump and its target label.

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

-}

-- See Note [AArch64 far jumps]
data BlockInRange = InRange | NotInRange Target

-- See Note [AArch64 far jumps]
makeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock Instr]
                -> UniqSM [NatBasicBlock Instr]
makeFarBranches :: Platform
-> LabelMap RawCmmStatics
-> [NatBasicBlock Instr]
-> UniqSM [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 AArch64 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] -> UniqSM [NatBasicBlock Instr]
forall a. a -> UniqSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [NatBasicBlock Instr]
basic_blocks
    else do
      (_,blocks) <- (Int -> NatBasicBlock Instr -> UniqSM (Int, [NatBasicBlock Instr]))
-> Int
-> [NatBasicBlock Instr]
-> UniqSM (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
-> UniqSM (Int, [NatBasicBlock Instr])
replace_blk LabelMap Int
lblMap) Int
0 [NatBasicBlock Instr]
basic_blocks
      pure $ concat blocks
      -- pprTrace "lblMap" (ppr lblMap) $ basic_blocks

  where
    -- 2^18, 19 bit immediate with one bit is reserved for the sign
    max_jump_dist :: Int
max_jump_dist = Int
2Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
18::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
3 :: Int
    long_bz_jump_size :: Int
long_bz_jump_size =  Int
4 :: Int

    -- Replace out of range conditional jumps with unconditional jumps.
    replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqSM (Int, [GenBasicBlock Instr])
    replace_blk :: LabelMap Int
-> Int
-> NatBasicBlock Instr
-> UniqSM (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 -> UniqSM (Int, [Instr]))
-> Int -> [Instr] -> UniqSM (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 -> UniqSM (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 -> UniqSM (Int, [Instr])
    replace_jump :: LabelMap Int -> Int -> Instr -> UniqSM (Int, [Instr])
replace_jump !LabelMap Int
m !Int
pos Instr
instr = do
      case Instr
instr of
        ANN SDoc
ann Instr
instr -> do
          (idx,instr':instrs') <- LabelMap Int -> Int -> Instr -> UniqSM (Int, [Instr])
replace_jump LabelMap Int
m Int
pos Instr
instr
          pure (idx, ANN ann instr':instrs')
        BCOND Cond
cond Target
t
          -> case LabelMap Int -> Target -> Int -> BlockInRange
target_in_range LabelMap Int
m Target
t Int
pos of
              BlockInRange
InRange -> (Int, [Instr]) -> UniqSM (Int, [Instr])
forall a. a -> UniqSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
long_bc_jump_size,[Instr
instr])
              NotInRange Target
far_target -> do
                jmp_code <- Cond -> Target -> UniqSM (OrdList Instr)
forall (m :: * -> *).
MonadUnique m =>
Cond -> Target -> m (OrdList Instr)
genCondFarJump Cond
cond Target
far_target
                pure (pos+long_bc_jump_size, fromOL jmp_code)
        CBZ Operand
op Target
t -> Operand -> Target -> Cond -> UniqSM (Int, [Instr])
long_zero_jump Operand
op Target
t Cond
EQ
        CBNZ Operand
op Target
t -> Operand -> Target -> Cond -> UniqSM (Int, [Instr])
long_zero_jump Operand
op Target
t Cond
NE
        Instr
instr
          | Instr -> Bool
isMetaInstr Instr
instr -> (Int, [Instr]) -> UniqSM (Int, [Instr])
forall a. a -> UniqSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
pos,[Instr
instr])
          | Bool
otherwise -> (Int, [Instr]) -> UniqSM (Int, [Instr])
forall a. a -> UniqSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, [Instr
instr])

      where
        -- cmp_op: EQ = CBZ, NEQ = CBNZ
        long_zero_jump :: Operand -> Target -> Cond -> UniqSM (Int, [Instr])
long_zero_jump Operand
op Target
t Cond
cmp_op =
          case LabelMap Int -> Target -> Int -> BlockInRange
target_in_range LabelMap Int
m Target
t Int
pos of
              BlockInRange
InRange -> (Int, [Instr]) -> UniqSM (Int, [Instr])
forall a. a -> UniqSM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
long_bz_jump_size,[Instr
instr])
              NotInRange Target
far_target -> do
                jmp_code <- Cond -> Target -> UniqSM (OrdList Instr)
forall (m :: * -> *).
MonadUnique m =>
Cond -> Target -> m (OrdList Instr)
genCondFarJump Cond
cmp_op Target
far_target
                -- TODO: Fix zero reg so we can use it here
                pure (pos + long_bz_jump_size, CMP op (OpImm (ImmInt 0)) : fromOL jmp_code)


    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
        (TLabel CLabel
clbl)
          | Just BlockId
bid <- CLabel -> Maybe BlockId
maybeLocalBlockLabel CLabel
clbl
          -> LabelMap Int -> Int -> BlockId -> BlockInRange
block_in_range LabelMap Int
m Int
src BlockId
bid
          | Bool
otherwise
          -- Maybe we should be pessimistic here, for now just fixing intra proc jumps
          -> BlockInRange
InRange

    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       ->
          String -> SDoc -> BlockInRange -> BlockInRange
forall a. String -> SDoc -> a -> a
pprTrace String
"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
$
            Target -> BlockInRange
NotInRange (BlockId -> Target
TBlock 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 Target -> BlockInRange
NotInRange (BlockId -> Target
TBlock 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 =
      case Instr
instr of
        ANN SDoc
_ann Instr
instr -> (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)
instr_pos (Int
pos, LabelMap Int
m) Instr
instr
        NEWBLOCK BlockId
_bid -> String -> (Int, LabelMap Int)
forall a. HasCallStack => String -> a
panic String
"mkFarBranched - unexpected NEWBLOCK" -- At this point there should be no NEWBLOCK
                                                                     -- in the instruction stream
                                                                     -- (pos, mapInsert bid pos m)
        COMMENT{} -> (Int
pos, LabelMap Int
m)
        Instr
instr
          | Just Int
jump_size <- Instr -> Maybe Int
is_expandable_jump Instr
instr -> (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
jump_size, LabelMap Int
m)
          | Bool
otherwise -> (Int
posInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1, 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

    -- These jumps have a 19bit immediate as offset which is quite
    -- limiting so we potentially have to expand them into
    -- multiple instructions.
    is_expandable_jump :: Instr -> Maybe Int
is_expandable_jump Instr
i = case Instr
i of
      CBZ{}   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
long_bz_jump_size
      CBNZ{}  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
long_bz_jump_size
      BCOND{} -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
long_bc_jump_size
      Instr
_ -> Maybe Int
forall a. Maybe a
Nothing