{-# language GADTs #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BinaryLiterals #-}
{-# 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.Monad (mapAccumLM)

import GHC.Cmm.Dataflow.Collections

-- 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
  ([[NatBasicBlock Instr]]
nat_blocks,[[NatCmmDecl RawCmmStatics Instr]]
statics) <- 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
  Maybe Reg
picBaseMb <- NatM (Maybe Reg)
getPicBaseMaybeNat

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

  case Maybe Reg
picBaseMb of
      Just Reg
_picBase -> forall a. String -> a
panic String
"AArch64.cmmTopCodeGen: picBase not implemented"
      Maybe Reg
Nothing -> 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)
  forall (m :: * -> *) a. Monad m => a -> m a
return [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
  NCGConfig
config <- NatM NCGConfig
getConfig
  -- do
  --   traceM $ "-- --------------------------- basicBlockCodeGen --------------------------- --\n"
  --         ++ showSDocUnsafe (ppr block)
  let (CmmNode C O
_, Block CmmNode O O
nodes, CmmNode O C
tail)  = forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit Block CmmNode C C
block
      id :: Label
id = forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel Block CmmNode C C
block
      stmts :: [CmmNode O O]
stmts = forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
nodes

      header_comment_instr :: OrdList Instr
header_comment_instr = forall a. a -> OrdList a
unitOL forall a b. (a -> b) -> a -> b
$ SDoc -> Instr
MULTILINE_COMMENT (
          String -> SDoc
text String
"-- --------------------------- basicBlockCodeGen --------------------------- --\n"
          SDoc -> SDoc -> SDoc
$+$ forall env a. OutputableP env a => env -> a -> SDoc
pdoc (NCGConfig -> Platform
ncgPlatform NCGConfig
config) Block CmmNode C C
block
          )
  -- Generate location directive
  Maybe DebugBlock
dbg <- Label -> NatM (Maybe DebugBlock)
getDebugBlock (forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel Block CmmNode C C
block)
  OrdList Instr
loc_instrs <- case DebugBlock -> Maybe CmmTickish
dblSourceTick forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe DebugBlock
dbg of
    Just (SourceNote RealSrcSpan
span String
name)
      -> do Int
fileId <- FastString -> NatM Int
getFileId (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
span)
            let line :: Int
line = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span; col :: Int
col = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
span
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> OrdList a
unitOL forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> String -> Instr
LOCATION Int
fileId Int
line Int
col String
name
    Maybe CmmTickish
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. OrdList a
nilOL
  (OrdList Instr
mid_instrs,Label
mid_bid) <- Label -> [CmmNode O O] -> NatM (OrdList Instr, Label)
stmtsToInstrs Label
id [CmmNode O O]
stmts
  (!OrdList Instr
tail_instrs,Maybe Label
_) <- forall (e :: Extensibility) (x :: Extensibility).
Label -> CmmNode e x -> NatM (OrdList Instr, Maybe Label)
stmtToInstrs Label
mid_bid CmmNode O C
tail
  let instrs :: OrdList Instr
instrs = OrdList Instr
header_comment_instr forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
loc_instrs forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
mid_instrs 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 extract
  -- LDATAs here too.
  let
        ([Instr]
top,[NatBasicBlock Instr]
other_blocks,[NatCmmDecl RawCmmStatics Instr]
statics) = forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL forall h g.
Instr
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
mkBlocks ([],[],[]) OrdList Instr
instrs

  forall (m :: * -> *) a. Monad m => a -> m a
return (forall i. Label -> [i] -> GenBasicBlock i
BasicBlock Label
id [Instr]
top forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
other_blocks, [NatCmmDecl RawCmmStatics Instr]
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 Label
id) ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl RawCmmStatics h g]
statics)
  = ([], forall i. Label -> [i] -> GenBasicBlock i
BasicBlock Label
id [Instr]
instrs forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
blocks, [GenCmmDecl RawCmmStatics h g]
statics)
mkBlocks (LDATA Section
sec RawCmmStatics
dat) ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl RawCmmStatics h g]
statics)
  = ([Instr]
instrs, [NatBasicBlock Instr]
blocks, forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec RawCmmStatics
datforall a. a -> [a] -> [a]
:[GenCmmDecl RawCmmStatics h g]
statics)
mkBlocks Instr
instr ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl RawCmmStatics h g]
statics)
  = (Instr
instrforall 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 assmebly we see.  By having the verbatim AST printed
-- we can simply check the patterns that were matched to arrive at the assmebly
-- 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 labourous and adds
-- indirections to find the matches that lead to the assembly.
--
-- An improvement oculd be to have
--
--    (pprExpr genericPlatform e) <> parens (text. show e)
--
-- to have the best of both worlds.
--
-- Note: debugIsOn is too restrictive, it only works for debug compilers.
-- However, we do not only want to inspect this for debug compilers. Ideally
-- we'd have a check for -dppr-debug here already, such that we don't even
-- generate the ANN expressions. However, as they are lazy, they shouldn't be
-- forced until we actually force them, and without -dppr-debug they should
-- never end up being forced.
annExpr :: CmmExpr -> Instr -> Instr
annExpr :: CmmExpr -> Instr -> Instr
annExpr CmmExpr
e Instr
instr {- debugIsOn -} = SDoc -> Instr -> Instr
ANN (String -> SDoc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show 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
reg, Format
format, OrdList Instr
code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
  let w :: Width
w = Format -> Width
formatToWidth Format
format
  let mkbranch :: OrdList Instr -> (Integer, Label) -> NatM (OrdList Instr)
mkbranch OrdList Instr
acc (Integer
key, Label
bid) = do
        (Reg
keyReg, Format
_format, OrdList Instr
code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg (CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
key Width
w))
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ OrdList Instr
code forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                 forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP (Width -> Reg -> Operand
OpReg Width
w Reg
reg) (Width -> Reg -> Operand
OpReg Width
w Reg
keyReg)
                      , Cond -> Target -> Instr
BCOND Cond
EQ (Label -> Target
TBlock Label
bid)
                      ] forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
acc
      def_code :: OrdList Instr
def_code = case SwitchTargets -> Maybe Label
switchTargetsDefault SwitchTargets
targets of
        Just Label
bid -> forall a. a -> OrdList a
unitOL (Target -> Instr
B (Label -> Target
TBlock Label
bid))
        Maybe Label
Nothing  -> forall a. OrdList a
nilOL

  OrdList Instr
switch_code <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM OrdList Instr -> (Integer, Label) -> NatM (OrdList Instr)
mkbranch forall a. OrdList a
nilOL (SwitchTargets -> [(Integer, Label)]
switchTargetsCases SwitchTargets
targets)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ OrdList Instr
code forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
switch_code forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
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
_ = 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 :: Label -> [CmmNode O O] -> NatM (OrdList Instr, Label)
stmtsToInstrs Label
bid [CmmNode O O]
stmts =
    forall {e :: Extensibility} {x :: Extensibility}.
Label
-> [CmmNode e x] -> OrdList Instr -> NatM (OrdList Instr, Label)
go Label
bid [CmmNode O O]
stmts forall a. OrdList a
nilOL
  where
    go :: Label
-> [CmmNode e x] -> OrdList Instr -> NatM (OrdList Instr, Label)
go Label
bid  []        OrdList Instr
instrs = forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
instrs,Label
bid)
    go Label
bid (CmmNode e x
s:[CmmNode e x]
stmts)  OrdList Instr
instrs = do
      (OrdList Instr
instrs',Maybe Label
bid') <- forall (e :: Extensibility) (x :: Extensibility).
Label -> CmmNode e x -> NatM (OrdList Instr, Maybe Label)
stmtToInstrs Label
bid CmmNode e x
s
      -- If the statement introduced a new block, we use that one
      let !newBid :: Label
newBid = forall a. a -> Maybe a -> a
fromMaybe Label
bid Maybe Label
bid'
      Label
-> [CmmNode e x] -> OrdList Instr -> NatM (OrdList Instr, Label)
go Label
newBid [CmmNode e x]
stmts (OrdList Instr
instrs forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
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).
Label -> CmmNode e x -> NatM (OrdList Instr, Maybe Label)
stmtToInstrs Label
bid CmmNode e x
stmt = do
  -- traceM $ "-- -------------------------- stmtToInstrs -------------------------- --\n"
  --     ++ showSDocUnsafe (ppr stmt)
  Platform
platform <- NatM Platform
getPlatform
  case CmmNode e x
stmt of
    CmmUnsafeForeignCall ForeignTarget
target [CmmFormal]
result_regs [CmmExpr]
args
       -> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Label
-> NatM (OrdList Instr, Maybe Label)
genCCall ForeignTarget
target [CmmFormal]
result_regs [CmmExpr]
args Label
bid

    CmmNode e x
_ -> (,forall a. Maybe a
Nothing) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case CmmNode e x
stmt of
      CmmComment FastString
s   -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> OrdList a
unitOL (SDoc -> Instr
COMMENT (FastString -> SDoc
ftext FastString
s)))
      CmmTick {}     -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 = Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
reg
                format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty

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

      CmmBranch Label
id          -> Label -> NatM (OrdList Instr)
genBranch Label
id

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

      CmmNode e x
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"stmtToInstrs: statement should have been cps'd away" (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 forall a b. (a -> b) -> a -> b
$ Unique -> Format -> VirtualReg
mkVirtualReg Unique
u (CmmType -> Format
cmmTypeFormat CmmType
pk)

getRegisterReg Platform
platform (CmmGlobal GlobalReg
mid)
  = case Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe Platform
platform GlobalReg
mid of
        Just RealReg
reg -> RealReg -> Reg
RegReal RealReg
reg
        Maybe RealReg
Nothing  -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegisterReg-memory" (forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ GlobalReg -> CmmReg
CmmGlobal GlobalReg
mid)
        -- 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
  Register
r <- CmmExpr -> NatM Register
getRegister CmmExpr
expr
  case Register
r of
    Any Format
rep Reg -> OrdList Instr
code -> do
        Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
        forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, Format
rep, Reg -> OrdList Instr
code Reg
tmp)
    Fixed Format
rep Reg
reg OrdList Instr
code ->
        forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg, Format
rep, OrdList Instr
code)

-- 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
  Register
r <- CmmExpr -> NatM Register
getRegister CmmExpr
expr
  case Register
r of
    Any Format
rep Reg -> OrdList Instr
code | Format -> Bool
isFloatFormat Format
rep -> do
      Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
      forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, Format
rep, Reg -> OrdList Instr
code Reg
tmp)
    Any Format
II32 Reg -> OrdList Instr
code -> do
      Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
FF32
      forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, Format
FF32, Reg -> OrdList Instr
code Reg
tmp)
    Any Format
II64 Reg -> OrdList Instr
code -> do
      Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
FF64
      forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, Format
FF64, Reg -> OrdList Instr
code Reg
tmp)
    Any Format
_w Reg -> OrdList Instr
_code -> do
      NCGConfig
config <- NatM NCGConfig
getConfig
      forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"can't do getFloatReg on" (forall env a. OutputableP env a => env -> a -> SDoc
pdoc (NCGConfig -> Platform
ncgPlatform NCGConfig
config) CmmExpr
expr)
    -- can't do much for fixed.
    Fixed Format
rep Reg
reg OrdList Instr
code ->
      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 = forall (m :: * -> *) a. Monad m => a -> m a
return (Imm -> Operand
OpImm (CmmLit -> Imm
litToImm CmmLit
lit), forall a. OrdList a
nilOL)

getRegister :: CmmExpr -> NatM Register
getRegister :: CmmExpr -> NatM Register
getRegister CmmExpr
e = do
  NCGConfig
config <- NatM NCGConfig
getConfig
  NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config (NCGConfig -> Platform
ncgPlatform NCGConfig
config) CmmExpr
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   = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"opRegWidth" (String -> SDoc
text String
"Unsupported width" SDoc -> SDoc -> 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 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 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 GlobalReg
PicBaseReg)
      -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegisterReg-memory" (forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ GlobalReg
PicBaseReg)
    CmmLit CmmLit
lit
      -> case CmmLit
lit of

        -- TODO handle CmmInt 0 specially, use wzr or xzr.

        CmmInt Integer
i Width
W8 | Integer
i forall a. Ord a => a -> a -> Bool
>= Integer
0 -> do
          forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
W8) (\Reg
dst -> forall a. a -> OrdList a
unitOL 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 forall a. Ord a => a -> a -> Bool
>= Integer
0 -> do
          forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
W16) (\Reg
dst -> forall a. a -> OrdList a
unitOL 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
          forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
W8) (\Reg
dst -> forall a. a -> OrdList a
unitOL 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
          forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
W16) (\Reg
dst -> forall a. a -> OrdList a
unitOL 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 | Int -> Integer -> Bool
isNbitEncodeable Int
16 Integer
i, Integer
i forall a. Ord a => a -> a -> Bool
>= Integer
0 -> do
          forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> forall a. a -> OrdList a
unitOL 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 forall a. Ord a => a -> a -> Bool
>= Integer
0 -> do
          let  half0 :: Int
half0 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Word16)
               half1 :: Int
half1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i forall a. Bits a => a -> Int -> a
`shiftR` Int
16) :: Word16)
          forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> forall a. [a] -> OrdList a
toOL [ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr
                                                  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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Word16)
               half1 :: Int
half1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i forall a. Bits a => a -> Int -> a
`shiftR` Int
16) :: Word16)
          forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
W32) (\Reg
dst -> forall a. [a] -> OrdList a
toOL [ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr
                                                    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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Word16)
               half1 :: Int
half1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i forall a. Bits a => a -> Int -> a
`shiftR` Int
16) :: Word16)
               half2 :: Int
half2 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i forall a. Bits a => a -> Int -> a
`shiftR` Int
32) :: Word16)
               half3 :: Int
half3 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i forall a. Bits a => a -> Int -> a
`shiftR` Int
48) :: Word16)
          forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
W64) (\Reg
dst -> forall a. [a] -> OrdList a
toOL [ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr
                                                    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
          (Operand
op, OrdList Instr
imm_code) <- CmmLit -> NatM (Operand, OrdList Instr)
litToImm' CmmLit
lit
          forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
rep) (\Reg
dst -> OrdList Instr
imm_code 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
          (Operand
op, OrdList Instr
imm_code) <- CmmLit -> NatM (Operand, OrdList Instr)
litToImm' CmmLit
lit
          forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
w) (\Reg
dst -> OrdList Instr
imm_code 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  -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmFloat), no support for bytes" (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmFloat Rational
_f Width
W16 -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmFloat), no support for halfs" (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 (forall a. Fractional a => Rational -> a
fromRational Rational
f) :: Word32
              half0 :: Int
half0 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
word :: Word16)
              half1 :: Int
half1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
word forall a. Bits a => a -> Int -> a
`shiftR` Int
16) :: Word16)
          Reg
tmp <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
W32)
          forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
W32) (\Reg
dst -> forall a. [a] -> OrdList a
toOL [ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr
                                                      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 (forall a. Fractional a => Rational -> a
fromRational Rational
f) :: Word64
              half0 :: Int
half0 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
word :: Word16)
              half1 :: Int
half1 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
word forall a. Bits a => a -> Int -> a
`shiftR` Int
16) :: Word16)
              half2 :: Int
half2 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
word forall a. Bits a => a -> Int -> a
`shiftR` Int
32) :: Word16)
              half3 :: Int
half3 = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
word forall a. Bits a => a -> Int -> a
`shiftR` Int
48) :: Word16)
          Reg
tmp <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
W64)
          forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
W64) (\Reg
dst -> forall a. [a] -> OrdList a
toOL [ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr
                                                      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 -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmFloat), unsupported float lit" (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmVec [CmmLit]
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmVec): " (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmLabel CLabel
_lbl -> do
          (Operand
op, OrdList Instr
imm_code) <- CmmLit -> NatM (Operand, OrdList Instr)
litToImm' CmmLit
lit
          let rep :: CmmType
rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
plat CmmLit
lit
              format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
rep
          forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format (\Reg
dst -> OrdList Instr
imm_code forall a. OrdList a -> a -> OrdList a
`snocOL` (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr 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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) -> do
          (Operand
op, OrdList Instr
imm_code) <- CmmLit -> NatM (Operand, OrdList Instr)
litToImm' CmmLit
lit
          let rep :: CmmType
rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
plat CmmLit
lit
              format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
rep
              -- width = typeWidth rep
          forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format (\Reg
dst -> OrdList Instr
imm_code 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
          (Operand
op, OrdList Instr
imm_code) <- CmmLit -> NatM (Operand, OrdList Instr)
litToImm' (CLabel -> CmmLit
CmmLabel CLabel
lbl)
          let rep :: CmmType
rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
plat CmmLit
lit
              format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
rep
              width :: Width
width = CmmType -> Width
typeWidth CmmType
rep
          (Reg
off_r, Format
_off_format, OrdList Instr
off_code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg forall a b. (a -> b) -> a -> b
$ CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
width)
          forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format (\Reg
dst -> OrdList Instr
imm_code forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
off_code 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 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
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmLabelOff): " (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmBlock Label
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmLabelOff): " (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmLit
CmmHighStackMark -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmLabelOff): " (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
    CmmLoad CmmExpr
mem CmmType
rep AlignmentSpec
_ -> do
      Amode AddrMode
addr OrdList Instr
addr_code <- Platform -> Width -> CmmExpr -> NatM Amode
getAmode Platform
plat (CmmType -> Width
typeWidth CmmType
rep) CmmExpr
mem
      let format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
rep
      forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format (\Reg
dst -> OrdList Instr
addr_code 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
_
      -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmStackSlot): " (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
    CmmReg CmmReg
reg
      -> forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed (CmmType -> Format
cmmTypeFormat (Platform -> CmmReg -> CmmType
cmmRegType Platform
plat CmmReg
reg))
                       (Platform -> CmmReg -> Reg
getRegisterReg Platform
plat CmmReg
reg)
                       forall a. OrdList a
nilOL)
    CmmRegOff CmmReg
reg Int
off | Int -> Integer -> Bool
isNbitEncodeable Int
12 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) -> do
      NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat forall a b. (a -> b) -> a -> b
$
            MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
width) [CmmReg -> CmmExpr
CmmReg CmmReg
reg, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
width)]
          where width :: Width
width = CmmType -> Width
typeWidth (Platform -> CmmReg -> CmmType
cmmRegType Platform
plat CmmReg
reg)

    CmmRegOff CmmReg
reg Int
off -> do
      (Reg
off_r, Format
_off_format, OrdList Instr
off_code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg forall a b. (a -> b) -> a -> b
$ CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
width)
      (Reg
reg, Format
_format, OrdList Instr
code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg forall a b. (a -> b) -> a -> b
$ CmmReg -> CmmExpr
CmmReg CmmReg
reg
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
width) (\Reg
dst -> OrdList Instr
off_code forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
width Reg
dst) (Width -> Reg -> Operand
OpReg Width
width Reg
reg) (Width -> Reg -> Operand
OpReg Width
width Reg
off_r))
          where width :: Width
width = CmmType -> Width
typeWidth (Platform -> CmmReg -> CmmType
cmmRegType Platform
plat CmmReg
reg)



    -- for MachOps, see GHC.Cmm.MachOp
    -- For CmmMachOp, see GHC.Cmm.Expr
    CmmMachOp MachOp
op [CmmExpr
e] -> do
      (Reg
reg, Format
_format, OrdList Instr
code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
e
      case MachOp
op of
        MO_Not Width
w -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) forall a b. (a -> b) -> a -> b
$ \Reg
dst ->
            let w' :: Width
w' = Width -> Width
opRegWidth Width
w
             in OrdList Instr
code 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) 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
w) (\Reg
dst -> OrdList Instr
code 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
to) (\Reg
dst -> OrdList Instr
code 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) (\Reg
dst -> OrdList Instr
code 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) (\Reg
dst -> OrdList Instr
code forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Operand -> Operand -> Instr
UBFM (Width -> Reg -> Operand
OpReg (forall a. Ord a => a -> a -> a
max Width
from Width
to) Reg
dst) (Width -> Reg -> Operand
OpReg (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 (forall a. Ord a => a -> a -> a
min Width
from Width
to)))
        MO_SS_Conv Width
from Width
to -> 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
to) (\Reg
dst -> OrdList Instr
code 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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmExpr -> NatM Register
getRegister CmmExpr
e

        MachOp
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (monadic CmmMachOp):" (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
reg', OrdList Instr
code_sx) <- Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
signExtendReg Width
w Width
w' Reg
reg
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) forall a b. (a -> b) -> a -> b
$ \Reg
dst ->
                OrdList Instr
code forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                OrdList Instr
code_sx 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') 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 (forall a. Ord a => a -> a -> a
max Width
from Width
to)
            in forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) forall a b. (a -> b) -> a -> b
$ \Reg
dst ->
                OrdList Instr
code 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 (forall a. Ord a => a -> a -> a
min Width
from Width
to)) 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 GlobalReg
_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 GlobalReg
_r)), CmmLit (CmmInt Integer
0 Width
_)] -> NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat CmmExpr
expr'
    -- 1. Compute Reg +/- n directly.
    --    For Add/Sub we can directly encode 12bits, or 12bits lsl #12.
    CmmMachOp (MO_Add Width
w) [(CmmReg CmmReg
reg), CmmLit (CmmInt Integer
n Width
_)]
      | Integer
n forall a. Ord a => a -> a -> Bool
> Integer
0 Bool -> Bool -> Bool
&& Integer
n forall a. Ord a => a -> a -> Bool
< Integer
4096
      , Width
w forall a. Eq a => a -> a -> Bool
== Width
W32 Bool -> Bool -> Bool
|| Width
w forall a. Eq a => a -> a -> Bool
== Width
W64 -- Work around #23749
      -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> forall a. a -> OrdList a
unitOL forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
w Reg
d) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
      -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.
      where w' :: Width
w' = Format -> Width
formatToWidth (CmmType -> Format
cmmTypeFormat (Platform -> CmmReg -> CmmType
cmmRegType Platform
plat CmmReg
reg))
            r' :: Reg
r' = Platform -> CmmReg -> Reg
getRegisterReg Platform
plat CmmReg
reg
    CmmMachOp (MO_Sub Width
w) [(CmmReg CmmReg
reg), CmmLit (CmmInt Integer
n Width
_)]
      | Integer
n forall a. Ord a => a -> a -> Bool
> Integer
0 Bool -> Bool -> Bool
&& Integer
n forall a. Ord a => a -> a -> Bool
< Integer
4096
      , Width
w forall a. Eq a => a -> a -> Bool
== Width
W32 Bool -> Bool -> Bool
|| Width
w forall a. Eq a => a -> a -> Bool
== Width
W64 -- Work around #23749
      -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> forall a. a -> OrdList a
unitOL forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SUB (Width -> Reg -> Operand
OpReg Width
w Reg
d) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
      -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.
      where w' :: Width
w' = Format -> Width
formatToWidth (CmmType -> Format
cmmTypeFormat (Platform -> CmmReg -> CmmType
cmmRegType Platform
plat CmmReg
reg))
            r' :: Reg
r' = Platform -> CmmReg -> Reg
getRegisterReg Platform
plat CmmReg
reg

    CmmMachOp (MO_U_Quot Width
w) [CmmExpr
x, CmmExpr
y] | Width
w forall a. Eq a => a -> a -> Bool
== Width
W8 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      (Reg
reg_y, Format
_format_y, OrdList Instr
code_y) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
y
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y 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)) 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)) 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 forall a. Eq a => a -> a -> Bool
== Width
W16 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      (Reg
reg_y, Format
_format_y, OrdList Instr
code_y) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
y
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y 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)) 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)) 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 forall a. Eq a => a -> a -> Bool
== Width
W32, Integer
0 forall a. Ord a => a -> a -> Bool
<= Integer
n, Integer
n forall a. Ord a => a -> a -> Bool
< Integer
32 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x 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_Shl Width
w) [CmmExpr
x, (CmmLit (CmmInt Integer
n Width
_))] | Width
w forall a. Eq a => a -> a -> Bool
== Width
W64, Integer
0 forall a. Ord a => a -> a -> Bool
<= Integer
n, Integer
n forall a. Ord a => a -> a -> Bool
< Integer
64 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x 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 forall a. Eq a => a -> a -> Bool
== Width
W8, Integer
0 forall a. Ord a => a -> a -> Bool
<= Integer
n, Integer
n forall a. Ord a => a -> a -> Bool
< Integer
8 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x 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
8forall a. Num a => a -> a -> a
-Integer
n)))))
    CmmMachOp (MO_S_Shr Width
w) [CmmExpr
x, CmmExpr
y] | Width
w forall a. Eq a => a -> a -> Bool
== Width
W8 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      (Reg
reg_y, Format
_format_y, OrdList Instr
code_y) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
y
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y 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)) 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 forall a. Eq a => a -> a -> Bool
== Width
W16, Integer
0 forall a. Ord a => a -> a -> Bool
<= Integer
n, Integer
n forall a. Ord a => a -> a -> Bool
< Integer
16 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x 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
16forall a. Num a => a -> a -> a
-Integer
n)))))
    CmmMachOp (MO_S_Shr Width
w) [CmmExpr
x, CmmExpr
y] | Width
w forall a. Eq a => a -> a -> Bool
== Width
W16 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      (Reg
reg_y, Format
_format_y, OrdList Instr
code_y) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
y
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y 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)) 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 forall a. Eq a => a -> a -> Bool
== Width
W32, Integer
0 forall a. Ord a => a -> a -> Bool
<= Integer
n, Integer
n forall a. Ord a => a -> a -> Bool
< Integer
32 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x 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_S_Shr Width
w) [CmmExpr
x, (CmmLit (CmmInt Integer
n Width
_))] | Width
w forall a. Eq a => a -> a -> Bool
== Width
W64, Integer
0 forall a. Ord a => a -> a -> Bool
<= Integer
n, Integer
n forall a. Ord a => a -> a -> Bool
< Integer
64 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x 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 forall a. Eq a => a -> a -> Bool
== Width
W8, Integer
0 forall a. Ord a => a -> a -> Bool
<= Integer
n, Integer
n forall a. Ord a => a -> a -> Bool
< Integer
8 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x 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
8forall a. Num a => a -> a -> a
-Integer
n)))))
    CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, CmmExpr
y] | Width
w forall a. Eq a => a -> a -> Bool
== Width
W8 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      (Reg
reg_y, Format
_format_y, OrdList Instr
code_y) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
y
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y 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)) 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 forall a. Eq a => a -> a -> Bool
== Width
W16, Integer
0 forall a. Ord a => a -> a -> Bool
<= Integer
n, Integer
n forall a. Ord a => a -> a -> Bool
< Integer
16 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x 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
16forall a. Num a => a -> a -> a
-Integer
n)))))
    CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, CmmExpr
y] | Width
w forall a. Eq a => a -> a -> Bool
== Width
W16 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      (Reg
reg_y, Format
_format_y, OrdList Instr
code_y) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
y
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y 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)) 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 forall a. Eq a => a -> a -> Bool
== Width
W32, Integer
0 forall a. Ord a => a -> a -> Bool
<= Integer
n, Integer
n forall a. Ord a => a -> a -> Bool
< Integer
32 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x 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))))

    CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, (CmmLit (CmmInt Integer
n Width
_))] | Width
w forall a. Eq a => a -> a -> Bool
== Width
W64, Integer
0 forall a. Ord a => a -> a -> Bool
<= Integer
n, Integer
n forall a. Ord a => a -> a -> Bool
< Integer
64 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x 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
_)] | Integer -> Bool
isAArch64Bitmask (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) ->
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> forall a. a -> OrdList a
unitOL 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 (Platform -> CmmReg -> CmmType
cmmRegType Platform
plat CmmReg
reg))
            r' :: Reg
r' = Platform -> CmmReg -> Reg
getRegisterReg Platform
plat CmmReg
reg

    CmmMachOp (MO_Or Width
w) [(CmmReg CmmReg
reg), CmmLit (CmmInt Integer
n Width
_)] | Integer -> Bool
isAArch64Bitmask (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) ->
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> forall a. a -> OrdList a
unitOL 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 (Platform -> CmmReg -> CmmType
cmmRegType Platform
plat CmmReg
reg))
            r' :: Reg
r' = Platform -> CmmReg -> Reg
getRegisterReg Platform
plat CmmReg
reg

    -- Generic 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
w) 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.
          bitOp :: Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
bitOp Width
w Operand -> Operand -> Operand -> OrdList Instr
op = do
            -- compute x<m> <- x
            -- compute x<o> <- y
            -- <OP> x<n>, x<m>, x<o>
            (Reg
reg_x, Format
format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
            (Reg
reg_y, Format
format_y, OrdList Instr
code_y) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
y
            forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (Format -> Bool
isIntFormat Format
format_x forall a. Eq a => a -> a -> Bool
== Format -> Bool
isIntFormat Format
format_y) forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"bitOp: incompatible"
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst ->
                OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                OrdList Instr
code_y forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                Operand -> Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y))

          -- A (potentially signed) integer operation.
          -- In the case of 8- and 16-bit signed arithmetic we must first
          -- sign-extend both arguments to 32-bits.
          -- See Note [Signed arithmetic on 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
reg_x, Format
format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
              (Reg
reg_y, Format
format_y, OrdList Instr
code_y) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
y
              forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (Format -> Bool
isIntFormat Format
format_x Bool -> Bool -> Bool
&& Format -> Bool
isIntFormat Format
format_y) forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"intOp: non-int"
              -- This is the width of the registers on which the operation
              -- should be performed.
              let w' :: Width
w' = Width -> Width
opRegWidth Width
w
                  signExt :: Reg -> NatM (Reg, OrdList Instr)
signExt Reg
r
                    | Bool -> Bool
not Bool
is_signed  = forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
r, forall a. OrdList a
nilOL)
                    | Bool
otherwise      = Width -> Width -> Reg -> NatM (Reg, OrdList Instr)
signExtendReg Width
w Width
w' Reg
r
              (Reg
reg_x_sx, OrdList Instr
code_x_sx) <- Reg -> NatM (Reg, OrdList Instr)
signExt Reg
reg_x
              (Reg
reg_y_sx, OrdList Instr
code_y_sx) <- Reg -> NatM (Reg, OrdList Instr)
signExt Reg
reg_y
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) forall a b. (a -> b) -> a -> b
$ \Reg
dst ->
                  OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                  OrdList Instr
code_y forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                  -- sign-extend both operands
                  OrdList Instr
code_x_sx forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                  OrdList Instr
code_y_sx 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) 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
reg_fx, Format
format_x, OrdList Instr
code_fx) <- HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
x
            (Reg
reg_fy, Format
format_y, OrdList Instr
code_fy) <- HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
y
            forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (Format -> Bool
isFloatFormat Format
format_x Bool -> Bool -> Bool
&& Format -> Bool
isFloatFormat Format
format_y) forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"floatOp: non-float"
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
w) (\Reg
dst -> OrdList Instr
code_fx forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_fy 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
reg_fx, Format
format_x, OrdList Instr
code_fx) <- HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
x
            (Reg
reg_fy, Format
format_y, OrdList Instr
code_fy) <- HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
y
            forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (Format -> Bool
isFloatFormat Format
format_x Bool -> Bool -> Bool
&& Format -> Bool
isFloatFormat Format
format_y) forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"floatCond: non-float"
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_fx forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_fy forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fx) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fy))

      case MachOp
op of
        -- Integer operations
        -- Add/Sub should only be Integer Options.
        MO_Add Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> forall a. a -> OrdList a
unitOL forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ADD Operand
d Operand
x Operand
y))
        -- TODO: Handle sub-word case
        MO_Sub Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> forall a. a -> OrdList a
unitOL forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SUB Operand
d Operand
x Operand
y))

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

        -- Signed multiply/divide
        MO_Mul Width
w          -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
True Width
w (\Operand
d Operand
x Operand
y -> forall a. a -> OrdList a
unitOL 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 -> forall a. a -> OrdList a
unitOL 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 -> forall {b}. Width -> (Operand -> NatM b) -> NatM b
withTempIntReg Width
w 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 -> 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_MulMayOflo Width
_w -> forall env a b. OutputableP env a => env -> a -> b
unsupportedP Platform
plat CmmExpr
expr
        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 -> forall a. a -> OrdList a
unitOL forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
UDIV Operand
d Operand
x Operand
y)
        MO_U_Rem Width
w  -> forall {b}. Width -> (Operand -> NatM b) -> NatM b
withTempIntReg Width
w 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 -> 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 -> 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 -> 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 -> 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 -> 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)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
UGE ])
        MO_U_Le Width
w     -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
ULE ])
        MO_U_Gt Width
w     -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
UGT ])
        MO_U_Lt Width
w     -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
ULT ])

        -- Floating point arithmetic
        MO_F_Add Width
w   -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatOp Width
w (\Operand
d Operand
x Operand
y -> forall a. a -> OrdList a
unitOL 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 -> forall a. a -> OrdList a
unitOL 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 -> forall a. a -> OrdList a
unitOL 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 -> forall a. a -> OrdList a
unitOL 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 -> 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 -> 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 intutive. 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 -> 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 -> 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 -> 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 -> 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)
-> NatM Register
bitOp Width
w (\Operand
d Operand
x Operand
y -> forall a. a -> OrdList a
unitOL forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
AND Operand
d Operand
x Operand
y)
        MO_Or    Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
bitOp Width
w (\Operand
d Operand
x Operand
y -> forall a. a -> OrdList a
unitOL forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
ORR Operand
d Operand
x Operand
y)
        MO_Xor   Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
bitOp Width
w (\Operand
d Operand
x Operand
y -> forall a. a -> OrdList a
unitOL forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
EOR Operand
d Operand
x Operand
y)
        MO_Shl   Width
w -> Bool
-> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Bool
False Width
w (\Operand
d Operand
x Operand
y -> forall a. a -> OrdList a
unitOL 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 -> forall a. a -> OrdList a
unitOL 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 -> forall a. a -> OrdList a
unitOL forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
ASR Operand
d Operand
x Operand
y)

        -- TODO

        MachOp
op -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (unhandled dyadic CmmMachOp): " forall a b. (a -> b) -> a -> b
$ (MachOp -> SDoc
pprMachOp MachOp
op) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in" SDoc -> SDoc -> SDoc
<+> (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
    CmmMachOp MachOp
_op [CmmExpr]
_xs
      -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (variadic CmmMachOp): " (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)

  where
    unsupportedP :: OutputableP env a => env -> a -> b
    unsupportedP :: forall env a b. OutputableP env a => env -> a -> b
unsupportedP env
platform a
op = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Unsupported op:" (forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
platform a
op)

    isNbitEncodeable :: Int -> Integer -> Bool
    isNbitEncodeable :: Int -> Integer -> Bool
isNbitEncodeable Int
n Integer
i = let shift :: Int
shift = Int
n forall a. Num a => a -> a -> a
- Int
1 in (-Integer
1 forall a. Bits a => a -> Int -> a
`shiftL` Int
shift) forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i forall a. Ord a => a -> a -> Bool
< (Integer
1 forall a. Bits a => a -> Int -> a
`shiftL` Int
shift)

    -- N.B. MUL does not set the overflow flag.
    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
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
        (Reg
reg_y, Format
_format_y, OrdList Instr
code_y) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
y
        Reg
lo <- Format -> NatM Reg
getNewRegNat Format
II64
        Reg
hi <- Format -> NatM Reg
getNewRegNat Format
II64
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst ->
            OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            OrdList Instr
code_y 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) 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) 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) 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
w CmmExpr
x CmmExpr
y = do
        (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
        (Reg
reg_y, Format
_format_y, OrdList Instr
code_y) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
y
        let tmp_w :: Width
tmp_w = case Width
w of
                      Width
W32 -> Width
W64
                      Width
W16 -> Width
W32
                      Width
W8  -> Width
W32
                      Width
_   -> forall a. String -> a
panic String
"do_mul_may_oflo: impossible"
        -- This will hold the product
        Reg
tmp <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
tmp_w)
        let ext_mode :: ExtMode
ext_mode = case Width
w of
                         Width
W32 -> ExtMode
ESXTW
                         Width
W16 -> ExtMode
ESXTH
                         Width
W8  -> ExtMode
ESXTB
                         Width
_   -> forall a. String -> a
panic String
"do_mul_may_oflo: impossible"
            mul :: Operand -> Operand -> Operand -> Instr
mul = case Width
w of
                    Width
W32 -> Operand -> Operand -> Operand -> Instr
SMULL
                    Width
W16 -> Operand -> Operand -> Operand -> Instr
MUL
                    Width
W8  -> Operand -> Operand -> Operand -> Instr
MUL
                    Width
_   -> forall a. String -> a
panic String
"do_mul_may_oflo: impossible"
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst ->
            OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
            OrdList Instr
code_y forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Operand -> Operand -> Instr
mul (Width -> Reg -> Operand
OpReg Width
tmp_w Reg
tmp) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y) forall a. OrdList a -> a -> OrdList a
`snocOL`
            Operand -> Operand -> Instr
CMP (Width -> Reg -> Operand
OpReg Width
tmp_w Reg
tmp) (Width -> Reg -> ExtMode -> Int -> Operand
OpRegExt Width
tmp_w Reg
tmp ExtMode
ext_mode Int
0) 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 :: Integer -> Bool
-- N.B. zero and ~0 are not encodable as bitmask immediates
isAArch64Bitmask :: Integer -> Bool
isAArch64Bitmask Integer
0  = Bool
False
isAArch64Bitmask Integer
n
  | Integer
n forall a. Eq a => a -> a -> Bool
== forall a. Bits a => Int -> a
bit Int
64 forall a. Num a => a -> a -> a
- Integer
1 = Bool
False
isAArch64Bitmask Integer
n  =
    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' = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64 -> Word64
mkPat Int
width Word64
subpat)
          in Integer
n forall a. Eq a => a -> a -> Bool
== Integer
n'
      | Bool
otherwise = Bool
False
      where
        subpat :: Word64
        subpat :: Word64
subpat = forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
n forall a. Bits a => a -> a -> a
.&. (forall a. Bits a => Int -> a
bit Int
width 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 =
        forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Bits a => a -> a -> a
(.|.) Word64
0 [ Word64
subpat 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 forall a. Eq a => a -> a -> Bool
== forall a. Bits a => a -> Int
popCount Word64
m forall a. Num a => a -> a -> a
+ forall b. FiniteBits b => b -> Int
countLeadingZeros Word64
m forall a. Num a => a -> a -> a
+ 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' 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
_             -> forall a. String -> a
panic String
"intOp"
  where
    noop :: NatM (Reg, OrdList Instr)
noop = forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
r, forall a. OrdList a
nilOL)
    extend :: (Operand -> Operand -> Instr) -> NatM (Reg, OrdList Instr)
extend Operand -> Operand -> Instr
instr = do
        Reg
r' <- Format -> NatM Reg
getNewRegNat Format
II64
        forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
r', forall a. a -> OrdList a
unitOL forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
instr (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Width -> Reg -> Operand
OpReg Width
w' Reg
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 -> forall a. OrdList a
nilOL
      Width
W32
        | Width
w' forall a. Eq a => a -> a -> Bool
== Width
W32 -> forall a. OrdList a
nilOL
      Width
_   -> forall a. a -> OrdList a
unitOL 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 forall a b. (a -> b) -> a -> b
$ Int -> Imm
ImmInt forall a b. (a -> b) -> a -> b
$ Width -> Int
widthInBits Width
w' 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:
-- LDUR/STUR: imm9: -256 - 255
getAmode :: Platform -> Width -> CmmExpr -> NatM Amode
getAmode Platform
platform Width
_ (CmmRegOff CmmReg
reg Int
off) | -Int
256 forall a. Ord a => a -> a -> Bool
<= Int
off, Int
off forall a. Ord a => a -> a -> Bool
<= Int
255
  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AddrMode -> OrdList Instr -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg' Imm
off') 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
-- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4
getAmode Platform
platform Width
W32 (CmmRegOff CmmReg
reg Int
off)
  | Int
0 forall a. Ord a => a -> a -> Bool
<= Int
off, Int
off forall a. Ord a => a -> a -> Bool
<= Int
16380, Int
off forall a. Integral a => a -> a -> a
`mod` Int
4 forall a. Eq a => a -> a -> Bool
== Int
0
  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AddrMode -> OrdList Instr -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg' Imm
off') 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
-- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8
getAmode Platform
platform Width
W64 (CmmRegOff CmmReg
reg Int
off)
  | Int
0 forall a. Ord a => a -> a -> Bool
<= Int
off, Int
off forall a. Ord a => a -> a -> Bool
<= Int
32760, Int
off forall a. Integral a => a -> a -> a
`mod` Int
8 forall a. Eq a => a -> a -> Bool
== Int
0
  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AddrMode -> OrdList Instr -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg' Imm
off') forall a. OrdList a
nilOL
    where reg' :: Reg
reg' = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg
          off' :: Imm
off' = Int -> Imm
ImmInt Int
off

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

getAmode Platform
_platform Width
_ (CmmMachOp (MO_Sub Width
_w) [CmmExpr
expr, CmmLit (CmmInt Integer
off Width
_w')])
  | -Integer
256 forall a. Ord a => a -> a -> Bool
<= -Integer
off, -Integer
off forall a. Ord a => a -> a -> Bool
<= Integer
255
  = do (Reg
reg, Format
_format, OrdList Instr
code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AddrMode -> OrdList Instr -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg (Integer -> Imm
ImmInteger (-Integer
off))) OrdList Instr
code

-- Generic case
getAmode Platform
_platform Width
_ CmmExpr
expr
  = do (Reg
reg, Format
_format, OrdList Instr
code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AddrMode -> OrdList Instr -> Amode
Amode (Reg -> AddrMode
AddrReg Reg
reg) OrdList Instr
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
    (Reg
src_reg, Format
_format, OrdList Instr
code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
srcE
    Platform
platform <- NatM Platform
getPlatform
    let w :: Width
w = Format -> Width
formatToWidth Format
rep
    Amode AddrMode
addr OrdList Instr
addr_code <- Platform -> Width -> CmmExpr -> NatM Amode
getAmode Platform
platform Width
w CmmExpr
addrE
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SDoc -> Instr
COMMENT (String -> SDoc
text String
"CmmStore" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (String -> SDoc
text (forall a. Show a => a -> String
show CmmExpr
addrE)) SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (String -> SDoc
text (forall a. Show a => a -> String
show CmmExpr
srcE)))
            forall a. a -> OrdList a -> OrdList a
`consOL` (OrdList Instr
code
            forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
addr_code
            forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Operand -> Operand -> Instr
STR Format
rep (Width -> Reg -> Operand
OpReg Width
w Reg
src_reg) (AddrMode -> Operand
OpAddr AddrMode
addr))

assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_IntCode Format
_ CmmReg
reg CmmExpr
src
  = do
    Platform
platform <- NatM Platform
getPlatform
    let dst :: Reg
dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg
    Register
r <- CmmExpr -> NatM Register
getRegister CmmExpr
src
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Register
r of
      Any Format
_ Reg -> OrdList Instr
code              -> SDoc -> Instr
COMMENT (String -> SDoc
text String
"CmmAssign" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (String -> SDoc
text (forall a. Show a => a -> String
show CmmReg
reg)) SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (String -> SDoc
text (forall a. Show a => a -> String
show CmmExpr
src))) 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
text String
"CmmAssign" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (String -> SDoc
text (forall a. Show a => a -> String
show CmmReg
reg)) SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (String -> SDoc
text (forall a. Show a => a -> String
show CmmExpr
src))) forall a. a -> OrdList a -> OrdList a
`consOL` (OrdList Instr
fcode 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))
  = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> OrdList a
unitOL (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Target -> Instr
J (CLabel -> Target
TLabel CLabel
lbl)))

genJump CmmExpr
expr = do
    (Reg
target, Format
_format, OrdList Instr
code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
    forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code forall a. OrdList a -> OrdList a -> OrdList a
`appOL` forall a. a -> OrdList a
unitOL (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Target -> Instr
J (Reg -> Target
TReg Reg
target))))

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

-- -----------------------------------------------------------------------------
-- Conditional branches
genCondJump
    :: BlockId
    -> CmmExpr
    -> NatM InstrBlock
genCondJump :: Label -> CmmExpr -> NatM (OrdList Instr)
genCondJump Label
bid CmmExpr
expr = do
    case CmmExpr
expr of
      -- Optimized == 0 case.
      CmmMachOp (MO_Eq Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
0 Width
_)] -> do
        (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ OrdList Instr
code_x forall a. OrdList a -> a -> OrdList a
`snocOL` (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Target -> Instr
CBZ (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Label -> Target
TBlock Label
bid)))

      -- Optimized /= 0 case.
      CmmMachOp (MO_Ne Width
w) [CmmExpr
x, CmmLit (CmmInt Integer
0 Width
_)] -> do
        (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ OrdList Instr
code_x forall a. OrdList a -> a -> OrdList a
`snocOL`  (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Target -> Instr
CBNZ (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Label -> Target
TBlock Label
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
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
                (Reg
reg_y, Format
_format_y, OrdList Instr
code_y) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
y
                let x' :: Operand
x' = Width -> Reg -> Operand
OpReg Width
w Reg
reg_x
                    y' :: Operand
y' = Width -> Reg -> Operand
OpReg Width
w Reg
reg_y
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Width
w of
                  Width
W8  -> OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y forall a. OrdList a -> OrdList a -> OrdList a
`appOL` 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 (Label -> Target
TBlock Label
bid))) ]
                  Width
W16 -> OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y forall a. OrdList a -> OrdList a -> OrdList a
`appOL` 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 (Label -> Target
TBlock Label
bid))) ]
                  Width
_   -> OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y forall a. OrdList a -> OrdList a -> OrdList a
`appOL` 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 (Label -> Target
TBlock Label
bid))) ]

            sbcond :: Width -> Cond -> NatM (OrdList Instr)
sbcond Width
w Cond
cmp = do
                -- compute both sides.
                (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
                (Reg
reg_y, Format
_format_y, OrdList Instr
code_y) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
y
                let x' :: Operand
x' = Width -> Reg -> Operand
OpReg Width
w Reg
reg_x
                    y' :: Operand
y' = Width -> Reg -> Operand
OpReg Width
w Reg
reg_y
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Width
w of
                  Width
W8  -> OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y forall a. OrdList a -> OrdList a -> OrdList a
`appOL` 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 (Label -> Target
TBlock Label
bid))) ]
                  Width
W16 -> OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y forall a. OrdList a -> OrdList a -> OrdList a
`appOL` 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 (Label -> Target
TBlock Label
bid))) ]
                  Width
_   -> OrdList Instr
code_x forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y forall a. OrdList a -> OrdList a -> OrdList a
`appOL` 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 (Label -> Target
TBlock Label
bid))) ]

            fbcond :: Width -> Cond -> NatM (OrdList Instr)
fbcond Width
w Cond
cmp = do
              -- ensure we get float regs
              (Reg
reg_fx, Format
_format_fx, OrdList Instr
code_fx) <- HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
x
              (Reg
reg_fy, Format
_format_fy, OrdList Instr
code_fy) <- HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
y
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ OrdList Instr
code_fx forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_fy forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
CMP (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fx) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fy) forall a. OrdList a -> a -> OrdList a
`snocOL` (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Cond -> Target -> Instr
BCOND Cond
cmp (Label -> Target
TBlock Label
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
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"AArch64.genCondJump:case mop: " (String -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show CmmExpr
expr)
      CmmExpr
_ -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"AArch64.genCondJump: " (String -> SDoc
text forall a b. (a -> b) -> a -> b
$ 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
  Label
skip_lbl_id <- forall (m :: * -> *). MonadUnique m => m Label
newBlockId
  Label
jmp_lbl_id <- forall (m :: * -> *). MonadUnique m => m Label
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.
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> OrdList a
toOL [ Cond -> Target -> Instr
BCOND Cond
cond (Label -> Target
TBlock Label
jmp_lbl_id)
                , Target -> Instr
B (Label -> Target
TBlock Label
skip_lbl_id)
                , Label -> Instr
NEWBLOCK Label
jmp_lbl_id
                , Target -> Instr
B Target
far_target
                , Label -> Instr
NEWBLOCK Label
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 :: Label -> Label -> Label -> CmmExpr -> NatM (OrdList Instr)
genCondBranch Label
_ Label
true Label
false CmmExpr
expr = do
  OrdList Instr
b1 <- Label -> CmmExpr -> NatM (OrdList Instr)
genCondJump Label
true CmmExpr
expr
  OrdList Instr
b2 <- Label -> NatM (OrdList Instr)
genBranch Label
false
  forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
b1 forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
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]
-> Label
-> NatM (OrdList Instr, Maybe Label)
genCCall ForeignTarget
target [CmmFormal]
dest_regs [CmmExpr]
arg_regs Label
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
      (Target
call_target, OrdList Instr
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)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (CLabel -> Target
TLabel CLabel
lbl, 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
reg, Format
_format, OrdList Instr
reg_code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reg -> Target
TReg Reg
reg, OrdList Instr
reg_code)
      -- compute the code and register logic for all arg_regs.
      -- this will give us the format information to match on.
      [(Reg, Format, OrdList Instr)]
arg_regs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg [CmmExpr]
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 ([ForeignHint]
_res_hints, [ForeignHint]
arg_hints) = ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints ForeignTarget
target
          arg_regs'' :: [(Reg, Format, ForeignHint, OrdList Instr)]
arg_regs'' = 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
platform <- NatM Platform
getPlatform
      let packStack :: Bool
packStack = Platform -> OS
platformOS Platform
platform forall a. Eq a => a -> a -> Bool
== OS
OSDarwin

      (Int
stackSpace', [Reg]
passRegs, OrdList Instr
passArgumentsCode) <- Bool
-> [Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments Bool
packStack [Reg]
allGpArgRegs [Reg]
allFpArgRegs [(Reg, Format, ForeignHint, OrdList Instr)]
arg_regs'' Int
0 [] forall a. OrdList a
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 :: Int
stackSpace = if Int
stackSpace' forall a. Integral a => a -> a -> a
`mod` Int
8 forall a. Eq a => a -> a -> Bool
/= Int
0
                       then Int
8 forall a. Num a => a -> a -> a
* (Int
stackSpace' forall a. Integral a => a -> a -> a
`div` Int
8 forall a. Num a => a -> a -> a
+ Int
1)
                       else Int
stackSpace'

      ([Reg]
returnRegs, OrdList Instr
readResultsCode)   <- [Reg]
-> [Reg]
-> [CmmFormal]
-> [Reg]
-> OrdList Instr
-> NatM ([Reg], OrdList Instr)
readResults [Reg]
allGpArgRegs [Reg]
allFpArgRegs [CmmFormal]
dest_regs [] forall a. OrdList a
nilOL

      let moveStackDown :: Int -> OrdList Instr
moveStackDown Int
0 = forall a. [a] -> OrdList a
toOL [ Instr
PUSH_STACK_FRAME
                                 , Int -> Instr
DELTA (-Int
16) ]
          moveStackDown Int
i | forall a. Integral a => a -> Bool
odd Int
i = Int -> OrdList Instr
moveStackDown (Int
i forall a. Num a => a -> a -> a
+ Int
1)
          moveStackDown Int
i = 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 forall a. Num a => a -> a -> a
* Int
i)))
                                 , Int -> Instr
DELTA (-Int
8 forall a. Num a => a -> a -> a
* Int
i forall a. Num a => a -> a -> a
- Int
16) ]
          moveStackUp :: Int -> OrdList Instr
moveStackUp Int
0 = forall a. [a] -> OrdList a
toOL [ Instr
POP_STACK_FRAME
                               , Int -> Instr
DELTA Int
0 ]
          moveStackUp Int
i | forall a. Integral a => a -> Bool
odd Int
i = Int -> OrdList Instr
moveStackUp (Int
i forall a. Num a => a -> a -> a
+ Int
1)
          moveStackUp Int
i = 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 forall a. Num a => a -> a -> a
* Int
i)))
                               , Instr
POP_STACK_FRAME
                               , Int -> Instr
DELTA Int
0 ]

      let code :: OrdList Instr
code =    OrdList Instr
call_target_code          -- compute the label (possibly into a register)
            forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Int -> OrdList Instr
moveStackDown (Int
stackSpace forall a. Integral a => a -> a -> a
`div` Int
8)
            forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
passArgumentsCode         -- put the arguments into x0, ...
            forall a. OrdList a -> OrdList a -> OrdList a
`appOL` (forall a. a -> OrdList a
unitOL forall a b. (a -> b) -> a -> b
$ Target -> [Reg] -> [Reg] -> Instr
BL Target
call_target [Reg]
passRegs [Reg]
returnRegs) -- branch and link.
            forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
readResultsCode           -- parse the results into registers
            forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Int -> OrdList Instr
moveStackUp (Int
stackSpace forall a. Integral a => a -> a -> a
`div` Int
8)
      forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code, forall a. Maybe a
Nothing)

    PrimTarget CallishMachOp
MO_F32_Fabs
      | [CmmExpr
arg_reg] <- [CmmExpr]
arg_regs, [CmmFormal
dest_reg] <- [CmmFormal]
dest_regs ->
        forall {a}.
Width
-> (Operand -> Operand -> OrdList Instr)
-> CmmExpr
-> CmmFormal
-> NatM (OrdList Instr, Maybe a)
unaryFloatOp Width
W32 (\Operand
d Operand
x -> forall a. a -> OrdList a
unitOL 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 ->
        forall {a}.
Width
-> (Operand -> Operand -> OrdList Instr)
-> CmmExpr
-> CmmFormal
-> NatM (OrdList Instr, Maybe a)
unaryFloatOp Width
W64 (\Operand
d Operand
x -> forall a. a -> OrdList a
unitOL 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 Label)
mkCCall FastString
"pow"

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

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

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

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

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

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

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

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

        -- Conversion
        MO_UF_Conv Width
w        -> FastString -> NatM (OrdList Instr, Maybe Label)
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 -> forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_S_QuotRem  Width
_w -> forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_U_QuotRem  Width
_w -> forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_U_QuotRem2 Width
_w -> forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_Add2       Width
_w -> forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_AddWordC   Width
_w -> forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_SubWordC   Width
_w -> forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_AddIntC    Width
_w -> forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_SubIntC    Width
_w -> forall a b. Show a => a -> b
unsupported CallishMachOp
mop
        MO_U_Mul2     Width
_w -> forall a b. Show a => a -> b
unsupported CallishMachOp
mop

        -- Memory Ordering
        -- TODO DMBSY is probably *way* too much!
        CallishMachOp
MO_ReadBarrier      ->  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> OrdList a
unitOL Instr
DMBSY, forall a. Maybe a
Nothing)
        CallishMachOp
MO_WriteBarrier     ->  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> OrdList a
unitOL Instr
DMBSY, forall a. Maybe a
Nothing)
        CallishMachOp
MO_Touch            ->  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. OrdList a
nilOL, forall a. Maybe a
Nothing) -- Keep variables live (when using interior pointers)
        -- Prefetch
        MO_Prefetch_Data Int
_n -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. OrdList a
nilOL, 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 Label)
mkCCall FastString
"memcpy"
        MO_Memset  Int
_align   -> FastString -> NatM (OrdList Instr, Maybe Label)
mkCCall FastString
"memset"
        MO_Memmove Int
_align   -> FastString -> NatM (OrdList Instr, Maybe Label)
mkCCall FastString
"memmove"
        MO_Memcmp  Int
_align   -> FastString -> NatM (OrdList Instr, Maybe Label)
mkCCall FastString
"memcmp"

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

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

        -- -- Atomic read-modify-write.
        MO_AtomicRMW Width
w AtomicMachOp
amop -> FastString -> NatM (OrdList Instr, Maybe Label)
mkCCall (Width -> AtomicMachOp -> FastString
atomicRMWLabel Width
w AtomicMachOp
amop)
        MO_AtomicRead Width
w MemoryOrdering
_   -> FastString -> NatM (OrdList Instr, Maybe Label)
mkCCall (Width -> FastString
atomicReadLabel Width
w)
        MO_AtomicWrite Width
w MemoryOrdering
_  -> FastString -> NatM (OrdList Instr, Maybe Label)
mkCCall (Width -> FastString
atomicWriteLabel Width
w)
        MO_Cmpxchg Width
w        -> FastString -> NatM (OrdList Instr, Maybe Label)
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 Label)
mkCCall (Width -> FastString
xchgLabel Width
w)

  where
    unsupported :: Show a => a -> b
    unsupported :: forall a b. Show a => a -> b
unsupported a
mop = forall a. String -> a
panic (String
"outOfLineCmmOp: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
mop
                          forall a. [a] -> [a] -> [a]
++ String
" not supported here")
    mkCCall :: FastString -> NatM (InstrBlock, Maybe BlockId)
    mkCCall :: FastString -> NatM (OrdList Instr, Maybe Label)
mkCCall FastString
name = do
      NCGConfig
config <- NatM NCGConfig
getConfig
      CmmExpr
target <- forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
NCGConfig -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference NCGConfig
config ReferenceKind
CallReference forall a b. (a -> b) -> a -> b
$
          FastString
-> Maybe Int -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
name forall a. Maybe a
Nothing ForeignLabelSource
ForeignLabelInThisPackage FunctionOrData
IsFunction
      let cconv :: ForeignConvention
cconv = CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [ForeignHint
NoHint] [ForeignHint
NoHint] CmmReturnInfo
CmmMayReturn
      ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> Label
-> NatM (OrdList Instr, Maybe Label)
genCCall (CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget CmmExpr
target ForeignConvention
cconv) [CmmFormal]
dest_regs [CmmExpr]
arg_regs Label
bid

    -- TODO: Optimize using paired stores and loads (STP, LDP). It is
    -- automomatically 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 = 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
platform <- NatM Platform
getPlatform
      let w :: Width
w = Format -> Width
formatToWidth Format
format
          mov :: Instr
mov
            -- Specifically, Darwin/AArch64's ABI requires that the caller
            -- sign-extend arguments which are smaller than 32-bits.
            | Width
w 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
_   -> forall a. 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
accumCode forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                       OrdList Instr
code_r forall a. OrdList a -> a -> OrdList a
`snocOL`
                       SDoc -> Instr -> Instr
ann (String -> SDoc
text String
"Pass gp argument: " SDoc -> SDoc -> 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
gpRegforall a. a -> [a] -> [a]
:[Reg]
accumRegs) OrdList Instr
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 forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                       OrdList Instr
code_r forall a. OrdList a -> a -> OrdList a
`snocOL`
                       SDoc -> Instr -> Instr
ann (String -> SDoc
text String
"Pass fp argument: " SDoc -> SDoc -> 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
fpRegforall 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 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 forall a. Integral a => a -> a -> a
`mod` Int
space forall a. Eq a => a -> a -> Bool
/= Int
0 = Int
stackSpace forall a. Num a => a -> a -> a
+ Int
space forall a. Num a => a -> a -> a
- (Int
stackSpace 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 forall a. OrdList a -> a -> OrdList a
`snocOL`
                      SDoc -> Instr -> Instr
ann (String -> SDoc
text String
"Pass argument (size " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
") on the stack: " SDoc -> SDoc -> 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'forall a. Num a => a -> a -> a
+Int
space) [Reg]
accumRegs (OrdList Instr
stackCode 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 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 forall a. Integral a => a -> a -> a
`mod` Int
space forall a. Eq a => a -> a -> Bool
/= Int
0 = Int
stackSpace forall a. Num a => a -> a -> a
+ Int
space forall a. Num a => a -> a -> a
- (Int
stackSpace 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 forall a. OrdList a -> a -> OrdList a
`snocOL`
                      SDoc -> Instr -> Instr
ann (String -> SDoc
text String
"Pass argument (size " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
") on the stack: " SDoc -> SDoc -> 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'forall a. Num a => a -> a -> a
+Int
space) [Reg]
accumRegs (OrdList Instr
stackCode 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 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 forall a. Integral a => a -> a -> a
`mod` Int
space forall a. Eq a => a -> a -> Bool
/= Int
0 = Int
stackSpace forall a. Num a => a -> a -> a
+ Int
space forall a. Num a => a -> a -> a
- (Int
stackSpace 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 forall a. OrdList a -> a -> OrdList a
`snocOL`
                      SDoc -> Instr -> Instr
ann (String -> SDoc
text String
"Pass argument (size " SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
") on the stack: " SDoc -> SDoc -> 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'forall a. Num a => a -> a -> a
+Int
space) [Reg]
accumRegs (OrdList Instr
stackCode 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
_ = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"passArguments" (String -> SDoc
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 = forall (m :: * -> *) a. Monad m => a -> m a
return ([Reg]
accumRegs, OrdList Instr
accumCode)
    readResults [] [Reg]
_ [CmmFormal]
_ [Reg]
_ OrdList Instr
_ = do
      Platform
platform <- NatM Platform
getPlatform
      forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genCCall, out of gp registers when reading results" (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform ForeignTarget
target)
    readResults [Reg]
_ [] [CmmFormal]
_ [Reg]
_ OrdList Instr
_ = do
      Platform
platform <- NatM Platform
getPlatform
      forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genCCall, out of fp registers when reading results" (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform ForeignTarget
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
platform <- NatM Platform
getPlatform
      let rep :: CmmType
rep = Platform -> CmmReg -> CmmType
cmmRegType Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
          format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
rep
          w :: Width
w   = Platform -> CmmReg -> Width
cmmRegWidth Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
          r_dst :: Reg
r_dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
      if Format -> Bool
isFloatFormat Format
format
        then [Reg]
-> [Reg]
-> [CmmFormal]
-> [Reg]
-> OrdList Instr
-> NatM ([Reg], OrdList Instr)
readResults (Reg
gpRegforall a. a -> [a] -> [a]
:[Reg]
gpRegs) [Reg]
fpRegs [CmmFormal]
dsts (Reg
fpRegforall a. a -> [a] -> [a]
:[Reg]
accumRegs) (OrdList Instr
accumCode forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
r_dst) (Width -> Reg -> Operand
OpReg Width
w Reg
fpReg))
        else [Reg]
-> [Reg]
-> [CmmFormal]
-> [Reg]
-> OrdList Instr
-> NatM ([Reg], OrdList Instr)
readResults [Reg]
gpRegs (Reg
fpRegforall a. a -> [a] -> [a]
:[Reg]
fpRegs) [CmmFormal]
dsts (Reg
gpRegforall a. a -> [a] -> [a]
:[Reg]
accumRegs) (OrdList Instr
accumCode forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
r_dst) (Width -> Reg -> Operand
OpReg Width
w Reg
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
platform <- NatM Platform
getPlatform
      (Reg
reg_fx, Format
_format_x, OrdList Instr
code_fx) <- HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
arg_reg
      let dst :: Reg
dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dest_reg)
      let code :: OrdList Instr
code = OrdList Instr
code_fx 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)
      forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code, forall a. Maybe a
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) = 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, forall (map :: * -> *) a. IsMap map => map a
mapEmpty) [NatBasicBlock Instr]
basic_blocks
  if Int
func_size forall a. Ord a => a -> a -> Bool
< Int
max_jump_dist
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure [NatBasicBlock Instr]
basic_blocks
    else do
      (Int
_,[[NatBasicBlock Instr]]
blocks) <- forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (LabelMap Int
-> Int
-> NatBasicBlock Instr
-> UniqSM (Int, [NatBasicBlock Instr])
replace_blk LabelMap Int
lblMap) Int
0 [NatBasicBlock Instr]
basic_blocks
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NatBasicBlock Instr]]
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
2forall a b. (Num a, Integral b) => a -> b -> a
^(Int
18::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 Label
lbl [Instr]
instrs) = do
      -- Account for a potential info table before the label.
      let !block_pos :: Int
block_pos = Int
pos forall a. Num a => a -> a -> a
+ Label -> Int
infoTblSize_maybe Label
lbl
      (!Int
pos', [[Instr]]
instrs') <- forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM (LabelMap Int -> Int -> Instr -> UniqSM (Int, [Instr])
replace_jump LabelMap Int
m) Int
block_pos [Instr]
instrs
      let instrs'' :: [Instr]
instrs'' = 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 ([Instr]
top, [NatBasicBlock Instr]
split_blocks, [GenCmmDecl RawCmmStatics Any Any]
no_data) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall h g.
Instr
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
mkBlocks ([],[],[]) [Instr]
instrs''
      -- There should be no data in the instruction stream at this point
      forall (m :: * -> *).
(HasCallStack, Applicative m) =>
Bool -> SDoc -> m ()
massertPpr (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenCmmDecl RawCmmStatics Any Any]
no_data) forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"There should be no data in the instruction stream"

      let final_blocks :: [NatBasicBlock Instr]
final_blocks = forall i. Label -> [i] -> GenBasicBlock i
BasicBlock Label
lbl [Instr]
top forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
split_blocks
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
pos', [NatBasicBlock Instr]
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
          (Int
idx,Instr
instr':[Instr]
instrs') <- LabelMap Int -> Int -> Instr -> UniqSM (Int, [Instr])
replace_jump LabelMap Int
m Int
pos Instr
instr
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
idx, SDoc -> Instr -> Instr
ANN SDoc
ann Instr
instr'forall a. a -> [a] -> [a]
:[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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
posforall a. Num a => a -> a -> a
+Int
long_bc_jump_size,[Instr
instr])
              NotInRange Target
far_target -> do
                OrdList Instr
jmp_code <- forall (m :: * -> *).
MonadUnique m =>
Cond -> Target -> m (OrdList Instr)
genCondFarJump Cond
cond Target
far_target
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
posforall a. Num a => a -> a -> a
+Int
long_bc_jump_size, forall a. OrdList a -> [a]
fromOL OrdList Instr
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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
pos,[Instr
instr])
          | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
posforall 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
posforall a. Num a => a -> a -> a
+Int
long_bz_jump_size,[Instr
instr])
              NotInRange Target
far_target -> do
                OrdList Instr
jmp_code <- 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
                forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
pos forall a. Num a => a -> a -> a
+ Int
long_bz_jump_size, Operand -> Operand -> Instr
CMP Operand
op (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
0)) forall a. a -> [a] -> [a]
: forall a. OrdList a -> [a]
fromOL OrdList Instr
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 Label
bid) -> LabelMap Int -> Int -> Label -> BlockInRange
block_in_range LabelMap Int
m Int
src Label
bid
        (TLabel CLabel
clbl)
          | Just Label
bid <- CLabel -> Maybe Label
maybeLocalBlockLabel CLabel
clbl
          -> LabelMap Int -> Int -> Label -> BlockInRange
block_in_range LabelMap Int
m Int
src Label
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 -> Label -> BlockInRange
block_in_range LabelMap Int
m Int
src_pos Label
dest_lbl =
      case forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
dest_lbl LabelMap Int
m of
        Maybe Int
Nothing       ->
          -- pprTrace "not in range" (ppr dest_lbl) $
            Target -> BlockInRange
NotInRange (Label -> Target
TBlock Label
dest_lbl)
        Just Int
dest_pos -> if forall a. Num a => a -> a
abs (Int
dest_pos forall a. Num a => a -> a -> a
- Int
src_pos) forall a. Ord a => a -> a -> Bool
< Int
max_jump_dist
          then BlockInRange
InRange
          else Target -> BlockInRange
NotInRange (Label -> Target
TBlock Label
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 Label
lbl [Instr]
instrs)
      = let !pos' :: Int
pos' = Int
pos forall a. Num a => a -> a -> a
+ Label -> Int
infoTblSize_maybe Label
lbl
        in 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',forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert Label
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 Label
_bid -> forall a. 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
posforall a. Num a => a -> a -> a
+Int
jump_size, LabelMap Int
m)
          | Bool
otherwise -> (Int
posforall a. Num a => a -> a -> a
+Int
1, LabelMap Int
m)

    infoTblSize_maybe :: Label -> Int
infoTblSize_maybe Label
bid =
      case forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
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{}   -> forall a. a -> Maybe a
Just Int
long_bz_jump_size
      CBNZ{}  -> forall a. a -> Maybe a
Just Int
long_bz_jump_size
      BCOND{} -> forall a. a -> Maybe a
Just Int
long_bc_jump_size
      Instr
_ -> forall a. Maybe a
Nothing