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

where

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

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.Graph
import GHC.Types.Tickish ( GenTickish(..) )
import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )

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

import Control.Monad    ( mapAndUnzipM, when, foldM )
import Data.Word
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

-- 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) <- (Block CmmNode C C
 -> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr]))
-> [Block CmmNode C C]
-> NatM
     ([[NatBasicBlock Instr]], [[NatCmmDecl RawCmmStatics Instr]])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM Block CmmNode C C
-> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr])
basicBlockCodeGen [Block CmmNode C C]
blocks
  Maybe Reg
picBaseMb <- NatM (Maybe Reg)
getPicBaseMaybeNat

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

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

-- ... or CmmData.
cmmTopCodeGen _cmm :: RawCmmDecl
_cmm@(CmmData Section
sec RawCmmStatics
dat) = do
  -- do
  --   traceM $ "-- -------------------------- cmmTopGen (CmmData) -------------------------- --\n"
  --         ++ showSDocUnsafe (ppr cmm)
  [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
forall (m :: * -> *) a. Monad m => a -> m a
return [Section -> RawCmmStatics -> NatCmmDecl RawCmmStatics Instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec RawCmmStatics
dat] -- no translation, we just use CmmStatic

basicBlockCodeGen
        :: Block CmmNode C C
        -> NatM ( [NatBasicBlock Instr]
                , [NatCmmDecl RawCmmStatics Instr])

basicBlockCodeGen :: Block CmmNode C C
-> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr])
basicBlockCodeGen Block CmmNode C C
block = do
  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)  = Block CmmNode C C -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
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 = Block CmmNode C C -> Label
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel Block CmmNode C C
block
      stmts :: [CmmNode O O]
stmts = Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
nodes

      header_comment_instr :: OrdList Instr
header_comment_instr = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ SDoc -> Instr
MULTILINE_COMMENT (
          String -> SDoc
text String
"-- --------------------------- basicBlockCodeGen --------------------------- --\n"
          SDoc -> SDoc -> SDoc
$+$ Platform -> Block CmmNode C C -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc (NCGConfig -> Platform
ncgPlatform NCGConfig
config) Block CmmNode C C
block
          )
  -- Generate location directive
  Maybe DebugBlock
dbg <- Label -> NatM (Maybe DebugBlock)
getDebugBlock (Block CmmNode C C -> Label
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 (DebugBlock -> Maybe CmmTickish)
-> Maybe DebugBlock -> Maybe CmmTickish
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
            OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> String -> Instr
LOCATION Int
fileId Int
line Int
col String
name
    Maybe CmmTickish
_ -> OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
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
_) <- Label -> CmmNode O C -> NatM (OrdList Instr, 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 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
loc_instrs OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
mid_instrs OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
tail_instrs
  -- TODO: Then x86 backend run @verifyBasicBlock@ here and inserts
  --      unwinding info. See Ticket 19913
  -- code generation may introduce new basic block boundaries, which
  -- are indicated by the NEWBLOCK instruction.  We must split up the
  -- instruction stream into basic blocks again.  Also, we extract
  -- LDATAs here too.
  let
        ([Instr]
top,[NatBasicBlock Instr]
other_blocks,[NatCmmDecl RawCmmStatics Instr]
statics) = (Instr
 -> ([Instr], [NatBasicBlock Instr],
     [NatCmmDecl RawCmmStatics Instr])
 -> ([Instr], [NatBasicBlock Instr],
     [NatCmmDecl RawCmmStatics Instr]))
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl RawCmmStatics Instr])
-> OrdList Instr
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl RawCmmStatics Instr])
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL Instr
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl RawCmmStatics Instr])
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl RawCmmStatics Instr])
forall {h} {g}.
Instr
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
mkBlocks ([],[],[]) OrdList Instr
instrs

        mkBlocks :: Instr
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
mkBlocks (NEWBLOCK Label
id) ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl RawCmmStatics h g]
statics)
          = ([], Label -> [Instr] -> NatBasicBlock Instr
forall i. Label -> [i] -> GenBasicBlock i
BasicBlock Label
id [Instr]
instrs NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
blocks, [GenCmmDecl RawCmmStatics h g]
statics)
        mkBlocks (LDATA Section
sec RawCmmStatics
dat) ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl RawCmmStatics h g]
statics)
          = ([Instr]
instrs, [NatBasicBlock Instr]
blocks, Section -> RawCmmStatics -> GenCmmDecl RawCmmStatics h g
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec RawCmmStatics
datGenCmmDecl RawCmmStatics h g
-> [GenCmmDecl RawCmmStatics h g] -> [GenCmmDecl RawCmmStatics h g]
forall a. a -> [a] -> [a]
:[GenCmmDecl RawCmmStatics h g]
statics)
        mkBlocks Instr
instr ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl RawCmmStatics h g]
statics)
          = (Instr
instrInstr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
:[Instr]
instrs, [NatBasicBlock Instr]
blocks, [GenCmmDecl RawCmmStatics h g]
statics)
  ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr])
-> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr])
forall (m :: * -> *) a. Monad m => a -> m a
return (Label -> [Instr] -> NatBasicBlock Instr
forall i. Label -> [i] -> GenBasicBlock i
BasicBlock Label
id [Instr]
top NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
other_blocks, [NatCmmDecl RawCmmStatics Instr]
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 (String -> SDoc) -> (CmmExpr -> String) -> CmmExpr -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmExpr -> String
forall a. Show a => a -> String
show (CmmExpr -> SDoc) -> CmmExpr -> SDoc
forall a b. (a -> b) -> a -> b
$ CmmExpr
e) Instr
instr
-- annExpr e instr {- | debugIsOn -} = ANN (pprExpr genericPlatform e) instr
-- annExpr _ instr = instr
{-# INLINE annExpr #-}

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

-- TODO jump tables would be a lot faster, but we'll use bare bones for now.
-- this is usually done by sticking the jump table ids into an instruction
-- and then have the @generateJumpTableForInstr@ callback produce the jump
-- table as a static.
--
-- See Ticket 19912
--
-- data SwitchTargets =
--    SwitchTargets
--        Bool                       -- Signed values
--        (Integer, Integer)         -- Range
--        (Maybe Label)              -- Default value
--        (M.Map Integer Label)      -- The branches
--
-- Non Jumptable plan:
-- xE <- expr
--
genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch :: CmmExpr -> SwitchTargets -> NatM (OrdList Instr)
genSwitch CmmExpr
expr SwitchTargets
targets = do -- pprPanic "genSwitch" (ppr expr)
  (Reg
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))
        OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                 [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ 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)
                      ] OrdList Instr -> OrdList Instr -> OrdList Instr
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 -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Target -> Instr
B (Label -> Target
TBlock Label
bid))
        Maybe Label
Nothing  -> OrdList Instr
forall a. OrdList a
nilOL

  OrdList Instr
switch_code <- (OrdList Instr -> (Integer, Label) -> NatM (OrdList Instr))
-> OrdList Instr -> [(Integer, Label)] -> NatM (OrdList Instr)
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 OrdList Instr
forall a. OrdList a
nilOL (SwitchTargets -> [(Integer, Label)]
switchTargetsCases SwitchTargets
targets)
  OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
switch_code OrdList Instr -> OrdList Instr -> OrdList Instr
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
_ = Maybe (NatCmmDecl RawCmmStatics Instr)
forall a. Maybe a
Nothing

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

-- See Note [Keeping track of the current block] for why
-- we pass the BlockId.
stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.
              -> [CmmNode O O] -- ^ Cmm Statement
              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction
stmtsToInstrs :: Label -> [CmmNode O O] -> NatM (OrdList Instr, Label)
stmtsToInstrs Label
bid [CmmNode O O]
stmts =
    Label
-> [CmmNode O O] -> OrdList Instr -> NatM (OrdList Instr, Label)
forall {e :: Extensibility} {x :: Extensibility}.
Label
-> [CmmNode e x] -> OrdList Instr -> NatM (OrdList Instr, Label)
go Label
bid [CmmNode O O]
stmts OrdList Instr
forall a. OrdList a
nilOL
  where
    go :: Label
-> [CmmNode e x] -> OrdList Instr -> NatM (OrdList Instr, Label)
go Label
bid  []        OrdList Instr
instrs = (OrdList Instr, Label) -> NatM (OrdList Instr, Label)
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') <- Label -> CmmNode e x -> NatM (OrdList Instr, Maybe Label)
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 = Label -> Maybe Label -> Label
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 OrdList Instr -> OrdList Instr -> OrdList Instr
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
_ -> (,Maybe Label
forall a. Maybe a
Nothing) (OrdList Instr -> (OrdList Instr, Maybe Label))
-> NatM (OrdList Instr) -> NatM (OrdList Instr, Maybe Label)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case CmmNode e x
stmt of
      CmmComment FastString
s   -> OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (SDoc -> Instr
COMMENT (FastString -> SDoc
ftext FastString
s)))
      CmmTick {}     -> OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL

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

      CmmStore CmmExpr
addr CmmExpr
src
        | 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 -> OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL

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

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

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

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

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

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

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

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


getRegister :: CmmExpr -> NatM Register
getRegister :: CmmExpr -> NatM Register
getRegister CmmExpr
e = do
  NCGConfig
config <- NatM NCGConfig
getConfig
  NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config (NCGConfig -> Platform
ncgPlatform NCGConfig
config) CmmExpr
e

-- 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 souldn't even be generated to begin with.
getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat (CmmMachOp (MO_Add Width
w0) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
w1)]) | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
  = NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Sub Width
w0) [CmmExpr
x, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (-Integer
i) Width
w1)])

getRegister' NCGConfig
config Platform
plat (CmmMachOp (MO_Sub Width
w0) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
w1)]) | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
  = NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
w0) [CmmExpr
x, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (-Integer
i) Width
w1)])


-- Generic case.
getRegister' NCGConfig
config Platform
plat CmmExpr
expr
  = case CmmExpr
expr of
    CmmReg (CmmGlobal GlobalReg
PicBaseReg)
      -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegisterReg-memory" (GlobalReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr (GlobalReg -> SDoc) -> GlobalReg -> SDoc
forall a b. (a -> b) -> a -> b
$ GlobalReg
PicBaseReg)
    CmmLit CmmLit
lit
      -> case CmmLit
lit of

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

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

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

        -- floatToBytes (fromRational f)
        CmmFloat Rational
0 Width
w   -> do
          (Operand
op, OrdList Instr
imm_code) <- CmmLit -> NatM (Operand, OrdList Instr)
litToImm' CmmLit
lit
          Register -> NatM Register
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 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
dst) Operand
op)))

        CmmFloat Rational
_f Width
W8  -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmFloat), no support for bytes" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmFloat Rational
_f Width
W16 -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmFloat), no support for halfs" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmFloat Rational
f Width
W32 -> do
          let word :: Word32
word = Float -> Word32
castFloatToWord32 (Rational -> Float
forall a. Fractional a => Rational -> a
fromRational Rational
f) :: Word32
              half0 :: Int
half0 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
word :: Word16)
              half1 :: Int
half1 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
word Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) :: Word16)
          Reg
tmp <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
W32)
          Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
W32) (\Reg
dst -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr
                                                      (Instr -> Instr) -> Instr -> Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W32 Reg
tmp) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
half0))
                                                      , Operand -> Operand -> Instr
MOVK (Width -> Reg -> Operand
OpReg Width
W32 Reg
tmp) (Imm -> ShiftMode -> Int -> Operand
OpImmShift (Int -> Imm
ImmInt Int
half1) ShiftMode
SLSL Int
16)
                                                      , Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W32 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W32 Reg
tmp)
                                                      ]))
        CmmFloat Rational
f Width
W64 -> do
          let word :: Word64
word = Double -> Word64
castDoubleToWord64 (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
f) :: Word64
              half0 :: Int
half0 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
word :: Word16)
              half1 :: Int
half1 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
word Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
16) :: Word16)
              half2 :: Int
half2 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
word Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32) :: Word16)
              half3 :: Int
half3 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
word Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
48) :: Word16)
          Reg
tmp <- Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
W64)
          Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
W64) (\Reg
dst -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr
                                                      (Instr -> Instr) -> Instr -> Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp) (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
half0))
                                                      , Operand -> Operand -> Instr
MOVK (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp) (Imm -> ShiftMode -> Int -> Operand
OpImmShift (Int -> Imm
ImmInt Int
half1) ShiftMode
SLSL Int
16)
                                                      , Operand -> Operand -> Instr
MOVK (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp) (Imm -> ShiftMode -> Int -> Operand
OpImmShift (Int -> Imm
ImmInt Int
half2) ShiftMode
SLSL Int
32)
                                                      , Operand -> Operand -> Instr
MOVK (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp) (Imm -> ShiftMode -> Int -> Operand
OpImmShift (Int -> Imm
ImmInt Int
half3) ShiftMode
SLSL Int
48)
                                                      , Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
W64 Reg
dst) (Width -> Reg -> Operand
OpReg Width
W64 Reg
tmp)
                                                      ]))
        CmmFloat Rational
_f Width
_w -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmFloat), unsupported float lit" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmVec [CmmLit]
_ -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmVec): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmLabel CLabel
_lbl -> do
          (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
          Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format (\Reg
dst -> OrdList Instr
imm_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` (CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Instr -> Instr) -> Instr -> Instr
forall a b. (a -> b) -> a -> b
$ Format -> Operand -> Operand -> Instr
LDR Format
format (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) Reg
dst) Operand
op)))

        CmmLabelOff CLabel
_lbl Int
off | Int -> Integer -> Bool
isNbitEncodeable Int
12 (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) -> do
          (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
          Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format (\Reg
dst -> OrdList Instr
imm_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Operand -> Operand -> Instr
LDR Format
format (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) Reg
dst) Operand
op))

        CmmLabelOff CLabel
lbl Int
off -> do
          (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 (CmmExpr -> NatM (Reg, Format, OrdList Instr))
-> CmmExpr -> NatM (Reg, Format, OrdList Instr)
forall a b. (a -> b) -> a -> b
$ CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
width)
          Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format (\Reg
dst -> OrdList Instr
imm_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
off_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Operand -> Operand -> Instr
LDR Format
format (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) Reg
dst) Operand
op OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
width Reg
dst) (Width -> Reg -> Operand
OpReg Width
width Reg
dst) (Width -> Reg -> Operand
OpReg Width
width Reg
off_r)))

        CmmLabelDiffOff CLabel
_ CLabel
_ Int
_ Width
_ -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmLabelOff): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmBlock Label
_ -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmLabelOff): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
        CmmLit
CmmHighStackMark -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmLit:CmmLabelOff): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
    CmmLoad CmmExpr
mem CmmType
rep -> do
      Amode AddrMode
addr OrdList Instr
addr_code <- Platform -> CmmExpr -> NatM Amode
getAmode Platform
plat CmmExpr
mem
      let format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
rep
      Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
format (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Operand -> Operand -> Instr
LDR Format
format (Width -> Reg -> Operand
OpReg (Format -> Width
formatToWidth Format
format) Reg
dst) (AddrMode -> Operand
OpAddr AddrMode
addr)))
    CmmStackSlot Area
_ Int
_
      -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (CmmStackSlot): " (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
    CmmReg CmmReg
reg
      -> Register -> NatM Register
forall (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)
                       OrdList Instr
forall a. OrdList a
nilOL)
    CmmRegOff CmmReg
reg Int
off | Int -> Integer -> Bool
isNbitEncodeable Int
12 (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) -> do
      NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
plat (CmmExpr -> NatM Register) -> CmmExpr -> NatM Register
forall a b. (a -> b) -> a -> b
$
            MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
width) [CmmReg -> CmmExpr
CmmReg CmmReg
reg, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
width)]
          where width :: Width
width = CmmType -> Width
typeWidth (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 (CmmExpr -> NatM (Reg, Format, OrdList Instr))
-> CmmExpr -> NatM (Reg, Format, OrdList Instr)
forall a b. (a -> b) -> a -> b
$ CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
width)
      (Reg
reg, Format
_format, OrdList Instr
code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg (CmmExpr -> NatM (Reg, Format, OrdList Instr))
-> CmmExpr -> NatM (Reg, Format, OrdList Instr)
forall a b. (a -> b) -> a -> b
$ CmmReg -> CmmExpr
CmmReg CmmReg
reg
      Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
width) (\Reg
dst -> OrdList Instr
off_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
width Reg
dst) (Width -> Reg -> Operand
OpReg Width
width Reg
reg) (Width -> Reg -> Operand
OpReg Width
width Reg
off_r))
          where width :: Width
width = CmmType -> Width
typeWidth (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 -> Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
MVN (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg))

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

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

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

        -- Conversions
        MO_XX_Conv Width
_from Width
to -> Format -> Register -> Register
swizzleRegisterRep (Width -> Format
intFormat Width
to) (Register -> Register) -> NatM Register -> NatM Register
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmExpr -> NatM Register
getRegister CmmExpr
e

        MachOp
_ -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister' (monadic CmmMachOp):" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
plat CmmExpr
expr)
      where toImm :: Width -> Operand
toImm Width
W8 =  (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
7))
            toImm Width
W16 = (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
15))
            toImm Width
W32 = (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
31))
            toImm Width
W64 = (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
63))
            toImm Width
W128 = (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
127))
            toImm Width
W256 = (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
255))
            toImm Width
W512 = (Imm -> Operand
OpImm (Int -> Imm
ImmInt Int
511))
    -- 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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 Bool -> Bool -> Bool
&& Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
4096 -> Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
w Reg
d) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
      -- 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 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 Bool -> Bool -> Bool
&& Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
4096 -> Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SUB (Width -> Reg -> Operand
OpReg Width
w Reg
d) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
      -- 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

    -- 2. Shifts. x << n, x >> n.
    CmmMachOp (MO_Shl Width
w) [CmmExpr
x, (CmmLit (CmmInt Integer
n Width
_))] | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32, Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n, Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
32 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
LSL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
    CmmMachOp (MO_Shl Width
w) [CmmExpr
x, (CmmLit (CmmInt Integer
n Width
_))] | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64, Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n, Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
64 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
LSL (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))

    CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, (CmmLit (CmmInt Integer
n Width
_))] | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32, Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n, Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
32 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
LSR (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
    CmmMachOp (MO_U_Shr Width
w) [CmmExpr
x, (CmmLit (CmmInt Integer
n Width
_))] | Width
w Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64, Integer
0 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n, Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
64 -> do
      (Reg
reg_x, Format
_format_x, OrdList Instr
code_x) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
x
      Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
LSR (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))

    -- 3. Logic &&, ||
    CmmMachOp (MO_And Width
w) [(CmmReg CmmReg
reg), CmmLit (CmmInt Integer
n Width
_)] | Integer -> Bool
isBitMaskImmediate (Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) ->
      Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
AND (Width -> Reg -> Operand
OpReg Width
w Reg
d) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
      where w' :: Width
w' = Format -> Width
formatToWidth (CmmType -> Format
cmmTypeFormat (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
isBitMaskImmediate (Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n) ->
      Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
d -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ORR (Width -> Reg -> Operand
OpReg Width
w Reg
d) (Width -> Reg -> Operand
OpReg Width
w' Reg
r') (Imm -> Operand
OpImm (Integer -> Imm
ImmInteger Integer
n))))
      where w' :: Width
w' = Format -> Width
formatToWidth (CmmType -> Format
cmmTypeFormat (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
      let genOp :: Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
genOp Width
w Operand -> Operand -> Operand -> OrdList Instr
op = 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
            Bool -> NatM () -> NatM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Format -> Bool
isFloatFormat Format
format_x Bool -> Bool -> Bool
&& Format -> Bool
isIntFormat Format
format_y) Bool -> Bool -> Bool
|| (Format -> Bool
isIntFormat Format
format_x Bool -> Bool -> Bool
&& Format -> Bool
isFloatFormat Format
format_y)) (NatM () -> NatM ()) -> NatM () -> NatM ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc -> NatM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister:genOp" (String -> SDoc
text String
"formats don't match:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (Format -> String
forall a. Show a => a -> String
show Format
format_x) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"/=" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text (Format -> String
forall a. Show a => a -> String
show Format
format_y))
            Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any Format
format_x (\Reg
dst -> OrdList Instr
code_x OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y))

          withTempIntReg :: Width -> (Operand -> NatM b) -> NatM b
withTempIntReg Width
w Operand -> NatM b
op = Width -> Reg -> Operand
OpReg Width
w (Reg -> Operand) -> NatM Reg -> NatM Operand
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Format -> NatM Reg
getNewRegNat (Width -> Format
intFormat Width
w) NatM Operand -> (Operand -> NatM b) -> NatM b
forall (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

          intOp :: Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp 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
            Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_x OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y))
          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)
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)
CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
y
            Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
floatFormat Width
w) (\Reg
dst -> OrdList Instr
code_fx OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_fy OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fx) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fy))
          -- need a special one for conditionals, as they return ints
          floatCond :: Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w Operand -> Operand -> Operand -> OrdList Instr
op = do
            (Reg
reg_fx, Format
_format_x, OrdList Instr
code_fx) <- HasCallStack => CmmExpr -> NatM (Reg, Format, OrdList Instr)
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)
CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
y
            Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
w) (\Reg
dst -> OrdList Instr
code_fx OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_fy OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fx) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fy))

      case MachOp
op of
        -- Integer operations
        -- Add/Sub should only be Interger Options.
        -- But our Cmm parser doesn't care about types
        -- and thus we end up with <float> + <float> => MO_Add <float> <float>
        MO_Add Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
genOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
ADD Operand
d Operand
x Operand
y))
        MO_Sub Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
genOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CmmExpr -> Instr -> Instr
annExpr CmmExpr
expr (Operand -> Operand -> Operand -> Instr
SUB Operand
d Operand
x Operand
y))
        --    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     |
        --- '-------------------------------------------------------------------------'

        MO_Eq Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
EQ ])
        MO_Ne Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
NE ])
        MO_Mul Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
MUL Operand
d Operand
x Operand
y)

        -- Signed multiply/divide
        MO_S_MulMayOflo Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Operand -> Instr
MUL Operand
d Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
VS ])
        MO_S_Quot Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
SDIV Operand
d Operand
x Operand
y)

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

        -- Unsigned multiply/divide
        MO_U_MulMayOflo Width
_w -> Platform -> CmmExpr -> NatM Register
forall env a b. OutputableP env a => env -> a -> b
unsupportedP Platform
plat CmmExpr
expr
        MO_U_Quot Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
UDIV Operand
d Operand
x Operand
y)
        MO_U_Rem Width
w  -> Width -> (Operand -> NatM Register) -> NatM Register
forall {b}. Width -> (Operand -> NatM b) -> NatM b
withTempIntReg Width
w ((Operand -> NatM Register) -> NatM Register)
-> (Operand -> NatM Register) -> NatM Register
forall a b. (a -> b) -> a -> b
$ \Operand
t ->
          Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Operand -> Instr
UDIV Operand
t Operand
x Operand
y, Operand -> Operand -> Operand -> Operand -> Instr
MSUB Operand
d Operand
t Operand
y Operand
x ])

        -- Signed comparisons -- see above for the CSET discussion
        MO_S_Ge Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
SGE ])
        MO_S_Le Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
SLE ])
        MO_S_Gt Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
SGT ])
        MO_S_Lt Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
SLT ])

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

        -- Floating point arithmetic
        MO_F_Add Width
w   -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
ADD Operand
d Operand
x Operand
y)
        MO_F_Sub Width
w   -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
SUB Operand
d Operand
x Operand
y)
        MO_F_Mul Width
w   -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
MUL Operand
d Operand
x Operand
y)
        MO_F_Quot Width
w  -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
SDIV Operand
d Operand
x Operand
y)

        -- Floating point comparison
        MO_F_Eq Width
w    -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
EQ ])
        MO_F_Ne Width
w    -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
NE ])

        -- careful with the floating point operations.
        -- SLE is effectively LE or unordered (NaN)
        -- SLT is the same. ULE, and ULT will not return true for NaN.
        -- This is a bit counter 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 -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
OGE ])
        MO_F_Le Width
w    -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
OLE ]) -- x <= y <=> y > x
        MO_F_Gt Width
w    -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
OGT ])
        MO_F_Lt Width
w    -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
floatCond Width
w (\Operand
d Operand
x Operand
y -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Instr
CMP Operand
x Operand
y, Operand -> Cond -> Instr
CSET Operand
d Cond
OLT ]) -- x < y <=> y >= x

        -- Bitwise operations
        MO_And   Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
AND Operand
d Operand
x Operand
y)
        MO_Or    Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
ORR Operand
d Operand
x Operand
y)
        MO_Xor   Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
EOR Operand
d Operand
x Operand
y)
        -- MO_Not   W64 ->
        MO_Shl   Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
LSL Operand
d Operand
x Operand
y)
        MO_U_Shr Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
LSR Operand
d Operand
x Operand
y)
        MO_S_Shr Width
w -> Width
-> (Operand -> Operand -> Operand -> OrdList Instr)
-> NatM Register
intOp Width
w (\Operand
d Operand
x Operand
y -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Operand -> Instr
ASR Operand
d Operand
x Operand
y)

        -- TODO

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

  where
    unsupportedP :: OutputableP env a => env -> a -> b
    unsupportedP :: forall env a b. OutputableP env a => env -> a -> b
unsupportedP env
platform a
op = String -> SDoc -> b
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Unsupported op:" (env -> a -> SDoc
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 in (-Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
shift) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
i Bool -> Bool -> Bool
&& Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< (Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
shift)
    -- This needs to check if n can be encoded as a bitmask immediate:
    --
    -- See https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly
    --
    isBitMaskImmediate :: Integer -> Bool
    isBitMaskImmediate :: Integer -> Bool
isBitMaskImmediate Integer
i = Integer
i Integer -> [Integer] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Integer
0b0000_0001, Integer
0b0000_0010, Integer
0b0000_0100, Integer
0b0000_1000, Integer
0b0001_0000, Integer
0b0010_0000, Integer
0b0100_0000, Integer
0b1000_0000
                                    ,Integer
0b0000_0011, Integer
0b0000_0110, Integer
0b0000_1100, Integer
0b0001_1000, Integer
0b0011_0000, Integer
0b0110_0000, Integer
0b1100_0000
                                    ,Integer
0b0000_0111, Integer
0b0000_1110, Integer
0b0001_1100, Integer
0b0011_1000, Integer
0b0111_0000, Integer
0b1110_0000
                                    ,Integer
0b0000_1111, Integer
0b0001_1110, Integer
0b0011_1100, Integer
0b0111_1000, Integer
0b1111_0000
                                    ,Integer
0b0001_1111, Integer
0b0011_1110, Integer
0b0111_1100, Integer
0b1111_1000
                                    ,Integer
0b0011_1111, Integer
0b0111_1110, Integer
0b1111_1100
                                    ,Integer
0b0111_1111, Integer
0b1111_1110
                                    ,Integer
0b1111_1111]


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

getAmode :: Platform -> CmmExpr -> NatM Amode
-- TODO: Specialize stuff we can destructure here.

-- OPTIMIZATION WARNING: Addressing modes.
-- Addressing options:
-- LDUR/STUR: imm9: -256 - 255
getAmode :: Platform -> CmmExpr -> NatM Amode
getAmode Platform
platform (CmmRegOff CmmReg
reg Int
off) | -Int
256 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
off, Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
255
  = Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (Amode -> NatM Amode) -> Amode -> NatM Amode
forall a b. (a -> b) -> a -> b
$ AddrMode -> OrdList Instr -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg' Imm
off') OrdList Instr
forall a. OrdList a
nilOL
    where reg' :: Reg
reg' = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg
          off' :: Imm
off' = Int -> Imm
ImmInt Int
off
-- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4
getAmode Platform
platform (CmmRegOff CmmReg
reg Int
off)
  | CmmType -> Width
typeWidth (Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
reg) Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32, Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
off, Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
16380, Int
off Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
4 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
  = Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (Amode -> NatM Amode) -> Amode -> NatM Amode
forall a b. (a -> b) -> a -> b
$ AddrMode -> OrdList Instr -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg' Imm
off') OrdList Instr
forall a. OrdList a
nilOL
    where reg' :: Reg
reg' = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg
          off' :: Imm
off' = Int -> Imm
ImmInt Int
off
-- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8
getAmode Platform
platform (CmmRegOff CmmReg
reg Int
off)
  | CmmType -> Width
typeWidth (Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
reg) Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64, Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
off, Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
32760, Int
off Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
  = Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (Amode -> NatM Amode) -> Amode -> NatM Amode
forall a b. (a -> b) -> a -> b
$ AddrMode -> OrdList Instr -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg' Imm
off') OrdList Instr
forall a. OrdList a
nilOL
    where reg' :: Reg
reg' = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg
          off' :: Imm
off' = Int -> Imm
ImmInt Int
off

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

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

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

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

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

genJump CmmExpr
expr = do
    (Reg
target, Format
_format, OrdList Instr
code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
    OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Instr -> OrdList Instr
forall a. a -> OrdList a
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 = OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> (Label -> OrdList Instr) -> Label -> NatM (OrdList Instr)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL ([Instr] -> OrdList Instr)
-> (Label -> [Instr]) -> Label -> OrdList Instr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> [Instr]
mkJumpInstr

-- -----------------------------------------------------------------------------
-- Conditional branches
genCondJump
    :: BlockId
    -> CmmExpr
    -> NatM InstrBlock
genCondJump :: Label -> CmmExpr -> NatM (OrdList Instr)
genCondJump Label
bid CmmExpr
expr = do
    case CmmExpr
expr of
      -- Optimized == 0 case.
      CmmMachOp (MO_Eq Width
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
        OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
code_x OrdList Instr -> Instr -> OrdList Instr
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
        OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
code_x OrdList Instr -> Instr -> OrdList Instr
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 bcond :: Width -> Cond -> NatM (OrdList Instr)
bcond 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
              OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
code_x OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Operand -> Operand -> Instr
CMP (Width -> Reg -> Operand
OpReg Width
w Reg
reg_x) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_y) OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` (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)
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)
CmmExpr -> NatM (Reg, Format, OrdList Instr)
getFloatReg CmmExpr
y
              OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
code_fx OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_fy OrdList Instr -> Instr -> OrdList Instr
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) OrdList Instr -> Instr -> OrdList Instr
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)
bcond Width
w Cond
EQ
          MO_Ne Width
w   -> Width -> Cond -> NatM (OrdList Instr)
bcond Width
w Cond
NE

          MO_S_Gt Width
w -> Width -> Cond -> NatM (OrdList Instr)
bcond Width
w Cond
SGT
          MO_S_Ge Width
w -> Width -> Cond -> NatM (OrdList Instr)
bcond Width
w Cond
SGE
          MO_S_Lt Width
w -> Width -> Cond -> NatM (OrdList Instr)
bcond Width
w Cond
SLT
          MO_S_Le Width
w -> Width -> Cond -> NatM (OrdList Instr)
bcond Width
w Cond
SLE
          MO_U_Gt Width
w -> Width -> Cond -> NatM (OrdList Instr)
bcond Width
w Cond
UGT
          MO_U_Ge Width
w -> Width -> Cond -> NatM (OrdList Instr)
bcond Width
w Cond
UGE
          MO_U_Lt Width
w -> Width -> Cond -> NatM (OrdList Instr)
bcond Width
w Cond
ULT
          MO_U_Le Width
w -> Width -> Cond -> NatM (OrdList Instr)
bcond Width
w Cond
ULE
          MachOp
_ -> String -> SDoc -> NatM (OrdList Instr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"AArch64.genCondJump:case mop: " (String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ CmmExpr -> String
forall a. Show a => a -> String
show CmmExpr
expr)
      CmmExpr
_ -> String -> SDoc -> NatM (OrdList Instr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"AArch64.genCondJump: " (String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ CmmExpr -> String
forall a. Show a => a -> String
show CmmExpr
expr)


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
  OrdList Instr -> NatM (OrdList Instr)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
b1 OrdList Instr -> OrdList Instr -> OrdList Instr
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>]
-- instaed 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)) -> (Target, OrdList Instr) -> NatM (Target, OrdList Instr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CLabel -> Target
TLabel CLabel
lbl, OrdList Instr
forall a. OrdList a
nilOL)
        -- ... if it's not a label--well--let's compute the expression into a
        -- register and jump to that. See Note [PLT vs GOT relocations]
        CmmExpr
_ -> do (Reg
reg, Format
_format, OrdList Instr
reg_code) <- CmmExpr -> NatM (Reg, Format, OrdList Instr)
getSomeReg CmmExpr
expr
                (Target, OrdList Instr) -> NatM (Target, OrdList Instr)
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' <- (CmmExpr -> NatM (Reg, Format, OrdList Instr))
-> [CmmExpr] -> NatM [(Reg, Format, OrdList Instr)]
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'' = ((Reg, Format, OrdList Instr)
 -> ForeignHint -> (Reg, Format, ForeignHint, OrdList Instr))
-> [(Reg, Format, OrdList Instr)]
-> [ForeignHint]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\(Reg
r, Format
f, OrdList Instr
c) ForeignHint
h -> (Reg
r,Format
f,ForeignHint
h,OrdList Instr
c)) [(Reg, Format, OrdList Instr)]
arg_regs' [ForeignHint]
arg_hints

      Platform
platform <- NatM Platform
getPlatform
      let packStack :: Bool
packStack = Platform -> OS
platformOS Platform
platform OS -> OS -> Bool
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 [] OrdList Instr
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' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0
                       then Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
stackSpace' Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                       else Int
stackSpace'

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

      let moveStackDown :: Int -> OrdList Instr
moveStackDown Int
0 = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Instr
PUSH_STACK_FRAME
                                 , Int -> Instr
DELTA (-Int
16) ]
          moveStackDown Int
i | Int -> Bool
forall a. Integral a => a -> Bool
odd Int
i = Int -> OrdList Instr
moveStackDown (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          moveStackDown Int
i = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Instr
PUSH_STACK_FRAME
                                 , Operand -> Operand -> Operand -> Instr
SUB (Width -> Reg -> Operand
OpReg Width
W64 (Int -> Reg
regSingle Int
31)) (Width -> Reg -> Operand
OpReg Width
W64 (Int -> Reg
regSingle Int
31)) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i)))
                                 , Int -> Instr
DELTA (-Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
16) ]
          moveStackUp :: Int -> OrdList Instr
moveStackUp Int
0 = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Instr
POP_STACK_FRAME
                               , Int -> Instr
DELTA Int
0 ]
          moveStackUp Int
i | Int -> Bool
forall a. Integral a => a -> Bool
odd Int
i = Int -> OrdList Instr
moveStackUp (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          moveStackUp Int
i = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Operand -> Operand -> Operand -> Instr
ADD (Width -> Reg -> Operand
OpReg Width
W64 (Int -> Reg
regSingle Int
31)) (Width -> Reg -> Operand
OpReg Width
W64 (Int -> Reg
regSingle Int
31)) (Imm -> Operand
OpImm (Int -> Imm
ImmInt (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i)))
                               , Instr
POP_STACK_FRAME
                               , Int -> Instr
DELTA Int
0 ]

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

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

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

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

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

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

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

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

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

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

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

        -- Conversion
        MO_UF_Conv Width
w        -> String -> NatM (OrdList Instr, Maybe Label)
mkCCall (Width -> String
word2FloatLabel Width
w)

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

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

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

        -- -- Atomic read-modify-write.
        MO_AtomicRMW Width
w AtomicMachOp
amop -> String -> NatM (OrdList Instr, Maybe Label)
mkCCall (Width -> AtomicMachOp -> String
atomicRMWLabel Width
w AtomicMachOp
amop)
        MO_AtomicRead Width
w     -> String -> NatM (OrdList Instr, Maybe Label)
mkCCall (Width -> String
atomicReadLabel Width
w)
        MO_AtomicWrite Width
w    -> String -> NatM (OrdList Instr, Maybe Label)
mkCCall (Width -> String
atomicWriteLabel Width
w)
        MO_Cmpxchg Width
w        -> String -> NatM (OrdList Instr, Maybe Label)
mkCCall (Width -> String
cmpxchgLabel Width
w)
        -- -- Should be an AtomicRMW variant eventually.
        -- -- Sequential consistent.
        -- TODO: this should be implemented properly!
        MO_Xchg Width
w           -> String -> NatM (OrdList Instr, Maybe Label)
mkCCall (Width -> String
xchgLabel Width
w)

  where
    unsupported :: Show a => a -> b
    unsupported :: forall a b. Show a => a -> b
unsupported a
mop = String -> b
forall a. String -> a
panic (String
"outOfLineCmmOp: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
mop
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not supported here")
    mkCCall :: String -> NatM (InstrBlock, Maybe BlockId)
    mkCCall :: String -> NatM (OrdList Instr, Maybe Label)
mkCCall String
name = do
      NCGConfig
config <- NatM NCGConfig
getConfig
      CmmExpr
target <- NCGConfig -> ReferenceKind -> CLabel -> NatM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
NCGConfig -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference NCGConfig
config ReferenceKind
CallReference (CLabel -> NatM CmmExpr) -> CLabel -> NatM CmmExpr
forall a b. (a -> b) -> a -> b
$
          FastString
-> Maybe Int -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel (String -> FastString
fsLit String
name) Maybe Int
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 = (Int, [Reg], OrdList Instr) -> NatM (Int, [Reg], OrdList Instr)
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
      let w :: Width
w = Format -> Width
formatToWidth Format
format
      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
gpRegReg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
:[Reg]
accumRegs) (OrdList Instr
accumCode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_r OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` (SDoc -> Instr -> Instr
ann (String -> SDoc
text String
"Pass gp argument: " SDoc -> SDoc -> SDoc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r) (Instr -> Instr) -> Instr -> Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
gpReg) (Width -> Reg -> Operand
OpReg Width
w Reg
r)))

    -- 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
      Bool
-> [Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments Bool
pack [Reg]
gpRegs [Reg]
fpRegs [(Reg, Format, ForeignHint, OrdList Instr)]
args Int
stackSpace (Reg
fpRegReg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
:[Reg]
accumRegs) (OrdList Instr
accumCode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_r OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` (SDoc -> Instr -> Instr
ann (String -> SDoc
text String
"Pass fp argument: " SDoc -> SDoc -> SDoc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r) (Instr -> Instr) -> Instr -> Instr
forall a b. (a -> b) -> a -> b
$ Operand -> Operand -> Instr
MOV (Width -> Reg -> Operand
OpReg Width
w Reg
fpReg) (Width -> Reg -> Operand
OpReg Width
w Reg
r)))

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

    -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.
    passArguments Bool
pack [] [Reg]
fpRegs ((Reg
r, Format
format, ForeignHint
_hint, OrdList Instr
code_r):[(Reg, Format, ForeignHint, OrdList Instr)]
args) Int
stackSpace [Reg]
accumRegs OrdList Instr
accumCode | Format -> Bool
isIntFormat Format
format = do
      let w :: Width
w = Format -> Width
formatToWidth Format
format
          bytes :: Int
bytes = Width -> Int
widthInBits Width
w Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
          space :: Int
space = if Bool
pack then Int
bytes else Int
8
          stackSpace' :: Int
stackSpace' | Bool
pack Bool -> Bool -> Bool
&& Int
stackSpace Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
space Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Int
stackSpace Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
space Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
stackSpace Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
space)
                      | Bool
otherwise                           = Int
stackSpace
          stackCode :: OrdList Instr
stackCode = OrdList Instr
code_r OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` (SDoc -> Instr -> Instr
ann (String -> SDoc
text String
"Pass argument (size " SDoc -> SDoc -> SDoc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
") on the stack: " SDoc -> SDoc -> SDoc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r) (Instr -> Instr) -> Instr -> Instr
forall a b. (a -> b) -> a -> b
$ 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'))))
      Bool
-> [Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments Bool
pack [] [Reg]
fpRegs [(Reg, Format, ForeignHint, OrdList Instr)]
args (Int
stackSpace'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
space) [Reg]
accumRegs (OrdList Instr
stackCode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
accumCode)

    -- Still have gpRegs left, but want to pass a FP argument. Must be passed on the stack then.
    passArguments Bool
pack [Reg]
gpRegs [] ((Reg
r, Format
format, ForeignHint
_hint, OrdList Instr
code_r):[(Reg, Format, ForeignHint, OrdList Instr)]
args) Int
stackSpace [Reg]
accumRegs OrdList Instr
accumCode | Format -> Bool
isFloatFormat Format
format = do
      let w :: Width
w = Format -> Width
formatToWidth Format
format
          bytes :: Int
bytes = Width -> Int
widthInBits Width
w Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
          space :: Int
space = if Bool
pack then Int
bytes else Int
8
          stackSpace' :: Int
stackSpace' | Bool
pack Bool -> Bool -> Bool
&& Int
stackSpace Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
space Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 = Int
stackSpace Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
space Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
stackSpace Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
space)
                      | Bool
otherwise                           = Int
stackSpace
          stackCode :: OrdList Instr
stackCode = OrdList Instr
code_r OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` (SDoc -> Instr -> Instr
ann (String -> SDoc
text String
"Pass argument (size " SDoc -> SDoc -> SDoc
<> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
") on the stack: " SDoc -> SDoc -> SDoc
<> Reg -> SDoc
forall a. Outputable a => a -> SDoc
ppr Reg
r) (Instr -> Instr) -> Instr -> Instr
forall a b. (a -> b) -> a -> b
$ 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'))))
      Bool
-> [Reg]
-> [Reg]
-> [(Reg, Format, ForeignHint, OrdList Instr)]
-> Int
-> [Reg]
-> OrdList Instr
-> NatM (Int, [Reg], OrdList Instr)
passArguments Bool
pack [Reg]
gpRegs [] [(Reg, Format, ForeignHint, OrdList Instr)]
args (Int
stackSpace'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
space) [Reg]
accumRegs (OrdList Instr
stackCode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
accumCode)

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

    readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM ([Reg], InstrBlock)
    readResults :: [Reg]
-> [Reg]
-> [CmmFormal]
-> [Reg]
-> OrdList Instr
-> NatM ([Reg], OrdList Instr)
readResults [Reg]
_ [Reg]
_ [] [Reg]
accumRegs OrdList Instr
accumCode = ([Reg], OrdList Instr) -> NatM ([Reg], OrdList Instr)
forall (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
      String -> SDoc -> NatM ([Reg], OrdList Instr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genCCall, out of gp registers when reading results" (Platform -> ForeignTarget -> SDoc
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
      String -> SDoc -> NatM ([Reg], OrdList Instr)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"genCCall, out of fp registers when reading results" (Platform -> ForeignTarget -> SDoc
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
gpRegReg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
:[Reg]
gpRegs) [Reg]
fpRegs [CmmFormal]
dsts (Reg
fpRegReg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
:[Reg]
accumRegs) (OrdList Instr
accumCode OrdList Instr -> Instr -> OrdList Instr
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
fpRegReg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
:[Reg]
fpRegs) [CmmFormal]
dsts (Reg
gpRegReg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
:[Reg]
accumRegs) (OrdList Instr
accumCode OrdList Instr -> Instr -> OrdList Instr
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)
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 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Operand -> Operand -> OrdList Instr
op (Width -> Reg -> Operand
OpReg Width
w Reg
dst) (Width -> Reg -> Operand
OpReg Width
w Reg
reg_fx)
      (OrdList Instr, Maybe a) -> NatM (OrdList Instr, Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code, Maybe a
forall a. Maybe a
Nothing)