{-# LANGUAGE GADTs #-}

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

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

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

where

-- NCG stuff:
import GHC.Prelude

import GHC.Platform.Regs
import GHC.CmmToAsm.PPC.Instr
import GHC.CmmToAsm.PPC.Cond
import GHC.CmmToAsm.PPC.Regs
import GHC.CmmToAsm.CPrim
import GHC.CmmToAsm.Types
import GHC.Cmm.DebugBlock
   ( DebugBlock(..) )
import GHC.CmmToAsm.Monad
   ( NatM, getNewRegNat, getNewLabelNat
   , getBlockIdNat, getPicBaseNat
   , Reg64(..), RegCode64(..), getNewReg64, localReg64
   , getPicBaseMaybeNat, getPlatform, getConfig
   , getDebugBlock, getFileId
   )
import GHC.CmmToAsm.PIC
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Config
import GHC.Platform.Reg.Class
import GHC.Platform.Reg
import GHC.CmmToAsm.Reg.Target
import GHC.Platform

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

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

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

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

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

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

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

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

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

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

basicBlockCodeGen :: CmmBlock
-> NatM ([NatBasicBlock Instr], [NatCmmDecl RawCmmStatics Instr])
basicBlockCodeGen CmmBlock
block = do
  let (CmmNode C O
_, Block CmmNode O O
nodes, CmmNode O C
tail)  = CmmBlock -> (CmmNode C O, Block CmmNode O O, CmmNode O C)
forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit CmmBlock
block
      id :: BlockId
id = CmmBlock -> BlockId
forall (x :: Extensibility). Block CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block
      stmts :: [CmmNode O O]
stmts = Block CmmNode O O -> [CmmNode O O]
forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
nodes
  -- Generate location directive
  Maybe DebugBlock
dbg <- BlockId -> NatM (Maybe DebugBlock)
getDebugBlock (CmmBlock -> BlockId
forall (x :: Extensibility). Block CmmNode C x -> BlockId
forall (thing :: Extensibility -> Extensibility -> *)
       (x :: Extensibility).
NonLocal thing =>
thing C x -> BlockId
entryLabel CmmBlock
block)
  OrdList Instr
loc_instrs <- case DebugBlock -> Maybe CmmTickish
dblSourceTick (DebugBlock -> Maybe CmmTickish)
-> Maybe DebugBlock -> Maybe CmmTickish
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe DebugBlock
dbg of
    Just (SourceNote RealSrcSpan
span String
name)
      -> do Int
fileid <- FastString -> NatM Int
getFileId (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
span)
            let line :: Int
line = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
span; col :: Int
col =RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
span
            OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> String -> Instr
LOCATION Int
fileid Int
line Int
col String
name
    Maybe CmmTickish
_ -> OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return OrdList Instr
forall a. OrdList a
nilOL
  OrdList Instr
mid_instrs <- [CmmNode O O] -> NatM (OrdList Instr)
forall (e :: Extensibility) (x :: Extensibility).
[CmmNode e x] -> NatM (OrdList Instr)
stmtsToInstrs [CmmNode O O]
stmts
  OrdList Instr
tail_instrs <- CmmNode O C -> NatM (OrdList Instr)
forall (e :: Extensibility) (x :: Extensibility).
CmmNode e x -> NatM (OrdList Instr)
stmtToInstrs CmmNode O C
tail
  let instrs :: OrdList Instr
instrs = OrdList Instr
loc_instrs OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
mid_instrs OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
tail_instrs
  -- code generation may introduce new basic block boundaries, which
  -- are indicated by the NEWBLOCK instruction.  We must split up the
  -- instruction stream into basic blocks again.  Also, we extract
  -- LDATAs here too.
  let
        ([Instr]
top,[NatBasicBlock Instr]
other_blocks,[NatCmmDecl RawCmmStatics Instr]
statics) = (Instr
 -> ([Instr], [NatBasicBlock Instr],
     [NatCmmDecl RawCmmStatics Instr])
 -> ([Instr], [NatBasicBlock Instr],
     [NatCmmDecl RawCmmStatics Instr]))
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl RawCmmStatics Instr])
-> OrdList Instr
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl RawCmmStatics Instr])
forall a b. (a -> b -> b) -> b -> OrdList a -> b
foldrOL Instr
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl RawCmmStatics Instr])
-> ([Instr], [NatBasicBlock Instr],
    [NatCmmDecl RawCmmStatics Instr])
forall {h} {g}.
Instr
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
-> ([Instr], [NatBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])
mkBlocks ([],[],[]) OrdList Instr
instrs

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

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

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

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

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

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

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

jumpRegs :: Platform -> [GlobalReg] -> [Reg]
jumpRegs :: Platform -> [GlobalReg] -> [Reg]
jumpRegs Platform
platform [GlobalReg]
gregs = [ RealReg -> Reg
RegReal RealReg
r | Just RealReg
r <- (GlobalReg -> Maybe RealReg) -> [GlobalReg] -> [Maybe RealReg]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> GlobalReg -> Maybe RealReg
globalRegMaybe Platform
platform) [GlobalReg]
gregs ]

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


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


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

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

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

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

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

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



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

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

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

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

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

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

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


assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock
assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_I64Code CmmExpr
addrTree CmmExpr
valueTree = do
        (AddrMode
hi_addr, AddrMode
lo_addr, OrdList Instr
addr_code) <- CmmExpr -> NatM (AddrMode, AddrMode, OrdList Instr)
getI64Amodes CmmExpr
addrTree
        RegCode64 OrdList Instr
vcode Reg
rhi Reg
rlo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
valueTree
        let
                -- 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
        OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
vcode OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_lo OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_hi)


assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock
assignReg_I64Code :: CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_I64Code (CmmLocal CmmFormal
lreg) CmmExpr
valueTree = do
   RegCode64 OrdList Instr
vcode Reg
r_src_hi Reg
r_src_lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
valueTree
   let Reg64 Reg
r_dst_hi Reg
r_dst_lo = (() :: Constraint) => CmmFormal -> Reg64
CmmFormal -> Reg64
localReg64 CmmFormal
lreg
       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
   OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (
        OrdList Instr
vcode OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_lo OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_hi
     )

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


iselExpr64        :: CmmExpr -> NatM (RegCode64 InstrBlock)
iselExpr64 :: CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 (CmmLoad CmmExpr
addrTree CmmType
ty AlignmentSpec
_) | CmmType -> Bool
isWord64 CmmType
ty = do
    (AddrMode
hi_addr, AddrMode
lo_addr, OrdList Instr
addr_code) <- CmmExpr -> NatM (AddrMode, AddrMode, OrdList Instr)
getI64Amodes CmmExpr
addrTree
    Reg64 Reg
rhi Reg
rlo <- NatM Reg64
getNewReg64
    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
    RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr)))
-> RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a b. (a -> b) -> a -> b
$ OrdList Instr -> Reg -> Reg -> RegCode64 (OrdList Instr)
forall code. code -> Reg -> Reg -> RegCode64 code
RegCode64 (OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_lo OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_hi)
                         Reg
rhi Reg
rlo

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

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

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

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

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

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

iselExpr64 (CmmMachOp (MO_SS_Conv Width
W32 Width
W64) [CmmExpr
expr]) = do
    (Reg
expr_reg,OrdList Instr
expr_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
expr
    Reg64 Reg
rhi Reg
rlo <- NatM Reg64
getNewReg64
    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 Int
31))
        mov_lo :: Instr
mov_lo = Reg -> Reg -> Instr
MR Reg
rlo Reg
expr_reg
    RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr)))
-> RegCode64 (OrdList Instr) -> NatM (RegCode64 (OrdList Instr))
forall a b. (a -> b) -> a -> b
$ OrdList Instr -> Reg -> Reg -> RegCode64 (OrdList Instr)
forall code. code -> Reg -> Reg -> RegCode64 code
RegCode64 (OrdList Instr
expr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_lo OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Instr
mov_hi)
                       Reg
rhi Reg
rlo
iselExpr64 CmmExpr
expr
   = do
     Platform
platform <- NatM Platform
getPlatform
     String -> SDoc -> NatM (RegCode64 (OrdList Instr))
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"iselExpr64(powerpc)" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr)



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

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

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

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

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

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

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

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

getRegister' NCGConfig
_ Platform
platform (CmmMachOp (MO_UU_Conv Width
W64 Width
W32) [CmmExpr
x])
 | Platform -> Bool
target32Bit Platform
platform = do
  RegCode64 OrdList Instr
code Reg
_rhi Reg
rlo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> OrdList Instr -> Register
Fixed Format
II32 Reg
rlo OrdList Instr
code

getRegister' NCGConfig
_ Platform
platform (CmmMachOp (MO_SS_Conv Width
W64 Width
W32) [CmmExpr
x])
 | Platform -> Bool
target32Bit Platform
platform = do
  RegCode64 OrdList Instr
code Reg
_rhi Reg
rlo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
  Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> Reg -> OrdList Instr -> Register
Fixed Format
II32 Reg
rlo OrdList Instr
code

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    where
        triv_ucode_int :: Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_int   Width
width Reg -> Reg -> Instr
instr = Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUCode (Width -> Format
intFormat    Width
width) Reg -> Reg -> Instr
instr CmmExpr
x
        triv_ucode_float :: Width -> (Reg -> Reg -> Instr) -> NatM Register
triv_ucode_float Width
width Reg -> Reg -> Instr
instr = Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUCode (Width -> Format
floatFormat  Width
width) Reg -> Reg -> Instr
instr CmmExpr
x

        conversionNop :: Format -> CmmExpr -> NatM Register
conversionNop Format
new_format CmmExpr
expr
            = do Register
e_code <- NCGConfig -> Platform -> CmmExpr -> NatM Register
getRegister' NCGConfig
config Platform
platform CmmExpr
expr
                 Register -> NatM Register
forall a. a -> NatM a
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 Width
from Width
to
            = do (Reg
src1, OrdList Instr
code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
                 let arch_fmt :: Format
arch_fmt  = Width -> Format
intFormat (Platform -> Width
wordWidth Platform
platform)
                     arch_bits :: Int
arch_bits = Width -> Int
widthInBits (Platform -> Width
wordWidth Platform
platform)
                     size :: Int
size      = Width -> Int
widthInBits Width
from
                     code :: Reg -> OrdList Instr
code Reg
dst  = OrdList Instr
code1 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL`
                                 Format -> Reg -> Reg -> Int -> Instr
CLRLI Format
arch_fmt Reg
dst Reg
src1 (Int
arch_bits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
size)
                 Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any (Width -> Format
intFormat Width
to) Reg -> OrdList Instr
code)

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

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

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

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

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

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

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

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

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

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

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

      MO_Shl Width
rep   -> Width
-> Bool
-> (Format -> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
shiftMulCode Width
rep Bool
False Format -> Reg -> Reg -> RI -> Instr
SL CmmExpr
x CmmExpr
y
      MO_S_Shr Width
rep -> Width
-> Bool
-> (Format -> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
srCode Width
rep Bool
True Format -> Reg -> Reg -> RI -> Instr
SRA CmmExpr
x CmmExpr
y
      MO_U_Shr Width
rep -> Width
-> Bool
-> (Format -> Reg -> Reg -> RI -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
srCode Width
rep Bool
False Format -> Reg -> Reg -> RI -> Instr
SR CmmExpr
x CmmExpr
y
      MachOp
_         -> String -> NatM Register
forall a. HasCallStack => String -> a
panic String
"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 Format -> Reg -> Reg -> Reg -> Instr
instr = Format
-> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCodeNoImm (Width -> Format
floatFormat Width
width) Format -> Reg -> Reg -> Reg -> Instr
instr CmmExpr
x CmmExpr
y

    remainder :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
    remainder :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register
remainder Width
rep Bool
sgn CmmExpr
x CmmExpr
y = do
      let fmt :: Format
fmt = Width -> Format
intFormat Width
rep
      Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
fmt
      Reg -> OrdList Instr
code <- Width
-> Bool -> Reg -> CmmExpr -> CmmExpr -> NatM (Reg -> OrdList Instr)
remainderCode Width
rep Bool
sgn Reg
tmp CmmExpr
x CmmExpr
y
      Register -> NatM Register
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> OrdList Instr) -> Register
Any Format
fmt Reg -> OrdList Instr
code)


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

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

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

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

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

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

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

data Amode
        = Amode AddrMode InstrBlock

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

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

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

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

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

getAmode :: InstrForm -> CmmExpr -> NatM Amode
getAmode :: InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
inf tree :: CmmExpr
tree@(CmmRegOff CmmReg
_ Int
_)
  = do Platform
platform <- NatM Platform
getPlatform
       InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
inf (Platform -> CmmExpr -> CmmExpr
mangleIndexTree Platform
platform CmmExpr
tree)

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


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

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


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

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

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

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

getAmode InstrForm
_ (CmmLit CmmLit
lit)
  = do
        Platform
platform <- NatM Platform
getPlatform
        case Platform -> Arch
platformArch Platform
platform of
             Arch
ArchPPC -> do
                 Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
II32
                 let imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
                     code :: OrdList Instr
code = Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Reg -> Imm -> Instr
LIS Reg
tmp (Imm -> Imm
HA Imm
imm))
                 Amode -> NatM Amode
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
tmp (Imm -> Imm
LO Imm
imm)) OrdList Instr
code)
             Arch
_        -> 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 :: OrdList Instr
code =  [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [
                          Reg -> Imm -> Instr
LIS Reg
tmp (Imm -> Imm
HIGHESTA Imm
imm),
                          Reg -> Reg -> RI -> Instr
OR Reg
tmp Reg
tmp (Imm -> RI
RIImm (Imm -> Imm
HIGHERA Imm
imm)),
                          Format -> Reg -> Reg -> RI -> Instr
SL  Format
II64 Reg
tmp Reg
tmp (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
32)),
                          Reg -> Reg -> Imm -> Instr
ORIS Reg
tmp Reg
tmp (Imm -> Imm
HA Imm
imm)
                          ]
                 Amode -> NatM Amode
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
tmp (Imm -> Imm
LO Imm
imm)) OrdList Instr
code)

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

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

getAmode InstrForm
_ CmmExpr
other
  = do
        (Reg
reg, OrdList Instr
code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
other
        let
            off :: Imm
off  = Int -> Imm
ImmInt Int
0
        Amode -> NatM Amode
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AddrMode -> OrdList Instr -> Amode
Amode (Reg -> Imm -> AddrMode
AddrRegImm Reg
reg Imm
off) OrdList Instr
code)


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

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

getCondCode :: CmmExpr -> NatM CondCode

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

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

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

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

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

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

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

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


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

condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
cond Width
width CmmExpr
x CmmExpr
y = do
  Platform
platform <- NatM Platform
getPlatform
  Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode' (Platform -> Bool
target32Bit Platform
platform) 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' Bool
True Cond
cond Width
W64 CmmExpr
x CmmExpr
y
  | Cond -> Bool
condUnsigned Cond
cond
  = do
      RegCode64 OrdList Instr
code_x Reg
x_hi Reg
x_lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
x
      RegCode64 OrdList Instr
code_y Reg
y_hi Reg
y_lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
iselExpr64 CmmExpr
y
      BlockId
end_lbl <- NatM BlockId
getBlockIdNat
      let code :: OrdList Instr
code = OrdList Instr
code_x OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code_y OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL
                 [ Format -> Reg -> RI -> Instr
CMPL Format
II32 Reg
x_hi (Reg -> RI
RIReg Reg
y_hi)
                 , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
end_lbl Maybe Bool
forall a. Maybe a
Nothing
                 , Format -> Reg -> RI -> Instr
CMPL Format
II32 Reg
x_lo (Reg -> RI
RIReg Reg
y_lo)
                 , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
end_lbl Maybe Bool
forall a. Maybe a
Nothing

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

                 , BlockId -> Instr
NEWBLOCK BlockId
end_lbl
                 ]
      CondCode -> NatM CondCode
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
False Cond
cond OrdList Instr
code)

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

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

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

condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
cond CmmExpr
x CmmExpr
y = do
    (Reg
src1, OrdList Instr
code1) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
x
    (Reg
src2, OrdList Instr
code2) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
y
    let
        code' :: OrdList Instr
code'  = OrdList Instr
code1 OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code2 OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
FCMP Reg
src1 Reg
src2
        code'' :: OrdList Instr
code'' = case Cond
cond of -- twiddle CR to handle unordered case
                    Cond
GE -> OrdList Instr
code' OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Int -> Int -> Int -> Instr
CRNOR Int
ltbit Int
eqbit Int
gtbit
                    Cond
LE -> OrdList Instr
code' OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Int -> Int -> Int -> Instr
CRNOR Int
gtbit Int
eqbit Int
ltbit
                    Cond
_ -> OrdList Instr
code'
                 where
                    ltbit :: Int
ltbit = Int
0 ; eqbit :: Int
eqbit = Int
2 ; gtbit :: Int
gtbit = Int
1
    CondCode -> NatM CondCode
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Cond -> OrdList Instr -> CondCode
CondCode Bool
True Cond
cond OrdList Instr
code'')



-- -----------------------------------------------------------------------------
-- Generating assignments

-- Assignments are really at the heart of the whole code generation
-- business.  Almost all top-level nodes of any real importance are
-- assignments, which correspond to loads, stores, or register
-- transfers.  If we're really lucky, some of the register transfers
-- will go away, because we can use the destination register to
-- complete the code generation for the right hand side.  This only
-- fails when the right hand side is forced into a fixed register
-- (e.g. the result of a call).

assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock

assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock
assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock

assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_IntCode Format
pk CmmExpr
addr CmmExpr
src = do
    (Reg
srcReg, OrdList Instr
code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
src
    Amode AddrMode
dstAddr OrdList Instr
addr_code <- case Format
pk of
                                Format
II64 -> InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
DS CmmExpr
addr
                                Format
_    -> InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
D  CmmExpr
addr
    OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
addr_code OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> 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 (OrdList Instr)
assignReg_IntCode Format
_ CmmReg
reg CmmExpr
src
    = do
        Platform
platform <- NatM Platform
getPlatform
        let dst :: Reg
dst = Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg
        Register
r <- CmmExpr -> NatM Register
getRegister CmmExpr
src
        OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ case Register
r of
            Any Format
_ Reg -> OrdList Instr
code         -> Reg -> OrdList Instr
code Reg
dst
            Fixed Format
_ Reg
freg OrdList Instr
fcode -> OrdList Instr
fcode OrdList Instr -> Instr -> OrdList Instr
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Reg -> Instr
MR Reg
dst Reg
freg



-- Easy, isn't it?
assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_FltCode = Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_IntCode
assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_FltCode = Format -> CmmReg -> CmmExpr -> NatM (OrdList Instr)
assignReg_IntCode



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

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

genJump CmmExpr
tree [Reg]
gregs
  = do
        Platform
platform <- NatM Platform
getPlatform
        CmmExpr -> GenCCallPlatform -> [Reg] -> NatM (OrdList Instr)
genJump' CmmExpr
tree (Platform -> GenCCallPlatform
platformToGCP Platform
platform) [Reg]
gregs

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

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

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

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

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


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

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


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

genCondJump :: BlockId -> CmmExpr -> Maybe Bool -> NatM (OrdList Instr)
genCondJump BlockId
id CmmExpr
bool Maybe Bool
prediction = do
  CondCode Bool
_ Cond
cond OrdList Instr
code <- CmmExpr -> NatM CondCode
getCondCode CmmExpr
bool
  OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr
code OrdList Instr -> Instr -> OrdList Instr
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 (OrdList Instr)
genCCall (PrimTarget CallishMachOp
MO_ReadBarrier) [CmmFormal]
_ [CmmExpr]
_
 = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
LWSYNC
genCCall (PrimTarget CallishMachOp
MO_WriteBarrier) [CmmFormal]
_ [CmmExpr]
_
 = OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
LWSYNC

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

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

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

genCCall (PrimTarget (MO_AtomicRead Width
width MemoryOrdering
_)) [CmmFormal
dst] [CmmExpr
addr]
 = do let fmt :: Format
fmt      = Width -> Format
intFormat Width
width
          reg_dst :: Reg
reg_dst  = CmmFormal -> Reg
getLocalRegReg CmmFormal
dst
          form :: InstrForm
form     = if Width -> Int
widthInBits Width
width Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
64 then InstrForm
DS else InstrForm
D
      Amode AddrMode
addr_reg OrdList Instr
addr_code <- InstrForm -> CmmExpr -> NatM Amode
getAmode InstrForm
form CmmExpr
addr
      BlockId
lbl_end <- NatM BlockId
getBlockIdNat
      OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
addr_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ 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 MemoryOrdering
_)) [] [CmmExpr
addr, CmmExpr
val] = do
    OrdList Instr
code <- Format -> CmmExpr -> CmmExpr -> NatM (OrdList Instr)
assignMem_IntCode (Width -> Format
intFormat Width
width) CmmExpr
addr CmmExpr
val
    OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL Instr
HWSYNC OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
code

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


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

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

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

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

genCCall (PrimTarget (MO_Ctz Width
width)) [CmmFormal
dst] [CmmExpr
src]
 = do Platform
platform <- NatM Platform
getPlatform
      let reg_dst :: Reg
reg_dst = CmmFormal -> Reg
getLocalRegReg 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
          RegCode64 OrdList Instr
code Reg
vr_hi Reg
vr_lo <- CmmExpr -> NatM (RegCode64 (OrdList Instr))
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
          OrdList Instr
cnttzlo <- Format -> Reg -> Reg -> NatM (OrdList Instr)
cnttz Format
format Reg
reg_dst Reg
vr_lo
          let cnttz64 :: OrdList Instr
cnttz64 = [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Format -> Reg -> RI -> Instr
CMPL Format
format Reg
vr_lo (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
0))
                             , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
NE BlockId
lbl2 Maybe Bool
forall a. Maybe a
Nothing
                             , Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
lbl1 Maybe Bool
forall a. Maybe a
Nothing

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

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

                             , BlockId -> Instr
NEWBLOCK BlockId
lbl3
                             ]
          OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
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
          (Reg
s_reg, OrdList Instr
s_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
src
          (Reg
reg_ctz, OrdList Instr
pre_code) <-
            case Width
width of
              Width
W64 -> (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
s_reg, OrdList Instr
forall a. OrdList a
nilOL)
              Width
W32 -> (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
s_reg, OrdList Instr
forall a. OrdList a
nilOL)
              Width
W16 -> do
                Reg
reg_tmp <- Format -> NatM Reg
getNewRegNat Format
format
                (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg_tmp, Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Reg -> Reg -> Imm -> Instr
ORIS Reg
reg_tmp Reg
s_reg (Int -> Imm
ImmInt Int
1))
              Width
W8  -> do
                Reg
reg_tmp <- Format -> NatM Reg
getNewRegNat Format
format
                (Reg, OrdList Instr) -> NatM (Reg, OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg_tmp, Instr -> OrdList Instr
forall a. a -> OrdList a
unitOL (Instr -> OrdList Instr) -> Instr -> OrdList Instr
forall a b. (a -> b) -> a -> b
$ Reg -> Reg -> RI -> Instr
OR Reg
reg_tmp Reg
s_reg (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
256)))
              Width
_   -> String -> NatM (Reg, OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCall: Ctz wrong format"
          OrdList Instr
ctz_code <- Format -> Reg -> Reg -> NatM (OrdList Instr)
cnttz Format
format Reg
reg_dst Reg
reg_ctz
          OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
s_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
pre_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
ctz_code
        where
          -- cnttz(x) = sizeof(x) - cntlz(~x & (x - 1))
          -- see Henry S. Warren, Hacker's Delight, p 107
          cnttz :: Format -> Reg -> Reg -> NatM (OrdList Instr)
cnttz Format
format Reg
dst Reg
src = do
            let format_bits :: Int
format_bits = Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Format -> Int
formatInBytes Format
format
            Reg
x' <- Format -> NatM Reg
getNewRegNat Format
format
            Reg
x'' <- Format -> NatM Reg
getNewRegNat Format
format
            Reg
r' <- Format -> NatM Reg
getNewRegNat Format
format
            OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ Reg -> Reg -> RI -> Instr
ADD Reg
x' Reg
src (Imm -> RI
RIImm (Int -> Imm
ImmInt (-Int
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 ForeignTarget
target [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
 = do Platform
platform <- NatM Platform
getPlatform
      case ForeignTarget
target of
        PrimTarget (MO_S_QuotRem  Width
width) -> Bool -> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
divOp1 Bool
True  Width
width
                                                   [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget (MO_U_QuotRem  Width
width) -> Bool -> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
divOp1 Bool
False Width
width
                                                   [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget (MO_U_QuotRem2 Width
width) -> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
divOp2 Width
width [CmmFormal]
dest_regs
                                                   [CmmExpr]
argsAndHints
        PrimTarget (MO_U_Mul2 Width
width) -> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
multOp2 Width
width [CmmFormal]
dest_regs
                                                [CmmExpr]
argsAndHints
        PrimTarget (MO_Add2 Width
_) -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
add2Op [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget (MO_AddWordC Width
_) -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
addcOp [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget (MO_SubWordC Width
_) -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
subcOp [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget (MO_AddIntC Width
width) -> (Reg -> Reg -> Reg -> Instr)
-> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
addSubCOp Reg -> Reg -> Reg -> Instr
ADDO Width
width
                                                   [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget (MO_SubIntC Width
width) -> (Reg -> Reg -> Reg -> Instr)
-> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
addSubCOp Reg -> Reg -> Reg -> Instr
SUBFO Width
width
                                                   [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget CallishMachOp
MO_F64_Fabs -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
fabs [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        PrimTarget CallishMachOp
MO_F32_Fabs -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
fabs [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        ForeignTarget
_ -> do NCGConfig
config <- NatM NCGConfig
getConfig
                NCGConfig
-> GenCCallPlatform
-> ForeignTarget
-> [CmmFormal]
-> [CmmExpr]
-> NatM (OrdList Instr)
genCCall' NCGConfig
config (Platform -> GenCCallPlatform
platformToGCP Platform
platform)
                       ForeignTarget
target [CmmFormal]
dest_regs [CmmExpr]
argsAndHints
        where divOp1 :: Bool -> Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
divOp1 Bool
signed Width
width [CmmFormal
res_q, CmmFormal
res_r] [CmmExpr
arg_x, CmmExpr
arg_y]
                = do let reg_q :: Reg
reg_q = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_q
                         reg_r :: Reg
reg_r = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_r
                     Width
-> Bool -> Reg -> CmmExpr -> CmmExpr -> NatM (Reg -> OrdList Instr)
remainderCode Width
width Bool
signed Reg
reg_q CmmExpr
arg_x CmmExpr
arg_y
                       NatM (Reg -> OrdList Instr) -> NatM Reg -> NatM (OrdList Instr)
forall a b. NatM (a -> b) -> NatM a -> NatM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Reg -> NatM Reg
forall a. a -> NatM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Reg
reg_r

              divOp1 Bool
_ Width
_ [CmmFormal]
_ [CmmExpr]
_
                = String -> NatM (OrdList Instr)
forall a. HasCallStack => String -> a
panic String
"genCCall: Wrong number of arguments for divOp1"
              divOp2 :: Width -> [CmmFormal] -> [CmmExpr] -> NatM (OrdList Instr)
divOp2 Width
width [CmmFormal
res_q, CmmFormal
res_r]
                                    [CmmExpr
arg_x_high, CmmExpr
arg_x_low, CmmExpr
arg_y]
                = do let reg_q :: Reg
reg_q = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_q
                         reg_r :: Reg
reg_r = CmmFormal -> Reg
getLocalRegReg CmmFormal
res_r
                         fmt :: Format
fmt   = Width -> Format
intFormat Width
width
                         half :: Int
half  = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Format -> Int
formatInBytes Format
fmt)
                     (Reg
xh_reg, OrdList Instr
xh_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
arg_x_high
                     (Reg
xl_reg, OrdList Instr
xl_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
getSomeReg CmmExpr
arg_x_low
                     (Reg
y_reg, OrdList Instr
y_code) <- CmmExpr -> NatM (Reg, OrdList Instr)
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
                     OrdList Instr -> NatM (OrdList Instr)
forall a. a -> NatM a
forall (m :: * -> *) a. Monad m => a -> m a
return (OrdList Instr -> NatM (OrdList Instr))
-> OrdList Instr -> NatM (OrdList Instr)
forall a b. (a -> b) -> a -> b
$ OrdList Instr
y_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
xl_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` OrdList Instr
xh_code OrdList Instr -> OrdList Instr -> OrdList Instr
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                              -- see Hacker's Delight p 196 Figure 9-3
                              [Instr] -> OrdList Instr
forall a. [a] -> OrdList a
toOL [ -- b = 2 ^ (bits_in_word / 2)
                                     Reg -> Imm -> Instr
LI Reg
b (Int -> Imm
ImmInt Int
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 (Int
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 -&