{-# LANGUAGE GADTs #-}

-----------------------------------------------------------------------------
--
-- Generating machine code (instruction selection)
--
-- (c) The University of Glasgow 1996-2004
--
-----------------------------------------------------------------------------

-- This is a big module, but, if you pay attention to
-- (a) the sectioning, and (b) the type signatures,
-- the structure should not be too overwhelming.

module GHC.CmmToAsm.PPC.CodeGen (
        cmmTopCodeGen,
        generateJumpTableForInstr,
        InstrBlock
)

where

-- NCG stuff:
import GHC.Prelude

import GHC.Platform.Regs
import GHC.CmmToAsm.PPC.Instr
import GHC.CmmToAsm.PPC.Cond
import GHC.CmmToAsm.PPC.Regs
import GHC.CmmToAsm.CPrim
import GHC.CmmToAsm.Types
import GHC.Cmm.DebugBlock
   ( DebugBlock(..) )
import GHC.CmmToAsm.Monad
   ( NatM, getNewRegNat, getNewLabelNat
   , getBlockIdNat, getPicBaseNat
   , Reg64(..), RegCode64(..), getNewReg64, localReg64
   , getPicBaseMaybeNat, getPlatform, getConfig
   , getDebugBlock, getFileId
   )
import GHC.CmmToAsm.PIC
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Config
import GHC.Platform.Reg.Class.Unified
import GHC.Platform.Reg
import GHC.CmmToAsm.Reg.Target
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 GHC.Utils.Panic

import Control.Monad    ( mapAndUnzipM, when )
import Data.Word

import GHC.Types.Basic
import GHC.Data.FastString

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

-- | '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 (pre-order?) yields the insns in the correct
-- order.

cmmTopCodeGen
        :: RawCmmDecl
        -> NatM [NatCmmDecl RawCmmStatics Instr]

cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl RawCmmStatics Instr]
cmmTopCodeGen (CmmProc LabelMap RawCmmStatics
info CLabel
lab [GlobalRegUse]
live CmmGraph
graph) = do
  let blocks :: [CmmBlock]
blocks = CmmGraph -> [CmmBlock]
toBlockListEntryFirst CmmGraph
graph
  (nat_blocks,statics) <- (CmmBlock
 -> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr]))
-> [CmmBlock]
-> NatM
     ([[NatBasicBlock Instr]], [[NatCmmDecl RawCmmStatics Instr]])
forall (m :: * -> *) a b c.
Applicative m =>
(a -> m (b, c)) -> [a] -> m ([b], [c])
mapAndUnzipM CmmBlock
-> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr])
basicBlockCodeGen [CmmBlock]
blocks
  platform <- getPlatform
  let proc = LabelMap RawCmmStatics
-> CLabel
-> [GlobalRegUse]
-> ListGraph Instr
-> NatCmmDecl RawCmmStatics Instr
forall d h g.
h -> CLabel -> [GlobalRegUse] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
info CLabel
lab [GlobalRegUse]
live ([NatBasicBlock Instr] -> ListGraph Instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph ([NatBasicBlock Instr] -> ListGraph Instr)
-> [NatBasicBlock Instr] -> ListGraph Instr
forall a b. (a -> b) -> a -> b
$ [[NatBasicBlock Instr]] -> [NatBasicBlock Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NatBasicBlock Instr]]
nat_blocks)
      tops = NatCmmDecl RawCmmStatics Instr
proc NatCmmDecl RawCmmStatics Instr
-> [NatCmmDecl RawCmmStatics Instr]
-> [NatCmmDecl RawCmmStatics Instr]
forall a. a -> [a] -> [a]
: [[NatCmmDecl RawCmmStatics Instr]]
-> [NatCmmDecl RawCmmStatics Instr]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NatCmmDecl RawCmmStatics Instr]]
statics
      os   = Platform -> OS
platformOS Platform
platform
      arch = Platform -> Arch
platformArch Platform
platform
  case arch of
    Arch
ArchPPC | OS
os OS -> OS -> Bool
forall a. Eq a => a -> a -> Bool
== OS
OSAIX -> [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return [NatCmmDecl RawCmmStatics Instr]
tops
            | Bool
otherwise -> do
      picBaseMb <- NatM (Maybe Reg)
getPicBaseMaybeNat
      case picBaseMb of
           Just Reg
picBase -> Arch
-> OS
-> Reg
-> [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
initializePicBase_ppc Arch
arch OS
os Reg
picBase [NatCmmDecl RawCmmStatics Instr]
tops
           Maybe Reg
Nothing -> [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return [NatCmmDecl RawCmmStatics Instr]
tops
    ArchPPC_64 PPC_64ABI
ELF_V1 -> [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
forall {m :: * -> *} {d} {h} {i}.
MonadGetUnique m =>
[GenCmmDecl d h (ListGraph i)] -> m [GenCmmDecl d h (ListGraph i)]
fixup_entry [NatCmmDecl RawCmmStatics Instr]
tops
                      -- generating function descriptor is handled in
                      -- pretty printer
    ArchPPC_64 PPC_64ABI
ELF_V2 -> [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
forall {m :: * -> *} {d} {h} {i}.
MonadGetUnique m =>
[GenCmmDecl d h (ListGraph i)] -> m [GenCmmDecl d h (ListGraph i)]
fixup_entry [NatCmmDecl RawCmmStatics Instr]
tops
                      -- generating function prologue is handled in
                      -- pretty printer
    Arch
_          -> String -> NatM [NatCmmDecl RawCmmStatics Instr]
forall a. HasCallStack => String -> a
panic String
"PPC.cmmTopCodeGen: unknown arch"
    where
      fixup_entry :: [GenCmmDecl d h (ListGraph i)] -> m [GenCmmDecl d h (ListGraph i)]
fixup_entry (CmmProc h
info CLabel
lab [GlobalRegUse]
live (ListGraph (GenBasicBlock i
entry:[GenBasicBlock i]
blocks)) : [GenCmmDecl d h (ListGraph i)]
statics)
        = do
        let BasicBlock BlockId
bID [i]
insns = GenBasicBlock i
entry
        bID' <- if CLabel
lab CLabel -> CLabel -> Bool
forall a. Eq a => a -> a -> Bool
== (BlockId -> CLabel
blockLbl BlockId
bID)
                then m BlockId
forall (m :: * -> *). MonadGetUnique m => m BlockId
newBlockId
                else BlockId -> m BlockId
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockId
bID
        let b' = BlockId -> [i] -> GenBasicBlock i
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
bID' [i]
insns
        return (CmmProc info lab live (ListGraph (b':blocks)) : statics)
      fixup_entry [GenCmmDecl d h (ListGraph i)]
_ = String -> m [GenCmmDecl d h (ListGraph i)]
forall a. HasCallStack => String -> a
panic String
"cmmTopCodegen: Broken CmmProc"

cmmTopCodeGen (CmmData Section
sec RawCmmStatics
dat) =
  [NatCmmDecl RawCmmStatics Instr]
-> NatM [NatCmmDecl RawCmmStatics Instr]
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return [Section -> RawCmmStatics -> NatCmmDecl RawCmmStatics Instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec RawCmmStatics
dat]  -- no translation, we just use CmmStatic

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

basicBlockCodeGen :: CmmBlock
-> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr])
basicBlockCodeGen CmmBlock
block = do
  let (CmmNode C O
_, Block CmmNode O O
nodes, CmmNode O C
tail)  = CmmBlock -> (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 CmmBlock
block
      id :: BlockId
id = CmmBlock -> BlockId
forall (x :: Extensibility). Block CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
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
  -- Generate location directive
  dbg <- BlockId -> NatM (Maybe DebugBlock)
getDebugBlock (CmmBlock -> BlockId
forall (x :: Extensibility). Block CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block)
  loc_instrs <- case dblSourceTick =<< dbg of
    Just (SourceNote RealSrcSpan
span (LexicalFastString FastString
name))
      -> do fileid <- FastString -> NatM Int
getFileId (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
span)
            let line = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span; col =RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
span
            return $ unitOL $ LOCATION fileid line col (unpackFS name)
    Maybe CmmTickish
_ -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
  mid_instrs <- stmtsToInstrs stmts
  tail_instrs <- stmtToInstrs tail
  let instrs = 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
  -- 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
        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs

        mkBlocks (NEWBLOCK BlockId
id) ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl RawCmmStatics h g]
statics)
          = ([], BlockId -> [Instr] -> NatBasicBlock Instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id [Instr]
instrs NatBasicBlock Instr
-> [NatBasicBlock Instr] -> [NatBasicBlock Instr]
forall a. a -> [a] -> [a]
: [NatBasicBlock Instr]
blocks, [GenCmmDecl RawCmmStatics h g]
statics)
        mkBlocks (LDATA Section
sec RawCmmStatics
dat) ([Instr]
instrs,[NatBasicBlock Instr]
blocks,[GenCmmDecl RawCmmStatics h g]
statics)
          = ([Instr]
instrs, [NatBasicBlock Instr]
blocks, Section -> RawCmmStatics -> GenCmmDecl RawCmmStatics h g
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData Section
sec RawCmmStatics
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)
  return (BasicBlock id top : other_blocks, statics)

stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
stmtsToInstrs :: forall (e :: Extensibility) (x :: Extensibility).
[CmmNode e x] -> NatM (OrdList Instr)
stmtsToInstrs [CmmNode e x]
stmts
   = do instrss <- (CmmNode e x -> NatM (OrdList Instr))
-> [CmmNode e x] -> NatM [OrdList Instr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM CmmNode e x -> NatM (OrdList Instr)
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> NatM (OrdList Instr)
stmtToInstrs [CmmNode e x]
stmts
        return (concatOL instrss)

stmtToInstrs :: CmmNode e x -> NatM InstrBlock
stmtToInstrs :: forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> NatM (OrdList Instr)
stmtToInstrs CmmNode e x
stmt = do
  config <- NatM NCGConfig
getConfig
  platform <- getPlatform
  case stmt of
    CmmComment FastString
s   -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (FastString -> Instr
COMMENT FastString
s))
    CmmTick {}     -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
    CmmUnwind {}   -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL

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

    CmmStore CmmExpr
addr CmmExpr
src AlignmentSpec
_alignment
      | CmmType -> Bool
isFloatType CmmType
ty -> Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_FltCode Format
format CmmExpr
addr CmmExpr
src
      | Platform -> Bool
target32Bit Platform
platform Bool -> Bool -> Bool
&&
        CmmType -> Bool
isWord64 CmmType
ty    -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_I64Code      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

    CmmUnsafeForeignCall ForeignTarget
target [CmmFormal]
result_regs [CmmExpr]
args
       -> ForeignTarget -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
genCCall ForeignTarget
target [CmmFormal]
result_regs [CmmExpr]
args

    CmmBranch BlockId
id          -> BlockId -> NatM (OrdList Instr)
genBranch BlockId
id
    CmmCondBranch CmmExpr
arg BlockId
true BlockId
false Maybe Bool
prediction -> do
      b1 <- BlockId -> CmmExpr -> Maybe Bool -> NatM (OrdList Instr)
genCondJump BlockId
true CmmExpr
arg Maybe Bool
prediction
      b2 <- genBranch false
      return (b1 `appOL` b2)
    CmmSwitch CmmExpr
arg SwitchTargets
ids -> NCGConfig -> CmmExpr -> SwitchTargets -> NatM (OrdList Instr)
genSwitch NCGConfig
config CmmExpr
arg SwitchTargets
ids
    CmmCall { cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmExpr
arg
            , cml_args_regs :: CmmNode O C -> [GlobalRegUse]
cml_args_regs = [GlobalRegUse]
gregs } -> CmmExpr -> [RegWithFormat] -> NatM (OrdList Instr)
genJump CmmExpr
arg (Platform -> [GlobalRegUse] -> [RegWithFormat]
jumpRegs Platform
platform [GlobalRegUse]
gregs)
    CmmNode e x
_ ->
      String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"stmtToInstrs: statement should have been cps'd away"

jumpRegs :: Platform -> [GlobalRegUse] -> [RegWithFormat]
jumpRegs :: Platform -> [GlobalRegUse] -> [RegWithFormat]
jumpRegs Platform
platform [GlobalRegUse]
gregs =
  [ Reg -> Format -> RegWithFormat
RegWithFormat (RealReg -> Reg
RegReal RealReg
r) (CmmType -> Format
cmmTypeFormat CmmType
ty)
  | GlobalRegUse GlobalReg
gr CmmType
ty <- [GlobalRegUse]
gregs
  , Just RealReg
r <- [Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe Platform
platform GlobalReg
gr] ]

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


swizzleRegisterRep :: Register -> Format -> Register
swizzleRegisterRep :: Register -> Format -> Register
swizzleRegisterRep (Fixed Format
_ Reg
reg OrdList Instr
code) Format
format = Format -> Reg -> OrdList Instr -> Register
Fixed Format
format Reg
reg OrdList Instr
code
swizzleRegisterRep (Any Format
_ Reg -> OrdList Instr
codefn)     Format
format = Format -> (Reg -> OrdList Instr) -> Register
Any   Format
format Reg -> OrdList Instr
codefn

getLocalRegReg :: LocalReg -> Reg
getLocalRegReg :: CmmFormal -> Reg
getLocalRegReg (LocalReg Unique
u CmmType
pk)
  = VirtualReg -> Reg
RegVirtual (Unique -> Format -> VirtualReg
mkVirtualReg Unique
u (CmmType -> Format
cmmTypeFormat CmmType
pk))

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

getRegisterReg :: Platform -> CmmReg -> Reg
getRegisterReg Platform
_ (CmmLocal CmmFormal
local_reg)
  = CmmFormal -> Reg
getLocalRegReg CmmFormal
local_reg

getRegisterReg Platform
platform (CmmGlobal GlobalRegUse
mid)
  = case Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe Platform
platform (GlobalRegUse -> GlobalReg
globalRegUse_reg GlobalRegUse
mid) of
        Just RealReg
reg -> RealReg -> Reg
RegReal RealReg
reg
        Maybe RealReg
Nothing  -> String -> SDoc -> Reg
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegisterReg-memory" (CmmReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr (CmmReg -> SDoc) -> CmmReg -> SDoc
forall a b. (a -> b) -> a -> b
$ GlobalRegUse -> CmmReg
CmmGlobal GlobalRegUse
mid)
        -- By this stage, the only MagicIds remaining should be the
        -- ones which map to a real machine register on this
        -- platform.  Hence ...

-- | Convert a BlockId to some CmmStatic data
jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic
jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic
jumpTableEntry NCGConfig
config Maybe BlockId
Nothing   = CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
0 (NCGConfig -> Width
ncgWordWidth NCGConfig
config))
jumpTableEntry NCGConfig
_ (Just BlockId
blockid) = CmmLit -> CmmStatic
CmmStaticLit (CLabel -> CmmLit
CmmLabel CLabel
blockLabel)
    where blockLabel :: CLabel
blockLabel = BlockId -> CLabel
blockLbl BlockId
blockid



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

-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert
-- CmmExprs into CmmRegOff?
mangleIndexTree :: CmmExpr -> CmmExpr
mangleIndexTree :: CmmExpr -> CmmExpr
mangleIndexTree (CmmRegOff CmmReg
reg Int
off)
  = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
width) [CmmReg -> CmmExpr
CmmReg CmmReg
reg, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
off) Width
width)]
  where width :: Width
width = CmmType -> Width
typeWidth (CmmReg -> CmmType
cmmRegType CmmReg
reg)

mangleIndexTree CmmExpr
_
        = String -> CmmExpr
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.mangleIndexTree: no match"

-- -----------------------------------------------------------------------------
--  Code gen for 64-bit arithmetic on 32-bit platforms

{-
Simple support for generating 64-bit code (ie, 64 bit values and 64
bit assignments) on 32-bit platforms.  Unlike the main code generator
we merely shoot for generating working code as simply as possible, and
pay little attention to code quality.  Specifically, there is no
attempt to deal cleverly with the fixed-vs-floating register
distinction; all values are generated into (pairs of) floating
registers, even if this would mean some redundant reg-reg moves as a
result.  Only one of the VRegUniques is returned, since it will be
of the VRegUniqueLo form, and the upper-half VReg can be determined
by applying getHiVRegFromLo to it.
-}

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

getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)
getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, OrdList Instr)
getI64Amodes CmmExpr
addrTree = do
    Amode hi_addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
addrTree
    case addrOffset hi_addr 4 of
        Just AddrMode
lo_addr -> (AddrMode, AddrMode, OrdList Instr)
-> NatM (AddrMode, AddrMode, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode
hi_addr, AddrMode
lo_addr, OrdList Instr
addr_code)
        Maybe AddrMode
Nothing      -> do (hi_ptr, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
addrTree
                           return (AddrRegImm hi_ptr (ImmInt 0),
                                   AddrRegImm hi_ptr (ImmInt 4),
                                   code)


assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_I64Code CmmExpr
addrTree CmmExpr
valueTree = do
        (hi_addr, lo_addr, addr_code) <- CmmExpr -> NatM (AddrMode, AddrMode, OrdList Instr)
getI64Amodes CmmExpr
addrTree
        RegCode64 vcode rhi rlo <- iselExpr64 valueTree
        let
                -- Big-endian store
                mov_hi = Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
rhi AddrMode
hi_addr
                mov_lo = Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
rlo AddrMode
lo_addr
        return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)


assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
assignReg_I64Code :: CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_I64Code (CmmLocal CmmFormal
lreg) CmmExpr
valueTree = do
   RegCode64 vcode r_src_hi r_src_lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
valueTree
   let Reg64 r_dst_hi r_dst_lo = localReg64 lreg
       mov_lo = Reg -> Reg -> Instr
MR Reg
r_dst_lo Reg
r_src_lo
       mov_hi = Reg -> Reg -> Instr
MR Reg
r_dst_hi Reg
r_src_hi
   return (
        vcode `snocOL` mov_lo `snocOL` mov_hi
     )

assignReg_I64Code CmmReg
_ CmmExpr
_
   = String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"assignReg_I64Code(powerpc): invalid lvalue"


iselExpr64        :: CmmExpr -> NatM (RegCode64 InstrBlock)
iselExpr64 :: CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 (CmmLoad CmmExpr
addrTree CmmType
ty AlignmentSpec
_) | CmmType -> Bool
isWord64 CmmType
ty = do
    (hi_addr, lo_addr, addr_code) <- CmmExpr -> NatM (AddrMode, AddrMode, OrdList Instr)
getI64Amodes CmmExpr
addrTree
    Reg64 rhi rlo <- getNewReg64
    let mov_hi = Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
rhi AddrMode
hi_addr
        mov_lo = Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
rlo AddrMode
lo_addr
    return $ RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)
                         rhi rlo

iselExpr64 (CmmReg (CmmLocal CmmFormal
local_reg)) = do
  let Reg64 Reg
hi Reg
lo = HasDebugCallStack => CmmFormal -> Reg64
CmmFormal -> Reg64
localReg64 CmmFormal
local_reg
  RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> Reg -> Reg -> RegCode64 (OrdList Instr)
forall code. code -> Reg -> Reg -> RegCode64 code
RegCode64 OrdList Instr
forall a. OrdList a
nilOL Reg
hi Reg
lo)

iselExpr64 (CmmLit (CmmInt Integer
i Width
_)) = do
  Reg64 rhi rlo <- NatM Reg64
getNewReg64
  let
        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 = 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 = 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 = 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)

        code = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                Reg -> Imm -> Instr
LIS Reg
rlo (Int -> Imm
ImmInt Int
half1),
                Reg -> Reg -> RI -> Instr
OR Reg
rlo Reg
rlo (Imm -> RI
RIImm (Imm -> RI) -> Imm -> RI
forall a b. (a -> b) -> a -> b
$ Int -> Imm
ImmInt Int
half0),
                Reg -> Imm -> Instr
LIS Reg
rhi (Int -> Imm
ImmInt Int
half3),
                Reg -> Reg -> RI -> Instr
OR Reg
rhi Reg
rhi (Imm -> RI
RIImm (Imm -> RI) -> Imm -> RI
forall a b. (a -> b) -> a -> b
$ Int -> Imm
ImmInt Int
half2)
                ]
  return (RegCode64 code rhi rlo)

iselExpr64 (CmmMachOp (MO_Add Width
_) [CmmExpr
e1,CmmExpr
e2]) = do
   RegCode64 code1 r1hi r1lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
e1
   RegCode64 code2 r2hi r2lo <- iselExpr64 e2
   Reg64 rhi rlo <- getNewReg64
   let
        code =  OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                OrdList Instr
code2 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Reg -> Reg -> Reg -> Instr
ADDC Reg
rlo Reg
r1lo Reg
r2lo,
                       Reg -> Reg -> Reg -> Instr
ADDE Reg
rhi Reg
r1hi Reg
r2hi ]
   return (RegCode64 code rhi rlo)

iselExpr64 (CmmMachOp (MO_Sub Width
_) [CmmExpr
e1,CmmExpr
e2]) = do
   RegCode64 code1 r1hi r1lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
e1
   RegCode64 code2 r2hi r2lo <- iselExpr64 e2
   Reg64 rhi rlo <- getNewReg64
   let
        code =  OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                OrdList Instr
code2 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Reg -> Reg -> RI -> Instr
SUBFC Reg
rlo Reg
r2lo (Reg -> RI
RIReg Reg
r1lo),
                       Reg -> Reg -> Reg -> Instr
SUBFE Reg
rhi Reg
r2hi Reg
r1hi ]
   return (RegCode64 code rhi rlo)

iselExpr64 (CmmMachOp (MO_UU_Conv Width
W32 Width
W64) [CmmExpr
expr]) = do
    (expr_reg,expr_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
expr
    Reg64 rhi rlo <- getNewReg64
    let mov_hi = Reg -> Imm -> Instr
LI Reg
rhi (Int -> Imm
ImmInt Int
0)
        mov_lo = Reg -> Reg -> Instr
MR Reg
rlo Reg
expr_reg
    return $ RegCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
                       rhi rlo

iselExpr64 (CmmMachOp (MO_SS_Conv Width
W32 Width
W64) [CmmExpr
expr]) = do
    (expr_reg,expr_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
expr
    Reg64 rhi rlo <- getNewReg64
    let mov_hi = Format -> Reg -> Reg -> RI -> Instr
SRA Format
II32 Reg
rhi Reg
expr_reg (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
31))
        mov_lo = Reg -> Reg -> Instr
MR Reg
rlo Reg
expr_reg
    return $ RegCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)
                       rhi rlo
iselExpr64 CmmExpr
expr
   = do
     platform <- NatM Platform
getPlatform
     pprPanic "iselExpr64(powerpc)" (pdoc platform expr)



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

getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register

getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
_ Platform
platform (CmmReg (CmmGlobal (GlobalRegUse GlobalReg
PicBaseReg CmmType
_)))
  | OS
OSAIX <- Platform -> OS
platformOS Platform
platform = do
        let code :: Reg -> OrdList Instr
code Reg
dst = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
dst AddrMode
tocAddr ]
            tocAddr :: AddrMode
tocAddr = Reg -> Imm -> AddrMode
AddrRegImm Reg
toc (FastString -> Imm
ImmLit (String -> FastString
fsLit String
"ghc_toc_table[TC]"))
        Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
II32 Reg -> OrdList Instr
code)
  | Platform -> Bool
target32Bit Platform
platform = do
      reg <- Format -> NatM Reg
getPicBaseNat (Format -> NatM Reg) -> Format -> NatM Reg
forall a b. (a -> b) -> a -> b
$ Bool -> Format
archWordFormat (Platform -> Bool
target32Bit Platform
platform)
      return (Fixed (archWordFormat (target32Bit platform))
                    reg nilOL)
  | Bool
otherwise = Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed Format
II64 Reg
toc OrdList Instr
forall a. OrdList a
nilOL)

getRegister' NCGConfig
_ Platform
platform (CmmReg CmmReg
reg)
  = Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> OrdList Instr -> Register
Fixed (CmmType -> Format
cmmTypeFormat (CmmReg -> CmmType
cmmRegType CmmReg
reg))
                  (Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg) OrdList Instr
forall a. OrdList a
nilOL)

getRegister' NCGConfig
config Platform
platform tree :: CmmExpr
tree@(CmmRegOff CmmReg
_ Int
_)
  = NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
platform (CmmExpr -> CmmExpr
mangleIndexTree CmmExpr
tree)

    -- for 32-bit architectures, support some 64 -> 32 bit conversions:
    -- TO_W_(x), TO_W_(x >> 32)

getRegister' NCGConfig
_ Platform
platform (CmmMachOp (MO_UU_Conv Width
W64 Width
W32)
                     [CmmMachOp (MO_U_Shr Width
W64) [CmmExpr
x,CmmLit (CmmInt Integer
32 Width
_)]])
 | Platform -> Bool
target32Bit Platform
platform = do
  RegCode64 code _rhi rlo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  return $ Fixed II32 (getHiVRegFromLo rlo) code

getRegister' NCGConfig
_ Platform
platform (CmmMachOp (MO_SS_Conv Width
W64 Width
W32)
                     [CmmMachOp (MO_U_Shr Width
W64) [CmmExpr
x,CmmLit (CmmInt Integer
32 Width
_)]])
 | Platform -> Bool
target32Bit Platform
platform = do
  RegCode64 code _rhi rlo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  return $ Fixed II32 (getHiVRegFromLo rlo) code

getRegister' NCGConfig
_ Platform
platform (CmmMachOp (MO_UU_Conv Width
W64 Width
W32) [CmmExpr
x])
 | Platform -> Bool
target32Bit Platform
platform = do
  RegCode64 code _rhi rlo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  return $ Fixed II32 rlo code

getRegister' NCGConfig
_ Platform
platform (CmmMachOp (MO_SS_Conv Width
W64 Width
W32) [CmmExpr
x])
 | Platform -> Bool
target32Bit Platform
platform = do
  RegCode64 code _rhi rlo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  return $ Fixed II32 rlo code

getRegister' NCGConfig
_ Platform
platform (CmmLoad CmmExpr
mem CmmType
pk AlignmentSpec
_)
 | Bool -> Bool
not (CmmType -> Bool
isWord64 CmmType
pk) = do
        Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
        let format = CmmType -> Format
cmmTypeFormat CmmType
pk
        let code Reg
dst = Bool -> OrdList Instr -> OrdList Instr
forall a. HasCallStack => Bool -> a -> a
assert ((Platform -> Reg -> RegClass
targetClassOfReg Platform
platform Reg
dst RegClass -> RegClass -> Bool
forall a. Eq a => a -> a -> Bool
== RegClass
RcFloatOrVector) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== CmmType -> Bool
isFloatType CmmType
pk) (OrdList Instr -> OrdList Instr) -> OrdList Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$
                       OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
format Reg
dst AddrMode
addr
        return (Any format code)
 | Bool -> Bool
not (Platform -> Bool
target32Bit Platform
platform) = do
        Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
DS CmmExpr
mem
        let code Reg
dst = OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II64 Reg
dst AddrMode
addr
        return (Any II64 code)

 | Bool
otherwise = do -- 32-bit arch & 64-bit load
        (hi_addr, lo_addr, addr_code) <- CmmExpr -> NatM (AddrMode, AddrMode, OrdList Instr)
getI64Amodes CmmExpr
mem
        let code Reg
dst = OrdList Instr
addr_code
                        OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
dst AddrMode
lo_addr
                        OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II32 (Reg -> Reg
getHiVRegFromLo Reg
dst) AddrMode
hi_addr
        return (Any II64 code)

-- catch simple cases of zero- or sign-extended load
getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_UU_Conv Width
W8 Width
W32) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
    Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    return (Any II32 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II8 Reg
dst AddrMode
addr))

getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_XX_Conv Width
W8 Width
W32) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
    Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    return (Any II32 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II8 Reg
dst AddrMode
addr))

getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_UU_Conv Width
W8 Width
W64) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
    Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    return (Any II64 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II8 Reg
dst AddrMode
addr))

getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_XX_Conv Width
W8 Width
W64) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
    Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    return (Any II64 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II8 Reg
dst AddrMode
addr))

-- Note: there is no Load Byte Arithmetic instruction, so no signed case here

getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_UU_Conv Width
W16 Width
W32) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
    Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    return (Any II32 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II16 Reg
dst AddrMode
addr))

getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_SS_Conv Width
W16 Width
W32) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
    Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    return (Any II32 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LA Format
II16 Reg
dst AddrMode
addr))

getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_UU_Conv Width
W16 Width
W64) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
    Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    return (Any II64 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II16 Reg
dst AddrMode
addr))

getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_SS_Conv Width
W16 Width
W64) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
    Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    return (Any II64 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LA Format
II16 Reg
dst AddrMode
addr))

getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_UU_Conv Width
W32 Width
W64) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
    Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    return (Any II64 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
dst AddrMode
addr))

getRegister' NCGConfig
_ Platform
_ (CmmMachOp (MO_SS_Conv Width
W32 Width
W64) [CmmLoad CmmExpr
mem CmmType
_ AlignmentSpec
_]) = do
    -- lwa is DS-form. See Note [Power instruction format]
    Amode addr addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
DS CmmExpr
mem
    return (Any II64 (\Reg
dst -> OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LA Format
II32 Reg
dst AddrMode
addr))

getRegister' NCGConfig
config Platform
platform (CmmMachOp (MO_RelaxedRead Width
w) [CmmExpr
e]) =
      NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
platform (CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad CmmExpr
e (Width -> CmmType
cmmBits Width
w) AlignmentSpec
NaturallyAligned)

getRegister' NCGConfig
config Platform
platform (CmmMachOp MachOp
mop [CmmExpr
x]) -- unary MachOps
  = case MachOp
mop of
      MO_Not Width
rep   -> Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_int Width
rep Reg -> Reg -> Instr
NOT

      MO_F_Neg Width
w   -> Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_float Width
w Reg -> Reg -> Instr
FNEG
      MO_S_Neg Width
w   -> Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_int   Width
w Reg -> Reg -> Instr
NEG

      MO_FF_Conv Width
W64 Width
W32 -> Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUCode  Format
FF32 Reg -> Reg -> Instr
FRSP CmmExpr
x
      MO_FF_Conv Width
W32 Width
W64 -> Format -> CmmExpr -> NatM Register
conversionNop Format
FF64 CmmExpr
x

      MO_FS_Truncate Width
from Width
to -> Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int Width
from Width
to CmmExpr
x
      MO_SF_Round    Width
from Width
to -> Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP Width
from Width
to CmmExpr
x

      MO_SS_Conv Width
from Width
to
        | Width
from Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
>= Width
to -> Format -> CmmExpr -> NatM Register
conversionNop (Width -> Format
intFormat Width
to) CmmExpr
x
        | Bool
otherwise  -> Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_int Width
to (Format -> Reg -> Reg -> Instr
EXTS (Width -> Format
intFormat Width
from))

      MO_UU_Conv Width
from Width
to
        | Width
from Width -> Width -> Bool
forall a. Ord a => a -> a -> Bool
>= Width
to -> Format -> CmmExpr -> NatM Register
conversionNop (Width -> Format
intFormat Width
to) CmmExpr
x
        | Bool
otherwise  -> Width -> Width -> NatM Register
clearLeft Width
from Width
to

      MO_XX_Conv Width
_ Width
to -> Format -> CmmExpr -> NatM Register
conversionNop (Width -> Format
intFormat Width
to) CmmExpr
x

      MO_V_Broadcast {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VF_Broadcast {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VF_Neg {} -> NatM Register
forall {a}. a
vectorsNeedLlvm

      MachOp
_ -> String -> NatM Register
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.getRegister: no match"

    where
        vectorsNeedLlvm :: a
vectorsNeedLlvm =
            String -> a
forall a. HasCallStack => String -> a
sorry String
"SIMD operations on PowerPC currently require the LLVM backend"
        triv_ucode_int :: Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_int   Width
width Reg -> Reg -> Instr
instr = Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUCode (Width -> Format
intFormat    Width
width) Reg -> Reg -> Instr
instr CmmExpr
x
        triv_ucode_float :: Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_float Width
width Reg -> Reg -> Instr
instr = Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUCode (Width -> Format
floatFormat  Width
width) Reg -> Reg -> Instr
instr CmmExpr
x

        conversionNop :: Format -> CmmExpr -> NatM Register
conversionNop Format
new_format CmmExpr
expr
            = do e_code <- NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
platform CmmExpr
expr
                 return (swizzleRegisterRep e_code new_format)

        clearLeft :: Width -> Width -> NatM Register
clearLeft Width
from Width
to
            = do (src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
                 let arch_fmt  = Width -> Format
intFormat (Platform -> Width
wordWidth Platform
platform)
                     arch_bits = Width -> Int
widthInBits (Platform -> Width
wordWidth Platform
platform)
                     size      = Width -> Int
widthInBits Width
from
                     code Reg
dst  = OrdList Instr
code1 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                 Format -> Reg -> Reg -> Int -> Instr
CLRLI Format
arch_fmt Reg
dst Reg
src1 (Int
arch_bits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
size)
                 return (Any (intFormat to) code)

getRegister' NCGConfig
_ Platform
_ (CmmMachOp MachOp
mop [CmmExpr
x, CmmExpr
y]) -- dyadic PrimOps
  = case MachOp
mop of
      MO_F_Eq Width
_ -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
EQQ CmmExpr
x CmmExpr
y
      MO_F_Ne Width
_ -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
NE  CmmExpr
x CmmExpr
y
      MO_F_Gt Width
_ -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
GTT CmmExpr
x CmmExpr
y
      MO_F_Ge Width
_ -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
GE  CmmExpr
x CmmExpr
y
      MO_F_Lt Width
_ -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
LTT CmmExpr
x CmmExpr
y
      MO_F_Le Width
_ -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
LE  CmmExpr
x CmmExpr
y

      MO_Eq Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
EQQ Width
rep CmmExpr
x CmmExpr
y
      MO_Ne Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
NE  Width
rep CmmExpr
x CmmExpr
y

      MO_S_Gt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
GTT Width
rep CmmExpr
x CmmExpr
y
      MO_S_Ge Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
GE  Width
rep CmmExpr
x CmmExpr
y
      MO_S_Lt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
LTT Width
rep CmmExpr
x CmmExpr
y
      MO_S_Le Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
LE  Width
rep CmmExpr
x CmmExpr
y

      MO_U_Gt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
GU  Width
rep CmmExpr
x CmmExpr
y
      MO_U_Ge Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
GEU Width
rep CmmExpr
x CmmExpr
y
      MO_U_Lt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
LU  Width
rep CmmExpr
x CmmExpr
y
      MO_U_Le Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
LEU Width
rep CmmExpr
x CmmExpr
y

      MO_F_Add Width
w  -> Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float Width
w Format -> Reg -> Reg -> Reg -> Instr
FADD
      MO_F_Sub Width
w  -> Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float Width
w Format -> Reg -> Reg -> Reg -> Instr
FSUB
      MO_F_Mul Width
w  -> Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float Width
w Format -> Reg -> Reg -> Reg -> Instr
FMUL
      MO_F_Quot Width
w -> Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float Width
w Format -> Reg -> Reg -> Reg -> Instr
FDIV
      MO_F_Min Width
w  -> Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float Width
w Format -> Reg -> Reg -> Reg -> Instr
FMIN
      MO_F_Max Width
w  -> Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float Width
w Format -> Reg -> Reg -> Reg -> Instr
FMAX

         -- optimize addition with 32-bit immediate
         -- (needed for PIC)
      MO_Add Width
W32 ->
        case CmmExpr
y of
          CmmLit (CmmInt Integer
imm Width
immrep) | Just Imm
_ <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W32 Bool
True Integer
imm
            -> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
W32 Bool
True Reg -> Reg -> RI -> Instr
ADD CmmExpr
x (CmmLit -> CmmExpr
CmmLit (CmmLit -> CmmExpr) -> CmmLit -> CmmExpr
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt Integer
imm Width
immrep)
          CmmLit CmmLit
lit
            -> do
                (src, srcCode) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
                let imm = CmmLit -> Imm
litToImm CmmLit
lit
                    code Reg
dst = OrdList Instr
srcCode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                                    Reg -> Reg -> Imm -> Instr
ADDIS Reg
dst Reg
src (Imm -> Imm
HA Imm
imm),
                                    Reg -> Reg -> RI -> Instr
ADD Reg
dst Reg
dst (Imm -> RI
RIImm (Imm -> Imm
LO Imm
imm))
                                ]
                return (Any II32 code)
          CmmExpr
_ -> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
W32 Bool
True Reg -> Reg -> RI -> Instr
ADD CmmExpr
x CmmExpr
y

      MO_Add Width
rep -> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Bool
True Reg -> Reg -> RI -> Instr
ADD CmmExpr
x CmmExpr
y
      MO_Sub Width
rep ->
        case CmmExpr
y of
          CmmLit (CmmInt Integer
imm Width
immrep) | Just Imm
_ <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
rep Bool
True (-Integer
imm)
            -> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Bool
True Reg -> Reg -> RI -> Instr
ADD CmmExpr
x (CmmLit -> CmmExpr
CmmLit (CmmLit -> CmmExpr) -> CmmLit -> CmmExpr
forall a b. (a -> b) -> a -> b
$ Integer -> Width -> CmmLit
CmmInt (-Integer
imm) Width
immrep)
          CmmExpr
_ -> case CmmExpr
x of
                 CmmLit (CmmInt Integer
imm Width
_)
                   | Just Imm
_ <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
rep Bool
True Integer
imm
                   -- subfi ('subtract from' with immediate) doesn't exist
                   -> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Bool
True Reg -> Reg -> RI -> Instr
SUBFC CmmExpr
y CmmExpr
x
                 CmmExpr
_ -> Format
-> (Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCodeNoImm' (Width -> Format
intFormat Width
rep) Reg -> Reg -> Reg -> Instr
SUBF CmmExpr
y CmmExpr
x

      MO_Mul Width
rep -> Width
-> Bool
-> (Format -> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shiftMulCode Width
rep Bool
True Format -> Reg -> Reg -> RI -> Instr
MULL CmmExpr
x CmmExpr
y
      MO_S_MulMayOflo Width
rep -> do
        (src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
        (src2, code2) <- getSomeReg y
        let
          format = Width -> Format
intFormat Width
rep
          code Reg
dst = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2
                       OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Reg -> Reg -> Reg -> Instr
MULLO Format
format Reg
dst Reg
src1 Reg
src2
                                    , Format -> Reg -> Instr
MFOV  Format
format Reg
dst
                                    ]
        return (Any format code)

      MO_S_Quot Width
rep -> Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
divCode Width
rep Bool
True CmmExpr
x CmmExpr
y
      MO_U_Quot Width
rep -> Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
divCode Width
rep Bool
False CmmExpr
x CmmExpr
y

      MO_S_Rem Width
rep -> Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
remainder Width
rep Bool
True CmmExpr
x CmmExpr
y
      MO_U_Rem Width
rep -> Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
remainder Width
rep Bool
False CmmExpr
x CmmExpr
y

      MO_And Width
rep   -> case CmmExpr
y of
        (CmmLit (CmmInt Integer
imm Width
_)) | Integer
imm Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -Integer
8 Bool -> Bool -> Bool
|| Integer
imm Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -Integer
4
            -> do
                (src, srcCode) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
                let clear_mask = if Integer
imm Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -Integer
4 then Int
2 else Int
3
                    fmt = Width -> Format
intFormat Width
rep
                    code Reg
dst = OrdList Instr
srcCode
                               OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Reg -> Reg -> Int -> Instr
CLRRI Format
fmt Reg
dst Reg
src Int
clear_mask)
                return (Any fmt code)
        CmmExpr
_ -> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Bool
False Reg -> Reg -> RI -> Instr
AND CmmExpr
x CmmExpr
y
      MO_Or Width
rep    -> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Bool
False Reg -> Reg -> RI -> Instr
OR CmmExpr
x CmmExpr
y
      MO_Xor Width
rep   -> Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Bool
False Reg -> Reg -> RI -> Instr
XOR CmmExpr
x CmmExpr
y

      MO_Shl Width
rep   -> Width
-> Bool
-> (Format -> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shiftMulCode Width
rep Bool
False Format -> Reg -> Reg -> RI -> Instr
SL CmmExpr
x CmmExpr
y
      MO_S_Shr Width
rep -> Width
-> Bool
-> (Format -> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
srCode Width
rep Bool
True Format -> Reg -> Reg -> RI -> Instr
SRA CmmExpr
x CmmExpr
y
      MO_U_Shr Width
rep -> Width
-> Bool
-> (Format -> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
srCode Width
rep Bool
False Format -> Reg -> Reg -> RI -> Instr
SR CmmExpr
x CmmExpr
y

      MO_V_Extract {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_V_Add {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_V_Sub {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_V_Mul {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VS_Quot {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VS_Rem {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VS_Neg {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VU_Quot {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VU_Rem {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VF_Extract {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VF_Add {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VF_Sub {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VF_Neg {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VF_Mul {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VF_Quot {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_V_Shuffle {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VF_Shuffle {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VU_Min {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VU_Max {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VS_Min {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VS_Max {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VF_Min {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VF_Max {} -> NatM Register
forall {a}. a
vectorsNeedLlvm

      MachOp
_ -> String -> NatM Register
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.getRegister: no match"

  where
    vectorsNeedLlvm :: a
vectorsNeedLlvm =
      String -> a
forall a. HasCallStack => String -> a
sorry String
"SIMD operations on PowerPC currently require the LLVM backend"

    triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
    triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float Width
width Format -> Reg -> Reg -> Reg -> Instr
instr = Format
-> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCodeNoImm (Width -> Format
floatFormat Width
width) Format -> Reg -> Reg -> Reg -> Instr
instr CmmExpr
x CmmExpr
y

    remainder :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
    remainder :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
remainder Width
rep Bool
sgn CmmExpr
x CmmExpr
y = do
      let fmt :: Format
fmt = Width -> Format
intFormat Width
rep
      tmp <- Format -> NatM Reg
getNewRegNat Format
fmt
      code <- remainderCode rep sgn tmp x y
      return (Any fmt code)

getRegister' NCGConfig
_ Platform
_ (CmmMachOp MachOp
mop [CmmExpr
x, CmmExpr
y, CmmExpr
z]) -- ternary PrimOps
  = case MachOp
mop of

      -- x86 fmadd    x * y + z <> PPC fmadd  rt =   ra * rc + rb
      -- x86 fmsub    x * y - z <> PPC fmsub  rt =   ra * rc - rb
      -- x86 fnmadd - x * y + z ~~ PPC fnmsub rt = -(ra * rc - rb)
      -- x86 fnmsub - x * y - z ~~ PPC fnmadd rt = -(ra * rc + rb)

      MO_FMA FMASign
variant Int
l Width
w | Int
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 ->
        case FMASign
variant of
          FMASign
FMAdd  -> Width
-> (Format -> Reg -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM Register
fma_code Width
w (FMASign -> Format -> Reg -> Reg -> Reg -> Reg -> Instr
FMADD FMASign
FMAdd) CmmExpr
x CmmExpr
y CmmExpr
z
          FMASign
FMSub  -> Width
-> (Format -> Reg -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM Register
fma_code Width
w (FMASign -> Format -> Reg -> Reg -> Reg -> Reg -> Instr
FMADD FMASign
FMSub) CmmExpr
x CmmExpr
y CmmExpr
z
          FMASign
FNMAdd -> Width
-> (Format -> Reg -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM Register
fma_code Width
w (FMASign -> Format -> Reg -> Reg -> Reg -> Reg -> Instr
FMADD FMASign
FNMAdd) CmmExpr
x CmmExpr
y CmmExpr
z
          FMASign
FNMSub -> Width
-> (Format -> Reg -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM Register
fma_code Width
w (FMASign -> Format -> Reg -> Reg -> Reg -> Reg -> Instr
FMADD FMASign
FNMSub) CmmExpr
x CmmExpr
y CmmExpr
z
        | Bool
otherwise
        -> NatM Register
forall {a}. a
vectorsNeedLlvm

      MO_V_Insert {} -> NatM Register
forall {a}. a
vectorsNeedLlvm
      MO_VF_Insert {} -> NatM Register
forall {a}. a
vectorsNeedLlvm

      MachOp
_ -> String -> NatM Register
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.getRegister: no match"
  where
    vectorsNeedLlvm :: a
vectorsNeedLlvm =
      String -> a
forall a. HasCallStack => String -> a
sorry String
"SIMD operations on PowerPC currently require the LLVM backend"

getRegister' NCGConfig
_ Platform
_ (CmmLit (CmmInt Integer
i Width
rep))
  | Just Imm
imm <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
rep Bool
True Integer
i
  = let
        code :: Reg -> OrdList Instr
code Reg
dst = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Reg -> Imm -> Instr
LI Reg
dst Imm
imm)
    in
        Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
rep) Reg -> OrdList Instr
code)

getRegister' NCGConfig
config Platform
_ (CmmLit (CmmFloat Rational
f Width
frep)) = do
    lbl <- NatM CLabel
getNewLabelNat
    dynRef <- cmmMakeDynamicReference config DataReference lbl
    Amode addr addr_code <- getAmode D dynRef
    let format = Width -> Format
floatFormat Width
frep
        code Reg
dst =
            Section -> RawCmmStatics -> Instr
LDATA (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl)
                  (CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl [CmmLit -> CmmStatic
CmmStaticLit (Rational -> Width -> CmmLit
CmmFloat Rational
f Width
frep)])
            Instr -> OrdList Instr -> OrdList Instr
forall a. a -> OrdList a -> OrdList a
`consOL` (OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
format Reg
dst AddrMode
addr)
    return (Any format code)

getRegister' NCGConfig
config Platform
platform (CmmLit CmmLit
lit)
  | Platform -> Bool
target32Bit Platform
platform
  = let rep :: CmmType
rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
platform CmmLit
lit
        imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
        code :: Reg -> OrdList Instr
code Reg
dst = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
              Reg -> Imm -> Instr
LIS Reg
dst (Imm -> Imm
HA Imm
imm),
              Reg -> Reg -> RI -> Instr
ADD Reg
dst Reg
dst (Imm -> RI
RIImm (Imm -> Imm
LO Imm
imm))
          ]
    in Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (CmmType -> Format
cmmTypeFormat CmmType
rep) Reg -> OrdList Instr
code)
  | Bool
otherwise
  = do lbl <- NatM CLabel
getNewLabelNat
       dynRef <- cmmMakeDynamicReference config DataReference lbl
       Amode addr addr_code <- getAmode D dynRef
       let rep = Platform -> CmmLit -> CmmType
cmmLitType Platform
platform CmmLit
lit
           format = CmmType -> Format
cmmTypeFormat CmmType
rep
           code Reg
dst =
            Section -> RawCmmStatics -> Instr
LDATA (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) (CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl [CmmLit -> CmmStatic
CmmStaticLit CmmLit
lit])
            Instr -> OrdList Instr -> OrdList Instr
forall a. a -> OrdList a -> OrdList a
`consOL` (OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
format Reg
dst AddrMode
addr)
       return (Any format code)

getRegister' NCGConfig
_ Platform
platform CmmExpr
other = String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister(ppc)" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
other)

    -- extend?Rep: wrap integer expression of type `from`
    -- in a conversion to `to`
extendSExpr :: Width -> Width -> CmmExpr -> CmmExpr
extendSExpr :: Width -> Width -> CmmExpr -> CmmExpr
extendSExpr Width
from Width
to CmmExpr
x = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_SS_Conv Width
from Width
to) [CmmExpr
x]

extendUExpr :: Width -> Width -> CmmExpr -> CmmExpr
extendUExpr :: Width -> Width -> CmmExpr -> CmmExpr
extendUExpr Width
from Width
to CmmExpr
x = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv Width
from Width
to) [CmmExpr
x]

-- -----------------------------------------------------------------------------
--  The 'Amode' type: Memory addressing modes passed up the tree.

data Amode
        = Amode AddrMode InstrBlock

{-
Now, given a tree (the argument to a CmmLoad) that references memory,
produce a suitable addressing mode.

A Rule of the Game (tm) for Amodes: use of the addr bit must
immediately follow use of the code part, since the code part puts
values in registers which the addr then refers to.  So you can't put
anything in between, lest it overwrite some of those registers.  If
you need to do some other computation between the code part and use of
the addr bit, first store the effective address from the amode in a
temporary, then do the other computation, and then use the temporary:

    code
    LEA amode, tmp
    ... other computation ...
    ... (tmp) ...
-}

{- Note [Power instruction format]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In some instructions the 16 bit offset must be a multiple of 4, i.e.
the two least significant bits must be zero. The "Power ISA" specification
calls these instruction formats "DS-FORM" and the instructions with
arbitrary 16 bit offsets are "D-FORM".

The Power ISA specification document can be obtained from www.power.org.
-}
data InstrForm = D | DS

getAmode :: InstrForm -> CmmExpr -> NatM Amode
getAmode :: InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
inf tree :: CmmExpr
tree@(CmmRegOff CmmReg
_ Int
_)
  = InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
inf (CmmExpr -> CmmExpr
mangleIndexTree CmmExpr
tree)

getAmode InstrForm
_ (CmmMachOp (MO_Sub Width
W32) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
_)])
  | Just Imm
off <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W32 Bool
True (-Integer
i)
  = do
        (reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
        return (Amode (AddrRegImm reg off) code)


getAmode InstrForm
_ (CmmMachOp (MO_Add Width
W32) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
_)])
  | Just Imm
off <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W32 Bool
True Integer
i
  = do
        (reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
        return (Amode (AddrRegImm reg off) code)

getAmode InstrForm
D (CmmMachOp (MO_Sub Width
W64) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
_)])
  | Just Imm
off <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W64 Bool
True (-Integer
i)
  = do
        (reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
        return (Amode (AddrRegImm reg off) code)


getAmode InstrForm
D (CmmMachOp (MO_Add Width
W64) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
_)])
  | Just Imm
off <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W64 Bool
True Integer
i
  = do
        (reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
        return (Amode (AddrRegImm reg off) code)

getAmode InstrForm
DS (CmmMachOp (MO_Sub Width
W64) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
_)])
  | Just Imm
off <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W64 Bool
True (-Integer
i)
  = do
        (reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
        (reg', off', code')  <-
                     if i `mod` 4 == 0
                      then return (reg, off, code)
                      else do
                           tmp <- getNewRegNat II64
                           return (tmp, ImmInt 0,
                                  code `snocOL` ADD tmp reg (RIImm off))
        return (Amode (AddrRegImm reg' off') code')

getAmode InstrForm
DS (CmmMachOp (MO_Add Width
W64) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
_)])
  | Just Imm
off <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W64 Bool
True Integer
i
  = do
        (reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
        (reg', off', code')  <-
                     if i `mod` 4 == 0
                      then return (reg, off, code)
                      else do
                           tmp <- getNewRegNat II64
                           return (tmp, ImmInt 0,
                                  code `snocOL` ADD tmp reg (RIImm off))
        return (Amode (AddrRegImm reg' off') code')

   -- optimize addition with 32-bit immediate
   -- (needed for PIC)
getAmode InstrForm
_ (CmmMachOp (MO_Add Width
W32) [CmmExpr
x, CmmLit CmmLit
lit])
  = do
        platform <- NatM Platform
getPlatform
        (src, srcCode) <- getSomeReg x
        let imm = CmmLit -> Imm
litToImm CmmLit
lit
        case () of
            ()
_ | OS
OSAIX <- Platform -> OS
platformOS Platform
platform
              , CmmLit -> Bool
isCmmLabelType CmmLit
lit ->
                    -- HA16/LO16 relocations on labels not supported on AIX
                    Amode -> NatM Amode
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
src Imm
imm) OrdList Instr
srcCode)
              | Bool
otherwise -> do
                    tmp <- Format -> NatM Reg
getNewRegNat Format
II32
                    let code = OrdList Instr
srcCode OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Imm -> Instr
ADDIS Reg
tmp Reg
src (Imm -> Imm
HA Imm
imm)
                    return (Amode (AddrRegImm tmp (LO imm)) code)
  where
      isCmmLabelType :: CmmLit -> Bool
isCmmLabelType (CmmLabel {})        = Bool
True
      isCmmLabelType (CmmLabelOff {})     = Bool
True
      isCmmLabelType (CmmLabelDiffOff {}) = Bool
True
      isCmmLabelType CmmLit
_                    = Bool
False

getAmode InstrForm
_ (CmmLit CmmLit
lit)
  = do
        platform <- NatM Platform
getPlatform
        case platformArch platform of
             Arch
ArchPPC -> do
                 tmp <- Format -> NatM Reg
getNewRegNat Format
II32
                 let imm = CmmLit -> Imm
litToImm CmmLit
lit
                     code = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Reg -> Imm -> Instr
LIS Reg
tmp (Imm -> Imm
HA Imm
imm))
                 return (Amode (AddrRegImm tmp (LO imm)) code)
             Arch
_        -> do -- TODO: Load from TOC,
                            -- see getRegister' _ (CmmLit lit)
                 tmp <- Format -> NatM Reg
getNewRegNat Format
II64
                 let imm = CmmLit -> Imm
litToImm CmmLit
lit
                     code =  [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                          Reg -> Imm -> Instr
LIS Reg
tmp (Imm -> Imm
HIGHESTA Imm
imm),
                          Reg -> Reg -> RI -> Instr
OR Reg
tmp Reg
tmp (Imm -> RI
RIImm (Imm -> Imm
HIGHERA Imm
imm)),
                          Format -> Reg -> Reg -> RI -> Instr
SL  Format
II64 Reg
tmp Reg
tmp (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
32)),
                          Reg -> Reg -> Imm -> Instr
ORIS Reg
tmp Reg
tmp (Imm -> Imm
HA Imm
imm)
                          ]
                 return (Amode (AddrRegImm tmp (LO imm)) code)

getAmode InstrForm
_ (CmmMachOp (MO_Add Width
W32) [CmmExpr
x, CmmExpr
y])
  = do
        (regX, codeX) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
        (regY, codeY) <- getSomeReg y
        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))

getAmode InstrForm
_ (CmmMachOp (MO_Add Width
W64) [CmmExpr
x, CmmExpr
y])
  = do
        (regX, codeX) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
        (regY, codeY) <- getSomeReg y
        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))

getAmode InstrForm
_ CmmExpr
other
  = do
        (reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
other
        let
            off  = Int -> Imm
ImmInt Int
0
        return (Amode (AddrRegImm reg off) code)


--  The 'CondCode' type:  Condition codes passed up the tree.
data CondCode
        = CondCode Bool Cond InstrBlock

-- Set up a condition code for a conditional branch.

getCondCode :: CmmExpr -> NatM CondCode

-- almost the same as everywhere else - but we need to
-- extend small integers to 32 bit or 64 bit first

getCondCode :: CmmExpr -> NatM CondCode
getCondCode (CmmMachOp MachOp
mop [CmmExpr
x, CmmExpr
y])
  = case MachOp
mop of
      MO_F_Eq Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
EQQ CmmExpr
x CmmExpr
y
      MO_F_Ne Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
NE  CmmExpr
x CmmExpr
y
      MO_F_Gt Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
GTT CmmExpr
x CmmExpr
y
      MO_F_Ge Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
GE  CmmExpr
x CmmExpr
y
      MO_F_Lt Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
LTT CmmExpr
x CmmExpr
y
      MO_F_Le Width
W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
LE  CmmExpr
x CmmExpr
y

      MO_F_Eq Width
W64 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
EQQ CmmExpr
x CmmExpr
y
      MO_F_Ne Width
W64 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
NE  CmmExpr
x CmmExpr
y
      MO_F_Gt Width
W64 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
GTT CmmExpr
x CmmExpr
y
      MO_F_Ge Width
W64 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
GE  CmmExpr
x CmmExpr
y
      MO_F_Lt Width
W64 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
LTT CmmExpr
x CmmExpr
y
      MO_F_Le Width
W64 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
LE  CmmExpr
x CmmExpr
y

      MO_Eq Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
EQQ Width
rep CmmExpr
x CmmExpr
y
      MO_Ne Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
NE  Width
rep CmmExpr
x CmmExpr
y

      MO_S_Gt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
GTT Width
rep CmmExpr
x CmmExpr
y
      MO_S_Ge Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
GE  Width
rep CmmExpr
x CmmExpr
y
      MO_S_Lt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
LTT Width
rep CmmExpr
x CmmExpr
y
      MO_S_Le Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
LE  Width
rep CmmExpr
x CmmExpr
y

      MO_U_Gt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
GU  Width
rep CmmExpr
x CmmExpr
y
      MO_U_Ge Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
GEU Width
rep CmmExpr
x CmmExpr
y
      MO_U_Lt Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
LU  Width
rep CmmExpr
x CmmExpr
y
      MO_U_Le Width
rep -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
LEU Width
rep CmmExpr
x CmmExpr
y

      MachOp
_ -> String -> SDoc -> NatM CondCode
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getCondCode(powerpc)" (MachOp -> SDoc
pprMachOp MachOp
mop)

getCondCode CmmExpr
_ = String -> NatM CondCode
forall a. HasCallStack => String -> a
panic String
"getCondCode(2)(powerpc)"


-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be
-- passed back up the tree.

condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
cond Width
width CmmExpr
x CmmExpr
y = do
  platform <- NatM Platform
getPlatform
  condIntCode' (target32Bit platform) cond width x y

condIntCode' :: Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode

-- simple code for 64-bit on 32-bit platforms
condIntCode' :: Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode' Bool
True Cond
cond Width
W64 CmmExpr
x CmmExpr
y
  | Cond -> Bool
condUnsigned Cond
cond
  = do
      RegCode64 code_x x_hi x_lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
      RegCode64 code_y y_hi y_lo <- iselExpr64 y
      end_lbl <- getBlockIdNat
      let code = OrdList Instr
code_x OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                 [ Format -> Reg -> RI -> Instr
CMPL Format
II32 Reg
x_hi (Reg -> RI
RIReg Reg
y_hi)
                 , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
end_lbl Maybe Bool
forall a. Maybe a
Nothing
                 , Format -> Reg -> RI -> Instr
CMPL Format
II32 Reg
x_lo (Reg -> RI
RIReg Reg
y_lo)
                 , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
end_lbl Maybe Bool
forall a. Maybe a
Nothing

                 , BlockId -> Instr
NEWBLOCK BlockId
end_lbl
                 ]
      return (CondCode False cond code)
  | Bool
otherwise
  = do
      RegCode64 code_x x_hi x_lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
      RegCode64 code_y y_hi y_lo <- iselExpr64 y
      end_lbl <- getBlockIdNat
      cmp_lo  <- getBlockIdNat
      let code = OrdList Instr
code_x OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                 [ Format -> Reg -> RI -> Instr
CMP Format
II32 Reg
x_hi (Reg -> RI
RIReg Reg
y_hi)
                 , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
end_lbl Maybe Bool
forall a. Maybe a
Nothing
                 , Format -> Reg -> RI -> Instr
CMP Format
II32 Reg
x_hi (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
0))
                 , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
LE BlockId
cmp_lo Maybe Bool
forall a. Maybe a
Nothing
                 , Format -> Reg -> RI -> Instr
CMPL Format
II32 Reg
x_lo (Reg -> RI
RIReg Reg
y_lo)
                 , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
end_lbl Maybe Bool
forall a. Maybe a
Nothing
                 , BlockId -> Instr
NEWBLOCK BlockId
cmp_lo
                 , Format -> Reg -> RI -> Instr
CMPL Format
II32 Reg
y_lo (Reg -> RI
RIReg Reg
x_lo)
                 , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
end_lbl Maybe Bool
forall a. Maybe a
Nothing

                 , BlockId -> Instr
NEWBLOCK BlockId
end_lbl
                 ]
      return (CondCode False cond code)

-- optimize pointer tag checks. Operation andi. sets condition register
-- so cmpi ..., 0 is redundant.
condIntCode' Bool
_ Cond
cond Width
_ (CmmMachOp (MO_And Width
_) [CmmExpr
x, CmmLit (CmmInt Integer
imm Width
rep)])
                 (CmmLit (CmmInt Integer
0 Width
_))
  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Cond -> Bool
condUnsigned Cond
cond,
    Just Imm
src2 <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
rep Bool
False Integer
imm
  = do
      (src1, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
      let code' = OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> RI -> Instr
AND Reg
r0 Reg
src1 (Imm -> RI
RIImm Imm
src2)
      return (CondCode False cond code')

condIntCode' Bool
_ Cond
cond Width
width CmmExpr
x (CmmLit (CmmInt Integer
y Width
rep))
  | Just Imm
src2 <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
rep (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Cond -> Bool
condUnsigned Cond
cond) Integer
y
  = do
      let op_len :: Width
op_len = Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width
      let extend :: CmmExpr -> CmmExpr
extend = if Cond -> Bool
condUnsigned Cond
cond then Width -> Width -> CmmExpr -> CmmExpr
extendUExpr Width
width Width
op_len
                   else Width -> Width -> CmmExpr -> CmmExpr
extendSExpr Width
width Width
op_len
      (src1, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg (CmmExpr -> CmmExpr
extend CmmExpr
x)
      let format = Width -> Format
intFormat Width
op_len
          code' = OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
            (if Cond -> Bool
condUnsigned Cond
cond then Format -> Reg -> RI -> Instr
CMPL else Format -> Reg -> RI -> Instr
CMP) Format
format Reg
src1 (Imm -> RI
RIImm Imm
src2)
      return (CondCode False cond code')

condIntCode' Bool
_ Cond
cond Width
width CmmExpr
x CmmExpr
y = do
  let op_len :: Width
op_len = Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width
  let extend :: CmmExpr -> CmmExpr
extend = if Cond -> Bool
condUnsigned Cond
cond then Width -> Width -> CmmExpr -> CmmExpr
extendUExpr Width
width Width
op_len
               else Width -> Width -> CmmExpr -> CmmExpr
extendSExpr Width
width Width
op_len
  (src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg (CmmExpr -> CmmExpr
extend CmmExpr
x)
  (src2, code2) <- getSomeReg (extend y)
  let format = Width -> Format
intFormat Width
op_len
      code' = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
        (if Cond -> Bool
condUnsigned Cond
cond then Format -> Reg -> RI -> Instr
CMPL else Format -> Reg -> RI -> Instr
CMP) Format
format Reg
src1 (Reg -> RI
RIReg Reg
src2)
  return (CondCode False cond code')

condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
cond CmmExpr
x CmmExpr
y = do
    (src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
    (src2, code2) <- getSomeReg y
    let
        code'  = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
FCMP Reg
src1 Reg
src2
        code'' = case Cond
cond of -- twiddle CR to handle unordered case
                    Cond
GE -> OrdList Instr
code' OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Int -> Int -> Int -> Instr
CRNOR Int
ltbit Int
eqbit Int
gtbit
                    Cond
LE -> OrdList Instr
code' OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Int -> Int -> Int -> Instr
CRNOR Int
gtbit Int
eqbit Int
ltbit
                    Cond
_ -> OrdList Instr
code'
                 where
                    ltbit :: Int
ltbit = Int
0 ; eqbit :: Int
eqbit = Int
2 ; gtbit :: Int
gtbit = Int
1
    return (CondCode True cond 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
pk CmmExpr
addr CmmExpr
src = do
    (srcReg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
src
    Amode dstAddr addr_code <- case pk of
                                Format
II64 -> InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
DS CmmExpr
addr
                                Format
_    -> InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D  CmmExpr
addr
    return $ code `appOL` addr_code `snocOL` ST pk srcReg dstAddr

-- dst is a reg, but src could be anything
assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_IntCode Format
_ CmmReg
reg CmmExpr
src
    = do
        platform <- NatM Platform
getPlatform
        let dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg
        r <- getRegister src
        return $ case r of
            Any Format
_ Reg -> OrdList Instr
code         -> Reg -> OrdList Instr
code Reg
dst
            Fixed Format
_ Reg
freg OrdList Instr
fcode -> OrdList Instr
fcode OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
MR Reg
dst Reg
freg



-- Easy, isn't it?
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



genJump :: CmmExpr{-the branch target-} -> [RegWithFormat] -> NatM InstrBlock

genJump :: CmmExpr -> [RegWithFormat] -> NatM (OrdList Instr)
genJump (CmmLit (CmmLabel CLabel
lbl)) [RegWithFormat]
regs
  = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ CLabel -> [RegWithFormat] -> Instr
JMP CLabel
lbl [RegWithFormat]
regs)

genJump CmmExpr
tree [RegWithFormat]
gregs
  = do
        platform <- NatM Platform
getPlatform
        genJump' tree (platformToGCP platform) gregs

genJump' :: CmmExpr -> GenCCallPlatform -> [RegWithFormat] -> NatM InstrBlock

genJump' :: CmmExpr
-> GenCCallPlatform -> [RegWithFormat] -> NatM (OrdList Instr)
genJump' CmmExpr
tree (GCP64ELF Int
1) [RegWithFormat]
regs
  = do
        (target,code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
tree
        return (code
               `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 0))
               `snocOL` LD II64 toc (AddrRegImm target (ImmInt 8))
               `snocOL` MTCTR r11
               `snocOL` LD II64 r11 (AddrRegImm target (ImmInt 16))
               `snocOL` BCTR [] Nothing regs)

genJump' CmmExpr
tree (GCP64ELF Int
2) [RegWithFormat]
regs
  = do
        (target,code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
tree
        return (code
               `snocOL` MR r12 target
               `snocOL` MTCTR r12
               `snocOL` BCTR [] Nothing regs)

genJump' CmmExpr
tree GenCCallPlatform
_ [RegWithFormat]
regs
  = do
        (target,code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
tree
        return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing regs)

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


-- -----------------------------------------------------------------------------
--  Conditional jumps

{-
Conditional jumps are always to local labels, so we can use branch
instructions.  We peek at the arguments to decide what kind of
comparison to do.
-}


genCondJump
    :: BlockId      -- the branch target
    -> CmmExpr      -- the condition on which to branch
    -> Maybe Bool
    -> NatM InstrBlock

genCondJump :: BlockId -> CmmExpr -> Maybe Bool -> NatM (OrdList Instr)
genCondJump BlockId
id CmmExpr
bool Maybe Bool
prediction = do
  CondCode _ cond code <- CmmExpr -> NatM CondCode
getCondCode CmmExpr
bool
  return (code `snocOL` BCC cond id prediction)



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

genCCall :: ForeignTarget      -- function to call
         -> [CmmFormal]        -- where to put the result
         -> [CmmActual]        -- arguments (of mixed type)
         -> NatM InstrBlock
genCCall :: ForeignTarget -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
genCCall (PrimTarget CallishMachOp
MO_AcquireFence) [CmmFormal]
_ [CmmExpr]
_
 = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
LWSYNC
genCCall (PrimTarget CallishMachOp
MO_ReleaseFence) [CmmFormal]
_ [CmmExpr]
_
 = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
LWSYNC
genCCall (PrimTarget CallishMachOp
MO_SeqCstFence) [CmmFormal]
_ [CmmExpr]
_
 = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
HWSYNC

genCCall (PrimTarget CallishMachOp
MO_Touch) [CmmFormal]
_ [CmmExpr]
_
 = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
forall a. OrdList a
nilOL

genCCall (PrimTarget (MO_Prefetch_Data Int
_)) [CmmFormal]
_ [CmmExpr]
_
 = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
forall a. OrdList a
nilOL

genCCall (PrimTarget (MO_AtomicRMW Width
width AtomicMachOp
amop)) [CmmFormal
dst] [CmmExpr
addr, CmmExpr
n]
 = do let fmt :: Format
fmt      = Width -> Format
intFormat Width
width
          reg_dst :: Reg
reg_dst  = CmmFormal -> Reg
getLocalRegReg CmmFormal
dst
      (instr, n_code) <- case AtomicMachOp
amop of
            AtomicMachOp
AMO_Add  -> (Reg -> Reg -> RI -> Instr)
-> Bool -> Reg -> NatM (Instr, OrdList Instr)
getSomeRegOrImm Reg -> Reg -> RI -> Instr
ADD Bool
True Reg
reg_dst
            AtomicMachOp
AMO_Sub  -> case CmmExpr
n of
                CmmLit (CmmInt Integer
i Width
_)
                  | Just Imm
imm <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
width Bool
True (-Integer
i)
                   -> (Instr, OrdList Instr) -> NatM (Instr, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Reg -> RI -> Instr
ADD Reg
reg_dst Reg
reg_dst (Imm -> RI
RIImm Imm
imm), OrdList Instr
forall a. OrdList a
nilOL)
                CmmExpr
_
                   -> do
                         (n_reg, n_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
n
                         return  (SUBF reg_dst n_reg reg_dst, n_code)
            AtomicMachOp
AMO_And  -> (Reg -> Reg -> RI -> Instr)
-> Bool -> Reg -> NatM (Instr, OrdList Instr)
getSomeRegOrImm Reg -> Reg -> RI -> Instr
AND Bool
False Reg
reg_dst
            AtomicMachOp
AMO_Nand -> do (n_reg, n_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
n
                           return (NAND reg_dst reg_dst n_reg, n_code)
            AtomicMachOp
AMO_Or   -> (Reg -> Reg -> RI -> Instr)
-> Bool -> Reg -> NatM (Instr, OrdList Instr)
getSomeRegOrImm Reg -> Reg -> RI -> Instr
OR Bool
False Reg
reg_dst
            AtomicMachOp
AMO_Xor  -> (Reg -> Reg -> RI -> Instr)
-> Bool -> Reg -> NatM (Instr, OrdList Instr)
getSomeRegOrImm Reg -> Reg -> RI -> Instr
XOR Bool
False Reg
reg_dst
      Amode addr_reg addr_code <- getAmodeIndex addr
      lbl_retry <- getBlockIdNat
      return $ n_code `appOL` addr_code
        `appOL` toOL [ HWSYNC
                     , BCC ALWAYS lbl_retry Nothing

                     , NEWBLOCK lbl_retry
                     , LDR fmt reg_dst addr_reg
                     , instr
                     , STC fmt reg_dst addr_reg
                     , BCC NE lbl_retry (Just False)
                     , ISYNC
                     ]
         where
           getAmodeIndex :: CmmExpr -> NatM Amode
getAmodeIndex (CmmMachOp (MO_Add Width
_) [CmmExpr
x, CmmExpr
y])
             = do
                 (regX, codeX) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
                 (regY, codeY) <- getSomeReg y
                 return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))
           getAmodeIndex CmmExpr
other
             = do
                 (reg, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
other
                 return (Amode (AddrRegReg r0 reg) code) -- NB: r0 is 0 here!
           getSomeRegOrImm :: (Reg -> Reg -> RI -> Instr)
-> Bool -> Reg -> NatM (Instr, OrdList Instr)
getSomeRegOrImm Reg -> Reg -> RI -> Instr
op Bool
sign Reg
dst
             = case CmmExpr
n of
                 CmmLit (CmmInt Integer
i Width
_) | Just Imm
imm <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
width Bool
sign Integer
i
                    -> (Instr, OrdList Instr) -> NatM (Instr, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Reg -> RI -> Instr
op Reg
dst Reg
dst (Imm -> RI
RIImm Imm
imm), OrdList Instr
forall a. OrdList a
nilOL)
                 CmmExpr
_
                    -> do
                          (n_reg, n_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
n
                          return  (op dst dst (RIReg n_reg), n_code)

genCCall (PrimTarget (MO_AtomicRead Width
width MemoryOrdering
_)) [CmmFormal
dst] [CmmExpr
addr]
 = do let fmt :: Format
fmt      = Width -> Format
intFormat Width
width
          reg_dst :: Reg
reg_dst  = CmmFormal -> Reg
getLocalRegReg CmmFormal
dst
          form :: InstrForm
form     = if Width -> Int
widthInBits Width
width Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
64 then InstrForm
DS else InstrForm
D
      Amode addr_reg addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
form CmmExpr
addr
      lbl_end <- getBlockIdNat
      return $ addr_code `appOL` toOL [ HWSYNC
                                      , LD fmt reg_dst addr_reg
                                      , CMP fmt reg_dst (RIReg reg_dst)
                                      , BCC NE lbl_end (Just False)
                                      , BCC ALWAYS lbl_end Nothing
                            -- See Note [Seemingly useless cmp and bne]
                                      , NEWBLOCK lbl_end
                                      , ISYNC
                                      ]

-- Note [Seemingly useless cmp and bne]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- In Power ISA, Book II, Section 4.4.1, Instruction Synchronize Instruction
-- the second paragraph says that isync may complete before storage accesses
-- "associated" with a preceding instruction have been performed. The cmp
-- operation and the following bne introduce a data and control dependency
-- on the load instruction (See also Power ISA, Book II, Appendix B.2.3, Safe
-- Fetch).
-- This is also what gcc does.


genCCall (PrimTarget (MO_AtomicWrite Width
width MemoryOrdering
_)) [] [CmmExpr
addr, CmmExpr
val] = do
    code <- Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_IntCode (Width -> Format
intFormat Width
width) CmmExpr
addr CmmExpr
val
    return $ unitOL HWSYNC `appOL` code

genCCall (PrimTarget (MO_Cmpxchg Width
width)) [CmmFormal
dst] [CmmExpr
addr, CmmExpr
old, CmmExpr
new]
  | Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32 Bool -> Bool -> Bool
|| Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64
  = do
      (old_reg, old_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
old
      (new_reg, new_code) <- getSomeReg new
      (addr_reg, addr_code) <- getSomeReg addr
      lbl_retry <- getBlockIdNat
      lbl_eq    <- getBlockIdNat
      lbl_end   <- getBlockIdNat
      let reg_dst   = CmmFormal -> Reg
getLocalRegReg CmmFormal
dst
          code      = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                      [ Instr
HWSYNC
                      , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl_retry Maybe Bool
forall a. Maybe a
Nothing
                      , BlockId -> Instr
NEWBLOCK BlockId
lbl_retry
                      , Format -> Reg -> AddrMode -> Instr
LDR Format
format Reg
reg_dst (Reg -> Reg -> AddrMode
AddrRegReg Reg
r0 Reg
addr_reg)
                      , Format -> Reg -> RI -> Instr
CMP Format
format Reg
reg_dst (Reg -> RI
RIReg Reg
old_reg)
                      , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
lbl_end Maybe Bool
forall a. Maybe a
Nothing
                      , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl_eq Maybe Bool
forall a. Maybe a
Nothing
                      , BlockId -> Instr
NEWBLOCK BlockId
lbl_eq
                      , Format -> Reg -> AddrMode -> Instr
STC Format
format Reg
new_reg (Reg -> Reg -> AddrMode
AddrRegReg Reg
r0 Reg
addr_reg)
                      , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
lbl_retry Maybe Bool
forall a. Maybe a
Nothing
                      , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl_end Maybe Bool
forall a. Maybe a
Nothing
                      , BlockId -> Instr
NEWBLOCK BlockId
lbl_end
                      , Instr
ISYNC
                      ]
      return $ addr_code `appOL` new_code `appOL` old_code `appOL` code
  where
    format :: Format
format = Width -> Format
intFormat Width
width


genCCall (PrimTarget (MO_Clz Width
width)) [CmmFormal
dst] [CmmExpr
src]
 = do platform <- NatM Platform
getPlatform
      let reg_dst = CmmFormal -> Reg
getLocalRegReg CmmFormal
dst
      if target32Bit platform && width == W64
        then do
          RegCode64 code vr_hi vr_lo <- iselExpr64 src
          lbl1 <- getBlockIdNat
          lbl2 <- getBlockIdNat
          lbl3 <- getBlockIdNat
          let cntlz = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Reg -> RI -> Instr
CMPL Format
II32 Reg
vr_hi (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
0))
                           , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
lbl2 Maybe Bool
forall a. Maybe a
Nothing
                           , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl1 Maybe Bool
forall a. Maybe a
Nothing

                           , BlockId -> Instr
NEWBLOCK BlockId
lbl1
                           , Format -> Reg -> Reg -> Instr
CNTLZ Format
II32 Reg
reg_dst Reg
vr_lo
                           , Reg -> Reg -> RI -> Instr
ADD Reg
reg_dst Reg
reg_dst (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
32))
                           , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl3 Maybe Bool
forall a. Maybe a
Nothing

                           , BlockId -> Instr
NEWBLOCK BlockId
lbl2
                           , Format -> Reg -> Reg -> Instr
CNTLZ Format
II32 Reg
reg_dst Reg
vr_hi
                           , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl3 Maybe Bool
forall a. Maybe a
Nothing

                           , BlockId -> Instr
NEWBLOCK BlockId
lbl3
                           ]
          return $ code `appOL` cntlz
        else do
          let format = if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 then Format
II64 else Format
II32
          (s_reg, s_code) <- getSomeReg src
          (pre, reg , post) <-
            case width of
              Width
W64 -> (OrdList Instr, Reg, OrdList Instr)
-> NatM (OrdList Instr, Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
forall a. OrdList a
nilOL, Reg
s_reg, OrdList Instr
forall a. OrdList a
nilOL)
              Width
W32 -> (OrdList Instr, Reg, OrdList Instr)
-> NatM (OrdList Instr, Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
forall a. OrdList a
nilOL, Reg
s_reg, OrdList Instr
forall a. OrdList a
nilOL)
              Width
W16 -> do
                reg_tmp <- Format -> NatM Reg
getNewRegNat Format
format
                return
                  ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 65535))
                  , reg_tmp
                  , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-16)))
                  )
              Width
W8  -> do
                reg_tmp <- Format -> NatM Reg
getNewRegNat Format
format
                return
                  ( unitOL $ AND reg_tmp s_reg (RIImm (ImmInt 255))
                  , reg_tmp
                  , unitOL $ ADD reg_dst reg_dst (RIImm (ImmInt (-24)))
                  )
              Width
_   -> String -> NatM (OrdList Instr, Reg, OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCall: Clz wrong format"
          let cntlz = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Format -> Reg -> Reg -> Instr
CNTLZ Format
format Reg
reg_dst Reg
reg)
          return $ s_code `appOL` pre `appOL` cntlz `appOL` post

genCCall (PrimTarget (MO_Ctz Width
width)) [CmmFormal
dst] [CmmExpr
src]
 = do platform <- NatM Platform
getPlatform
      let reg_dst = CmmFormal -> Reg
getLocalRegReg CmmFormal
dst
      if target32Bit platform && width == W64
        then do
          let format = Format
II32
          RegCode64 code vr_hi vr_lo <- iselExpr64 src
          lbl1 <- getBlockIdNat
          lbl2 <- getBlockIdNat
          lbl3 <- getBlockIdNat
          x' <- getNewRegNat format
          x'' <- getNewRegNat format
          r' <- getNewRegNat format
          cnttzlo <- cnttz format reg_dst vr_lo
          let cnttz64 = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Reg -> RI -> Instr
CMPL Format
format Reg
vr_lo (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
0))
                             , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
lbl2 Maybe Bool
forall a. Maybe a
Nothing
                             , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl1 Maybe Bool
forall a. Maybe a
Nothing

                             , BlockId -> Instr
NEWBLOCK BlockId
lbl1
                             , Reg -> Reg -> RI -> Instr
ADD Reg
x' Reg
vr_hi (Imm -> RI
RIImm (Int -> Imm
ImmInt (-Int
1)))
                             , Reg -> Reg -> Reg -> Instr
ANDC Reg
x'' Reg
x' Reg
vr_hi
                             , Format -> Reg -> Reg -> Instr
CNTLZ Format
format Reg
r' Reg
x''
                               -- 32 + (32 - clz(x''))
                             , Reg -> Reg -> RI -> Instr
SUBFC Reg
reg_dst Reg
r' (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
64))
                             , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl3 Maybe Bool
forall a. Maybe a
Nothing

                             , BlockId -> Instr
NEWBLOCK BlockId
lbl2
                             ]
                        OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
cnttzlo OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                        [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl3 Maybe Bool
forall a. Maybe a
Nothing

                             , BlockId -> Instr
NEWBLOCK BlockId
lbl3
                             ]
          return $ code `appOL` cnttz64
        else do
          let format = if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 then Format
II64 else Format
II32
          (s_reg, s_code) <- getSomeReg src
          (reg_ctz, pre_code) <-
            case width of
              Width
W64 -> (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
s_reg, OrdList Instr
forall a. OrdList a
nilOL)
              Width
W32 -> (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
s_reg, OrdList Instr
forall a. OrdList a
nilOL)
              Width
W16 -> do
                reg_tmp <- Format -> NatM Reg
getNewRegNat Format
format
                return (reg_tmp, unitOL $ ORIS reg_tmp s_reg (ImmInt 1))
              Width
W8  -> do
                reg_tmp <- Format -> NatM Reg
getNewRegNat Format
format
                return (reg_tmp, unitOL $ OR reg_tmp s_reg (RIImm (ImmInt 256)))
              Width
_   -> String -> NatM (Reg, OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCall: Ctz wrong format"
          ctz_code <- cnttz format reg_dst reg_ctz
          return $ s_code `appOL` pre_code `appOL` ctz_code
        where
          -- cnttz(x) = sizeof(x) - cntlz(~x & (x - 1))
          -- see Henry S. Warren, Hacker's Delight, p 107
          cnttz :: Format -> Reg -> Reg -> NatM (OrdList Instr)
cnttz Format
format Reg
dst Reg
src = do
            let format_bits :: Int
format_bits = Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Format -> Int
formatInBytes Format
format
            x' <- Format -> NatM Reg
getNewRegNat Format
format
            x'' <- getNewRegNat format
            r' <- getNewRegNat format
            return $ toOL [ ADD x' src (RIImm (ImmInt (-1)))
                          , ANDC x'' x' src
                          , CNTLZ format r' x''
                          , SUBFC dst r' (RIImm (ImmInt (format_bits)))
                          ]

genCCall ForeignTarget
target [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
 = do platform <- NatM Platform
getPlatform
      case target of
        PrimTarget (MO_S_QuotRem  Width
width) -> Bool -> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
divOp1 Bool
True  Width
width
                                                   [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget (MO_U_QuotRem  Width
width) -> Bool -> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
divOp1 Bool
False Width
width
                                                   [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget (MO_U_QuotRem2 Width
width) -> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
divOp2 Width
width [CmmFormal]
dest_regs
                                                   [CmmExpr]
argsAndHints
        PrimTarget (MO_U_Mul2 Width
width) -> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
multOp2 Width
width [CmmFormal]
dest_regs
                                                [CmmExpr]
argsAndHints
        PrimTarget (MO_Add2 Width
_) -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
add2Op [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget (MO_AddWordC Width
_) -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
addcOp [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget (MO_SubWordC Width
_) -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
subcOp [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget (MO_AddIntC Width
width) -> (Reg -> Reg -> Reg -> Instr)
-> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
addSubCOp Reg -> Reg -> Reg -> Instr
ADDO Width
width
                                                   [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget (MO_SubIntC Width
width) -> (Reg -> Reg -> Reg -> Instr)
-> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
addSubCOp Reg -> Reg -> Reg -> Instr
SUBFO Width
width
                                                   [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget CallishMachOp
MO_F64_Fabs -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
fabs [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget CallishMachOp
MO_F32_Fabs -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
fabs [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        ForeignTarget
_ -> do config <- NatM NCGConfig
getConfig
                genCCall' config (platformToGCP platform)
                       target dest_regs argsAndHints
        where divOp1 :: Bool -> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
divOp1 Bool
signed Width
width [CmmFormal
res_q, CmmFormal
res_r] [CmmExpr
arg_x, CmmExpr
arg_y]
                = do let reg_q :: Reg
reg_q = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_q
                         reg_r :: Reg
reg_r = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_r
                     Width
-> Bool -> Reg -> CmmExpr -> CmmExpr -> NatM (Reg -> OrdList Instr)
remainderCode Width
width Bool
signed Reg
reg_q CmmExpr
arg_x CmmExpr
arg_y
                       NatM (Reg -> OrdList Instr) -> NatM Reg -> NatM (OrdList Instr)
forall a b. NatM (a -> b) -> NatM a -> NatM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Reg -> NatM Reg
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Reg
reg_r

              divOp1 Bool
_ Width
_ [CmmFormal]
_ [CmmExpr]
_
                = String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCCall: Wrong number of arguments for divOp1"
              divOp2 :: Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
divOp2 Width
width [CmmFormal
res_q, CmmFormal
res_r]
                                    [CmmExpr
arg_x_high, CmmExpr
arg_x_low, CmmExpr
arg_y]
                = do let reg_q :: Reg
reg_q = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_q
                         reg_r :: Reg
reg_r = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_r
                         fmt :: Format
fmt   = Width -> Format
intFormat Width
width
                         half :: Int
half  = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Format -> Int
formatInBytes Format
fmt)
                     (xh_reg, xh_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
arg_x_high
                     (xl_reg, xl_code) <- getSomeReg arg_x_low
                     (y_reg, y_code) <- getSomeReg arg_y
                     s <- getNewRegNat fmt
                     b <- getNewRegNat fmt
                     v <- getNewRegNat fmt
                     vn1 <- getNewRegNat fmt
                     vn0 <- getNewRegNat fmt
                     un32 <- getNewRegNat fmt
                     tmp  <- getNewRegNat fmt
                     un10 <- getNewRegNat fmt
                     un1 <- getNewRegNat fmt
                     un0 <- getNewRegNat fmt
                     q1 <- getNewRegNat fmt
                     rhat <- getNewRegNat fmt
                     tmp1 <- getNewRegNat fmt
                     q0 <- getNewRegNat fmt
                     un21 <- getNewRegNat fmt
                     again1 <- getBlockIdNat
                     no1 <- getBlockIdNat
                     then1 <- getBlockIdNat
                     endif1 <- getBlockIdNat
                     again2 <- getBlockIdNat
                     no2 <- getBlockIdNat
                     then2 <- getBlockIdNat
                     endif2 <- getBlockIdNat
                     return $ y_code `appOL` xl_code `appOL` xh_code `appOL`
                              -- see Hacker's Delight p 196 Figure 9-3
                              toOL [ -- b = 2 ^ (bits_in_word / 2)
                                     LI b (ImmInt 1)
                                   , SL fmt b b (RIImm (ImmInt half))
                                     -- s = clz(y)
                                   , CNTLZ fmt s y_reg
                                     -- v = y << s
                                   , SL fmt v y_reg (RIReg s)
                                     -- vn1 = upper half of v
                                   , SR fmt vn1 v (RIImm (ImmInt half))
                                     -- vn0 = lower half of v
                                   , CLRLI fmt vn0 v half
                                     -- un32 = (u1 << s)
                                     --      | (u0 >> (bits_in_word - s))
                                   , SL fmt un32 xh_reg (RIReg s)
                                   , SUBFC tmp s
                                        (RIImm (ImmInt (8 * formatInBytes fmt)))
                                   , SR fmt tmp xl_reg (RIReg tmp)
                                   , OR un32 un32 (RIReg tmp)
                                     -- un10 = u0 << s
                                   , SL fmt un10 xl_reg (RIReg s)
                                     -- un1 = upper half of un10
                                   , SR fmt un1 un10 (RIImm (ImmInt half))
                                     -- un0 = lower half of un10
                                   , CLRLI fmt un0 un10 half
                                     -- q1 = un32/vn1
                                   , DIV fmt False q1 un32 vn1
                                     -- rhat = un32 - q1*vn1
                                   , MULL fmt tmp q1 (RIReg vn1)
                                   , SUBF rhat tmp un32
                                   , BCC ALWAYS again1 Nothing

                                   , NEWBLOCK again1
                                     -- if (q1 >= b || q1*vn0 > b*rhat + un1)
                                   , CMPL fmt q1 (RIReg b)
                                   , BCC GEU then1 Nothing
                                   , BCC ALWAYS no1 Nothing

                                   , NEWBLOCK no1
                                   , MULL fmt tmp q1 (RIReg vn0)
                                   , SL fmt tmp1 rhat (RIImm (ImmInt half))
                                   , ADD tmp1 tmp1 (RIReg un1)
                                   , CMPL fmt tmp (RIReg tmp1)
                                   , BCC LEU endif1 Nothing
                                   , BCC ALWAYS then1 Nothing

                                   , NEWBLOCK then1
                                     -- q1 = q1 - 1
                                   , ADD q1 q1 (RIImm (ImmInt (-1)))
                                     -- rhat = rhat + vn1
                                   , ADD rhat rhat (RIReg vn1)
                                     -- if (rhat < b) goto again1
                                   , CMPL fmt rhat (RIReg b)
                                   , BCC LTT again1 Nothing
                                   , BCC ALWAYS endif1 Nothing

                                   , NEWBLOCK endif1
                                     -- un21 = un32*b + un1 - q1*v
                                   , SL fmt un21 un32 (RIImm (ImmInt half))
                                   , ADD un21 un21 (RIReg un1)
                                   , MULL fmt tmp q1 (RIReg v)
                                   , SUBF un21 tmp un21
                                     -- compute second quotient digit
                                     -- q0 = un21/vn1
                                   , DIV fmt False q0 un21 vn1
                                     -- rhat = un21- q0*vn1
                                   , MULL fmt tmp q0 (RIReg vn1)
                                   , SUBF rhat tmp un21
                                   , BCC ALWAYS again2 Nothing

                                   , NEWBLOCK again2
                                     -- if (q0>b || q0*vn0 > b*rhat + un0)
                                   , CMPL fmt q0 (RIReg b)
                                   , BCC GEU then2 Nothing
                                   , BCC ALWAYS no2 Nothing

                                   , NEWBLOCK no2
                                   , MULL fmt tmp q0 (RIReg vn0)
                                   , SL fmt tmp1 rhat (RIImm (ImmInt half))
                                   , ADD tmp1 tmp1 (RIReg un0)
                                   , CMPL fmt tmp (RIReg tmp1)
                                   , BCC LEU endif2 Nothing
                                   , BCC ALWAYS then2 Nothing

                                   , NEWBLOCK then2
                                     -- q0 = q0 - 1
                                   , ADD q0 q0 (RIImm (ImmInt (-1)))
                                     -- rhat = rhat + vn1
                                   , ADD rhat rhat (RIReg vn1)
                                     -- if (rhat<b) goto again2
                                   , CMPL fmt rhat (RIReg b)
                                   , BCC LTT again2 Nothing
                                   , BCC ALWAYS endif2 Nothing

                                   , NEWBLOCK endif2
                                     -- compute remainder
                                     -- r = (un21*b + un0 - q0*v) >> s
                                   , SL fmt reg_r un21 (RIImm (ImmInt half))
                                   , ADD reg_r reg_r (RIReg un0)
                                   , MULL fmt tmp q0 (RIReg v)
                                   , SUBF reg_r tmp reg_r
                                   , SR fmt reg_r reg_r (RIReg s)
                                     -- compute quotient
                                     -- q = q1*b + q0
                                   , SL fmt reg_q q1 (RIImm (ImmInt half))
                                   , ADD reg_q reg_q (RIReg q0)
                                   ]
              divOp2 Width
_ [CmmFormal]
_ [CmmExpr]
_
                = String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCCall: Wrong number of arguments for divOp2"
              multOp2 :: Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
multOp2 Width
width [CmmFormal
res_h, CmmFormal
res_l] [CmmExpr
arg_x, CmmExpr
arg_y]
                = do let reg_h :: Reg
reg_h = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_h
                         reg_l :: Reg
reg_l = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_l
                         fmt :: Format
fmt = Width -> Format
intFormat Width
width
                     (x_reg, x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
arg_x
                     (y_reg, y_code) <- getSomeReg arg_y
                     return $ y_code `appOL` x_code
                            `appOL` toOL [ MULL fmt reg_l x_reg (RIReg y_reg)
                                         , MULHU fmt reg_h x_reg y_reg
                                         ]
              multOp2 Width
_ [CmmFormal]
_ [CmmExpr]
_
                = String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCall: Wrong number of arguments for multOp2"
              add2Op :: [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
add2Op [CmmFormal
res_h, CmmFormal
res_l] [CmmExpr
arg_x, CmmExpr
arg_y]
                = do let reg_h :: Reg
reg_h = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_h
                         reg_l :: Reg
reg_l = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_l
                     (x_reg, x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
arg_x
                     (y_reg, y_code) <- getSomeReg arg_y
                     return $ y_code `appOL` x_code
                            `appOL` toOL [ LI reg_h (ImmInt 0)
                                         , ADDC reg_l x_reg y_reg
                                         , ADDZE reg_h reg_h
                                         ]
              add2Op [CmmFormal]
_ [CmmExpr]
_
                = String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCCall: Wrong number of arguments/results for add2"

              addcOp :: [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
addcOp [CmmFormal
res_r, CmmFormal
res_c] [CmmExpr
arg_x, CmmExpr
arg_y]
                = [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
add2Op [CmmFormal
res_c {-hi-}, CmmFormal
res_r {-lo-}] [CmmExpr
arg_x, CmmExpr
arg_y]
              addcOp [CmmFormal]
_ [CmmExpr]
_
                = String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCCall: Wrong number of arguments/results for addc"

              -- PowerPC subfc sets the carry for rT = ~(rA) + rB + 1,
              -- which is 0 for borrow and 1 otherwise. We need 1 and 0
              -- so xor with 1.
              subcOp :: [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
subcOp [CmmFormal
res_r, CmmFormal
res_c] [CmmExpr
arg_x, CmmExpr
arg_y]
                = do let reg_r :: Reg
reg_r = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_r
                         reg_c :: Reg
reg_c = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_c
                     (x_reg, x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
arg_x
                     (y_reg, y_code) <- getSomeReg arg_y
                     return $ y_code `appOL` x_code
                            `appOL` toOL [ LI reg_c (ImmInt 0)
                                         , SUBFC reg_r y_reg (RIReg x_reg)
                                         , ADDZE reg_c reg_c
                                         , XOR reg_c reg_c (RIImm (ImmInt 1))
                                         ]
              subcOp [CmmFormal]
_ [CmmExpr]
_
                = String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCCall: Wrong number of arguments/results for subc"
              addSubCOp :: (Reg -> Reg -> Reg -> Instr)
-> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
addSubCOp Reg -> Reg -> Reg -> Instr
instr Width
width [CmmFormal
res_r, CmmFormal
res_c] [CmmExpr
arg_x, CmmExpr
arg_y]
                = do let reg_r :: Reg
reg_r = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_r
                         reg_c :: Reg
reg_c = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_c
                     (x_reg, x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
arg_x
                     (y_reg, y_code) <- getSomeReg arg_y
                     return $ y_code `appOL` x_code
                            `appOL` toOL [ instr reg_r y_reg x_reg,
                                           -- SUBFO argument order reversed!
                                           MFOV (intFormat width) reg_c
                                         ]
              addSubCOp Reg -> Reg -> Reg -> Instr
_ Width
_ [CmmFormal]
_ [CmmExpr]
_
                = String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCall: Wrong number of arguments/results for addC"
              fabs :: [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
fabs [CmmFormal
res] [CmmExpr
arg]
                = do let res_r :: Reg
res_r = CmmFormal -> Reg
getLocalRegReg CmmFormal
res
                     (arg_reg, arg_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
arg
                     return $ arg_code `snocOL` FABS res_r arg_reg
              fabs [CmmFormal]
_ [CmmExpr]
_
                = String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCall: Wrong number of arguments/results for fabs"

-- TODO: replace 'Int' by an enum such as 'PPC_64ABI'
data GenCCallPlatform = GCP32ELF | GCP64ELF !Int | GCPAIX

platformToGCP :: Platform -> GenCCallPlatform
platformToGCP :: Platform -> GenCCallPlatform
platformToGCP Platform
platform
  = case Platform -> OS
platformOS Platform
platform of
      OS
OSAIX    -> GenCCallPlatform
GCPAIX
      OS
_ -> case Platform -> Arch
platformArch Platform
platform of
             Arch
ArchPPC           -> GenCCallPlatform
GCP32ELF
             ArchPPC_64 PPC_64ABI
ELF_V1 -> Int -> GenCCallPlatform
GCP64ELF Int
1
             ArchPPC_64 PPC_64ABI
ELF_V2 -> Int -> GenCCallPlatform
GCP64ELF Int
2
             Arch
_ -> String -> GenCCallPlatform
forall a. HasCallStack => String -> a
panic String
"platformToGCP: Not PowerPC"


genCCall'
    :: NCGConfig
    -> GenCCallPlatform
    -> ForeignTarget            -- function to call
    -> [CmmFormal]        -- where to put the result
    -> [CmmActual]        -- arguments (of mixed type)
    -> NatM InstrBlock

{-
    PowerPC Linux uses the System V Release 4 Calling Convention
    for PowerPC. It is described in the
    "System V Application Binary Interface PowerPC Processor Supplement".

    PowerPC 64 Linux uses the System V Release 4 Calling Convention for
    64-bit PowerPC. It is specified in
    "64-bit PowerPC ELF Application Binary Interface Supplement 1.9"
    (PPC64 ELF v1.9).

    PowerPC 64 Linux in little endian mode uses the "Power Architecture 64-Bit
    ELF V2 ABI Specification -- OpenPOWER ABI for Linux Supplement"
    (PPC64 ELF v2).

    AIX follows the "PowerOpen ABI: Application Binary Interface Big-Endian
    32-Bit Hardware Implementation"

    All four conventions are similar:
    Parameters may be passed in general-purpose registers starting at r3, in
    floating point registers starting at f1, or on the stack.

    But there are substantial differences:
    * The number of registers used for parameter passing and the exact set of
      nonvolatile registers differs (see MachRegs.hs).
    * On AIX and 64-bit ELF, stack space is always reserved for parameters,
      even if they are passed in registers. The called routine may choose to
      save parameters from registers to the corresponding space on the stack.
    * On AIX and 64-bit ELF, a corresponding amount of GPRs is skipped when
      a floating point parameter is passed in an FPR.
    * SysV insists on either passing I64 arguments on the stack, or in two GPRs,
      starting with an odd-numbered GPR. It may skip a GPR to achieve this.
      AIX just treats an I64 likt two separate I32s (high word first).
    * I64 and FF64 arguments are 8-byte aligned on the stack for SysV, but only
      4-byte aligned like everything else on AIX.
    * The SysV spec claims that FF32 is represented as FF64 on the stack. GCC on
      PowerPC Linux does not agree, so neither do we.

    According to all conventions, the parameter area should be part of the
    caller's stack frame, allocated in the caller's prologue code (large enough
    to hold the parameter lists for all called routines). The NCG already
    uses the stack for register spilling, leaving 64 bytes free at the top.
    If we need a larger parameter area than that, we increase the size
    of the stack frame just before ccalling.
-}


genCCall' :: NCGConfig
-> GenCCallPlatform
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> NatM (OrdList Instr)
genCCall' NCGConfig
config GenCCallPlatform
gcp ForeignTarget
target [CmmFormal]
dest_regs [CmmExpr]
args
  = do
        (finalStack,passArgumentsCode,usedRegs) <- [(CmmExpr, CmmType, ForeignHint)]
-> [Reg]
-> [Reg]
-> Int
-> OrdList Instr
-> [Reg]
-> NatM (Int, OrdList Instr, [Reg])
passArguments
                                                   ([CmmExpr]
-> [CmmType] -> [ForeignHint] -> [(CmmExpr, CmmType, ForeignHint)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [CmmExpr]
args [CmmType]
argReps [ForeignHint]
argHints)
                                                   [Reg]
allArgRegs
                                                   (Platform -> [Reg]
allFPArgRegs Platform
platform)
                                                   Int
initialStackOffset
                                                   OrdList Instr
forall a. OrdList a
nilOL []

        (labelOrExpr, reduceToFF32) <- case target of
            ForeignTarget (CmmLit (CmmLabel CLabel
lbl)) ForeignConvention
_ -> do
                NatM ()
uses_pic_base_implicitly
                (Either CLabel CmmExpr, Bool) -> NatM (Either CLabel CmmExpr, Bool)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CLabel -> Either CLabel CmmExpr
forall a b. a -> Either a b
Left CLabel
lbl, Bool
False)
            ForeignTarget CmmExpr
expr ForeignConvention
_ -> do
                NatM ()
uses_pic_base_implicitly
                (Either CLabel CmmExpr, Bool) -> NatM (Either CLabel CmmExpr, Bool)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmExpr -> Either CLabel CmmExpr
forall a b. b -> Either a b
Right CmmExpr
expr, Bool
False)
            PrimTarget CallishMachOp
mop -> CallishMachOp -> NatM (Either CLabel CmmExpr, Bool)
outOfLineMachOp CallishMachOp
mop

        let codeBefore = Int -> OrdList Instr
move_sp_down Int
finalStack OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
passArgumentsCode
            codeAfter = Int -> OrdList Instr
move_sp_up Int
finalStack OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Bool -> OrdList Instr
moveResult Bool
reduceToFF32

        case labelOrExpr of
            Left CLabel
lbl -> -- the linker does all the work for us
                OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (         OrdList Instr
codeBefore
                        OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` CLabel -> [Reg] -> Instr
BL CLabel
lbl [Reg]
usedRegs
                        OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  OrdList Instr
maybeNOP -- some ABI require a NOP after BL
                        OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  OrdList Instr
codeAfter)
            Right CmmExpr
dyn -> do -- implement call through function pointer
                (dynReg, dynCode) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
dyn
                case gcp of
                     GCP64ELF Int
1      -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( OrdList Instr
dynCode
                       OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  OrdList Instr
codeBefore
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
ST Format
spFormat Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
40))
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II64 Reg
r11 (Reg -> Imm -> AddrMode
AddrRegImm Reg
dynReg (Int -> Imm
ImmInt Int
0))
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II64 Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
dynReg (Int -> Imm
ImmInt Int
8))
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
MTCTR Reg
r11
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II64 Reg
r11 (Reg -> Imm -> AddrMode
AddrRegImm Reg
dynReg (Int -> Imm
ImmInt Int
16))
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` [Reg] -> Instr
BCTRL [Reg]
usedRegs
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
spFormat Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
40))
                       OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  OrdList Instr
codeAfter)
                     GCP64ELF Int
2      -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( OrdList Instr
dynCode
                       OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  OrdList Instr
codeBefore
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
ST Format
spFormat Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
24))
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
MR Reg
r12 Reg
dynReg
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
MTCTR Reg
r12
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` [Reg] -> Instr
BCTRL [Reg]
usedRegs
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
spFormat Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
24))
                       OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  OrdList Instr
codeAfter)
                     GenCCallPlatform
GCPAIX          -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( OrdList Instr
dynCode
                       -- AIX/XCOFF follows the PowerOPEN ABI
                       -- which is quite similar to LinuxPPC64/ELFv1
                       OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  OrdList Instr
codeBefore
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
ST Format
spFormat Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
20))
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
r11 (Reg -> Imm -> AddrMode
AddrRegImm Reg
dynReg (Int -> Imm
ImmInt Int
0))
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
dynReg (Int -> Imm
ImmInt Int
4))
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
MTCTR Reg
r11
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
r11 (Reg -> Imm -> AddrMode
AddrRegImm Reg
dynReg (Int -> Imm
ImmInt Int
8))
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` [Reg] -> Instr
BCTRL [Reg]
usedRegs
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
spFormat Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
20))
                       OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  OrdList Instr
codeAfter)
                     GenCCallPlatform
_               -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return ( OrdList Instr
dynCode
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
MTCTR Reg
dynReg
                       OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  OrdList Instr
codeBefore
                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` [Reg] -> Instr
BCTRL [Reg]
usedRegs
                       OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  OrdList Instr
codeAfter)
    where
        platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config

        uses_pic_base_implicitly :: NatM ()
uses_pic_base_implicitly =
            -- See Note [implicit register in PPC PIC code]
            -- on why we claim to use PIC register here
            Bool -> NatM () -> NatM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NCGConfig -> Bool
ncgPIC NCGConfig
config Bool -> Bool -> Bool
&& Platform -> Bool
target32Bit Platform
platform) (NatM () -> NatM ()) -> NatM () -> NatM ()
forall a b. (a -> b) -> a -> b
$ do
                _ <- Format -> NatM Reg
getPicBaseNat (Format -> NatM Reg) -> Format -> NatM Reg
forall a b. (a -> b) -> a -> b
$ Bool -> Format
archWordFormat Bool
True
                return ()

        initialStackOffset :: Int
initialStackOffset = case GenCCallPlatform
gcp of
                             GenCCallPlatform
GCPAIX     -> Int
24
                             GenCCallPlatform
GCP32ELF   -> Int
8
                             GCP64ELF Int
1 -> Int
48
                             GCP64ELF Int
2 -> Int
32
                             GenCCallPlatform
_ -> String -> Int
forall a. HasCallStack => String -> a
panic String
"genCall': unknown calling convention"
            -- size of linkage area + size of arguments, in bytes
        stackDelta :: Int -> Int
stackDelta Int
finalStack = case GenCCallPlatform
gcp of
                                GenCCallPlatform
GCPAIX ->
                                    Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
16 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
24 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
32 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$
                                    (CmmType -> Int) -> [CmmType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Width -> Int
widthInBytes (Width -> Int) -> (CmmType -> Width) -> CmmType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmType -> Width
typeWidth) [CmmType]
argReps
                                GenCCallPlatform
GCP32ELF -> Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
16 Int
finalStack
                                GCP64ELF Int
1 ->
                                    Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
16 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
48 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
64 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$
                                    (CmmType -> Int) -> [CmmType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
8 (Int -> Int) -> (CmmType -> Int) -> CmmType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Width -> Int
widthInBytes (Width -> Int) -> (CmmType -> Width) -> CmmType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmType -> Width
typeWidth)
                                        [CmmType]
argReps
                                GCP64ELF Int
2 ->
                                    Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
16 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
64 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$
                                    (CmmType -> Int) -> [CmmType] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
8 (Int -> Int) -> (CmmType -> Int) -> CmmType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Width -> Int
widthInBytes (Width -> Int) -> (CmmType -> Width) -> CmmType -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmType -> Width
typeWidth)
                                        [CmmType]
argReps
                                GenCCallPlatform
_ -> String -> Int
forall a. HasCallStack => String -> a
panic String
"genCall': unknown calling conv."

        argReps :: [CmmType]
argReps = (CmmExpr -> CmmType) -> [CmmExpr] -> [CmmType]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform) [CmmExpr]
args
        ([ForeignHint]
_, [ForeignHint]
argHints) = ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints ForeignTarget
target

        roundTo :: a -> a -> a
roundTo a
a a
x | a
x a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 = a
x
                    | Bool
otherwise = a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
a a -> a -> a
forall a. Num a => a -> a -> a
- (a
x a -> a -> a
forall a. Integral a => a -> a -> a
`mod` a
a)

        spFormat :: Format
spFormat = if Platform -> Bool
target32Bit Platform
platform then Format
II32 else Format
II64

        -- TODO: Do not create a new stack frame if delta is too large.
        move_sp_down :: Int -> OrdList Instr
move_sp_down Int
finalStack
               | Int
delta Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Platform -> Int
stackFrameHeaderSize Platform
platform =
                        [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Format -> Reg -> AddrMode -> Instr
STU Format
spFormat Reg
sp (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt (-Int
delta))),
                              Int -> Instr
DELTA (-Int
delta)]
               | Bool
otherwise = OrdList Instr
forall a. OrdList a
nilOL
               where delta :: Int
delta = Int -> Int
stackDelta Int
finalStack
        move_sp_up :: Int -> OrdList Instr
move_sp_up Int
finalStack
               | Int
delta Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Platform -> Int
stackFrameHeaderSize Platform
platform =
                        [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Reg -> Reg -> RI -> Instr
ADD Reg
sp Reg
sp (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
delta)),
                              Int -> Instr
DELTA Int
0]
               | Bool
otherwise = OrdList Instr
forall a. OrdList a
nilOL
               where delta :: Int
delta = Int -> Int
stackDelta Int
finalStack

        -- A NOP instruction is required after a call (bl instruction)
        -- on AIX and 64-Bit Linux.
        -- If the call is to a function with a different TOC (r2) the
        -- link editor replaces the NOP instruction with a load of the TOC
        -- from the stack to restore the TOC.
        maybeNOP :: OrdList Instr
maybeNOP = case GenCCallPlatform
gcp of
           GenCCallPlatform
GCP32ELF        -> OrdList Instr
forall a. OrdList a
nilOL
           -- See Section 3.9.4 of OpenPower ABI
           GenCCallPlatform
GCPAIX          -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
NOP
           -- See Section 3.5.11 of PPC64 ELF v1.9
           GCP64ELF Int
1      -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
NOP
           -- See Section 2.3.6 of PPC64 ELF v2
           GCP64ELF Int
2      -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
NOP
           GenCCallPlatform
_               -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"maybeNOP: Unknown PowerPC 64-bit ABI"

        passArguments :: [(CmmExpr, CmmType, ForeignHint)]
-> [Reg]
-> [Reg]
-> Int
-> OrdList Instr
-> [Reg]
-> NatM (Int, OrdList Instr, [Reg])
passArguments [] [Reg]
_ [Reg]
_ Int
stackOffset OrdList Instr
accumCode [Reg]
accumUsed = (Int, OrdList Instr, [Reg]) -> NatM (Int, OrdList Instr, [Reg])
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
stackOffset, OrdList Instr
accumCode, [Reg]
accumUsed)
        passArguments ((CmmExpr
arg,CmmType
arg_ty,ForeignHint
_):[(CmmExpr, CmmType, ForeignHint)]
args) [Reg]
gprs [Reg]
fprs Int
stackOffset
               OrdList Instr
accumCode [Reg]
accumUsed | CmmType -> Bool
isWord64 CmmType
arg_ty
                                     Bool -> Bool -> Bool
&& Platform -> Bool
target32Bit (NCGConfig -> Platform
ncgPlatform NCGConfig
config) =
            do
                RegCode64 code vr_hi vr_lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
arg

                case gcp of
                    GenCCallPlatform
GCPAIX ->
                        do let storeWord :: Reg -> [Reg] -> Int -> Instr
storeWord Reg
vr (Reg
gpr:[Reg]
_) Int
_ = Reg -> Reg -> Instr
MR Reg
gpr Reg
vr
                               storeWord Reg
vr [] Int
offset
                                   = Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
vr (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
offset))
                           [(CmmExpr, CmmType, ForeignHint)]
-> [Reg]
-> [Reg]
-> Int
-> OrdList Instr
-> [Reg]
-> NatM (Int, OrdList Instr, [Reg])
passArguments [(CmmExpr, CmmType, ForeignHint)]
args
                                         (Int -> [Reg] -> [Reg]
forall a. Int -> [a] -> [a]
drop Int
2 [Reg]
gprs)
                                         [Reg]
fprs
                                         (Int
stackOffsetInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
8)
                                         (OrdList Instr
accumCode 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` Reg -> [Reg] -> Int -> Instr
storeWord Reg
vr_hi [Reg]
gprs Int
stackOffset
                                               OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> [Reg] -> Int -> Instr
storeWord Reg
vr_lo (Int -> [Reg] -> [Reg]
forall a. Int -> [a] -> [a]
drop Int
1 [Reg]
gprs) (Int
stackOffsetInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
4))
                                         ((Int -> [Reg] -> [Reg]
forall a. Int -> [a] -> [a]
take Int
2 [Reg]
gprs) [Reg] -> [Reg] -> [Reg]
forall a. [a] -> [a] -> [a]
++ [Reg]
accumUsed)
                    GenCCallPlatform
GCP32ELF ->
                        do let stackOffset' :: Int
stackOffset' = Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
8 Int
stackOffset
                               stackCode :: OrdList Instr
stackCode = OrdList Instr
accumCode 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` Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
vr_hi (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
stackOffset'))
                                   OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
vr_lo (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt (Int
stackOffset'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
4)))
                               regCode :: Reg -> Reg -> OrdList Instr
regCode Reg
hireg Reg
loreg =
                                   OrdList Instr
accumCode 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` Reg -> Reg -> Instr
MR Reg
hireg Reg
vr_hi
                                       OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
MR Reg
loreg Reg
vr_lo

                           case [Reg]
gprs of
                               Reg
hireg : Reg
loreg : [Reg]
regs | Int -> Bool
forall a. Integral a => a -> Bool
even ([Reg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Reg]
gprs) ->
                                   [(CmmExpr, CmmType, ForeignHint)]
-> [Reg]
-> [Reg]
-> Int
-> OrdList Instr
-> [Reg]
-> NatM (Int, OrdList Instr, [Reg])
passArguments [(CmmExpr, CmmType, ForeignHint)]
args [Reg]
regs [Reg]
fprs Int
stackOffset
                                                 (Reg -> Reg -> OrdList Instr
regCode Reg
hireg Reg
loreg) (Reg
hireg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: Reg
loreg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
accumUsed)
                               Reg
_skipped : Reg
hireg : Reg
loreg : [Reg]
regs ->
                                   [(CmmExpr, CmmType, ForeignHint)]
-> [Reg]
-> [Reg]
-> Int
-> OrdList Instr
-> [Reg]
-> NatM (Int, OrdList Instr, [Reg])
passArguments [(CmmExpr, CmmType, ForeignHint)]
args [Reg]
regs [Reg]
fprs Int
stackOffset
                                                 (Reg -> Reg -> OrdList Instr
regCode Reg
hireg Reg
loreg) (Reg
hireg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: Reg
loreg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: [Reg]
accumUsed)
                               [Reg]
_ -> -- only one or no regs left
                                   [(CmmExpr, CmmType, ForeignHint)]
-> [Reg]
-> [Reg]
-> Int
-> OrdList Instr
-> [Reg]
-> NatM (Int, OrdList Instr, [Reg])
passArguments [(CmmExpr, CmmType, ForeignHint)]
args [] [Reg]
fprs (Int
stackOffset'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
8)
                                                 OrdList Instr
stackCode [Reg]
accumUsed
                    GCP64ELF Int
_ -> String -> NatM (Int, OrdList Instr, [Reg])
forall a. HasCallStack => String -> a
panic String
"passArguments: 32 bit code"

        passArguments ((CmmExpr
arg,CmmType
rep,ForeignHint
hint):[(CmmExpr, CmmType, ForeignHint)]
args) [Reg]
gprs [Reg]
fprs Int
stackOffset OrdList Instr
accumCode [Reg]
accumUsed
            | Reg
reg : [Reg]
_ <- [Reg]
regs = do
                register <- CmmExpr -> NatM Register
getRegister CmmExpr
arg_pro
                let code = case Register
register of
                            Fixed Format
_ Reg
freg OrdList Instr
fcode -> OrdList Instr
fcode OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
MR Reg
reg Reg
freg
                            Any Format
_ Reg -> OrdList Instr
acode -> Reg -> OrdList Instr
acode Reg
reg
                    stackOffsetRes = case GenCCallPlatform
gcp of
                                     -- The PowerOpen ABI requires that we
                                     -- reserve stack slots for register
                                     -- parameters
                                     GenCCallPlatform
GCPAIX    -> Int
stackOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
stackBytes
                                     -- ... the SysV ABI 32-bit doesn't.
                                     GenCCallPlatform
GCP32ELF -> Int
stackOffset
                                     -- ... but SysV ABI 64-bit does.
                                     GCP64ELF Int
_ -> Int
stackOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
stackBytes
                passArguments args
                              (drop nGprs gprs)
                              (drop nFprs fprs)
                              stackOffsetRes
                              (accumCode `appOL` code)
                              (reg : accumUsed)
            | Bool
otherwise = do
                (vr, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
arg_pro
                passArguments args
                              (drop nGprs gprs)
                              (drop nFprs fprs)
                              (stackOffset' + stackBytes)
                              (accumCode `appOL` code
                                         `snocOL` ST format_pro vr stackSlot)
                              accumUsed
            where
                arg_pro :: CmmExpr
arg_pro
                   | CmmType -> Bool
isBitsType CmmType
rep = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
conv_op (CmmType -> Width
typeWidth CmmType
rep) (Platform -> Width
wordWidth Platform
platform)) [CmmExpr
arg]
                   | Bool
otherwise      = CmmExpr
arg
                format_pro :: Format
format_pro
                   | CmmType -> Bool
isBitsType CmmType
rep = Width -> Format
intFormat (Platform -> Width
wordWidth Platform
platform)
                   | Bool
otherwise      = CmmType -> Format
cmmTypeFormat CmmType
rep
                conv_op :: Width -> Width -> MachOp
conv_op = case ForeignHint
hint of
                            ForeignHint
SignedHint -> Width -> Width -> MachOp
MO_SS_Conv
                            ForeignHint
_          -> Width -> Width -> MachOp
MO_UU_Conv

                stackOffset' :: Int
stackOffset' = case GenCCallPlatform
gcp of
                               GenCCallPlatform
GCPAIX ->
                                   -- The 32bit PowerOPEN ABI is happy with
                                   -- 32bit-alignment ...
                                   Int
stackOffset
                               GenCCallPlatform
GCP32ELF
                                   -- ... the SysV ABI requires 8-byte
                                   -- alignment for doubles.
                                | CmmType -> Bool
isFloatType CmmType
rep Bool -> Bool -> Bool
&& CmmType -> Width
typeWidth CmmType
rep Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 ->
                                   Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo Int
8 Int
stackOffset
                                | Bool
otherwise ->
                                   Int
stackOffset
                               GCP64ELF Int
_ ->
                                   -- Everything on the stack is mapped to
                                   -- 8-byte aligned doublewords
                                   Int
stackOffset
                stackOffset'' :: Int
stackOffset''
                     | CmmType -> Bool
isFloatType CmmType
rep Bool -> Bool -> Bool
&& CmmType -> Width
typeWidth CmmType
rep Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32 =
                         case GenCCallPlatform
gcp of
                         -- The ELF v1 ABI Section 3.2.3 requires:
                         -- "Single precision floating point values
                         -- are mapped to the second word in a single
                         -- doubleword"
                         GCP64ELF Int
1 -> Int
stackOffset' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4
                         -- ELF v2 ABI Revision 1.5 Section 2.2.3.3. requires
                         -- a single-precision floating-point value
                         -- to be mapped to the least-significant
                         -- word in a single doubleword.
                         GCP64ELF Int
2 -> case Platform -> ByteOrder
platformByteOrder Platform
platform of
                                       ByteOrder
BigEndian    -> Int
stackOffset' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4
                                       ByteOrder
LittleEndian -> Int
stackOffset'
                         GenCCallPlatform
_          -> Int
stackOffset'
                     | Bool
otherwise = Int
stackOffset'

                stackSlot :: AddrMode
stackSlot = Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
stackOffset'')
                (Int
nGprs, Int
nFprs, Int
stackBytes, [Reg]
regs)
                    = case GenCCallPlatform
gcp of
                      GenCCallPlatform
GCPAIX ->
                          case CmmType -> Format
cmmTypeFormat CmmType
rep of
                          Format
II8  -> (Int
1, Int
0, Int
4, [Reg]
gprs)
                          Format
II16 -> (Int
1, Int
0, Int
4, [Reg]
gprs)
                          Format
II32 -> (Int
1, Int
0, Int
4, [Reg]
gprs)
                          -- The PowerOpen ABI requires that we skip a
                          -- corresponding number of GPRs when we use
                          -- the FPRs.
                          --
                          -- E.g. for a `double` two GPRs are skipped,
                          -- whereas for a `float` one GPR is skipped
                          -- when parameters are assigned to
                          -- registers.
                          --
                          -- The PowerOpen ABI specification can be found at
                          -- ftp://www.sourceware.org/pub/binutils/ppc-docs/ppc-poweropen/
                          Format
FF32 -> (Int
1, Int
1, Int
4, [Reg]
fprs)
                          Format
FF64 -> (Int
2, Int
1, Int
8, [Reg]
fprs)
                          Format
II64 -> String -> (Int, Int, Int, [Reg])
forall a. HasCallStack => String -> a
panic String
"genCCall' passArguments II64"
                          VecFormat {}
                               -> String -> (Int, Int, Int, [Reg])
forall a. HasCallStack => String -> a
panic String
"genCCall' passArguments vector format"

                      GenCCallPlatform
GCP32ELF ->
                          case CmmType -> Format
cmmTypeFormat CmmType
rep of
                          Format
II8  -> (Int
1, Int
0, Int
4, [Reg]
gprs)
                          Format
II16 -> (Int
1, Int
0, Int
4, [Reg]
gprs)
                          Format
II32 -> (Int
1, Int
0, Int
4, [Reg]
gprs)
                          -- ... the SysV ABI doesn't.
                          Format
FF32 -> (Int
0, Int
1, Int
4, [Reg]
fprs)
                          Format
FF64 -> (Int
0, Int
1, Int
8, [Reg]
fprs)
                          Format
II64 -> String -> (Int, Int, Int, [Reg])
forall a. HasCallStack => String -> a
panic String
"genCCall' passArguments II64"
                          VecFormat {}
                               -> String -> (Int, Int, Int, [Reg])
forall a. HasCallStack => String -> a
panic String
"genCCall' passArguments vector format"

                      GCP64ELF Int
_ ->
                          case CmmType -> Format
cmmTypeFormat CmmType
rep of
                          Format
II8  -> (Int
1, Int
0, Int
8, [Reg]
gprs)
                          Format
II16 -> (Int
1, Int
0, Int
8, [Reg]
gprs)
                          Format
II32 -> (Int
1, Int
0, Int
8, [Reg]
gprs)
                          Format
II64 -> (Int
1, Int
0, Int
8, [Reg]
gprs)
                          -- The ELFv1 ABI requires that we skip a
                          -- corresponding number of GPRs when we use
                          -- the FPRs.
                          Format
FF32 -> (Int
1, Int
1, Int
8, [Reg]
fprs)
                          Format
FF64 -> (Int
1, Int
1, Int
8, [Reg]
fprs)
                          VecFormat {}
                               -> String -> (Int, Int, Int, [Reg])
forall a. HasCallStack => String -> a
panic String
"genCCall' passArguments vector format"

        moveResult :: Bool -> OrdList Instr
moveResult Bool
reduceToFF32 =
            case [CmmFormal]
dest_regs of
                [] -> OrdList Instr
forall a. OrdList a
nilOL
                [CmmFormal
dest]
                    | Bool
reduceToFF32 Bool -> Bool -> Bool
&& CmmType -> Bool
isFloat32 CmmType
rep   -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Reg -> Reg -> Instr
FRSP Reg
r_dest Reg
f1)
                    | CmmType -> Bool
isFloat32 CmmType
rep Bool -> Bool -> Bool
|| CmmType -> Bool
isFloat64 CmmType
rep -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Reg -> Reg -> Instr
MR Reg
r_dest Reg
f1)
                    | CmmType -> Bool
isWord64 CmmType
rep Bool -> Bool -> Bool
&& Platform -> Bool
target32Bit Platform
platform
                       -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [Reg -> Reg -> Instr
MR (Reg -> Reg
getHiVRegFromLo Reg
r_dest) Reg
r3,
                                Reg -> Reg -> Instr
MR Reg
r_dest Reg
r4]
                    | Bool
otherwise -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Reg -> Reg -> Instr
MR Reg
r_dest Reg
r3)
                    where rep :: CmmType
rep = CmmReg -> CmmType
cmmRegType (CmmFormal -> CmmReg
CmmLocal CmmFormal
dest)
                          r_dest :: Reg
r_dest = CmmFormal -> Reg
getLocalRegReg CmmFormal
dest
                [CmmFormal]
_ -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"genCCall' moveResult: Bad dest_regs"

        outOfLineMachOp :: CallishMachOp -> NatM (Either CLabel CmmExpr, Bool)
outOfLineMachOp CallishMachOp
mop =
            do
                mopExpr <- 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 -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
functionName ForeignLabelSource
ForeignLabelInThisPackage FunctionOrData
IsFunction
                let mopLabelOrExpr = case CmmExpr
mopExpr of
                        CmmLit (CmmLabel CLabel
lbl) -> CLabel -> Either CLabel CmmExpr
forall a b. a -> Either a b
Left CLabel
lbl
                        CmmExpr
_ -> CmmExpr -> Either CLabel CmmExpr
forall a b. b -> Either a b
Right CmmExpr
mopExpr
                return (mopLabelOrExpr, reduce)
            where
                (FastString
functionName, Bool
reduce) = case CallishMachOp
mop of
                    CallishMachOp
MO_F32_Exp   -> (String -> FastString
fsLit String
"exp", Bool
True)
                    CallishMachOp
MO_F32_ExpM1 -> (String -> FastString
fsLit String
"expm1", Bool
True)
                    CallishMachOp
MO_F32_Log   -> (String -> FastString
fsLit String
"log", Bool
True)
                    CallishMachOp
MO_F32_Log1P -> (String -> FastString
fsLit String
"log1p", Bool
True)
                    CallishMachOp
MO_F32_Sqrt  -> (String -> FastString
fsLit String
"sqrt", Bool
True)
                    CallishMachOp
MO_F32_Fabs  -> (FastString, Bool)
unsupported

                    CallishMachOp
MO_F32_Sin   -> (String -> FastString
fsLit String
"sin", Bool
True)
                    CallishMachOp
MO_F32_Cos   -> (String -> FastString
fsLit String
"cos", Bool
True)
                    CallishMachOp
MO_F32_Tan   -> (String -> FastString
fsLit String
"tan", Bool
True)

                    CallishMachOp
MO_F32_Asin  -> (String -> FastString
fsLit String
"asin", Bool
True)
                    CallishMachOp
MO_F32_Acos  -> (String -> FastString
fsLit String
"acos", Bool
True)
                    CallishMachOp
MO_F32_Atan  -> (String -> FastString
fsLit String
"atan", Bool
True)

                    CallishMachOp
MO_F32_Sinh  -> (String -> FastString
fsLit String
"sinh", Bool
True)
                    CallishMachOp
MO_F32_Cosh  -> (String -> FastString
fsLit String
"cosh", Bool
True)
                    CallishMachOp
MO_F32_Tanh  -> (String -> FastString
fsLit String
"tanh", Bool
True)
                    CallishMachOp
MO_F32_Pwr   -> (String -> FastString
fsLit String
"pow", Bool
True)

                    CallishMachOp
MO_F32_Asinh -> (String -> FastString
fsLit String
"asinh", Bool
True)
                    CallishMachOp
MO_F32_Acosh -> (String -> FastString
fsLit String
"acosh", Bool
True)
                    CallishMachOp
MO_F32_Atanh -> (String -> FastString
fsLit String
"atanh", Bool
True)

                    CallishMachOp
MO_F64_Exp   -> (String -> FastString
fsLit String
"exp", Bool
False)
                    CallishMachOp
MO_F64_ExpM1 -> (String -> FastString
fsLit String
"expm1", Bool
False)
                    CallishMachOp
MO_F64_Log   -> (String -> FastString
fsLit String
"log", Bool
False)
                    CallishMachOp
MO_F64_Log1P -> (String -> FastString
fsLit String
"log1p", Bool
False)
                    CallishMachOp
MO_F64_Sqrt  -> (String -> FastString
fsLit String
"sqrt", Bool
False)
                    CallishMachOp
MO_F64_Fabs  -> (FastString, Bool)
unsupported

                    CallishMachOp
MO_F64_Sin   -> (String -> FastString
fsLit String
"sin", Bool
False)
                    CallishMachOp
MO_F64_Cos   -> (String -> FastString
fsLit String
"cos", Bool
False)
                    CallishMachOp
MO_F64_Tan   -> (String -> FastString
fsLit String
"tan", Bool
False)

                    CallishMachOp
MO_F64_Asin  -> (String -> FastString
fsLit String
"asin", Bool
False)
                    CallishMachOp
MO_F64_Acos  -> (String -> FastString
fsLit String
"acos", Bool
False)
                    CallishMachOp
MO_F64_Atan  -> (String -> FastString
fsLit String
"atan", Bool
False)

                    CallishMachOp
MO_F64_Sinh  -> (String -> FastString
fsLit String
"sinh", Bool
False)
                    CallishMachOp
MO_F64_Cosh  -> (String -> FastString
fsLit String
"cosh", Bool
False)
                    CallishMachOp
MO_F64_Tanh  -> (String -> FastString
fsLit String
"tanh", Bool
False)
                    CallishMachOp
MO_F64_Pwr   -> (String -> FastString
fsLit String
"pow", Bool
False)

                    CallishMachOp
MO_F64_Asinh -> (String -> FastString
fsLit String
"asinh", Bool
False)
                    CallishMachOp
MO_F64_Acosh -> (String -> FastString
fsLit String
"acosh", Bool
False)
                    CallishMachOp
MO_F64_Atanh -> (String -> FastString
fsLit String
"atanh", Bool
False)

                    CallishMachOp
MO_I64_ToI   -> (String -> FastString
fsLit String
"hs_int64ToInt", Bool
False)
                    CallishMachOp
MO_I64_FromI -> (String -> FastString
fsLit String
"hs_intToInt64", Bool
False)
                    CallishMachOp
MO_W64_ToW   -> (String -> FastString
fsLit String
"hs_word64ToWord", Bool
False)
                    CallishMachOp
MO_W64_FromW -> (String -> FastString
fsLit String
"hs_wordToWord64", Bool
False)

                    CallishMachOp
MO_x64_Neg   -> (String -> FastString
fsLit String
"hs_neg64", Bool
False)
                    CallishMachOp
MO_x64_Add   -> (String -> FastString
fsLit String
"hs_add64", Bool
False)
                    CallishMachOp
MO_x64_Sub   -> (String -> FastString
fsLit String
"hs_sub64", Bool
False)
                    CallishMachOp
MO_x64_Mul   -> (String -> FastString
fsLit String
"hs_mul64", Bool
False)
                    CallishMachOp
MO_I64_Quot  -> (String -> FastString
fsLit String
"hs_quotInt64", Bool
False)
                    CallishMachOp
MO_I64_Rem   -> (String -> FastString
fsLit String
"hs_remInt64", Bool
False)
                    CallishMachOp
MO_W64_Quot  -> (String -> FastString
fsLit String
"hs_quotWord64", Bool
False)
                    CallishMachOp
MO_W64_Rem   -> (String -> FastString
fsLit String
"hs_remWord64", Bool
False)

                    CallishMachOp
MO_x64_And   -> (String -> FastString
fsLit String
"hs_and64", Bool
False)
                    CallishMachOp
MO_x64_Or    -> (String -> FastString
fsLit String
"hs_or64", Bool
False)
                    CallishMachOp
MO_x64_Xor   -> (String -> FastString
fsLit String
"hs_xor64", Bool
False)
                    CallishMachOp
MO_x64_Not   -> (String -> FastString
fsLit String
"hs_not64", Bool
False)
                    CallishMachOp
MO_x64_Shl   -> (String -> FastString
fsLit String
"hs_uncheckedShiftL64", Bool
False)
                    CallishMachOp
MO_I64_Shr   -> (String -> FastString
fsLit String
"hs_uncheckedIShiftRA64", Bool
False)
                    CallishMachOp
MO_W64_Shr   -> (String -> FastString
fsLit String
"hs_uncheckedShiftRL64", Bool
False)

                    CallishMachOp
MO_x64_Eq    -> (String -> FastString
fsLit String
"hs_eq64", Bool
False)
                    CallishMachOp
MO_x64_Ne    -> (String -> FastString
fsLit String
"hs_ne64", Bool
False)
                    CallishMachOp
MO_I64_Ge    -> (String -> FastString
fsLit String
"hs_geInt64", Bool
False)
                    CallishMachOp
MO_I64_Gt    -> (String -> FastString
fsLit String
"hs_gtInt64", Bool
False)
                    CallishMachOp
MO_I64_Le    -> (String -> FastString
fsLit String
"hs_leInt64", Bool
False)
                    CallishMachOp
MO_I64_Lt    -> (String -> FastString
fsLit String
"hs_ltInt64", Bool
False)
                    CallishMachOp
MO_W64_Ge    -> (String -> FastString
fsLit String
"hs_geWord64", Bool
False)
                    CallishMachOp
MO_W64_Gt    -> (String -> FastString
fsLit String
"hs_gtWord64", Bool
False)
                    CallishMachOp
MO_W64_Le    -> (String -> FastString
fsLit String
"hs_leWord64", Bool
False)
                    CallishMachOp
MO_W64_Lt    -> (String -> FastString
fsLit String
"hs_ltWord64", Bool
False)

                    MO_UF_Conv Width
w -> (Width -> FastString
word2FloatLabel Width
w, Bool
False)

                    MO_Memcpy Int
_  -> (String -> FastString
fsLit String
"memcpy", Bool
False)
                    MO_Memset Int
_  -> (String -> FastString
fsLit String
"memset", Bool
False)
                    MO_Memmove Int
_ -> (String -> FastString
fsLit String
"memmove", Bool
False)
                    MO_Memcmp Int
_  -> (String -> FastString
fsLit String
"memcmp", Bool
False)

                    CallishMachOp
MO_SuspendThread -> (String -> FastString
fsLit String
"suspendThread", Bool
False)
                    CallishMachOp
MO_ResumeThread  -> (String -> FastString
fsLit String
"resumeThread", Bool
False)

                    MO_BSwap Width
w   -> (Width -> FastString
bSwapLabel Width
w, Bool
False)
                    MO_BRev Width
w    -> (Width -> FastString
bRevLabel Width
w, Bool
False)
                    MO_PopCnt Width
w  -> (Width -> FastString
popCntLabel Width
w, Bool
False)
                    MO_Pdep Width
w    -> (Width -> FastString
pdepLabel Width
w, Bool
False)
                    MO_Pext Width
w    -> (Width -> FastString
pextLabel Width
w, Bool
False)
                    MO_Clz Width
_     -> (FastString, Bool)
unsupported
                    MO_Ctz Width
_     -> (FastString, Bool)
unsupported
                    MO_AtomicRMW {} -> (FastString, Bool)
unsupported
                    MO_Cmpxchg Width
w -> (Width -> FastString
cmpxchgLabel Width
w, Bool
False)
                    MO_Xchg Width
w    -> (Width -> FastString
xchgLabel Width
w, Bool
False)
                    MO_AtomicRead Width
_ MemoryOrdering
_  -> (FastString, Bool)
unsupported
                    MO_AtomicWrite Width
_ MemoryOrdering
_ -> (FastString, Bool)
unsupported

                    MO_S_Mul2    {}  -> (FastString, Bool)
unsupported
                    MO_S_QuotRem {}  -> (FastString, Bool)
unsupported
                    MO_U_QuotRem {}  -> (FastString, Bool)
unsupported
                    MO_U_QuotRem2 {} -> (FastString, Bool)
unsupported
                    MO_Add2 {}       -> (FastString, Bool)
unsupported
                    MO_AddWordC {}   -> (FastString, Bool)
unsupported
                    MO_SubWordC {}   -> (FastString, Bool)
unsupported
                    MO_AddIntC {}    -> (FastString, Bool)
unsupported
                    MO_SubIntC {}    -> (FastString, Bool)
unsupported
                    MO_U_Mul2 {}     -> (FastString, Bool)
unsupported
                    CallishMachOp
MO_AcquireFence  -> (FastString, Bool)
unsupported
                    CallishMachOp
MO_ReleaseFence  -> (FastString, Bool)
unsupported
                    CallishMachOp
MO_SeqCstFence   -> (FastString, Bool)
unsupported
                    CallishMachOp
MO_Touch         -> (FastString, Bool)
unsupported
                    MO_Prefetch_Data Int
_ -> (FastString, Bool)
unsupported
                unsupported :: (FastString, Bool)
unsupported = String -> (FastString, Bool)
forall a. HasCallStack => String -> a
panic (String
"outOfLineCmmOp: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CallishMachOp -> String
forall a. Show a => a -> String
show CallishMachOp
mop
                                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not supported")

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

genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM (OrdList Instr)
genSwitch NCGConfig
config CmmExpr
expr SwitchTargets
targets
  | OS
OSAIX <- Platform -> OS
platformOS Platform
platform
  = do
        (reg,e_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
indexExpr
        let fmt = Bool -> Format
archWordFormat (Bool -> Format) -> Bool -> Format
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit Platform
platform
            sha = if Platform -> Bool
target32Bit Platform
platform then Int
2 else Int
3
        tmp <- getNewRegNat fmt
        lbl <- getNewLabelNat
        dynRef <- cmmMakeDynamicReference config DataReference lbl
        (tableReg,t_code) <- getSomeReg $ dynRef
        let code = OrdList Instr
e_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
t_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                            Format -> Reg -> Reg -> RI -> Instr
SL Format
fmt Reg
tmp Reg
reg (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
sha)),
                            Format -> Reg -> AddrMode -> Instr
LD Format
fmt Reg
tmp (Reg -> Reg -> AddrMode
AddrRegReg Reg
tableReg Reg
tmp),
                            Reg -> Instr
MTCTR Reg
tmp,
                            [Maybe BlockId] -> Maybe CLabel -> [RegWithFormat] -> Instr
BCTR [Maybe BlockId]
ids (CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
lbl) []
                    ]
        return code

  | (NCGConfig -> Bool
ncgPIC NCGConfig
config) Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit Platform
platform)
  = do
        (reg,e_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
indexExpr
        let fmt = Bool -> Format
archWordFormat (Bool -> Format) -> Bool -> Format
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit Platform
platform
            sha = if Platform -> Bool
target32Bit Platform
platform then Int
2 else Int
3
        tmp <- getNewRegNat fmt
        lbl <- getNewLabelNat
        dynRef <- cmmMakeDynamicReference config DataReference lbl
        (tableReg,t_code) <- getSomeReg $ dynRef
        let code = OrdList Instr
e_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
t_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                            Format -> Reg -> Reg -> RI -> Instr
SL Format
fmt Reg
tmp Reg
reg (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
sha)),
                            Format -> Reg -> AddrMode -> Instr
LD Format
fmt Reg
tmp (Reg -> Reg -> AddrMode
AddrRegReg Reg
tableReg Reg
tmp),
                            Reg -> Reg -> RI -> Instr
ADD Reg
tmp Reg
tmp (Reg -> RI
RIReg Reg
tableReg),
                            Reg -> Instr
MTCTR Reg
tmp,
                            [Maybe BlockId] -> Maybe CLabel -> [RegWithFormat] -> Instr
BCTR [Maybe BlockId]
ids (CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
lbl) []
                    ]
        return code
  | Bool
otherwise
  = do
        (reg,e_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
indexExpr
        let fmt = Bool -> Format
archWordFormat (Bool -> Format) -> Bool -> Format
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit Platform
platform
            sha = if Platform -> Bool
target32Bit Platform
platform then Int
2 else Int
3
        tmp <- getNewRegNat fmt
        lbl <- getNewLabelNat
        let code = OrdList Instr
e_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 [
                            Format -> Reg -> Reg -> RI -> Instr
SL Format
fmt Reg
tmp Reg
reg (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
sha)),
                            Reg -> Reg -> Imm -> Instr
ADDIS Reg
tmp Reg
tmp (Imm -> Imm
HA (CLabel -> Imm
ImmCLbl CLabel
lbl)),
                            Format -> Reg -> AddrMode -> Instr
LD Format
fmt Reg
tmp (Reg -> Imm -> AddrMode
AddrRegImm Reg
tmp (Imm -> Imm
LO (CLabel -> Imm
ImmCLbl CLabel
lbl))),
                            Reg -> Instr
MTCTR Reg
tmp,
                            [Maybe BlockId] -> Maybe CLabel -> [RegWithFormat] -> Instr
BCTR [Maybe BlockId]
ids (CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
lbl) []
                    ]
        return code
  where
    -- See Note [Sub-word subtlety during jump-table indexing] in
    -- GHC.CmmToAsm.X86.CodeGen for why we must first offset, then widen.
    indexExpr0 :: CmmExpr
indexExpr0 = Platform -> CmmExpr -> Int -> CmmExpr
cmmOffset Platform
platform CmmExpr
expr Int
offset
    -- We widen to a native-width register to sanitize the high bits
    indexExpr :: CmmExpr
indexExpr = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp
      (Width -> Width -> MachOp
MO_UU_Conv Width
expr_w (Platform -> Width
platformWordWidth Platform
platform))
      [CmmExpr
indexExpr0]
    expr_w :: Width
expr_w = Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
expr
    (Int
offset, [Maybe BlockId]
ids) = SwitchTargets -> (Int, [Maybe BlockId])
switchTargetsToTable SwitchTargets
targets
    platform :: Platform
platform      = NCGConfig -> Platform
ncgPlatform NCGConfig
config

generateJumpTableForInstr :: NCGConfig -> Instr
                          -> Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl RawCmmStatics Instr)
generateJumpTableForInstr NCGConfig
config (BCTR [Maybe BlockId]
ids (Just CLabel
lbl) [RegWithFormat]
_) =
    let jumpTable :: [CmmStatic]
jumpTable
            | (NCGConfig -> Bool
ncgPIC NCGConfig
config) Bool -> Bool -> Bool
|| (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit (Platform -> Bool) -> Platform -> Bool
forall a b. (a -> b) -> a -> b
$ NCGConfig -> Platform
ncgPlatform NCGConfig
config)
            = (Maybe BlockId -> CmmStatic) -> [Maybe BlockId] -> [CmmStatic]
forall a b. (a -> b) -> [a] -> [b]
map Maybe BlockId -> CmmStatic
jumpTableEntryRel [Maybe BlockId]
ids
            | Bool
otherwise = (Maybe BlockId -> CmmStatic) -> [Maybe BlockId] -> [CmmStatic]
forall a b. (a -> b) -> [a] -> [b]
map (NCGConfig -> Maybe BlockId -> CmmStatic
jumpTableEntry NCGConfig
config) [Maybe BlockId]
ids
                where jumpTableEntryRel :: Maybe BlockId -> CmmStatic
jumpTableEntryRel Maybe BlockId
Nothing
                        = CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
0 (NCGConfig -> Width
ncgWordWidth NCGConfig
config))
                      jumpTableEntryRel (Just BlockId
blockid)
                        = CmmLit -> CmmStatic
CmmStaticLit (CLabel -> CLabel -> Int -> Width -> CmmLit
CmmLabelDiffOff CLabel
blockLabel CLabel
lbl Int
0
                                         (NCGConfig -> Width
ncgWordWidth NCGConfig
config))
                            where blockLabel :: CLabel
blockLabel = BlockId -> CLabel
blockLbl BlockId
blockid
    in NatCmmDecl RawCmmStatics Instr
-> Maybe (NatCmmDecl RawCmmStatics Instr)
forall a. a -> Maybe a
Just (Section -> RawCmmStatics -> NatCmmDecl RawCmmStatics Instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) (CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl [CmmStatic]
jumpTable))
generateJumpTableForInstr NCGConfig
_ Instr
_ = Maybe (NatCmmDecl RawCmmStatics Instr)
forall a. Maybe a
Nothing

-- -----------------------------------------------------------------------------
-- 'condIntReg' and 'condFltReg': condition codes into registers

-- Turn those condition codes into integers now (when they appear on
-- the right hand side of an assignment).



condReg :: NatM CondCode -> NatM Register
condReg :: NatM CondCode -> NatM Register
condReg NatM CondCode
getCond = do
    CondCode _ cond cond_code <- NatM CondCode
getCond
    platform <- getPlatform
    let
        code Reg
dst = OrdList Instr
cond_code
            OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
negate_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 [
                Reg -> Instr
MFCR Reg
dst,
                Reg -> Reg -> Int -> Int -> Int -> Instr
RLWINM Reg
dst Reg
dst (Int
bit Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
31 Int
31
            ]

        negate_code | Bool
do_negate = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Int -> Int -> Int -> Instr
CRNOR Int
bit Int
bit Int
bit)
                    | Bool
otherwise = OrdList Instr
forall a. OrdList a
nilOL

        (bit, do_negate) = case cond of
            Cond
LTT -> (Int
0, Bool
False)
            Cond
LE  -> (Int
1, Bool
True)
            Cond
EQQ -> (Int
2, Bool
False)
            Cond
GE  -> (Int
0, Bool
True)
            Cond
GTT -> (Int
1, Bool
False)

            Cond
NE  -> (Int
2, Bool
True)

            Cond
LU  -> (Int
0, Bool
False)
            Cond
LEU -> (Int
1, Bool
True)
            Cond
GEU -> (Int
0, Bool
True)
            Cond
GU  -> (Int
1, Bool
False)
            Cond
_   -> String -> (Int, Bool)
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.codeReg: no match"

        format = Bool -> Format
archWordFormat (Bool -> Format) -> Bool -> Format
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit Platform
platform
    return (Any format code)

condIntReg :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
cond Width
width CmmExpr
x CmmExpr
y = NatM CondCode -> NatM Register
condReg (Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
cond Width
width CmmExpr
x CmmExpr
y)
condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
cond CmmExpr
x CmmExpr
y = NatM CondCode -> NatM Register
condReg (Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
cond CmmExpr
x CmmExpr
y)



-- -----------------------------------------------------------------------------
-- 'trivial*Code': deal with trivial instructions

-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',
-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.
-- Only look for constants on the right hand side, because that's
-- where the generic optimizer will have put them.

-- Similarly, for unary instructions, we don't have to worry about
-- matching an StInt as the argument, because genericOpt will already
-- have handled the constant-folding.



{-
Wolfgang's PowerPC version of The Rules:

A slightly modified version of The Rules to take advantage of the fact
that PowerPC instructions work on all registers and don't implicitly
clobber any fixed registers.

* The only expression for which getRegister returns Fixed is (CmmReg reg).

* If getRegister returns Any, then the code it generates may modify only:
        (a) fresh temporaries
        (b) the destination register
  It may *not* modify global registers, unless the global
  register happens to be the destination register.
  It may not clobber any other registers. In fact, only ccalls clobber any
  fixed registers.
  Also, it may not modify the counter register (used by genCCall).

  Corollary: If a getRegister for a subexpression returns Fixed, you need
  not move it to a fresh temporary before evaluating the next subexpression.
  The Fixed register won't be modified.
  Therefore, we don't need a counterpart for the x86's getStableReg on PPC.

* SDM's First Rule is valid for PowerPC, too: subexpressions can depend on
  the value of the destination register.
-}

trivialCode
        :: Width
        -> Bool
        -> (Reg -> Reg -> RI -> Instr)
        -> CmmExpr
        -> CmmExpr
        -> NatM Register

trivialCode :: Width
-> Bool
-> (Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Bool
signed Reg -> Reg -> RI -> Instr
instr CmmExpr
x (CmmLit (CmmInt Integer
y Width
_))
    | Just Imm
imm <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
rep Bool
signed Integer
y
    = do
        (src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
        let code Reg
dst = OrdList Instr
code1 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> RI -> Instr
instr Reg
dst Reg
src1 (Imm -> RI
RIImm Imm
imm)
        return (Any (intFormat rep) code)

trivialCode Width
rep Bool
_ Reg -> Reg -> RI -> Instr
instr CmmExpr
x CmmExpr
y = do
    (src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
    (src2, code2) <- getSomeReg y
    let code Reg
dst = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> RI -> Instr
instr Reg
dst Reg
src1 (Reg -> RI
RIReg Reg
src2)
    return (Any (intFormat rep) code)

shiftMulCode
        :: Width
        -> Bool
        -> (Format-> Reg -> Reg -> RI -> Instr)
        -> CmmExpr
        -> CmmExpr
        -> NatM Register
shiftMulCode :: Width
-> Bool
-> (Format -> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shiftMulCode Width
width Bool
sign Format -> Reg -> Reg -> RI -> Instr
instr CmmExpr
x (CmmLit (CmmInt Integer
y Width
_))
    | Just Imm
imm <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
width Bool
sign Integer
y
    = do
        (src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
        let format = Width -> Format
intFormat Width
width
        let ins_fmt = Width -> Format
intFormat (Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width)
        let code Reg
dst = OrdList Instr
code1 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> Reg -> RI -> Instr
instr Format
ins_fmt Reg
dst Reg
src1 (Imm -> RI
RIImm Imm
imm)
        return (Any format code)

shiftMulCode Width
width Bool
_ Format -> Reg -> Reg -> RI -> Instr
instr CmmExpr
x CmmExpr
y = do
    (src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
    (src2, code2) <- getSomeReg y
    let format = Width -> Format
intFormat Width
width
    let ins_fmt = Width -> Format
intFormat (Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width)
    let code Reg
dst = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2
                   OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> Reg -> RI -> Instr
instr Format
ins_fmt Reg
dst Reg
src1 (Reg -> RI
RIReg Reg
src2)
    return (Any format code)

trivialCodeNoImm' :: Format -> (Reg -> Reg -> Reg -> Instr)
                 -> CmmExpr -> CmmExpr -> NatM Register
trivialCodeNoImm' :: Format
-> (Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCodeNoImm' Format
format Reg -> Reg -> Reg -> Instr
instr CmmExpr
x CmmExpr
y = do
    (src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
    (src2, code2) <- getSomeReg y
    let code Reg
dst = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Reg -> Instr
instr Reg
dst Reg
src1 Reg
src2
    return (Any format code)

trivialCodeNoImm :: Format -> (Format -> Reg -> Reg -> Reg -> Instr)
                 -> CmmExpr -> CmmExpr -> NatM Register
trivialCodeNoImm :: Format
-> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCodeNoImm Format
format Format -> Reg -> Reg -> Reg -> Instr
instr CmmExpr
x CmmExpr
y
  = Format
-> (Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCodeNoImm' Format
format (Format -> Reg -> Reg -> Reg -> Instr
instr Format
format) CmmExpr
x CmmExpr
y

srCode :: Width -> Bool -> (Format-> Reg -> Reg -> RI -> Instr)
       -> CmmExpr -> CmmExpr -> NatM Register
srCode :: Width
-> Bool
-> (Format -> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
srCode Width
width Bool
sgn Format -> Reg -> Reg -> RI -> Instr
instr CmmExpr
x (CmmLit (CmmInt Integer
y Width
_))
    | Just Imm
imm <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
width Bool
sgn Integer
y
    = do
        let op_len :: Width
op_len = Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width
            extend :: Width -> Width -> CmmExpr -> CmmExpr
extend = if Bool
sgn then Width -> Width -> CmmExpr -> CmmExpr
extendSExpr else Width -> Width -> CmmExpr -> CmmExpr
extendUExpr
        (src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg (Width -> Width -> CmmExpr -> CmmExpr
extend Width
width Width
op_len CmmExpr
x)
        let code Reg
dst = OrdList Instr
code1 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                       Format -> Reg -> Reg -> RI -> Instr
instr (Width -> Format
intFormat Width
op_len) Reg
dst Reg
src1 (Imm -> RI
RIImm Imm
imm)
        return (Any (intFormat width) code)

srCode Width
width Bool
sgn Format -> Reg -> Reg -> RI -> Instr
instr CmmExpr
x CmmExpr
y = do
  let op_len :: Width
op_len = Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width
      extend :: Width -> Width -> CmmExpr -> CmmExpr
extend = if Bool
sgn then Width -> Width -> CmmExpr -> CmmExpr
extendSExpr else Width -> Width -> CmmExpr -> CmmExpr
extendUExpr
  (src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg (Width -> Width -> CmmExpr -> CmmExpr
extend Width
width Width
op_len CmmExpr
x)
  (src2, code2) <- getSomeReg (extendUExpr width op_len y)
  -- Note: Shift amount `y` is unsigned
  let code Reg
dst = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                 Format -> Reg -> Reg -> RI -> Instr
instr (Width -> Format
intFormat Width
op_len) Reg
dst Reg
src1 (Reg -> RI
RIReg Reg
src2)
  return (Any (intFormat width) code)

divCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
divCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
divCode Width
width Bool
sgn CmmExpr
x CmmExpr
y = do
  let op_len :: Width
op_len = Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width
      extend :: Width -> Width -> CmmExpr -> CmmExpr
extend = if Bool
sgn then Width -> Width -> CmmExpr -> CmmExpr
extendSExpr else Width -> Width -> CmmExpr -> CmmExpr
extendUExpr
  (src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg (Width -> Width -> CmmExpr -> CmmExpr
extend Width
width Width
op_len CmmExpr
x)
  (src2, code2) <- getSomeReg (extend width op_len y)
  let code Reg
dst = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                 Format -> Bool -> Reg -> Reg -> Reg -> Instr
DIV (Width -> Format
intFormat Width
op_len) Bool
sgn Reg
dst Reg
src1 Reg
src2
  return (Any (intFormat width) code)


trivialUCode :: Format
             -> (Reg -> Reg -> Instr)
             -> CmmExpr
             -> NatM Register
trivialUCode :: Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUCode Format
rep Reg -> Reg -> Instr
instr CmmExpr
x = do
    (src, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
    let code' Reg
dst = OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
instr Reg
dst Reg
src
    return (Any rep code')

-- | Generate code for a 4-register FMA instruction,
-- e.g. @fmadd rt ra rc rb := rt <- ra * rc + rb@.
fma_code :: Width
         -> (Format -> Reg -> Reg -> Reg -> Reg -> Instr)
         -> CmmExpr
         -> CmmExpr
         -> CmmExpr
         -> NatM Register
fma_code :: Width
-> (Format -> Reg -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> CmmExpr
-> NatM Register
fma_code Width
w Format -> Reg -> Reg -> Reg -> Reg -> Instr
instr CmmExpr
ra CmmExpr
rc CmmExpr
rb = do
    let rep :: Format
rep = Width -> Format
floatFormat Width
w
    (src1, code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
ra
    (src2, code2) <- getSomeReg rc
    (src3, code3) <- getSomeReg rb
    let instrCode Reg
rt =
          OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
          OrdList Instr
code2 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
          OrdList Instr
code3 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> Reg -> Reg -> Reg -> Instr
instr Format
rep Reg
rt Reg
src1 Reg
src2 Reg
src3
    return $ Any rep instrCode

-- There is no "remainder" instruction on the PPC, so we have to do
-- it the hard way.
-- The "sgn" parameter is the signedness for the division instruction
remainderCode :: Width -> Bool -> Reg -> CmmExpr -> CmmExpr
               -> NatM (Reg -> InstrBlock)
remainderCode :: Width
-> Bool -> Reg -> CmmExpr -> CmmExpr -> NatM (Reg -> OrdList Instr)
remainderCode Width
rep Bool
sgn Reg
reg_q CmmExpr
arg_x CmmExpr
arg_y = do
  let op_len :: Width
op_len = Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
rep
      fmt :: Format
fmt    = Width -> Format
intFormat Width
op_len
      extend :: Width -> Width -> CmmExpr -> CmmExpr
extend = if Bool
sgn then Width -> Width -> CmmExpr -> CmmExpr
extendSExpr else Width -> Width -> CmmExpr -> CmmExpr
extendUExpr
  (x_reg, x_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg (Width -> Width -> CmmExpr -> CmmExpr
extend Width
rep Width
op_len CmmExpr
arg_x)
  (y_reg, y_code) <- getSomeReg (extend rep op_len arg_y)
  return $ \Reg
reg_r -> OrdList Instr
y_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
x_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 [ Format -> Bool -> Reg -> Reg -> Reg -> Instr
DIV Format
fmt Bool
sgn Reg
reg_q Reg
x_reg Reg
y_reg
                                  , Format -> Reg -> Reg -> RI -> Instr
MULL Format
fmt Reg
reg_r Reg
reg_q (Reg -> RI
RIReg Reg
y_reg)
                                  , Reg -> Reg -> Reg -> Instr
SUBF Reg
reg_r Reg
reg_r Reg
x_reg
                                  ]


coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP Width
fromRep Width
toRep CmmExpr
x = do
    platform <- NatM Platform
getPlatform
    let arch = Platform -> Arch
platformArch Platform
platform
    coerceInt2FP' arch fromRep toRep x

coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP' Arch
ArchPPC Width
fromRep Width
toRep CmmExpr
x = do
    (src, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
    lbl <- getNewLabelNat
    itmp <- getNewRegNat II32
    ftmp <- getNewRegNat FF64
    config <- getConfig
    platform <- getPlatform
    dynRef <- cmmMakeDynamicReference config DataReference lbl
    Amode addr addr_code <- getAmode D dynRef
    let
        code' Reg
dst = OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
maybe_exts OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                Section -> RawCmmStatics -> Instr
LDATA (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) (RawCmmStatics -> Instr) -> RawCmmStatics -> Instr
forall a b. (a -> b) -> a -> b
$ CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl
                                 [CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
0x43300000 Width
W32),
                                  CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt Integer
0x80000000 Width
W32)],
                Reg -> Reg -> Imm -> Instr
XORIS Reg
itmp Reg
src (Int -> Imm
ImmInt Int
0x8000),
                Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
itmp (Platform -> Int -> AddrMode
spRel Platform
platform Int
3),
                Reg -> Imm -> Instr
LIS Reg
itmp (Int -> Imm
ImmInt Int
0x4330),
                Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
itmp (Platform -> Int -> AddrMode
spRel Platform
platform Int
2),
                Format -> Reg -> AddrMode -> Instr
LD Format
FF64 Reg
ftmp (Platform -> Int -> AddrMode
spRel Platform
platform Int
2)
            ] OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
addr_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 [
                Format -> Reg -> AddrMode -> Instr
LD Format
FF64 Reg
dst AddrMode
addr,
                Format -> Reg -> Reg -> Reg -> Instr
FSUB Format
FF64 Reg
dst Reg
ftmp Reg
dst
            ] OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
maybe_frsp Reg
dst

        maybe_exts = case Width
fromRep of
                        Width
W8 ->  Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> Reg -> Instr
EXTS Format
II8 Reg
src Reg
src
                        Width
W16 -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> Reg -> Instr
EXTS Format
II16 Reg
src Reg
src
                        Width
W32 -> OrdList Instr
forall a. OrdList a
nilOL
                        Width
_       -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.coerceInt2FP: no match"

        maybe_frsp Reg
dst
                = case Width
toRep of
                        Width
W32 -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Reg -> Reg -> Instr
FRSP Reg
dst Reg
dst
                        Width
W64 -> OrdList Instr
forall a. OrdList a
nilOL
                        Width
_       -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.coerceInt2FP: no match"

    return (Any (floatFormat toRep) code')

-- On an ELF v1 Linux we use the compiler doubleword in the stack frame
-- this is the TOC pointer doubleword on ELF v2 Linux. The latter is only
-- set right before a call and restored right after return from the call.
-- So it is fine.
coerceInt2FP' (ArchPPC_64 PPC_64ABI
_) Width
fromRep Width
toRep CmmExpr
x = do
    (src, code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
    platform <- getPlatform
    upper <- getNewRegNat II64
    lower <- getNewRegNat II64
    l1 <- getBlockIdNat
    l2 <- getBlockIdNat
    let
        code' Reg
dst = OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
maybe_exts OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                Format -> Reg -> AddrMode -> Instr
ST Format
II64 Reg
src (Platform -> Int -> AddrMode
spRel Platform
platform Int
3),
                Format -> Reg -> AddrMode -> Instr
LD Format
FF64 Reg
dst (Platform -> Int -> AddrMode
spRel Platform
platform Int
3),
                Reg -> Reg -> Instr
FCFID Reg
dst Reg
dst
            ] OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> OrdList Instr
maybe_frsp Reg
dst

        maybe_exts
          = case Width
fromRep of
              Width
W8 ->  Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> Reg -> Instr
EXTS Format
II8 Reg
src Reg
src
              Width
W16 -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> Reg -> Instr
EXTS Format
II16 Reg
src Reg
src
              Width
W32 -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> Reg -> Instr
EXTS Format
II32 Reg
src Reg
src
              Width
W64 -> case Width
toRep of
                        Width
W32 -> [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Reg -> Reg -> RI -> Instr
SRA Format
II64 Reg
upper Reg
src (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
53))
                                    , Format -> Reg -> Reg -> Int -> Instr
CLRLI Format
II64 Reg
lower Reg
src Int
53
                                    , Reg -> Reg -> RI -> Instr
ADD Reg
upper Reg
upper (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
1))
                                    , Reg -> Reg -> RI -> Instr
ADD Reg
lower Reg
lower (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
2047))
                                    , Format -> Reg -> RI -> Instr
CMPL Format
II64 Reg
upper (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
2))
                                    , Reg -> Reg -> RI -> Instr
OR Reg
lower Reg
lower (Reg -> RI
RIReg Reg
src)
                                    , Format -> Reg -> Reg -> Int -> Instr
CLRRI Format
II64 Reg
lower Reg
lower Int
11
                                    , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
LTT BlockId
l2 Maybe Bool
forall a. Maybe a
Nothing
                                    , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
l1 Maybe Bool
forall a. Maybe a
Nothing
                                    , BlockId -> Instr
NEWBLOCK BlockId
l1
                                    , Reg -> Reg -> Instr
MR Reg
src Reg
lower
                                    , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
l2 Maybe Bool
forall a. Maybe a
Nothing
                                    , BlockId -> Instr
NEWBLOCK BlockId
l2
                                    ]
                        Width
_   -> OrdList Instr
forall a. OrdList a
nilOL
              Width
_       -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.coerceInt2FP: no match"

        maybe_frsp Reg
dst
                = case Width
toRep of
                        Width
W32 -> Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Reg -> Reg -> Instr
FRSP Reg
dst Reg
dst
                        Width
W64 -> OrdList Instr
forall a. OrdList a
nilOL
                        Width
_       -> String -> OrdList Instr
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.coerceInt2FP: no match"

    return (Any (floatFormat toRep) code')

coerceInt2FP' Arch
_ Width
_ Width
_ CmmExpr
_ = String -> NatM Register
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.coerceInt2FP: unknown arch"


coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int Width
fromRep Width
toRep CmmExpr
x = do
    platform <- NatM Platform
getPlatform
    let arch =  Platform -> Arch
platformArch Platform
platform
    coerceFP2Int' arch fromRep toRep x

coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int' Arch
ArchPPC Width
_ Width
toRep CmmExpr
x = do
    platform <- NatM Platform
getPlatform
    -- the reps don't really matter: F*->FF64 and II32->I* are no-ops
    (src, code) <- getSomeReg x
    tmp <- getNewRegNat FF64
    let
        code' Reg
dst = OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                -- convert to int in FP reg
            Reg -> Reg -> Instr
FCTIWZ Reg
tmp Reg
src,
                -- store value (64bit) from FP to stack
            Format -> Reg -> AddrMode -> Instr
ST Format
FF64 Reg
tmp (Platform -> Int -> AddrMode
spRel Platform
platform Int
2),
                -- read low word of value (high word is undefined)
            Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
dst (Platform -> Int -> AddrMode
spRel Platform
platform Int
3)]
    return (Any (intFormat toRep) code')

coerceFP2Int' (ArchPPC_64 PPC_64ABI
_) Width
_ Width
toRep CmmExpr
x = do
    platform <- NatM Platform
getPlatform
    -- the reps don't really matter: F*->FF64 and II64->I* are no-ops
    (src, code) <- getSomeReg x
    tmp <- getNewRegNat FF64
    let
        code' Reg
dst = OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                -- convert to int in FP reg
            Reg -> Reg -> Instr
FCTIDZ Reg
tmp Reg
src,
                -- store value (64bit) from FP to compiler word on stack
            Format -> Reg -> AddrMode -> Instr
ST Format
FF64 Reg
tmp (Platform -> Int -> AddrMode
spRel Platform
platform Int
3),
            Format -> Reg -> AddrMode -> Instr
LD Format
II64 Reg
dst (Platform -> Int -> AddrMode
spRel Platform
platform Int
3)]
    return (Any (intFormat toRep) code')

coerceFP2Int' Arch
_ Width
_ Width
_ CmmExpr
_ = String -> NatM Register
forall a. HasCallStack => String -> a
panic String
"PPC.CodeGen.coerceFP2Int: unknown arch"

-- Note [.LCTOC1 in PPC PIC code]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- The .LCTOC1 label is defined to point 32768 bytes into the GOT table
-- to make the most of the PPC's 16-bit displacements.
-- As 16-bit signed offset is used (usually via addi/lwz instructions)
-- first element will have '-32768' offset against .LCTOC1.

-- Note [implicit register in PPC PIC code]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- PPC generates calls by labels in assembly
-- in form of:
--     bl puts+32768@plt
-- in this form it's not seen directly (by GHC NCG)
-- that r30 (PicBaseReg) is used,
-- but r30 is a required part of PLT code setup:
--   puts+32768@plt:
--       lwz     r11,-30484(r30) ; offset in .LCTOC1
--       mtctr   r11
--       bctr