{-# LANGUAGE CPP, 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 PPC.CodeGen (
        cmmTopCodeGen,
        generateJumpTableForInstr,
        InstrBlock
)

where

#include "HsVersions.h"
#include "nativeGen/NCG.h"
#include "MachDeps.h"

-- NCG stuff:
import GhcPrelude

import CodeGen.Platform
import PPC.Instr
import PPC.Cond
import PPC.Regs
import CPrim
import NCGMonad   ( NatM, getNewRegNat, getNewLabelNat
                  , getBlockIdNat, getPicBaseNat, getNewRegPairNat
                  , getPicBaseMaybeNat )
import Instruction
import PIC
import Format
import RegClass
import Reg
import TargetReg
import Platform

-- Our intermediate code:
import BlockId
import PprCmm           ( pprExpr )
import Cmm
import CmmUtils
import CmmSwitch
import CLabel
import Hoopl.Block
import Hoopl.Graph

-- The rest:
import OrdList
import Outputable
import DynFlags

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

import BasicTypes
import FastString
import Util

-- -----------------------------------------------------------------------------
-- 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 CmmStatics Instr]

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

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

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

basicBlockCodeGen :: CmmBlock
-> NatM ([NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr])
basicBlockCodeGen block :: CmmBlock
block = do
  let (_, nodes :: Block CmmNode O O
nodes, tail :: CmmNode O C
tail)  = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: * -> * -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
      id :: BlockId
id = CmmBlock -> BlockId
forall (thing :: * -> * -> *) x.
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block
      stmts :: [CmmNode O O]
stmts = Block CmmNode O O -> [CmmNode O O]
forall (n :: * -> * -> *). Block n O O -> [n O O]
blockToList Block CmmNode O O
nodes
  InstrBlock
mid_instrs <- [CmmNode O O] -> NatM InstrBlock
forall e x. [CmmNode e x] -> NatM InstrBlock
stmtsToInstrs [CmmNode O O]
stmts
  InstrBlock
tail_instrs <- CmmNode O C -> NatM InstrBlock
forall e x. CmmNode e x -> NatM InstrBlock
stmtToInstrs CmmNode O C
tail
  let instrs :: InstrBlock
instrs = InstrBlock
mid_instrs InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
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 :: [Instr]
top,other_blocks :: [NatBasicBlock Instr]
other_blocks,statics :: [NatCmmDecl CmmStatics Instr]
statics) = (Instr
 -> ([Instr], [NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr])
 -> ([Instr], [NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr]))
-> ([Instr], [NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr])
-> InstrBlock
-> ([Instr], [NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr])
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL Instr
-> ([Instr], [NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr])
-> ([Instr], [NatBasicBlock Instr], [NatCmmDecl CmmStatics Instr])
forall h g.
Instr
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl CmmStatics h g])
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl CmmStatics h g])
mkBlocks ([],[],[]) InstrBlock
instrs

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

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

stmtToInstrs :: CmmNode e x -> NatM InstrBlock
stmtToInstrs :: CmmNode e x -> NatM InstrBlock
stmtToInstrs stmt :: CmmNode e x
stmt = do
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  case CmmNode e x
stmt of
    CmmComment s :: FastString
s   -> InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (FastString -> Instr
COMMENT FastString
s))
    CmmTick {}     -> InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return InstrBlock
forall a. OrdList a
nilOL
    CmmUnwind {}   -> InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return InstrBlock
forall a. OrdList a
nilOL

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

    CmmStore addr :: CmmExpr
addr src :: CmmExpr
src
      | CmmType -> Bool
isFloatType CmmType
ty -> Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_FltCode Format
format CmmExpr
addr CmmExpr
src
      | Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags) Bool -> Bool -> Bool
&&
        CmmType -> Bool
isWord64 CmmType
ty    -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_I64Code      CmmExpr
addr CmmExpr
src
      | Bool
otherwise      -> Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_IntCode Format
format CmmExpr
addr CmmExpr
src
        where ty :: CmmType
ty = DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
src
              format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
ty

    CmmUnsafeForeignCall target :: ForeignTarget
target result_regs :: [CmmFormal]
result_regs args :: [CmmExpr]
args
       -> ForeignTarget -> [CmmFormal] -> [CmmExpr] -> NatM InstrBlock
genCCall ForeignTarget
target [CmmFormal]
result_regs [CmmExpr]
args

    CmmBranch id :: BlockId
id          -> BlockId -> NatM InstrBlock
genBranch BlockId
id
    CmmCondBranch arg :: CmmExpr
arg true :: BlockId
true false :: BlockId
false prediction :: Maybe Bool
prediction -> do
      InstrBlock
b1 <- BlockId -> CmmExpr -> Maybe Bool -> NatM InstrBlock
genCondJump BlockId
true CmmExpr
arg Maybe Bool
prediction
      InstrBlock
b2 <- BlockId -> NatM InstrBlock
genBranch BlockId
false
      InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock
b1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
b2)
    CmmSwitch arg :: CmmExpr
arg ids :: SwitchTargets
ids -> do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                            DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch DynFlags
dflags CmmExpr
arg SwitchTargets
ids
    CmmCall { cml_target :: CmmNode O C -> CmmExpr
cml_target = CmmExpr
arg } -> CmmExpr -> NatM InstrBlock
genJump CmmExpr
arg
    _ ->
      String -> NatM InstrBlock
forall a. String -> a
panic "stmtToInstrs: statement should have been cps'd away"


--------------------------------------------------------------------------------
-- | '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 _ reg :: Reg
reg code :: InstrBlock
code) format :: Format
format = Format -> Reg -> InstrBlock -> Register
Fixed Format
format Reg
reg InstrBlock
code
swizzleRegisterRep (Any _ codefn :: Reg -> InstrBlock
codefn)     format :: Format
format = Format -> (Reg -> InstrBlock) -> Register
Any   Format
format Reg -> InstrBlock
codefn


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

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

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

-- | Convert a BlockId to some CmmStatic data
jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic
jumpTableEntry dflags :: DynFlags
dflags Nothing = CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt 0 (DynFlags -> Width
wordWidth DynFlags
dflags))
jumpTableEntry _ (Just blockid :: 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 :: DynFlags -> CmmExpr -> CmmExpr
mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr
mangleIndexTree dflags :: DynFlags
dflags (CmmRegOff reg :: CmmReg
reg off :: 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 (DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags CmmReg
reg)

mangleIndexTree _ _
        = String -> CmmExpr
forall a. String -> a
panic "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.
-}

data ChildCode64        -- a.k.a "Register64"
      = ChildCode64
           InstrBlock   -- code
           Reg          -- the lower 32-bit temporary which contains the
                        -- result; use getHiVRegFromLo to find the other
                        -- VRegUnique.  Rules of this simplified insn
                        -- selection game are therefore that the returned
                        -- Reg may be modified


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

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


assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_I64Code addrTree :: CmmExpr
addrTree valueTree :: CmmExpr
valueTree = do
        (hi_addr :: AddrMode
hi_addr, lo_addr :: AddrMode
lo_addr, addr_code :: InstrBlock
addr_code) <- CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)
getI64Amodes CmmExpr
addrTree
        ChildCode64 vcode :: InstrBlock
vcode rlo :: Reg
rlo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
valueTree
        let
                rhi :: Reg
rhi = Reg -> Reg
getHiVRegFromLo Reg
rlo

                -- Big-endian store
                mov_hi :: Instr
mov_hi = Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
rhi AddrMode
hi_addr
                mov_lo :: Instr
mov_lo = Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
rlo AddrMode
lo_addr
        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock
vcode InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
addr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_lo InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_hi)


assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_I64Code (CmmLocal (LocalReg u_dst :: Unique
u_dst _)) valueTree :: CmmExpr
valueTree = do
   ChildCode64 vcode :: InstrBlock
vcode r_src_lo :: Reg
r_src_lo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
valueTree
   let
         r_dst_lo :: Reg
r_dst_lo = VirtualReg -> Reg
RegVirtual (VirtualReg -> Reg) -> VirtualReg -> Reg
forall a b. (a -> b) -> a -> b
$ Unique -> Format -> VirtualReg
mkVirtualReg Unique
u_dst Format
II32
         r_dst_hi :: Reg
r_dst_hi = Reg -> Reg
getHiVRegFromLo Reg
r_dst_lo
         r_src_hi :: Reg
r_src_hi = Reg -> Reg
getHiVRegFromLo Reg
r_src_lo
         mov_lo :: Instr
mov_lo = Reg -> Reg -> Instr
MR Reg
r_dst_lo Reg
r_src_lo
         mov_hi :: Instr
mov_hi = Reg -> Reg -> Instr
MR Reg
r_dst_hi Reg
r_src_hi
   InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (
        InstrBlock
vcode InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_lo InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_hi
     )

assignReg_I64Code _ _
   = String -> NatM InstrBlock
forall a. String -> a
panic "assignReg_I64Code(powerpc): invalid lvalue"


iselExpr64        :: CmmExpr -> NatM ChildCode64
iselExpr64 :: CmmExpr -> NatM ChildCode64
iselExpr64 (CmmLoad addrTree :: CmmExpr
addrTree ty :: CmmType
ty) | CmmType -> Bool
isWord64 CmmType
ty = do
    (hi_addr :: AddrMode
hi_addr, lo_addr :: AddrMode
lo_addr, addr_code :: InstrBlock
addr_code) <- CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)
getI64Amodes CmmExpr
addrTree
    (rlo :: Reg
rlo, rhi :: Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
    let mov_hi :: Instr
mov_hi = Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
rhi AddrMode
hi_addr
        mov_lo :: Instr
mov_lo = Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
rlo AddrMode
lo_addr
    ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (ChildCode64 -> NatM ChildCode64)
-> ChildCode64 -> NatM ChildCode64
forall a b. (a -> b) -> a -> b
$ InstrBlock -> Reg -> ChildCode64
ChildCode64 (InstrBlock
addr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_lo InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_hi)
                         Reg
rlo

iselExpr64 (CmmReg (CmmLocal (LocalReg vu :: Unique
vu ty :: CmmType
ty))) | CmmType -> Bool
isWord64 CmmType
ty
   = ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> Reg -> ChildCode64
ChildCode64 InstrBlock
forall a. OrdList a
nilOL (VirtualReg -> Reg
RegVirtual (VirtualReg -> Reg) -> VirtualReg -> Reg
forall a b. (a -> b) -> a -> b
$ Unique -> Format -> VirtualReg
mkVirtualReg Unique
vu Format
II32))

iselExpr64 (CmmLit (CmmInt i :: Integer
i _)) = do
  (rlo :: Reg
rlo,rhi :: Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
  let
        half0 :: Int
half0 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i :: Word16)
        half1 :: Int
half1 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` 16) :: Word16)
        half2 :: Int
half2 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` 32) :: Word16)
        half3 :: Int
half3 = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` 48) :: Word16)

        code :: InstrBlock
code = [Instr] -> InstrBlock
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)
                ]
  ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> Reg -> ChildCode64
ChildCode64 InstrBlock
code Reg
rlo)

iselExpr64 (CmmMachOp (MO_Add _) [e1 :: CmmExpr
e1,e2 :: CmmExpr
e2]) = do
   ChildCode64 code1 :: InstrBlock
code1 r1lo :: Reg
r1lo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
e1
   ChildCode64 code2 :: InstrBlock
code2 r2lo :: Reg
r2lo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
e2
   (rlo :: Reg
rlo,rhi :: Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
   let
        r1hi :: Reg
r1hi = Reg -> Reg
getHiVRegFromLo Reg
r1lo
        r2hi :: Reg
r2hi = Reg -> Reg
getHiVRegFromLo Reg
r2lo
        code :: InstrBlock
code =  InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                InstrBlock
code2 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                [Instr] -> InstrBlock
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 ]
   ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> Reg -> ChildCode64
ChildCode64 InstrBlock
code Reg
rlo)

iselExpr64 (CmmMachOp (MO_Sub _) [e1 :: CmmExpr
e1,e2 :: CmmExpr
e2]) = do
   ChildCode64 code1 :: InstrBlock
code1 r1lo :: Reg
r1lo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
e1
   ChildCode64 code2 :: InstrBlock
code2 r2lo :: Reg
r2lo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
e2
   (rlo :: Reg
rlo,rhi :: Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
   let
        r1hi :: Reg
r1hi = Reg -> Reg
getHiVRegFromLo Reg
r1lo
        r2hi :: Reg
r2hi = Reg -> Reg
getHiVRegFromLo Reg
r2lo
        code :: InstrBlock
code =  InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                InstrBlock
code2 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                [Instr] -> InstrBlock
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 ]
   ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> Reg -> ChildCode64
ChildCode64 InstrBlock
code Reg
rlo)

iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr :: CmmExpr
expr]) = do
    (expr_reg :: Reg
expr_reg,expr_code :: InstrBlock
expr_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
expr
    (rlo :: Reg
rlo, rhi :: Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
    let mov_hi :: Instr
mov_hi = Reg -> Imm -> Instr
LI Reg
rhi (Int -> Imm
ImmInt 0)
        mov_lo :: Instr
mov_lo = Reg -> Reg -> Instr
MR Reg
rlo Reg
expr_reg
    ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (ChildCode64 -> NatM ChildCode64)
-> ChildCode64 -> NatM ChildCode64
forall a b. (a -> b) -> a -> b
$ InstrBlock -> Reg -> ChildCode64
ChildCode64 (InstrBlock
expr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_lo InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_hi)
                         Reg
rlo

iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr :: CmmExpr
expr]) = do
    (expr_reg :: Reg
expr_reg,expr_code :: InstrBlock
expr_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
expr
    (rlo :: Reg
rlo, rhi :: Reg
rhi) <- Format -> NatM (Reg, Reg)
getNewRegPairNat Format
II32
    let mov_hi :: Instr
mov_hi = Format -> Reg -> Reg -> RI -> Instr
SRA Format
II32 Reg
rhi Reg
expr_reg (Imm -> RI
RIImm (Int -> Imm
ImmInt 31))
        mov_lo :: Instr
mov_lo = Reg -> Reg -> Instr
MR Reg
rlo Reg
expr_reg
    ChildCode64 -> NatM ChildCode64
forall (m :: * -> *) a. Monad m => a -> m a
return (ChildCode64 -> NatM ChildCode64)
-> ChildCode64 -> NatM ChildCode64
forall a b. (a -> b) -> a -> b
$ InstrBlock -> Reg -> ChildCode64
ChildCode64 (InstrBlock
expr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_lo InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_hi)
                         Reg
rlo
iselExpr64 expr :: CmmExpr
expr
   = String -> SDoc -> NatM ChildCode64
forall a. HasCallStack => String -> SDoc -> a
pprPanic "iselExpr64(powerpc)" (CmmExpr -> SDoc
pprExpr CmmExpr
expr)



getRegister :: CmmExpr -> NatM Register
getRegister :: CmmExpr -> NatM Register
getRegister e :: CmmExpr
e = do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                   DynFlags -> CmmExpr -> NatM Register
getRegister' DynFlags
dflags CmmExpr
e

getRegister' :: DynFlags -> CmmExpr -> NatM Register

getRegister' :: DynFlags -> CmmExpr -> NatM Register
getRegister' dflags :: DynFlags
dflags (CmmReg (CmmGlobal PicBaseReg))
  | OS
OSAIX <- Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags) = do
        let code :: Reg -> InstrBlock
code dst :: Reg
dst = [Instr] -> InstrBlock
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 (SDoc -> Imm
ImmLit (String -> SDoc
text "ghc_toc_table[TC]"))
        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 Reg -> InstrBlock
code)
  | Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags) = do
      Reg
reg <- Format -> NatM Reg
getPicBaseNat (Format -> NatM Reg) -> Format -> NatM Reg
forall a b. (a -> b) -> a -> b
$ Bool -> Format
archWordFormat (Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags))
      Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> InstrBlock -> Register
Fixed (Bool -> Format
archWordFormat (Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags)))
                    Reg
reg InstrBlock
forall a. OrdList a
nilOL)
  | Bool
otherwise = Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> InstrBlock -> Register
Fixed Format
II64 Reg
toc InstrBlock
forall a. OrdList a
nilOL)

getRegister' dflags :: DynFlags
dflags (CmmReg reg :: CmmReg
reg)
  = Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> InstrBlock -> Register
Fixed (CmmType -> Format
cmmTypeFormat (DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags CmmReg
reg))
                  (Platform -> CmmReg -> Reg
getRegisterReg (DynFlags -> Platform
targetPlatform DynFlags
dflags) CmmReg
reg) InstrBlock
forall a. OrdList a
nilOL)

getRegister' dflags :: DynFlags
dflags tree :: CmmExpr
tree@(CmmRegOff _ _)
  = DynFlags -> CmmExpr -> NatM Register
getRegister' DynFlags
dflags (DynFlags -> CmmExpr -> CmmExpr
mangleIndexTree DynFlags
dflags CmmExpr
tree)

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

getRegister' dflags :: DynFlags
dflags (CmmMachOp (MO_UU_Conv W64 W32)
                     [CmmMachOp (MO_U_Shr W64) [x :: CmmExpr
x,CmmLit (CmmInt 32 _)]])
 | Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags) = do
  ChildCode64 code :: InstrBlock
code rlo :: Reg
rlo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
x
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> InstrBlock -> Register
Fixed Format
II32 (Reg -> Reg
getHiVRegFromLo Reg
rlo) InstrBlock
code

getRegister' dflags :: DynFlags
dflags (CmmMachOp (MO_SS_Conv W64 W32)
                     [CmmMachOp (MO_U_Shr W64) [x :: CmmExpr
x,CmmLit (CmmInt 32 _)]])
 | Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags) = do
  ChildCode64 code :: InstrBlock
code rlo :: Reg
rlo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
x
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> InstrBlock -> Register
Fixed Format
II32 (Reg -> Reg
getHiVRegFromLo Reg
rlo) InstrBlock
code

getRegister' dflags :: DynFlags
dflags (CmmMachOp (MO_UU_Conv W64 W32) [x :: CmmExpr
x])
 | Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags) = do
  ChildCode64 code :: InstrBlock
code rlo :: Reg
rlo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
x
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> InstrBlock -> Register
Fixed Format
II32 Reg
rlo InstrBlock
code

getRegister' dflags :: DynFlags
dflags (CmmMachOp (MO_SS_Conv W64 W32) [x :: CmmExpr
x])
 | Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags) = do
  ChildCode64 code :: InstrBlock
code rlo :: Reg
rlo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
x
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> InstrBlock -> Register
Fixed Format
II32 Reg
rlo InstrBlock
code

getRegister' dflags :: DynFlags
dflags (CmmLoad mem :: CmmExpr
mem pk :: CmmType
pk)
 | Bool -> Bool
not (CmmType -> Bool
isWord64 CmmType
pk) = do
        let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
        Amode addr :: AddrMode
addr addr_code :: InstrBlock
addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
        let code :: Reg -> InstrBlock
code dst :: Reg
dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk)
                       InstrBlock
addr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
format Reg
dst AddrMode
addr
        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
format Reg -> InstrBlock
code)
 | Bool -> Bool
not (Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags)) = do
        Amode addr :: AddrMode
addr addr_code :: InstrBlock
addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
DS CmmExpr
mem
        let code :: Reg -> InstrBlock
code dst :: Reg
dst = InstrBlock
addr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II64 Reg
dst AddrMode
addr
        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II64 Reg -> InstrBlock
code)

          where format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
pk

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

getRegister' _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem :: CmmExpr
mem _]) = do
    Amode addr :: AddrMode
addr addr_code :: InstrBlock
addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 (\dst :: Reg
dst -> InstrBlock
addr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II8 Reg
dst AddrMode
addr))

getRegister' _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem :: CmmExpr
mem _]) = do
    Amode addr :: AddrMode
addr addr_code :: InstrBlock
addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II64 (\dst :: Reg
dst -> InstrBlock
addr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II8 Reg
dst AddrMode
addr))

getRegister' _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem :: CmmExpr
mem _]) = do
    Amode addr :: AddrMode
addr addr_code :: InstrBlock
addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II64 (\dst :: Reg
dst -> InstrBlock
addr_code InstrBlock -> Instr -> InstrBlock
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' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem :: CmmExpr
mem _]) = do
    Amode addr :: AddrMode
addr addr_code :: InstrBlock
addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 (\dst :: Reg
dst -> InstrBlock
addr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II16 Reg
dst AddrMode
addr))

getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem :: CmmExpr
mem _]) = do
    Amode addr :: AddrMode
addr addr_code :: InstrBlock
addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 (\dst :: Reg
dst -> InstrBlock
addr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LA Format
II16 Reg
dst AddrMode
addr))

getRegister' _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem :: CmmExpr
mem _]) = do
    Amode addr :: AddrMode
addr addr_code :: InstrBlock
addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II64 (\dst :: Reg
dst -> InstrBlock
addr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II16 Reg
dst AddrMode
addr))

getRegister' _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem :: CmmExpr
mem _]) = do
    Amode addr :: AddrMode
addr addr_code :: InstrBlock
addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II64 (\dst :: Reg
dst -> InstrBlock
addr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LA Format
II16 Reg
dst AddrMode
addr))

getRegister' _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem :: CmmExpr
mem _]) = do
    Amode addr :: AddrMode
addr addr_code :: InstrBlock
addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
mem
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II64 (\dst :: Reg
dst -> InstrBlock
addr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
dst AddrMode
addr))

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

getRegister' dflags :: DynFlags
dflags (CmmMachOp mop :: MachOp
mop [x :: CmmExpr
x]) -- unary MachOps
  = case MachOp
mop of
      MO_Not rep :: Width
rep   -> Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_int Width
rep Reg -> Reg -> Instr
NOT

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

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

      MO_FS_Conv from :: Width
from to :: Width
to -> Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int Width
from Width
to CmmExpr
x
      MO_SF_Conv from :: Width
from to :: Width
to -> Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP Width
from Width
to CmmExpr
x

      MO_SS_Conv from :: Width
from to :: 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 from :: Width
from to :: 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 _ to :: Width
to -> Format -> CmmExpr -> NatM Register
conversionNop (Width -> Format
intFormat Width
to) CmmExpr
x

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

    where
        triv_ucode_int :: Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_int   width :: Width
width instr :: 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
width instr :: 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 new_format :: Format
new_format expr :: CmmExpr
expr
            = do Register
e_code <- DynFlags -> CmmExpr -> NatM Register
getRegister' DynFlags
dflags CmmExpr
expr
                 Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> Format -> Register
swizzleRegisterRep Register
e_code Format
new_format)

        clearLeft :: Width -> Width -> NatM Register
clearLeft from :: Width
from to :: Width
to
            = do (src1 :: Reg
src1, code1 :: InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
                 let arch_fmt :: Format
arch_fmt  = Width -> Format
intFormat (DynFlags -> Width
wordWidth DynFlags
dflags)
                     arch_bits :: Int
arch_bits = Width -> Int
widthInBits (DynFlags -> Width
wordWidth DynFlags
dflags)
                     size :: Int
size      = Width -> Int
widthInBits Width
from
                     code :: Reg -> InstrBlock
code dst :: Reg
dst  = InstrBlock
code1 InstrBlock -> Instr -> InstrBlock
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)
                 Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any (Width -> Format
intFormat Width
to) Reg -> InstrBlock
code)

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

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

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

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

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

         -- optimize addition with 32-bit immediate
         -- (needed for PIC)
      MO_Add W32 ->
        case CmmExpr
y of
          CmmLit (CmmInt imm :: Integer
imm immrep :: Width
immrep) | Just _ <- 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 lit :: CmmLit
lit
            -> do
                (src :: Reg
src, srcCode :: InstrBlock
srcCode) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
                let imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
                    code :: Reg -> InstrBlock
code dst :: Reg
dst = InstrBlock
srcCode InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
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))
                                ]
                Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 Reg -> InstrBlock
code)
          _ -> 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 rep :: 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 rep :: Width
rep ->
        case CmmExpr
y of
          CmmLit (CmmInt imm :: Integer
imm immrep :: Width
immrep) | Just _ <- 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)
          _ -> case CmmExpr
x of
                 CmmLit (CmmInt imm :: Integer
imm _)
                   | Just _ <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
rep Bool
True Integer
imm
                   -- subfi ('substract 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
                 _ -> 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 rep :: 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 rep :: Width
rep -> do
        (src1 :: Reg
src1, code1 :: InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        (src2 :: Reg
src2, code2 :: InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y
        let
          format :: Format
format = Width -> Format
intFormat Width
rep
          code :: Reg -> InstrBlock
code dst :: Reg
dst = InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2
                       InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
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
                                    ]
        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
format Reg -> InstrBlock
code)

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

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

      MO_And rep :: Width
rep   -> case CmmExpr
y of
        (CmmLit (CmmInt imm :: Integer
imm _)) | Integer
imm Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -8 Bool -> Bool -> Bool
|| Integer
imm Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -4
            -> do
                (src :: Reg
src, srcCode :: InstrBlock
srcCode) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
                let clear_mask :: Int
clear_mask = if Integer
imm Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -4 then 2 else 3
                    fmt :: Format
fmt = Width -> Format
intFormat Width
rep
                    code :: Reg -> InstrBlock
code dst :: Reg
dst = InstrBlock
srcCode
                               InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Format -> Reg -> Reg -> Int -> Instr
CLRRI Format
fmt Reg
dst Reg
src Int
clear_mask)
                Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
fmt Reg -> InstrBlock
code)
        _ -> 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 rep :: 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 rep :: 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 rep :: 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 rep :: 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 rep :: 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
      _         -> String -> NatM Register
forall a. String -> a
panic "PPC.CodeGen.getRegister: no match"

  where
    triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
    triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register
triv_float width :: Width
width instr :: 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 rep :: Width
rep sgn :: Bool
sgn x :: CmmExpr
x y :: CmmExpr
y = do
      let fmt :: Format
fmt = Width -> Format
intFormat Width
rep
      Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
fmt
      Reg -> InstrBlock
code <- Width
-> Bool -> Reg -> CmmExpr -> CmmExpr -> NatM (Reg -> InstrBlock)
remainderCode Width
rep Bool
sgn Reg
tmp CmmExpr
x CmmExpr
y
      Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
fmt Reg -> InstrBlock
code)


getRegister' _ (CmmLit (CmmInt i :: Integer
i rep :: Width
rep))
  | Just imm :: 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 -> InstrBlock
code dst :: Reg
dst = Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Reg -> Imm -> Instr
LI Reg
dst Imm
imm)
    in
        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any (Width -> Format
intFormat Width
rep) Reg -> InstrBlock
code)

getRegister' _ (CmmLit (CmmFloat f :: Rational
f frep :: Width
frep)) = do
    CLabel
lbl <- NatM CLabel
getNewLabelNat
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    CmmExpr
dynRef <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference DynFlags
dflags ReferenceKind
DataReference CLabel
lbl
    Amode addr :: AddrMode
addr addr_code :: InstrBlock
addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
dynRef
    let format :: Format
format = Width -> Format
floatFormat Width
frep
        code :: Reg -> InstrBlock
code dst :: Reg
dst =
            Section -> CmmStatics -> Instr
LDATA (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl)
                  (CLabel -> [CmmStatic] -> CmmStatics
Statics CLabel
lbl [CmmLit -> CmmStatic
CmmStaticLit (Rational -> Width -> CmmLit
CmmFloat Rational
f Width
frep)])
            Instr -> InstrBlock -> InstrBlock
forall a. a -> OrdList a -> OrdList a
`consOL` (InstrBlock
addr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
format Reg
dst AddrMode
addr)
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
format Reg -> InstrBlock
code)

getRegister' dflags :: DynFlags
dflags (CmmLit lit :: CmmLit
lit)
  | Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags)
  = let rep :: CmmType
rep = DynFlags -> CmmLit -> CmmType
cmmLitType DynFlags
dflags CmmLit
lit
        imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
        code :: Reg -> InstrBlock
code dst :: Reg
dst = [Instr] -> InstrBlock
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 (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any (CmmType -> Format
cmmTypeFormat CmmType
rep) Reg -> InstrBlock
code)
  | Bool
otherwise
  = do CLabel
lbl <- NatM CLabel
getNewLabelNat
       DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       CmmExpr
dynRef <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference DynFlags
dflags ReferenceKind
DataReference CLabel
lbl
       Amode addr :: AddrMode
addr addr_code :: InstrBlock
addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
dynRef
       let rep :: CmmType
rep = DynFlags -> CmmLit -> CmmType
cmmLitType DynFlags
dflags CmmLit
lit
           format :: Format
format = CmmType -> Format
cmmTypeFormat CmmType
rep
           code :: Reg -> InstrBlock
code dst :: Reg
dst =
            Section -> CmmStatics -> Instr
LDATA (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) (CLabel -> [CmmStatic] -> CmmStatics
Statics CLabel
lbl [CmmLit -> CmmStatic
CmmStaticLit CmmLit
lit])
            Instr -> InstrBlock -> InstrBlock
forall a. a -> OrdList a -> OrdList a
`consOL` (InstrBlock
addr_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
format Reg
dst AddrMode
addr)
       Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
format Reg -> InstrBlock
code)

getRegister' _ other :: CmmExpr
other = String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic "getRegister(ppc)" (CmmExpr -> SDoc
pprExpr 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 from :: Width
from to :: Width
to x :: 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 from :: Width
from to :: Width
to x :: 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 inf :: InstrForm
inf tree :: CmmExpr
tree@(CmmRegOff _ _)
  = do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
inf (DynFlags -> CmmExpr -> CmmExpr
mangleIndexTree DynFlags
dflags CmmExpr
tree)

getAmode _ (CmmMachOp (MO_Sub W32) [x :: CmmExpr
x, CmmLit (CmmInt i :: Integer
i _)])
  | Just off :: 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 :: Reg
reg, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> InstrBlock -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg Imm
off) InstrBlock
code)


getAmode _ (CmmMachOp (MO_Add W32) [x :: CmmExpr
x, CmmLit (CmmInt i :: Integer
i _)])
  | Just off :: 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 :: Reg
reg, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> InstrBlock -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg Imm
off) InstrBlock
code)

getAmode D (CmmMachOp (MO_Sub W64) [x :: CmmExpr
x, CmmLit (CmmInt i :: Integer
i _)])
  | Just off :: 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 :: Reg
reg, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> InstrBlock -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg Imm
off) InstrBlock
code)


getAmode D (CmmMachOp (MO_Add W64) [x :: CmmExpr
x, CmmLit (CmmInt i :: Integer
i _)])
  | Just off :: 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 :: Reg
reg, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> InstrBlock -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg Imm
off) InstrBlock
code)

getAmode DS (CmmMachOp (MO_Sub W64) [x :: CmmExpr
x, CmmLit (CmmInt i :: Integer
i _)])
  | Just off :: 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 :: Reg
reg, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        (reg' :: Reg
reg', off' :: Imm
off', code' :: InstrBlock
code')  <-
                     if Integer
i Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` 4 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0
                      then do (Reg, Imm, InstrBlock) -> NatM (Reg, Imm, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg, Imm
off, InstrBlock
code)
                      else do
                           Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
II64
                           (Reg, Imm, InstrBlock) -> NatM (Reg, Imm, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, Int -> Imm
ImmInt 0,
                                  InstrBlock
code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> RI -> Instr
ADD Reg
tmp Reg
reg (Imm -> RI
RIImm Imm
off))
        Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> InstrBlock -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg' Imm
off') InstrBlock
code')

getAmode DS (CmmMachOp (MO_Add W64) [x :: CmmExpr
x, CmmLit (CmmInt i :: Integer
i _)])
  | Just off :: 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 :: Reg
reg, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        (reg' :: Reg
reg', off' :: Imm
off', code' :: InstrBlock
code')  <-
                     if Integer
i Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` 4 Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 0
                      then do (Reg, Imm, InstrBlock) -> NatM (Reg, Imm, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg, Imm
off, InstrBlock
code)
                      else do
                           Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
II64
                           (Reg, Imm, InstrBlock) -> NatM (Reg, Imm, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, Int -> Imm
ImmInt 0,
                                  InstrBlock
code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> RI -> Instr
ADD Reg
tmp Reg
reg (Imm -> RI
RIImm Imm
off))
        Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> InstrBlock -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg' Imm
off') InstrBlock
code')

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

getAmode _ (CmmLit lit :: CmmLit
lit)
  = do
        DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        case Platform -> Arch
platformArch (Platform -> Arch) -> Platform -> Arch
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags of
             ArchPPC -> do
                 Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
II32
                 let imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
                     code :: InstrBlock
code = Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Reg -> Imm -> Instr
LIS Reg
tmp (Imm -> Imm
HA Imm
imm))
                 Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> InstrBlock -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
tmp (Imm -> Imm
LO Imm
imm)) InstrBlock
code)
             _        -> do -- TODO: Load from TOC,
                            -- see getRegister' _ (CmmLit lit)
                 Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
II64
                 let imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
                     code :: InstrBlock
code =  [Instr] -> InstrBlock
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 32)),
                          Reg -> Reg -> Imm -> Instr
ORIS Reg
tmp Reg
tmp (Imm -> Imm
HA Imm
imm)
                          ]
                 Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> InstrBlock -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
tmp (Imm -> Imm
LO Imm
imm)) InstrBlock
code)

getAmode _ (CmmMachOp (MO_Add W32) [x :: CmmExpr
x, y :: CmmExpr
y])
  = do
        (regX :: Reg
regX, codeX :: InstrBlock
codeX) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        (regY :: Reg
regY, codeY :: InstrBlock
codeY) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y
        Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> InstrBlock -> Amode
Amode (Reg -> Reg -> AddrMode
AddrRegReg Reg
regX Reg
regY) (InstrBlock
codeX InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
codeY))

getAmode _ (CmmMachOp (MO_Add W64) [x :: CmmExpr
x, y :: CmmExpr
y])
  = do
        (regX :: Reg
regX, codeX :: InstrBlock
codeX) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        (regY :: Reg
regY, codeY :: InstrBlock
codeY) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y
        Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> InstrBlock -> Amode
Amode (Reg -> Reg -> AddrMode
AddrRegReg Reg
regX Reg
regY) (InstrBlock
codeX InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
codeY))

getAmode _ other :: CmmExpr
other
  = do
        (reg :: Reg
reg, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
other
        let
            off :: Imm
off  = Int -> Imm
ImmInt 0
        Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> InstrBlock -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg Imm
off) InstrBlock
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 mop :: MachOp
mop [x :: CmmExpr
x, y :: CmmExpr
y])
  = do
    case MachOp
mop of
      MO_F_Eq W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
EQQ CmmExpr
x CmmExpr
y
      MO_F_Ne W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
NE  CmmExpr
x CmmExpr
y
      MO_F_Gt W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
GTT CmmExpr
x CmmExpr
y
      MO_F_Ge W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
GE  CmmExpr
x CmmExpr
y
      MO_F_Lt W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
LTT CmmExpr
x CmmExpr
y
      MO_F_Le W32 -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
LE  CmmExpr
x CmmExpr
y

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

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

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

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

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

getCondCode _ = String -> NatM CondCode
forall a. String -> a
panic "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
cond width :: Width
width x :: CmmExpr
x y :: CmmExpr
y = do
  DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode' (Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags)) Cond
cond Width
width CmmExpr
x CmmExpr
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' True cond :: Cond
cond W64 x :: CmmExpr
x y :: CmmExpr
y
  | Cond -> Bool
condUnsigned Cond
cond
  = do
      ChildCode64 code_x :: InstrBlock
code_x x_lo :: Reg
x_lo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
x
      ChildCode64 code_y :: InstrBlock
code_y y_lo :: Reg
y_lo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
y
      let x_hi :: Reg
x_hi = Reg -> Reg
getHiVRegFromLo Reg
x_lo
          y_hi :: Reg
y_hi = Reg -> Reg
getHiVRegFromLo Reg
y_lo
      BlockId
end_lbl <- NatM BlockId
getBlockIdNat
      let code :: InstrBlock
code = InstrBlock
code_x InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code_y InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
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
                 ]
      CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> InstrBlock -> CondCode
CondCode Bool
False Cond
cond InstrBlock
code)
  | Bool
otherwise
  = do
      ChildCode64 code_x :: InstrBlock
code_x x_lo :: Reg
x_lo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
x
      ChildCode64 code_y :: InstrBlock
code_y y_lo :: Reg
y_lo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
y
      let x_hi :: Reg
x_hi = Reg -> Reg
getHiVRegFromLo Reg
x_lo
          y_hi :: Reg
y_hi = Reg -> Reg
getHiVRegFromLo Reg
y_lo
      BlockId
end_lbl <- NatM BlockId
getBlockIdNat
      BlockId
cmp_lo  <- NatM BlockId
getBlockIdNat
      let code :: InstrBlock
code = InstrBlock
code_x InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code_y InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
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 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
                 ]
      CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> InstrBlock -> CondCode
CondCode Bool
False Cond
cond InstrBlock
code)

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

condIntCode' _ cond :: Cond
cond width :: Width
width x :: CmmExpr
x (CmmLit (CmmInt y :: Integer
y rep :: Width
rep))
  | Just src2 :: 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 = Width -> Width -> CmmExpr -> CmmExpr
extendSExpr Width
width Width
op_len
      (src1 :: Reg
src1, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (CmmExpr -> CmmExpr
extend CmmExpr
x)
      let format :: Format
format = Width -> Format
intFormat Width
op_len
          code' :: InstrBlock
code' = InstrBlock
code InstrBlock -> Instr -> InstrBlock
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)
      CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> InstrBlock -> CondCode
CondCode Bool
False Cond
cond InstrBlock
code')

condIntCode' _ cond :: Cond
cond width :: Width
width x :: CmmExpr
x y :: 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 :: Reg
src1, code1 :: InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (CmmExpr -> CmmExpr
extend CmmExpr
x)
  (src2 :: Reg
src2, code2 :: InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (CmmExpr -> CmmExpr
extend CmmExpr
y)
  let format :: Format
format = Width -> Format
intFormat Width
op_len
      code' :: InstrBlock
code' = InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2 InstrBlock -> Instr -> InstrBlock
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)
  CondCode -> NatM CondCode
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> InstrBlock -> CondCode
CondCode Bool
False Cond
cond InstrBlock
code')

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

-- dst is a reg, but src could be anything
assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_IntCode _ reg :: CmmReg
reg src :: CmmExpr
src
    = do
        DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        let dst :: Reg
dst = Platform -> CmmReg -> Reg
getRegisterReg (DynFlags -> Platform
targetPlatform DynFlags
dflags) CmmReg
reg
        Register
r <- CmmExpr -> NatM Register
getRegister CmmExpr
src
        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ case Register
r of
            Any _ code :: Reg -> InstrBlock
code         -> Reg -> InstrBlock
code Reg
dst
            Fixed _ freg :: Reg
freg fcode :: InstrBlock
fcode -> InstrBlock
fcode InstrBlock -> Instr -> InstrBlock
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 InstrBlock
assignMem_FltCode = Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_IntCode
assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_FltCode = Format -> CmmReg -> CmmExpr -> NatM InstrBlock
assignReg_IntCode



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

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

genJump tree :: CmmExpr
tree
  = do
        DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        CmmExpr -> GenCCallPlatform -> NatM InstrBlock
genJump' CmmExpr
tree (Platform -> GenCCallPlatform
platformToGCP (DynFlags -> Platform
targetPlatform DynFlags
dflags))

genJump' :: CmmExpr -> GenCCallPlatform -> NatM InstrBlock

genJump' :: CmmExpr -> GenCCallPlatform -> NatM InstrBlock
genJump' tree :: CmmExpr
tree (GCP64ELF 1)
  = do
        (target :: Reg
target,code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
tree
        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock
code
               InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II64 Reg
r11 (Reg -> Imm -> AddrMode
AddrRegImm Reg
target (Int -> Imm
ImmInt 0))
               InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II64 Reg
toc (Reg -> Imm -> AddrMode
AddrRegImm Reg
target (Int -> Imm
ImmInt 8))
               InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
MTCTR Reg
r11
               InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Reg -> AddrMode -> Instr
LD Format
II64 Reg
r11 (Reg -> Imm -> AddrMode
AddrRegImm Reg
target (Int -> Imm
ImmInt 16))
               InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` [Maybe BlockId] -> Maybe CLabel -> Instr
BCTR [] Maybe CLabel
forall a. Maybe a
Nothing)

genJump' tree :: CmmExpr
tree (GCP64ELF 2)
  = do
        (target :: Reg
target,code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
tree
        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock
code
               InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
MR Reg
r12 Reg
target
               InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
MTCTR Reg
r12
               InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` [Maybe BlockId] -> Maybe CLabel -> Instr
BCTR [] Maybe CLabel
forall a. Maybe a
Nothing)

genJump' tree :: CmmExpr
tree _
  = do
        (target :: Reg
target,code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
tree
        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock
code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
MTCTR Reg
target InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` [Maybe BlockId] -> Maybe CLabel -> Instr
BCTR [] Maybe CLabel
forall a. Maybe a
Nothing)

-- -----------------------------------------------------------------------------
--  Unconditional branches
genBranch :: BlockId -> NatM InstrBlock
genBranch :: BlockId -> NatM InstrBlock
genBranch = InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock)
-> (BlockId -> InstrBlock) -> BlockId -> NatM InstrBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL ([Instr] -> InstrBlock)
-> (BlockId -> [Instr]) -> BlockId -> InstrBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockId -> [Instr]
forall instr. Instruction instr => 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 InstrBlock
genCondJump id :: BlockId
id bool :: CmmExpr
bool prediction :: Maybe Bool
prediction = do
  CondCode _ cond :: Cond
cond code :: InstrBlock
code <- CmmExpr -> NatM CondCode
getCondCode CmmExpr
bool
  InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock
code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
cond BlockId
id Maybe Bool
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 InstrBlock
genCCall (PrimTarget MO_ReadBarrier) _ _
 = InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ Instr -> InstrBlock
forall a. a -> OrdList a
unitOL Instr
LWSYNC
genCCall (PrimTarget MO_WriteBarrier) _ _
 = InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ Instr -> InstrBlock
forall a. a -> OrdList a
unitOL Instr
LWSYNC

genCCall (PrimTarget MO_Touch) _ _
 = InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
forall a. OrdList a
nilOL

genCCall (PrimTarget (MO_Prefetch_Data _)) _ _
 = InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
forall a. OrdList a
nilOL

genCCall (PrimTarget (MO_AtomicRMW width :: Width
width amop :: AtomicMachOp
amop)) [dst :: CmmFormal
dst] [addr :: CmmExpr
addr, n :: CmmExpr
n]
 = do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
          fmt :: Format
fmt      = Width -> Format
intFormat Width
width
          reg_dst :: Reg
reg_dst  = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
      (instr :: Instr
instr, n_code :: InstrBlock
n_code) <- case AtomicMachOp
amop of
            AMO_Add  -> (Reg -> Reg -> RI -> Instr)
-> Bool -> Reg -> NatM (Instr, InstrBlock)
getSomeRegOrImm Reg -> Reg -> RI -> Instr
ADD Bool
True Reg
reg_dst
            AMO_Sub  -> case CmmExpr
n of
                CmmLit (CmmInt i :: Integer
i _)
                  | Just imm :: Imm
imm <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
width Bool
True (-Integer
i)
                   -> (Instr, InstrBlock) -> NatM (Instr, InstrBlock)
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), InstrBlock
forall a. OrdList a
nilOL)
                _
                   -> do
                         (n_reg :: Reg
n_reg, n_code :: InstrBlock
n_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
n
                         (Instr, InstrBlock) -> NatM (Instr, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return  (Reg -> Reg -> Reg -> Instr
SUBF Reg
reg_dst Reg
n_reg Reg
reg_dst, InstrBlock
n_code)
            AMO_And  -> (Reg -> Reg -> RI -> Instr)
-> Bool -> Reg -> NatM (Instr, InstrBlock)
getSomeRegOrImm Reg -> Reg -> RI -> Instr
AND Bool
False Reg
reg_dst
            AMO_Nand -> do (n_reg :: Reg
n_reg, n_code :: InstrBlock
n_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
n
                           (Instr, InstrBlock) -> NatM (Instr, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Reg -> Reg -> Instr
NAND Reg
reg_dst Reg
reg_dst Reg
n_reg, InstrBlock
n_code)
            AMO_Or   -> (Reg -> Reg -> RI -> Instr)
-> Bool -> Reg -> NatM (Instr, InstrBlock)
getSomeRegOrImm Reg -> Reg -> RI -> Instr
OR Bool
False Reg
reg_dst
            AMO_Xor  -> (Reg -> Reg -> RI -> Instr)
-> Bool -> Reg -> NatM (Instr, InstrBlock)
getSomeRegOrImm Reg -> Reg -> RI -> Instr
XOR Bool
False Reg
reg_dst
      Amode addr_reg :: AddrMode
addr_reg addr_code :: InstrBlock
addr_code <- CmmExpr -> NatM Amode
getAmodeIndex CmmExpr
addr
      BlockId
lbl_retry <- NatM BlockId
getBlockIdNat
      InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
n_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
addr_code
        InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
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
fmt Reg
reg_dst AddrMode
addr_reg
                     , Instr
instr
                     , Format -> Reg -> AddrMode -> Instr
STC Format
fmt Reg
reg_dst AddrMode
addr_reg
                     , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
lbl_retry (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
                     , Instr
ISYNC
                     ]
         where
           getAmodeIndex :: CmmExpr -> NatM Amode
getAmodeIndex (CmmMachOp (MO_Add _) [x :: CmmExpr
x, y :: CmmExpr
y])
             = do
                 (regX :: Reg
regX, codeX :: InstrBlock
codeX) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
                 (regY :: Reg
regY, codeY :: InstrBlock
codeY) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y
                 Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> InstrBlock -> Amode
Amode (Reg -> Reg -> AddrMode
AddrRegReg Reg
regX Reg
regY) (InstrBlock
codeX InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
codeY))
           getAmodeIndex other :: CmmExpr
other
             = do
                 (reg :: Reg
reg, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
other
                 Amode -> NatM Amode
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> InstrBlock -> Amode
Amode (Reg -> Reg -> AddrMode
AddrRegReg Reg
r0 Reg
reg) InstrBlock
code) -- NB: r0 is 0 here!
           getSomeRegOrImm :: (Reg -> Reg -> RI -> Instr)
-> Bool -> Reg -> NatM (Instr, InstrBlock)
getSomeRegOrImm op :: Reg -> Reg -> RI -> Instr
op sign :: Bool
sign dst :: Reg
dst
             = case CmmExpr
n of
                 CmmLit (CmmInt i :: Integer
i _) | Just imm :: Imm
imm <- Width -> Bool -> Integer -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
width Bool
sign Integer
i
                    -> (Instr, InstrBlock) -> NatM (Instr, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg -> Reg -> RI -> Instr
op Reg
dst Reg
dst (Imm -> RI
RIImm Imm
imm), InstrBlock
forall a. OrdList a
nilOL)
                 _
                    -> do
                          (n_reg :: Reg
n_reg, n_code :: InstrBlock
n_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
n
                          (Instr, InstrBlock) -> NatM (Instr, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return  (Reg -> Reg -> RI -> Instr
op Reg
dst Reg
dst (Reg -> RI
RIReg Reg
n_reg), InstrBlock
n_code)

genCCall (PrimTarget (MO_AtomicRead width :: Width
width)) [dst :: CmmFormal
dst] [addr :: CmmExpr
addr]
 = do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
          fmt :: Format
fmt      = Width -> Format
intFormat Width
width
          reg_dst :: Reg
reg_dst  = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
          form :: InstrForm
form     = if Width -> Int
widthInBits Width
width Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 64 then InstrForm
DS else InstrForm
D
      Amode addr_reg :: AddrMode
addr_reg addr_code :: InstrBlock
addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
form CmmExpr
addr
      BlockId
lbl_end <- NatM BlockId
getBlockIdNat
      InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
addr_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [ Instr
HWSYNC
                                      , Format -> Reg -> AddrMode -> Instr
LD Format
fmt Reg
reg_dst AddrMode
addr_reg
                                      , Format -> Reg -> RI -> Instr
CMP Format
fmt Reg
reg_dst (Reg -> RI
RIReg Reg
reg_dst)
                                      , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
lbl_end (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
                                      , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl_end Maybe Bool
forall a. Maybe a
Nothing
                            -- See Note [Seemingly useless cmp and bne]
                                      , BlockId -> Instr
NEWBLOCK BlockId
lbl_end
                                      , Instr
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
width)) [] [addr :: CmmExpr
addr, val :: CmmExpr
val] = do
    InstrBlock
code <- Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_IntCode (Width -> Format
intFormat Width
width) CmmExpr
addr CmmExpr
val
    InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ Instr -> InstrBlock
forall a. a -> OrdList a
unitOL(Instr
HWSYNC) InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code

genCCall (PrimTarget (MO_Clz width :: Width
width)) [dst :: CmmFormal
dst] [src :: CmmExpr
src]
 = do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
          reg_dst :: Reg
reg_dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
      if Platform -> Bool
target32Bit Platform
platform Bool -> Bool -> Bool
&& Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64
        then do
          ChildCode64 code :: InstrBlock
code vr_lo :: Reg
vr_lo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
src
          BlockId
lbl1 <- NatM BlockId
getBlockIdNat
          BlockId
lbl2 <- NatM BlockId
getBlockIdNat
          BlockId
lbl3 <- NatM BlockId
getBlockIdNat
          let vr_hi :: Reg
vr_hi = Reg -> Reg
getHiVRegFromLo Reg
vr_lo
              cntlz :: InstrBlock
cntlz = [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [ Format -> Reg -> RI -> Instr
CMPL Format
II32 Reg
vr_hi (Imm -> RI
RIImm (Int -> Imm
ImmInt 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 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
                           ]
          InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
cntlz
        else do
          let format :: Format
format = if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 then Format
II64 else Format
II32
          (s_reg :: Reg
s_reg, s_code :: InstrBlock
s_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
src
          (pre :: InstrBlock
pre, reg :: Reg
reg , post :: InstrBlock
post) <-
            case Width
width of
              W64 -> (InstrBlock, Reg, InstrBlock) -> NatM (InstrBlock, Reg, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock
forall a. OrdList a
nilOL, Reg
s_reg, InstrBlock
forall a. OrdList a
nilOL)
              W32 -> (InstrBlock, Reg, InstrBlock) -> NatM (InstrBlock, Reg, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock
forall a. OrdList a
nilOL, Reg
s_reg, InstrBlock
forall a. OrdList a
nilOL)
              W16 -> do
                Reg
reg_tmp <- Format -> NatM Reg
getNewRegNat Format
format
                (InstrBlock, Reg, InstrBlock) -> NatM (InstrBlock, Reg, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return
                  ( Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Instr -> InstrBlock) -> Instr -> InstrBlock
forall a b. (a -> b) -> a -> b
$ Reg -> Reg -> RI -> Instr
AND Reg
reg_tmp Reg
s_reg (Imm -> RI
RIImm (Int -> Imm
ImmInt 65535))
                  , Reg
reg_tmp
                  , Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Instr -> InstrBlock) -> Instr -> InstrBlock
forall a b. (a -> b) -> a -> b
$ Reg -> Reg -> RI -> Instr
ADD Reg
reg_dst Reg
reg_dst (Imm -> RI
RIImm (Int -> Imm
ImmInt (-16)))
                  )
              W8  -> do
                Reg
reg_tmp <- Format -> NatM Reg
getNewRegNat Format
format
                (InstrBlock, Reg, InstrBlock) -> NatM (InstrBlock, Reg, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return
                  ( Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Instr -> InstrBlock) -> Instr -> InstrBlock
forall a b. (a -> b) -> a -> b
$ Reg -> Reg -> RI -> Instr
AND Reg
reg_tmp Reg
s_reg (Imm -> RI
RIImm (Int -> Imm
ImmInt 255))
                  , Reg
reg_tmp
                  , Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Instr -> InstrBlock) -> Instr -> InstrBlock
forall a b. (a -> b) -> a -> b
$ Reg -> Reg -> RI -> Instr
ADD Reg
reg_dst Reg
reg_dst (Imm -> RI
RIImm (Int -> Imm
ImmInt (-24)))
                  )
              _   -> String -> NatM (InstrBlock, Reg, InstrBlock)
forall a. String -> a
panic "genCall: Clz wrong format"
          let cntlz :: InstrBlock
cntlz = Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Format -> Reg -> Reg -> Instr
CNTLZ Format
format Reg
reg_dst Reg
reg)
          InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
s_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
pre InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
cntlz InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
post

genCCall (PrimTarget (MO_Ctz width :: Width
width)) [dst :: CmmFormal
dst] [src :: CmmExpr
src]
 = do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
      let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
          reg_dst :: Reg
reg_dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dst)
      if Platform -> Bool
target32Bit Platform
platform Bool -> Bool -> Bool
&& Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64
        then do
          let format :: Format
format = Format
II32
          ChildCode64 code :: InstrBlock
code vr_lo :: Reg
vr_lo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
src
          BlockId
lbl1 <- NatM BlockId
getBlockIdNat
          BlockId
lbl2 <- NatM BlockId
getBlockIdNat
          BlockId
lbl3 <- NatM BlockId
getBlockIdNat
          Reg
x' <- Format -> NatM Reg
getNewRegNat Format
format
          Reg
x'' <- Format -> NatM Reg
getNewRegNat Format
format
          Reg
r' <- Format -> NatM Reg
getNewRegNat Format
format
          InstrBlock
cnttzlo <- Format -> Reg -> Reg -> NatM InstrBlock
cnttz Format
format Reg
reg_dst Reg
vr_lo
          let vr_hi :: Reg
vr_hi = Reg -> Reg
getHiVRegFromLo Reg
vr_lo
              cnttz64 :: InstrBlock
cnttz64 = [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [ Format -> Reg -> RI -> Instr
CMPL Format
format Reg
vr_lo (Imm -> RI
RIImm (Int -> Imm
ImmInt 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 (-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 64))
                             , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl3 Maybe Bool
forall a. Maybe a
Nothing

                             , BlockId -> Instr
NEWBLOCK BlockId
lbl2
                             ]
                        InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
cnttzlo InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                        [Instr] -> InstrBlock
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
                             ]
          InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
cnttz64
        else do
          let format :: Format
format = if Width
width Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W64 then Format
II64 else Format
II32
          (s_reg :: Reg
s_reg, s_code :: InstrBlock
s_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
src
          (reg_ctz :: Reg
reg_ctz, pre_code :: InstrBlock
pre_code) <-
            case Width
width of
              W64 -> (Reg, InstrBlock) -> NatM (Reg, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
s_reg, InstrBlock
forall a. OrdList a
nilOL)
              W32 -> (Reg, InstrBlock) -> NatM (Reg, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
s_reg, InstrBlock
forall a. OrdList a
nilOL)
              W16 -> do
                Reg
reg_tmp <- Format -> NatM Reg
getNewRegNat Format
format
                (Reg, InstrBlock) -> NatM (Reg, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg_tmp, Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Instr -> InstrBlock) -> Instr -> InstrBlock
forall a b. (a -> b) -> a -> b
$ Reg -> Reg -> Imm -> Instr
ORIS Reg
reg_tmp Reg
s_reg (Int -> Imm
ImmInt 1))
              W8  -> do
                Reg
reg_tmp <- Format -> NatM Reg
getNewRegNat Format
format
                (Reg, InstrBlock) -> NatM (Reg, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg_tmp, Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Instr -> InstrBlock) -> Instr -> InstrBlock
forall a b. (a -> b) -> a -> b
$ Reg -> Reg -> RI -> Instr
OR Reg
reg_tmp Reg
s_reg (Imm -> RI
RIImm (Int -> Imm
ImmInt 256)))
              _   -> String -> NatM (Reg, InstrBlock)
forall a. String -> a
panic "genCall: Ctz wrong format"
          InstrBlock
ctz_code <- Format -> Reg -> Reg -> NatM InstrBlock
cnttz Format
format Reg
reg_dst Reg
reg_ctz
          InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
s_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
pre_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
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 InstrBlock
cnttz format :: Format
format dst :: Reg
dst src :: Reg
src = do
            let format_bits :: Int
format_bits = 8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Format -> Int
formatInBytes Format
format
            Reg
x' <- Format -> NatM Reg
getNewRegNat Format
format
            Reg
x'' <- Format -> NatM Reg
getNewRegNat Format
format
            Reg
r' <- Format -> NatM Reg
getNewRegNat Format
format
            InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [ Reg -> Reg -> RI -> Instr
ADD Reg
x' Reg
src (Imm -> RI
RIImm (Int -> Imm
ImmInt (-1)))
                          , Reg -> Reg -> Reg -> Instr
ANDC Reg
x'' Reg
x' Reg
src
                          , Format -> Reg -> Reg -> Instr
CNTLZ Format
format Reg
r' Reg
x''
                          , Reg -> Reg -> RI -> Instr
SUBFC Reg
dst Reg
r' (Imm -> RI
RIImm (Int -> Imm
ImmInt (Int
format_bits)))
                          ]

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

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

                                   , BlockId -> Instr
NEWBLOCK BlockId
again1
                                     -- if (q1 >= b || q1*vn0 > b*rhat + un1)
                                   , Format -> Reg -> RI -> Instr
CMPL Format
fmt Reg
q1 (Reg -> RI
RIReg Reg
b)
                                   , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
GEU BlockId
then1 Maybe Bool
forall a. Maybe a
Nothing
                                   , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
no1 Maybe Bool
forall a. Maybe a
Nothing

                                   , BlockId -> Instr
NEWBLOCK BlockId
no1
                                   , Format -> Reg -> Reg -> RI -> Instr
MULL Format
fmt Reg
tmp Reg
q1 (Reg -> RI
RIReg Reg
vn0)
                                   , Format -> Reg -> Reg -> RI -> Instr
SL Format
fmt Reg
tmp1 Reg
rhat (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
half))
                                   , Reg -> Reg -> RI -> Instr
ADD Reg
tmp1 Reg
tmp1 (Reg -> RI
RIReg Reg
un1)
                                   , Format -> Reg -> RI -> Instr
CMPL Format
fmt Reg
tmp (Reg -> RI
RIReg Reg
tmp1)
                                   , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
LEU BlockId
endif1 Maybe Bool
forall a. Maybe a
Nothing
                                   , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
then1 Maybe Bool
forall a. Maybe a
Nothing

                                   , BlockId -> Instr
NEWBLOCK BlockId
then1
                                     -- q1 = q1 - 1
                                   , Reg -> Reg -> RI -> Instr
ADD Reg
q1 Reg
q1 (Imm -> RI
RIImm (Int -> Imm
ImmInt (-1)))
                                     -- rhat = rhat + vn1
                                   , Reg -> Reg -> RI -> Instr
ADD Reg
rhat Reg
rhat (Reg -> RI
RIReg Reg
vn1)
                                     -- if (rhat < b) goto again1
                                   , Format -> Reg -> RI -> Instr
CMPL Format
fmt Reg
rhat (Reg -> RI
RIReg Reg
b)
                                   , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
LTT BlockId
again1 Maybe Bool
forall a. Maybe a
Nothing
                                   , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
endif1 Maybe Bool
forall a. Maybe a
Nothing

                                   , BlockId -> Instr
NEWBLOCK BlockId
endif1
                                     -- un21 = un32*b + un1 - q1*v
                                   , Format -> Reg -> Reg -> RI -> Instr
SL Format
fmt Reg
un21 Reg
un32 (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
half))
                                   , Reg -> Reg -> RI -> Instr
ADD Reg
un21 Reg
un21 (Reg -> RI
RIReg Reg
un1)
                                   , Format -> Reg -> Reg -> RI -> Instr
MULL Format
fmt Reg
tmp Reg
q1 (Reg -> RI
RIReg Reg
v)
                                   , Reg -> Reg -> Reg -> Instr
SUBF Reg
un21 Reg
tmp Reg
un21
                                     -- compute second quotient digit
                                     -- q0 = un21/vn1
                                   , Format -> Bool -> Reg -> Reg -> Reg -> Instr
DIV Format
fmt Bool
False Reg
q0 Reg
un21 Reg
vn1
                                     -- rhat = un21- q0*vn1
                                   , Format -> Reg -> Reg -> RI -> Instr
MULL Format
fmt Reg
tmp Reg
q0 (Reg -> RI
RIReg Reg
vn1)
                                   , Reg -> Reg -> Reg -> Instr
SUBF Reg
rhat Reg
tmp Reg
un21
                                   , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
again2 Maybe Bool
forall a. Maybe a
Nothing

                                   , BlockId -> Instr
NEWBLOCK BlockId
again2
                                     -- if (q0>b || q0*vn0 > b*rhat + un0)
                                   , Format -> Reg -> RI -> Instr
CMPL Format
fmt Reg
q0 (Reg -> RI
RIReg Reg
b)
                                   , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
GEU BlockId
then2 Maybe Bool
forall a. Maybe a
Nothing
                                   , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
no2 Maybe Bool
forall a. Maybe a
Nothing

                                   , BlockId -> Instr
NEWBLOCK BlockId
no2
                                   , Format -> Reg -> Reg -> RI -> Instr
MULL Format
fmt Reg
tmp Reg
q0 (Reg -> RI
RIReg Reg
vn0)
                                   , Format -> Reg -> Reg -> RI -> Instr
SL Format
fmt Reg
tmp1 Reg
rhat (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
half))
                                   , Reg -> Reg -> RI -> Instr
ADD Reg
tmp1 Reg
tmp1 (Reg -> RI
RIReg Reg
un0)
                                   , Format -> Reg -> RI -> Instr
CMPL Format
fmt Reg
tmp (Reg -> RI
RIReg Reg
tmp1)
                                   , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
LEU BlockId
endif2 Maybe Bool
forall a. Maybe a
Nothing
                                   , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
then2 Maybe Bool
forall a. Maybe a
Nothing

                                   , BlockId -> Instr
NEWBLOCK BlockId
then2
                                     -- q0 = q0 - 1
                                   , Reg -> Reg -> RI -> Instr
ADD Reg
q0 Reg
q0 (Imm -> RI
RIImm (Int -> Imm
ImmInt (-1)))
                                     -- rhat = rhat + vn1
                                   , Reg -> Reg -> RI -> Instr
ADD Reg
rhat Reg
rhat (Reg -> RI
RIReg Reg
vn1)
                                     -- if (rhat<b) goto again2
                                   , Format -> Reg -> RI -> Instr
CMPL Format
fmt Reg
rhat (Reg -> RI
RIReg Reg
b)
                                   , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
LTT BlockId
again2 Maybe Bool
forall a. Maybe a
Nothing
                                   , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
endif2 Maybe Bool
forall a. Maybe a
Nothing

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

              addcOp :: Platform -> [CmmFormal] -> [CmmExpr] -> NatM InstrBlock
addcOp platform :: Platform
platform [res_r :: CmmFormal
res_r, res_c :: CmmFormal
res_c] [arg_x :: CmmExpr
arg_x, arg_y :: CmmExpr
arg_y]
                = Platform -> [CmmFormal] -> [CmmExpr] -> NatM InstrBlock
add2Op Platform
platform [CmmFormal
res_c {-hi-}, CmmFormal
res_r {-lo-}] [CmmExpr
arg_x, CmmExpr
arg_y]
              addcOp _ _ _
                = String -> NatM InstrBlock
forall a. String -> a
panic "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 :: Platform -> [CmmFormal] -> [CmmExpr] -> NatM InstrBlock
subcOp platform :: Platform
platform [res_r :: CmmFormal
res_r, res_c :: CmmFormal
res_c] [arg_x :: CmmExpr
arg_x, arg_y :: CmmExpr
arg_y]
                = do let reg_r :: Reg
reg_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_r)
                         reg_c :: Reg
reg_c = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_c)
                     (x_reg :: Reg
x_reg, x_code :: InstrBlock
x_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
arg_x
                     (y_reg :: Reg
y_reg, y_code :: InstrBlock
y_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
arg_y
                     InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
y_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
x_code
                            InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [ Reg -> Imm -> Instr
LI Reg
reg_c (Int -> Imm
ImmInt 0)
                                         , Reg -> Reg -> RI -> Instr
SUBFC Reg
reg_r Reg
y_reg (Reg -> RI
RIReg Reg
x_reg)
                                         , Reg -> Reg -> Instr
ADDZE Reg
reg_c Reg
reg_c
                                         , Reg -> Reg -> RI -> Instr
XOR Reg
reg_c Reg
reg_c (Imm -> RI
RIImm (Int -> Imm
ImmInt 1))
                                         ]
              subcOp _ _ _
                = String -> NatM InstrBlock
forall a. String -> a
panic "genCCall: Wrong number of arguments/results for subc"
              addSubCOp :: (Reg -> Reg -> Reg -> Instr)
-> Platform -> Width -> [CmmFormal] -> [CmmExpr] -> NatM InstrBlock
addSubCOp instr :: Reg -> Reg -> Reg -> Instr
instr platform :: Platform
platform width :: Width
width [res_r :: CmmFormal
res_r, res_c :: CmmFormal
res_c] [arg_x :: CmmExpr
arg_x, arg_y :: CmmExpr
arg_y]
                = do let reg_r :: Reg
reg_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_r)
                         reg_c :: Reg
reg_c = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
res_c)
                     (x_reg :: Reg
x_reg, x_code :: InstrBlock
x_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
arg_x
                     (y_reg :: Reg
y_reg, y_code :: InstrBlock
y_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
arg_y
                     InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
y_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
x_code
                            InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [ Reg -> Reg -> Reg -> Instr
instr Reg
reg_r Reg
y_reg Reg
x_reg,
                                           -- SUBFO argument order reversed!
                                           Format -> Reg -> Instr
MFOV (Width -> Format
intFormat Width
width) Reg
reg_c
                                         ]
              addSubCOp _ _ _ _ _
                = String -> NatM InstrBlock
forall a. String -> a
panic "genCall: Wrong number of arguments/results for addC"
              fabs :: Platform -> [CmmFormal] -> [CmmExpr] -> NatM InstrBlock
fabs platform :: Platform
platform [res :: CmmFormal
res] [arg :: CmmExpr
arg]
                = do let res_r :: Reg
res_r = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
res)
                     (arg_reg :: Reg
arg_reg, arg_code :: InstrBlock
arg_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
arg
                     InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (InstrBlock -> NatM InstrBlock) -> InstrBlock -> NatM InstrBlock
forall a b. (a -> b) -> a -> b
$ InstrBlock
arg_code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
FABS Reg
res_r Reg
arg_reg
              fabs _ _ _
                = String -> NatM InstrBlock
forall a. String -> a
panic "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
platform
  = case Platform -> OS
platformOS Platform
platform of
      OSAIX    -> GenCCallPlatform
GCPAIX
      _ -> case Platform -> Arch
platformArch Platform
platform of
             ArchPPC           -> GenCCallPlatform
GCP32ELF
             ArchPPC_64 ELF_V1 -> Int -> GenCCallPlatform
GCP64ELF 1
             ArchPPC_64 ELF_V2 -> Int -> GenCCallPlatform
GCP64ELF 2
             _ -> String -> GenCCallPlatform
forall a. String -> a
panic "platformToGCP: Not PowerPC"


genCCall'
    :: DynFlags
    -> 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' :: DynFlags
-> GenCCallPlatform
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> NatM InstrBlock
genCCall' dflags :: DynFlags
dflags gcp :: GenCCallPlatform
gcp target :: ForeignTarget
target dest_regs :: [CmmFormal]
dest_regs args :: [CmmExpr]
args
  = do
        (finalStack :: Int
finalStack,passArgumentsCode :: InstrBlock
passArgumentsCode,usedRegs :: [Reg]
usedRegs) <- [(CmmExpr, CmmType, ForeignHint)]
-> [Reg]
-> [Reg]
-> Int
-> InstrBlock
-> [Reg]
-> NatM (Int, InstrBlock, [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
                                                   InstrBlock
forall a. OrdList a
nilOL []

        (labelOrExpr :: Either CLabel CmmExpr
labelOrExpr, reduceToFF32 :: Bool
reduceToFF32) <- case ForeignTarget
target of
            ForeignTarget (CmmLit (CmmLabel lbl :: CLabel
lbl)) _ -> do
                NatM ()
uses_pic_base_implicitly
                (Either CLabel CmmExpr, Bool) -> NatM (Either CLabel CmmExpr, Bool)
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 expr :: CmmExpr
expr _ -> do
                NatM ()
uses_pic_base_implicitly
                (Either CLabel CmmExpr, Bool) -> NatM (Either CLabel CmmExpr, Bool)
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 mop :: CallishMachOp
mop -> CallishMachOp -> NatM (Either CLabel CmmExpr, Bool)
forall (m :: * -> *).
(HasDynFlags m, CmmMakeDynamicReferenceM m) =>
CallishMachOp -> m (Either CLabel CmmExpr, Bool)
outOfLineMachOp CallishMachOp
mop

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

        case Either CLabel CmmExpr
labelOrExpr of
            Left lbl :: CLabel
lbl -> do -- the linker does all the work for us
                InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return (         InstrBlock
codeBefore
                        InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` CLabel -> [Reg] -> Instr
BL CLabel
lbl [Reg]
usedRegs
                        InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  InstrBlock
maybeNOP -- some ABI require a NOP after BL
                        InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  InstrBlock
codeAfter)
            Right dyn :: CmmExpr
dyn -> do -- implement call through function pointer
                (dynReg :: Reg
dynReg, dynCode :: InstrBlock
dynCode) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
dyn
                case GenCCallPlatform
gcp of
                     GCP64ELF 1      -> InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return ( InstrBlock
dynCode
                       InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  InstrBlock
codeBefore
                       InstrBlock -> Instr -> InstrBlock
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 40))
                       InstrBlock -> Instr -> InstrBlock
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 0))
                       InstrBlock -> Instr -> InstrBlock
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 8))
                       InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
MTCTR Reg
r11
                       InstrBlock -> Instr -> InstrBlock
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 16))
                       InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` [Reg] -> Instr
BCTRL [Reg]
usedRegs
                       InstrBlock -> Instr -> InstrBlock
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 40))
                       InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  InstrBlock
codeAfter)
                     GCP64ELF 2      -> InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return ( InstrBlock
dynCode
                       InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  InstrBlock
codeBefore
                       InstrBlock -> Instr -> InstrBlock
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 24))
                       InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
MR Reg
r12 Reg
dynReg
                       InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
MTCTR Reg
r12
                       InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` [Reg] -> Instr
BCTRL [Reg]
usedRegs
                       InstrBlock -> Instr -> InstrBlock
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 24))
                       InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  InstrBlock
codeAfter)
                     GCPAIX          -> InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return ( InstrBlock
dynCode
                       -- AIX/XCOFF follows the PowerOPEN ABI
                       -- which is quite similiar to LinuxPPC64/ELFv1
                       InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  InstrBlock
codeBefore
                       InstrBlock -> Instr -> InstrBlock
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 20))
                       InstrBlock -> Instr -> InstrBlock
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 0))
                       InstrBlock -> Instr -> InstrBlock
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 4))
                       InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
MTCTR Reg
r11
                       InstrBlock -> Instr -> InstrBlock
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 8))
                       InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` [Reg] -> Instr
BCTRL [Reg]
usedRegs
                       InstrBlock -> Instr -> InstrBlock
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 20))
                       InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  InstrBlock
codeAfter)
                     _               -> InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return ( InstrBlock
dynCode
                       InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
MTCTR Reg
dynReg
                       InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  InstrBlock
codeBefore
                       InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` [Reg] -> Instr
BCTRL [Reg]
usedRegs
                       InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`  InstrBlock
codeAfter)
    where
        platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags

        uses_pic_base_implicitly :: NatM ()
uses_pic_base_implicitly = do
            -- 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 (DynFlags -> Bool
positionIndependent DynFlags
dflags Bool -> Bool -> Bool
&& Platform -> Bool
target32Bit Platform
platform) (NatM () -> NatM ()) -> NatM () -> NatM ()
forall a b. (a -> b) -> a -> b
$ do
                Reg
_ <- Format -> NatM Reg
getPicBaseNat (Format -> NatM Reg) -> Format -> NatM Reg
forall a b. (a -> b) -> a -> b
$ Bool -> Format
archWordFormat Bool
True
                () -> NatM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        initialStackOffset :: Int
initialStackOffset = case GenCCallPlatform
gcp of
                             GCPAIX     -> 24
                             GCP32ELF   -> 8
                             GCP64ELF 1 -> 48
                             GCP64ELF 2 -> 32
                             _ -> String -> Int
forall a. String -> a
panic "genCall': unknown calling convention"
            -- size of linkage area + size of arguments, in bytes
        stackDelta :: Int -> Int
stackDelta finalStack :: Int
finalStack = case GenCCallPlatform
gcp of
                                GCPAIX ->
                                    Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo 16 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (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 32 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
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
                                GCP32ELF -> Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo 16 Int
finalStack
                                GCP64ELF 1 ->
                                    Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo 16 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (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 64 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
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 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 2 ->
                                    Int -> Int -> Int
forall a. Integral a => a -> a -> a
roundTo 16 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ (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 64 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
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 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
                                _ -> String -> Int
forall a. String -> a
panic "genCall': unknown calling conv."

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

        roundTo :: a -> a -> a
roundTo a :: a
a x :: 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
== 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 -> InstrBlock
move_sp_down finalStack :: Int
finalStack
               | Int
delta Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> DynFlags -> Int
stackFrameHeaderSize DynFlags
dflags =
                        [Instr] -> InstrBlock
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 = InstrBlock
forall a. OrdList a
nilOL
               where delta :: Int
delta = Int -> Int
stackDelta Int
finalStack
        move_sp_up :: Int -> InstrBlock
move_sp_up finalStack :: Int
finalStack
               | Int
delta Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> DynFlags -> Int
stackFrameHeaderSize DynFlags
dflags =
                        [Instr] -> InstrBlock
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 0]
               | Bool
otherwise = InstrBlock
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 :: InstrBlock
maybeNOP = case GenCCallPlatform
gcp of
           GCP32ELF        -> InstrBlock
forall a. OrdList a
nilOL
           -- See Section 3.9.4 of OpenPower ABI
           GCPAIX          -> Instr -> InstrBlock
forall a. a -> OrdList a
unitOL Instr
NOP
           -- See Section 3.5.11 of PPC64 ELF v1.9
           GCP64ELF 1      -> Instr -> InstrBlock
forall a. a -> OrdList a
unitOL Instr
NOP
           -- See Section 2.3.6 of PPC64 ELF v2
           GCP64ELF 2      -> Instr -> InstrBlock
forall a. a -> OrdList a
unitOL Instr
NOP
           _               -> String -> InstrBlock
forall a. String -> a
panic "maybeNOP: Unknown PowerPC 64-bit ABI"

        passArguments :: [(CmmExpr, CmmType, ForeignHint)]
-> [Reg]
-> [Reg]
-> Int
-> InstrBlock
-> [Reg]
-> NatM (Int, InstrBlock, [Reg])
passArguments [] _ _ stackOffset :: Int
stackOffset accumCode :: InstrBlock
accumCode accumUsed :: [Reg]
accumUsed = (Int, InstrBlock, [Reg]) -> NatM (Int, InstrBlock, [Reg])
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
stackOffset, InstrBlock
accumCode, [Reg]
accumUsed)
        passArguments ((arg :: CmmExpr
arg,arg_ty :: CmmType
arg_ty,_):args :: [(CmmExpr, CmmType, ForeignHint)]
args) gprs :: [Reg]
gprs fprs :: [Reg]
fprs stackOffset :: Int
stackOffset
               accumCode :: InstrBlock
accumCode accumUsed :: [Reg]
accumUsed | CmmType -> Bool
isWord64 CmmType
arg_ty
                                     Bool -> Bool -> Bool
&& Platform -> Bool
target32Bit (DynFlags -> Platform
targetPlatform DynFlags
dflags) =
            do
                ChildCode64 code :: InstrBlock
code vr_lo :: Reg
vr_lo <- CmmExpr -> NatM ChildCode64
iselExpr64 CmmExpr
arg
                let vr_hi :: Reg
vr_hi = Reg -> Reg
getHiVRegFromLo Reg
vr_lo

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

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

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

                stackOffset' :: Int
stackOffset' = case GenCCallPlatform
gcp of
                               GCPAIX ->
                                   -- The 32bit PowerOPEN ABI is happy with
                                   -- 32bit-alignment ...
                                   Int
stackOffset
                               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 8 Int
stackOffset
                                | Bool
otherwise ->
                                   Int
stackOffset
                               GCP64ELF _ ->
                                   -- 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 1      -> Int
stackOffset' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4
                         _               -> Int
stackOffset'
                     | Bool
otherwise = Int
stackOffset'

                stackSlot :: AddrMode
stackSlot = Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt Int
stackOffset'')
                (nGprs :: Int
nGprs, nFprs :: Int
nFprs, stackBytes :: Int
stackBytes, regs :: [Reg]
regs)
                    = case GenCCallPlatform
gcp of
                      GCPAIX ->
                          case CmmType -> Format
cmmTypeFormat CmmType
rep of
                          II8  -> (1, 0, 4, [Reg]
gprs)
                          II16 -> (1, 0, 4, [Reg]
gprs)
                          II32 -> (1, 0, 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/
                          FF32 -> (1, 1, 4, [Reg]
fprs)
                          FF64 -> (2, 1, 8, [Reg]
fprs)
                          II64 -> String -> (Int, Int, Int, [Reg])
forall a. String -> a
panic "genCCall' passArguments II64"
                          FF80 -> String -> (Int, Int, Int, [Reg])
forall a. String -> a
panic "genCCall' passArguments FF80"
                      GCP32ELF ->
                          case CmmType -> Format
cmmTypeFormat CmmType
rep of
                          II8  -> (1, 0, 4, [Reg]
gprs)
                          II16 -> (1, 0, 4, [Reg]
gprs)
                          II32 -> (1, 0, 4, [Reg]
gprs)
                          -- ... the SysV ABI doesn't.
                          FF32 -> (0, 1, 4, [Reg]
fprs)
                          FF64 -> (0, 1, 8, [Reg]
fprs)
                          II64 -> String -> (Int, Int, Int, [Reg])
forall a. String -> a
panic "genCCall' passArguments II64"
                          FF80 -> String -> (Int, Int, Int, [Reg])
forall a. String -> a
panic "genCCall' passArguments FF80"
                      GCP64ELF _ ->
                          case CmmType -> Format
cmmTypeFormat CmmType
rep of
                          II8  -> (1, 0, 8, [Reg]
gprs)
                          II16 -> (1, 0, 8, [Reg]
gprs)
                          II32 -> (1, 0, 8, [Reg]
gprs)
                          II64 -> (1, 0, 8, [Reg]
gprs)
                          -- The ELFv1 ABI requires that we skip a
                          -- corresponding number of GPRs when we use
                          -- the FPRs.
                          FF32 -> (1, 1, 8, [Reg]
fprs)
                          FF64 -> (1, 1, 8, [Reg]
fprs)
                          FF80 -> String -> (Int, Int, Int, [Reg])
forall a. String -> a
panic "genCCall' passArguments FF80"

        moveResult :: Bool -> InstrBlock
moveResult reduceToFF32 :: Bool
reduceToFF32 =
            case [CmmFormal]
dest_regs of
                [] -> InstrBlock
forall a. OrdList a
nilOL
                [dest :: CmmFormal
dest]
                    | Bool
reduceToFF32 Bool -> Bool -> Bool
&& CmmType -> Bool
isFloat32 CmmType
rep   -> Instr -> InstrBlock
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 -> InstrBlock
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 (DynFlags -> Platform
targetPlatform DynFlags
dflags)
                       -> [Instr] -> InstrBlock
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 -> InstrBlock
forall a. a -> OrdList a
unitOL (Reg -> Reg -> Instr
MR Reg
r_dest Reg
r3)
                    where rep :: CmmType
rep = DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags (CmmFormal -> CmmReg
CmmLocal CmmFormal
dest)
                          r_dest :: Reg
r_dest = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform (CmmFormal -> CmmReg
CmmLocal CmmFormal
dest)
                _ -> String -> InstrBlock
forall a. String -> a
panic "genCCall' moveResult: Bad dest_regs"

        outOfLineMachOp :: CallishMachOp -> m (Either CLabel CmmExpr, Bool)
outOfLineMachOp mop :: CallishMachOp
mop =
            do
                DynFlags
dflags <- m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
                CmmExpr
mopExpr <- DynFlags -> ReferenceKind -> CLabel -> m CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference DynFlags
dflags ReferenceKind
CallReference (CLabel -> m CmmExpr) -> CLabel -> m CmmExpr
forall a b. (a -> b) -> a -> b
$
                              FastString
-> Maybe Int -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
functionName Maybe Int
forall a. Maybe a
Nothing ForeignLabelSource
ForeignLabelInThisPackage FunctionOrData
IsFunction
                let mopLabelOrExpr :: Either CLabel CmmExpr
mopLabelOrExpr = case CmmExpr
mopExpr of
                        CmmLit (CmmLabel lbl :: CLabel
lbl) -> CLabel -> Either CLabel CmmExpr
forall a b. a -> Either a b
Left CLabel
lbl
                        _ -> CmmExpr -> Either CLabel CmmExpr
forall a b. b -> Either a b
Right CmmExpr
mopExpr
                (Either CLabel CmmExpr, Bool) -> m (Either CLabel CmmExpr, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either CLabel CmmExpr
mopLabelOrExpr, Bool
reduce)
            where
                (functionName :: FastString
functionName, reduce :: Bool
reduce) = case CallishMachOp
mop of
                    MO_F32_Exp   -> (String -> FastString
fsLit "exp", Bool
True)
                    MO_F32_Log   -> (String -> FastString
fsLit "log", Bool
True)
                    MO_F32_Sqrt  -> (String -> FastString
fsLit "sqrt", Bool
True)
                    MO_F32_Fabs  -> (FastString, Bool)
unsupported

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

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

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

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

                    MO_F64_Exp   -> (String -> FastString
fsLit "exp", Bool
False)
                    MO_F64_Log   -> (String -> FastString
fsLit "log", Bool
False)
                    MO_F64_Sqrt  -> (String -> FastString
fsLit "sqrt", Bool
False)
                    MO_F64_Fabs  -> (FastString, Bool)
unsupported

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

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

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

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

                    MO_UF_Conv w :: Width
w -> (String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
word2FloatLabel Width
w, Bool
False)

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

                    MO_BSwap w :: Width
w   -> (String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
bSwapLabel Width
w, Bool
False)
                    MO_PopCnt w :: Width
w  -> (String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
popCntLabel Width
w, Bool
False)
                    MO_Pdep w :: Width
w    -> (String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
pdepLabel Width
w, Bool
False)
                    MO_Pext w :: Width
w    -> (String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
pextLabel Width
w, Bool
False)
                    MO_Clz _     -> (FastString, Bool)
unsupported
                    MO_Ctz _     -> (FastString, Bool)
unsupported
                    MO_AtomicRMW {} -> (FastString, Bool)
unsupported
                    MO_Cmpxchg w :: Width
w -> (String -> FastString
fsLit (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$ Width -> String
cmpxchgLabel Width
w, Bool
False)
                    MO_AtomicRead _  -> (FastString, Bool)
unsupported
                    MO_AtomicWrite _ -> (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
                    MO_ReadBarrier   -> (FastString, Bool)
unsupported
                    MO_WriteBarrier  -> (FastString, Bool)
unsupported
                    MO_Touch         -> (FastString, Bool)
unsupported
                    MO_Prefetch_Data _ -> (FastString, Bool)
unsupported
                unsupported :: (FastString, Bool)
unsupported = String -> (FastString, Bool)
forall a. String -> a
panic ("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]
++ " not supported")

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

genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> NatM InstrBlock
genSwitch dflags :: DynFlags
dflags expr :: CmmExpr
expr targets :: SwitchTargets
targets
  | OS
OSAIX <- Platform -> OS
platformOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)
  = do
        (reg :: Reg
reg,e_code :: InstrBlock
e_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags CmmExpr
expr Int
offset)
        let fmt :: Format
fmt = Bool -> Format
archWordFormat (Bool -> Format) -> Bool -> Format
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit (Platform -> Bool) -> Platform -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags
            sha :: Int
sha = if Platform -> Bool
target32Bit (Platform -> Bool) -> Platform -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags then 2 else 3
        Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
fmt
        CLabel
lbl <- NatM CLabel
getNewLabelNat
        CmmExpr
dynRef <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference DynFlags
dflags ReferenceKind
DataReference CLabel
lbl
        (tableReg :: Reg
tableReg,t_code :: InstrBlock
t_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (CmmExpr -> NatM (Reg, InstrBlock))
-> CmmExpr -> NatM (Reg, InstrBlock)
forall a b. (a -> b) -> a -> b
$ CmmExpr
dynRef
        let code :: InstrBlock
code = InstrBlock
e_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
t_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
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 -> Instr
BCTR [Maybe BlockId]
ids (CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
lbl)
                    ]
        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return InstrBlock
code

  | (DynFlags -> Bool
positionIndependent DynFlags
dflags) 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
$ DynFlags -> Platform
targetPlatform DynFlags
dflags)
  = do
        (reg :: Reg
reg,e_code :: InstrBlock
e_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags CmmExpr
expr Int
offset)
        let fmt :: Format
fmt = Bool -> Format
archWordFormat (Bool -> Format) -> Bool -> Format
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit (Platform -> Bool) -> Platform -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags
            sha :: Int
sha = if Platform -> Bool
target32Bit (Platform -> Bool) -> Platform -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags then 2 else 3
        Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
fmt
        CLabel
lbl <- NatM CLabel
getNewLabelNat
        CmmExpr
dynRef <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference DynFlags
dflags ReferenceKind
DataReference CLabel
lbl
        (tableReg :: Reg
tableReg,t_code :: InstrBlock
t_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (CmmExpr -> NatM (Reg, InstrBlock))
-> CmmExpr -> NatM (Reg, InstrBlock)
forall a b. (a -> b) -> a -> b
$ CmmExpr
dynRef
        let code :: InstrBlock
code = InstrBlock
e_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
t_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
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 -> Instr
BCTR [Maybe BlockId]
ids (CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
lbl)
                    ]
        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return InstrBlock
code
  | Bool
otherwise
  = do
        (reg :: Reg
reg,e_code :: InstrBlock
e_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags CmmExpr
expr Int
offset)
        let fmt :: Format
fmt = Bool -> Format
archWordFormat (Bool -> Format) -> Bool -> Format
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit (Platform -> Bool) -> Platform -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags
            sha :: Int
sha = if Platform -> Bool
target32Bit (Platform -> Bool) -> Platform -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags then 2 else 3
        Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
fmt
        CLabel
lbl <- NatM CLabel
getNewLabelNat
        let code :: InstrBlock
code = InstrBlock
e_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
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 -> Instr
BCTR [Maybe BlockId]
ids (CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
lbl)
                    ]
        InstrBlock -> NatM InstrBlock
forall (m :: * -> *) a. Monad m => a -> m a
return InstrBlock
code
  where (offset :: Int
offset, ids :: [Maybe BlockId]
ids) = SwitchTargets -> (Int, [Maybe BlockId])
switchTargetsToTable SwitchTargets
targets

generateJumpTableForInstr :: DynFlags -> Instr
                          -> Maybe (NatCmmDecl CmmStatics Instr)
generateJumpTableForInstr :: DynFlags -> Instr -> Maybe (NatCmmDecl CmmStatics Instr)
generateJumpTableForInstr dflags :: DynFlags
dflags (BCTR ids :: [Maybe BlockId]
ids (Just lbl :: CLabel
lbl)) =
    let jumpTable :: [CmmStatic]
jumpTable
            | (DynFlags -> Bool
positionIndependent DynFlags
dflags)
              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
$ DynFlags -> Platform
targetPlatform DynFlags
dflags)
            = (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 (DynFlags -> Maybe BlockId -> CmmStatic
jumpTableEntry DynFlags
dflags) [Maybe BlockId]
ids
                where jumpTableEntryRel :: Maybe BlockId -> CmmStatic
jumpTableEntryRel Nothing
                        = CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt 0 (DynFlags -> Width
wordWidth DynFlags
dflags))
                      jumpTableEntryRel (Just blockid :: BlockId
blockid)
                        = CmmLit -> CmmStatic
CmmStaticLit (CLabel -> CLabel -> Int -> Width -> CmmLit
CmmLabelDiffOff CLabel
blockLabel CLabel
lbl 0
                                         (DynFlags -> Width
wordWidth DynFlags
dflags))
                            where blockLabel :: CLabel
blockLabel = BlockId -> CLabel
blockLbl BlockId
blockid
    in NatCmmDecl CmmStatics Instr -> Maybe (NatCmmDecl CmmStatics Instr)
forall a. a -> Maybe a
Just (Section -> CmmStatics -> NatCmmDecl CmmStatics Instr
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) (CLabel -> [CmmStatic] -> CmmStatics
Statics CLabel
lbl [CmmStatic]
jumpTable))
generateJumpTableForInstr _ _ = Maybe (NatCmmDecl CmmStatics 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 getCond :: NatM CondCode
getCond = do
    CondCode _ cond :: Cond
cond cond_code :: InstrBlock
cond_code <- NatM CondCode
getCond
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let
        code :: Reg -> InstrBlock
code dst :: Reg
dst = InstrBlock
cond_code
            InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
negate_code
            InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
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
+ 1) 31 31
            ]

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

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

            NE  -> (2, Bool
True)

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

        format :: Format
format = Bool -> Format
archWordFormat (Bool -> Format) -> Bool -> Format
forall a b. (a -> b) -> a -> b
$ Platform -> Bool
target32Bit (Platform -> Bool) -> Platform -> Bool
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
format Reg -> InstrBlock
code)

condIntReg :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM Register
condIntReg cond :: Cond
cond width :: Width
width x :: CmmExpr
x y :: 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
cond x :: CmmExpr
x y :: 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 rep :: Width
rep signed :: Bool
signed instr :: Reg -> Reg -> RI -> Instr
instr x :: CmmExpr
x (CmmLit (CmmInt y :: Integer
y _))
    | Just imm :: 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 :: Reg
src1, code1 :: InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        let code :: Reg -> InstrBlock
code dst :: Reg
dst = InstrBlock
code1 InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> RI -> Instr
instr Reg
dst Reg
src1 (Imm -> RI
RIImm Imm
imm)
        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any (Width -> Format
intFormat Width
rep) Reg -> InstrBlock
code)

trivialCode rep :: Width
rep _ instr :: Reg -> Reg -> RI -> Instr
instr x :: CmmExpr
x y :: CmmExpr
y = do
    (src1 :: Reg
src1, code1 :: InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    (src2 :: Reg
src2, code2 :: InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y
    let code :: Reg -> InstrBlock
code dst :: Reg
dst = InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2 InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> RI -> Instr
instr Reg
dst Reg
src1 (Reg -> RI
RIReg Reg
src2)
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any (Width -> Format
intFormat Width
rep) Reg -> InstrBlock
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
width sign :: Bool
sign instr :: Format -> Reg -> Reg -> RI -> Instr
instr x :: CmmExpr
x (CmmLit (CmmInt y :: Integer
y _))
    | Just imm :: 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 :: Reg
src1, code1 :: InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        let format :: Format
format = Width -> Format
intFormat Width
width
        let ins_fmt :: Format
ins_fmt = Width -> Format
intFormat (Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width)
        let code :: Reg -> InstrBlock
code dst :: Reg
dst = InstrBlock
code1 InstrBlock -> Instr -> InstrBlock
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)
        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
format Reg -> InstrBlock
code)

shiftMulCode width :: Width
width _ instr :: Format -> Reg -> Reg -> RI -> Instr
instr x :: CmmExpr
x y :: CmmExpr
y = do
    (src1 :: Reg
src1, code1 :: InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    (src2 :: Reg
src2, code2 :: InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y
    let format :: Format
format = Width -> Format
intFormat Width
width
    let ins_fmt :: Format
ins_fmt = Width -> Format
intFormat (Width -> Width -> Width
forall a. Ord a => a -> a -> a
max Width
W32 Width
width)
    let code :: Reg -> InstrBlock
code dst :: Reg
dst = InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2
                   InstrBlock -> Instr -> InstrBlock
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)
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
format Reg -> InstrBlock
code)

trivialCodeNoImm' :: Format -> (Reg -> Reg -> Reg -> Instr)
                 -> CmmExpr -> CmmExpr -> NatM Register
trivialCodeNoImm' :: Format
-> (Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCodeNoImm' format :: Format
format instr :: Reg -> Reg -> Reg -> Instr
instr x :: CmmExpr
x y :: CmmExpr
y = do
    (src1 :: Reg
src1, code1 :: InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    (src2 :: Reg
src2, code2 :: InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y
    let code :: Reg -> InstrBlock
code dst :: Reg
dst = InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2 InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Reg -> Instr
instr Reg
dst Reg
src1 Reg
src2
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
format Reg -> InstrBlock
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 instr :: Format -> Reg -> Reg -> Reg -> Instr
instr x :: CmmExpr
x y :: 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
width sgn :: Bool
sgn instr :: Format -> Reg -> Reg -> RI -> Instr
instr x :: CmmExpr
x (CmmLit (CmmInt y :: Integer
y _))
    | Just imm :: 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 :: Reg
src1, code1 :: InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (Width -> Width -> CmmExpr -> CmmExpr
extend Width
width Width
op_len CmmExpr
x)
        let code :: Reg -> InstrBlock
code dst :: Reg
dst = InstrBlock
code1 InstrBlock -> Instr -> InstrBlock
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)
        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any (Width -> Format
intFormat Width
width) Reg -> InstrBlock
code)

srCode width :: Width
width sgn :: Bool
sgn instr :: Format -> Reg -> Reg -> RI -> Instr
instr x :: CmmExpr
x y :: 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 :: Reg
src1, code1 :: InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (Width -> Width -> CmmExpr -> CmmExpr
extend Width
width Width
op_len CmmExpr
x)
  (src2 :: Reg
src2, code2 :: InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (Width -> Width -> CmmExpr -> CmmExpr
extendUExpr Width
width Width
op_len CmmExpr
y)
  -- Note: Shift amount `y` is unsigned
  let code :: Reg -> InstrBlock
code dst :: Reg
dst = InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2 InstrBlock -> Instr -> InstrBlock
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)
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any (Width -> Format
intFormat Width
width) Reg -> InstrBlock
code)

divCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
divCode :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
divCode width :: Width
width sgn :: Bool
sgn x :: CmmExpr
x y :: 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 :: Reg
src1, code1 :: InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (Width -> Width -> CmmExpr -> CmmExpr
extend Width
width Width
op_len CmmExpr
x)
  (src2 :: Reg
src2, code2 :: InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (Width -> Width -> CmmExpr -> CmmExpr
extend Width
width Width
op_len CmmExpr
y)
  let code :: Reg -> InstrBlock
code dst :: Reg
dst = InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2 InstrBlock -> Instr -> InstrBlock
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
  Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any (Width -> Format
intFormat Width
width) Reg -> InstrBlock
code)


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

-- 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 -> InstrBlock)
remainderCode rep :: Width
rep sgn :: Bool
sgn reg_q :: Reg
reg_q arg_x :: CmmExpr
arg_x arg_y :: 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 :: Reg
x_reg, x_code :: InstrBlock
x_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (Width -> Width -> CmmExpr -> CmmExpr
extend Width
rep Width
op_len CmmExpr
arg_x)
  (y_reg :: Reg
y_reg, y_code :: InstrBlock
y_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg (Width -> Width -> CmmExpr -> CmmExpr
extend Width
rep Width
op_len CmmExpr
arg_y)
  (Reg -> InstrBlock) -> NatM (Reg -> InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Reg -> InstrBlock) -> NatM (Reg -> InstrBlock))
-> (Reg -> InstrBlock) -> NatM (Reg -> InstrBlock)
forall a b. (a -> b) -> a -> b
$ \reg_r :: Reg
reg_r -> InstrBlock
y_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
x_code
                     InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
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 fromRep :: Width
fromRep toRep :: Width
toRep x :: CmmExpr
x = do
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let arch :: Arch
arch =  Platform -> Arch
platformArch (Platform -> Arch) -> Platform -> Arch
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags
    Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP' Arch
arch Width
fromRep Width
toRep CmmExpr
x

coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP' ArchPPC fromRep :: Width
fromRep toRep :: Width
toRep x :: CmmExpr
x = do
    (src :: Reg
src, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    CLabel
lbl <- NatM CLabel
getNewLabelNat
    Reg
itmp <- Format -> NatM Reg
getNewRegNat Format
II32
    Reg
ftmp <- Format -> NatM Reg
getNewRegNat Format
FF64
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    CmmExpr
dynRef <- DynFlags -> ReferenceKind -> CLabel -> NatM CmmExpr
forall (m :: * -> *).
CmmMakeDynamicReferenceM m =>
DynFlags -> ReferenceKind -> CLabel -> m CmmExpr
cmmMakeDynamicReference DynFlags
dflags ReferenceKind
DataReference CLabel
lbl
    Amode addr :: AddrMode
addr addr_code :: InstrBlock
addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D CmmExpr
dynRef
    let
        code' :: Reg -> InstrBlock
code' dst :: Reg
dst = InstrBlock
code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
maybe_exts InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
                Section -> CmmStatics -> Instr
LDATA (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) (CmmStatics -> Instr) -> CmmStatics -> Instr
forall a b. (a -> b) -> a -> b
$ CLabel -> [CmmStatic] -> CmmStatics
Statics CLabel
lbl
                                 [CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt 0x43300000 Width
W32),
                                  CmmLit -> CmmStatic
CmmStaticLit (Integer -> Width -> CmmLit
CmmInt 0x80000000 Width
W32)],
                Reg -> Reg -> Imm -> Instr
XORIS Reg
itmp Reg
src (Int -> Imm
ImmInt 0x8000),
                Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
itmp (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags 3),
                Reg -> Imm -> Instr
LIS Reg
itmp (Int -> Imm
ImmInt 0x4330),
                Format -> Reg -> AddrMode -> Instr
ST Format
II32 Reg
itmp (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags 2),
                Format -> Reg -> AddrMode -> Instr
LD Format
FF64 Reg
ftmp (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags 2)
            ] InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
addr_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
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
            ] InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> InstrBlock
maybe_frsp Reg
dst

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

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

    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any (Width -> Format
floatFormat Width
toRep) Reg -> InstrBlock
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 _) fromRep :: Width
fromRep toRep :: Width
toRep x :: CmmExpr
x = do
    (src :: Reg
src, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let
        code' :: Reg -> InstrBlock
code' dst :: Reg
dst = InstrBlock
code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
maybe_exts InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
                Format -> Reg -> AddrMode -> Instr
ST Format
II64 Reg
src (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags 3),
                Format -> Reg -> AddrMode -> Instr
LD Format
FF64 Reg
dst (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags 3),
                Reg -> Reg -> Instr
FCFID Reg
dst Reg
dst
            ] InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` Reg -> InstrBlock
maybe_frsp Reg
dst

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

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

    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any (Width -> Format
floatFormat Width
toRep) Reg -> InstrBlock
code')

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


coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int fromRep :: Width
fromRep toRep :: Width
toRep x :: CmmExpr
x = do
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    let arch :: Arch
arch =  Platform -> Arch
platformArch (Platform -> Arch) -> Platform -> Arch
forall a b. (a -> b) -> a -> b
$ DynFlags -> Platform
targetPlatform DynFlags
dflags
    Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int' Arch
arch Width
fromRep Width
toRep CmmExpr
x

coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int' :: Arch -> Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int' ArchPPC _ toRep :: Width
toRep x :: CmmExpr
x = do
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    -- the reps don't really matter: F*->FF64 and II32->I* are no-ops
    (src :: Reg
src, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
FF64
    let
        code' :: Reg -> InstrBlock
code' dst :: Reg
dst = InstrBlock
code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
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 (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags 2),
                -- read low word of value (high word is undefined)
            Format -> Reg -> AddrMode -> Instr
LD Format
II32 Reg
dst (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags 3)]
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any (Width -> Format
intFormat Width
toRep) Reg -> InstrBlock
code')

coerceFP2Int' (ArchPPC_64 _) _ toRep :: Width
toRep x :: CmmExpr
x = do
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    -- the reps don't really matter: F*->FF64 and II64->I* are no-ops
    (src :: Reg
src, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
FF64
    let
        code' :: Reg -> InstrBlock
code' dst :: Reg
dst = InstrBlock
code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
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 (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags 3),
            Format -> Reg -> AddrMode -> Instr
LD Format
II64 Reg
dst (DynFlags -> Int -> AddrMode
spRel DynFlags
dflags 3)]
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any (Width -> Format
intFormat Width
toRep) Reg -> InstrBlock
code')

coerceFP2Int' _ _ _ _ = String -> NatM Register
forall a. String -> a
panic "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