{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-----------------------------------------------------------------------------
--
-- Machine-dependent assembly language
--
-- (c) The University of Glasgow 1993-2004
--
-----------------------------------------------------------------------------

module GHC.CmmToAsm.PPC.Instr
   ( Instr(..)
   , RI(..)
   , archWordFormat
   , stackFrameHeaderSize
   , maxSpillSlots
   , allocMoreStack
   , makeFarBranches
   , mkJumpInstr
   , mkLoadInstr
   , mkSpillInstr
   , patchJumpInstr
   , patchRegsOfInstr
   , jumpDestsOfInstr
   , takeRegRegMoveInstr
   , takeDeltaInstr
   , mkRegRegMoveInstr
   , mkStackAllocInstr
   , mkStackDeallocInstr
   , regUsageOfInstr
   , isJumpishInstr
   , isMetaInstr
   )
where

import GHC.Prelude hiding (head, init, last, tail)

import GHC.CmmToAsm.PPC.Regs
import GHC.CmmToAsm.PPC.Cond
import GHC.CmmToAsm.Types
import GHC.CmmToAsm.Instr (RegUsage(..), noUsage)
import GHC.CmmToAsm.Format
import GHC.CmmToAsm.Reg.Target
import GHC.CmmToAsm.Config
import GHC.Platform.Reg.Class
import GHC.Platform.Reg

import GHC.Platform.Regs
import GHC.Cmm.BlockId
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
import GHC.Cmm
import GHC.Cmm.Info
import GHC.Cmm.CLabel
import GHC.Utils.Panic
import GHC.Platform
import GHC.Types.Unique.FM (listToUFM, lookupUFM)
import GHC.Types.Unique.Supply

import Data.Foldable (toList)
import qualified Data.List.NonEmpty as NE
import GHC.Data.FastString (FastString)
import Data.Maybe (fromMaybe)


--------------------------------------------------------------------------------
-- Format of a PPC memory address.
--
archWordFormat :: Bool -> Format
archWordFormat :: Bool -> Format
archWordFormat Bool
is32Bit
 | Bool
is32Bit   = Format
II32
 | Bool
otherwise = Format
II64


mkStackAllocInstr :: Platform -> Int -> [Instr]
mkStackAllocInstr :: Platform -> Int -> [Instr]
mkStackAllocInstr Platform
platform Int
amount
  = Platform -> Int -> [Instr]
mkStackAllocInstr' Platform
platform (-Int
amount)

mkStackDeallocInstr :: Platform -> Int -> [Instr]
mkStackDeallocInstr :: Platform -> Int -> [Instr]
mkStackDeallocInstr Platform
platform Int
amount
  = Platform -> Int -> [Instr]
mkStackAllocInstr' Platform
platform Int
amount

mkStackAllocInstr' :: Platform -> Int -> [Instr]
mkStackAllocInstr' :: Platform -> Int -> [Instr]
mkStackAllocInstr' Platform
platform Int
amount
  | Int -> Bool
forall a. Integral a => a -> Bool
fits16Bits Int
amount
  = [ Format -> Reg -> AddrMode -> Instr
LD Format
fmt Reg
r0 (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp Imm
zero)
    , Format -> Reg -> AddrMode -> Instr
STU Format
fmt Reg
r0 (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp Imm
immAmount)
    ]
  | Bool
otherwise
  = [ Format -> Reg -> AddrMode -> Instr
LD Format
fmt Reg
r0 (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp Imm
zero)
    , Reg -> Reg -> Imm -> Instr
ADDIS Reg
tmp Reg
sp (Imm -> Imm
HA Imm
immAmount)
    , Reg -> Reg -> RI -> Instr
ADD Reg
tmp Reg
tmp (Imm -> RI
RIImm (Imm -> Imm
LO Imm
immAmount))
    , Format -> Reg -> AddrMode -> Instr
STU Format
fmt Reg
r0 (Reg -> Reg -> AddrMode
AddrRegReg Reg
sp Reg
tmp)
    ]
  where
    fmt :: Format
fmt = Width -> Format
intFormat (Width -> Format) -> Width -> Format
forall a b. (a -> b) -> a -> b
$ Int -> Width
widthFromBytes (Platform -> Int
platformWordSizeInBytes Platform
platform)
    zero :: Imm
zero = Int -> Imm
ImmInt Int
0
    tmp :: Reg
tmp = Platform -> Reg
tmpReg Platform
platform
    immAmount :: Imm
immAmount = Int -> Imm
ImmInt Int
amount

--
-- See Note [extra spill slots] in X86/Instr.hs
--
allocMoreStack
  :: Platform
  -> Int
  -> NatCmmDecl statics GHC.CmmToAsm.PPC.Instr.Instr
  -> UniqSM (NatCmmDecl statics GHC.CmmToAsm.PPC.Instr.Instr, [(BlockId,BlockId)])

allocMoreStack :: forall statics.
Platform
-> Int
-> NatCmmDecl statics Instr
-> UniqSM (NatCmmDecl statics Instr, [(BlockId, BlockId)])
allocMoreStack Platform
_ Int
_ top :: NatCmmDecl statics Instr
top@(CmmData Section
_ statics
_) = (NatCmmDecl statics Instr, [(BlockId, BlockId)])
-> UniqSM (NatCmmDecl statics Instr, [(BlockId, BlockId)])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (NatCmmDecl statics Instr
top,[])
allocMoreStack Platform
platform Int
slots (CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalReg]
live (ListGraph [GenBasicBlock Instr]
code)) = do
    let
        infos :: [KeyOf LabelMap]
infos   = LabelMap RawCmmStatics -> [KeyOf LabelMap]
forall a. LabelMap a -> [KeyOf LabelMap]
forall (map :: * -> *) a. IsMap map => map a -> [KeyOf map]
mapKeys LabelMap RawCmmStatics
info
        entries :: [KeyOf LabelMap]
entries = case [GenBasicBlock Instr]
code of
                    [] -> [KeyOf LabelMap]
infos
                    BasicBlock BlockId
entry [Instr]
_ : [GenBasicBlock Instr]
_ -- first block is the entry point
                        | BlockId
entry BlockId -> [BlockId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyOf LabelMap]
[BlockId]
infos -> [KeyOf LabelMap]
infos
                        | Bool
otherwise          -> BlockId
entry BlockId -> [BlockId] -> [BlockId]
forall a. a -> [a] -> [a]
: [KeyOf LabelMap]
[BlockId]
infos

    [Unique]
uniqs <- UniqSM [Unique]
forall (m :: * -> *). MonadUnique m => m [Unique]
getUniquesM

    let
        delta :: Int
delta = ((Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
stackAlign Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
stackAlign) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
stackAlign -- round up
            where x :: Int
x = Int
slots Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
spillSlotSize -- sp delta

        alloc :: [Instr]
alloc   = Platform -> Int -> [Instr]
mkStackAllocInstr   Platform
platform Int
delta
        dealloc :: [Instr]
dealloc = Platform -> Int -> [Instr]
mkStackDeallocInstr Platform
platform Int
delta

        retargetList :: [(BlockId, BlockId)]
retargetList = ([BlockId] -> [BlockId] -> [(BlockId, BlockId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [KeyOf LabelMap]
[BlockId]
entries ((Unique -> BlockId) -> [Unique] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map Unique -> BlockId
mkBlockId [Unique]
uniqs))

        new_blockmap :: LabelMap BlockId
        new_blockmap :: LabelMap BlockId
new_blockmap = [(KeyOf LabelMap, BlockId)] -> LabelMap BlockId
forall a. [(KeyOf LabelMap, a)] -> LabelMap a
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList [(KeyOf LabelMap, BlockId)]
[(BlockId, BlockId)]
retargetList

        insert_stack_insns :: GenBasicBlock Instr -> [GenBasicBlock Instr]
insert_stack_insns (BasicBlock BlockId
id [Instr]
insns)
            | Just BlockId
new_blockid <- KeyOf LabelMap -> LabelMap BlockId -> Maybe BlockId
forall a. KeyOf LabelMap -> LabelMap a -> Maybe a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
id LabelMap BlockId
new_blockmap
                = [ BlockId -> [Instr] -> GenBasicBlock Instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id ([Instr] -> GenBasicBlock Instr) -> [Instr] -> GenBasicBlock Instr
forall a b. (a -> b) -> a -> b
$ [Instr]
alloc [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++ [Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
new_blockid Maybe Bool
forall a. Maybe a
Nothing]
                  , BlockId -> [Instr] -> GenBasicBlock Instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
new_blockid [Instr]
block'
                  ]
            | Bool
otherwise
                = [ BlockId -> [Instr] -> GenBasicBlock Instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id [Instr]
block' ]
            where
              block' :: [Instr]
block' = (Instr -> [Instr] -> [Instr]) -> [Instr] -> [Instr] -> [Instr]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Instr -> [Instr] -> [Instr]
insert_dealloc [] [Instr]
insns

        insert_dealloc :: Instr -> [Instr] -> [Instr]
insert_dealloc Instr
insn [Instr]
r
            -- BCTR might or might not be a non-local jump. For
            -- "labeled-goto" we use JMP, and for "computed-goto" we
            -- use MTCTR followed by BCTR. See 'PPC.CodeGen.genJump'.
            = case Instr
insn of
                JMP CLabel
_ [Reg]
_           -> [Instr]
dealloc [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++ (Instr
insn Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
r)
                BCTR [] Maybe CLabel
Nothing [Reg]
_ -> [Instr]
dealloc [Instr] -> [Instr] -> [Instr]
forall a. [a] -> [a] -> [a]
++ (Instr
insn Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
r)
                BCTR [Maybe BlockId]
ids Maybe CLabel
label [Reg]
rs -> [Maybe BlockId] -> Maybe CLabel -> [Reg] -> Instr
BCTR ((Maybe BlockId -> Maybe BlockId)
-> [Maybe BlockId] -> [Maybe BlockId]
forall a b. (a -> b) -> [a] -> [b]
map ((BlockId -> BlockId) -> Maybe BlockId -> Maybe BlockId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlockId -> BlockId
retarget) [Maybe BlockId]
ids) Maybe CLabel
label [Reg]
rs Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
r
                BCCFAR Cond
cond BlockId
b Maybe Bool
p   -> Cond -> BlockId -> Maybe Bool -> Instr
BCCFAR Cond
cond (BlockId -> BlockId
retarget BlockId
b) Maybe Bool
p Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
r
                BCC    Cond
cond BlockId
b Maybe Bool
p   -> Cond -> BlockId -> Maybe Bool -> Instr
BCC    Cond
cond (BlockId -> BlockId
retarget BlockId
b) Maybe Bool
p Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
r
                Instr
_                 -> Instr
insn Instr -> [Instr] -> [Instr]
forall a. a -> [a] -> [a]
: [Instr]
r
            -- BL and BCTRL are call-like instructions rather than
            -- jumps, and are used only for C calls.

        retarget :: BlockId -> BlockId
        retarget :: BlockId -> BlockId
retarget BlockId
b
            = BlockId -> Maybe BlockId -> BlockId
forall a. a -> Maybe a -> a
fromMaybe BlockId
b (KeyOf LabelMap -> LabelMap BlockId -> Maybe BlockId
forall a. KeyOf LabelMap -> LabelMap a -> Maybe a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
BlockId
b LabelMap BlockId
new_blockmap)

        new_code :: [GenBasicBlock Instr]
new_code
            = (GenBasicBlock Instr -> [GenBasicBlock Instr])
-> [GenBasicBlock Instr] -> [GenBasicBlock Instr]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenBasicBlock Instr -> [GenBasicBlock Instr]
insert_stack_insns [GenBasicBlock Instr]
code

    -- in
    (NatCmmDecl statics Instr, [(BlockId, BlockId)])
-> UniqSM (NatCmmDecl statics Instr, [(BlockId, BlockId)])
forall a. a -> UniqSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (LabelMap RawCmmStatics
-> CLabel
-> [GlobalReg]
-> ListGraph Instr
-> NatCmmDecl statics Instr
forall d h g. h -> CLabel -> [GlobalReg] -> g -> GenCmmDecl d h g
CmmProc LabelMap RawCmmStatics
info CLabel
lbl [GlobalReg]
live ([GenBasicBlock Instr] -> ListGraph Instr
forall i. [GenBasicBlock i] -> ListGraph i
ListGraph [GenBasicBlock Instr]
new_code),[(BlockId, BlockId)]
retargetList)


-- -----------------------------------------------------------------------------
-- Machine's assembly language

-- We have a few common "instructions" (nearly all the pseudo-ops) but
-- mostly all of 'Instr' is machine-specific.

-- Register or immediate
data RI
    = RIReg Reg
    | RIImm Imm

data Instr
    -- comment pseudo-op
    = COMMENT FastString

    -- location pseudo-op (file, line, col, name)
    | LOCATION Int Int Int String

    -- some static data spat out during code
    -- generation.  Will be extracted before
    -- pretty-printing.
    | LDATA   Section RawCmmStatics

    -- start a new basic block.  Useful during
    -- codegen, removed later.  Preceding
    -- instruction should be a jump, as per the
    -- invariants for a BasicBlock (see Cmm).
    | NEWBLOCK BlockId

    -- specify current stack offset for
    -- benefit of subsequent passes
    | DELTA   Int

    -- Loads and stores.
    | LD      Format Reg AddrMode   -- Load format, dst, src
    | LDFAR   Format Reg AddrMode   -- Load format, dst, src 32 bit offset
    | LDR     Format Reg AddrMode   -- Load and reserve format, dst, src
    | LA      Format Reg AddrMode   -- Load arithmetic format, dst, src
    | ST      Format Reg AddrMode   -- Store format, src, dst
    | STFAR   Format Reg AddrMode   -- Store format, src, dst 32 bit offset
    | STU     Format Reg AddrMode   -- Store with Update format, src, dst
    | STC     Format Reg AddrMode   -- Store conditional format, src, dst
    | LIS     Reg Imm               -- Load Immediate Shifted dst, src
    | LI      Reg Imm               -- Load Immediate dst, src
    | MR      Reg Reg               -- Move Register dst, src -- also for fmr

    | CMP     Format Reg RI         -- format, src1, src2
    | CMPL    Format Reg RI         -- format, src1, src2

    | BCC     Cond BlockId (Maybe Bool) -- cond, block, hint
    | BCCFAR  Cond BlockId (Maybe Bool) -- cond, block, hint
                                    --   hint:
                                    --    Just True:  branch likely taken
                                    --    Just False: branch likely not taken
                                    --    Nothing:    no hint
    | JMP     CLabel [Reg]          -- same as branch,
                                    -- but with CLabel instead of block ID
                                    -- and live global registers
    | MTCTR   Reg
    | BCTR    [Maybe BlockId] (Maybe CLabel) [Reg]
                                    -- with list of local destinations, and
                                    -- jump table location if necessary
    | BL      CLabel [Reg]          -- with list of argument regs
    | BCTRL   [Reg]

    | ADD     Reg Reg RI            -- dst, src1, src2
    | ADDO    Reg Reg Reg           -- add and set overflow
    | ADDC    Reg Reg Reg           -- (carrying) dst, src1, src2
    | ADDE    Reg Reg Reg           -- (extended) dst, src1, src2
    | ADDZE   Reg Reg               -- (to zero extended) dst, src
    | ADDIS   Reg Reg Imm           -- Add Immediate Shifted dst, src1, src2
    | SUBF    Reg Reg Reg           -- dst, src1, src2 ; dst = src2 - src1
    | SUBFO   Reg Reg Reg           -- subtract from and set overflow
    | SUBFC   Reg Reg RI            -- (carrying) dst, src1, src2 ;
                                    -- dst = src2 - src1
    | SUBFE   Reg Reg Reg           -- (extended) dst, src1, src2 ;
                                    -- dst = src2 - src1
    | MULL    Format Reg Reg RI
    | MULLO   Format Reg Reg Reg    -- multiply and set overflow
    | MFOV    Format Reg            -- move overflow bit (1|33) to register
                                    -- pseudo-instruction; pretty printed as
                                    -- mfxer dst
                                    -- extr[w|d]i dst, dst, 1, [1|33]
    | MULHU   Format Reg Reg Reg
    | DIV     Format Bool Reg Reg Reg
    | AND     Reg Reg RI            -- dst, src1, src2
    | ANDC    Reg Reg Reg           -- AND with complement, dst = src1 & ~ src2
    | NAND    Reg Reg Reg           -- dst, src1, src2
    | OR      Reg Reg RI            -- dst, src1, src2
    | ORIS    Reg Reg Imm           -- OR Immediate Shifted dst, src1, src2
    | XOR     Reg Reg RI            -- dst, src1, src2
    | XORIS   Reg Reg Imm           -- XOR Immediate Shifted dst, src1, src2

    | EXTS    Format Reg Reg
    | CNTLZ   Format Reg Reg

    | NEG     Reg Reg
    | NOT     Reg Reg

    | SL      Format Reg Reg RI            -- shift left
    | SR      Format Reg Reg RI            -- shift right
    | SRA     Format Reg Reg RI            -- shift right arithmetic

    | RLWINM  Reg Reg Int Int Int   -- Rotate Left Word Immediate then AND with Mask
    | CLRLI   Format Reg Reg Int    -- clear left immediate (extended mnemonic)
    | CLRRI   Format Reg Reg Int    -- clear right immediate (extended mnemonic)

    | FADD    Format Reg Reg Reg
    | FSUB    Format Reg Reg Reg
    | FMUL    Format Reg Reg Reg
    | FDIV    Format Reg Reg Reg
    | FABS    Reg Reg               -- abs is the same for single and double
    | FNEG    Reg Reg               -- negate is the same for single and double prec.

    -- | Fused multiply-add instructions.
    --
    --   - FMADD:  @rd =  (ra * rb) + rd@
    --   - FMSUB:  @rd =   ra * rb  - rd@
    --   - FNMADD: @rd = -(ra * rb + rd)@
    --   - FNMSUB: @rd = -(ra * rb - rd)@
    | FMADD FMASign Format Reg Reg Reg Reg

    | FCMP    Reg Reg

    | FCTIWZ  Reg Reg           -- convert to integer word
    | FCTIDZ  Reg Reg           -- convert to integer double word
    | FCFID   Reg Reg           -- convert from integer double word
    | FRSP    Reg Reg           -- reduce to single precision
                                -- (but destination is a FP register)

    | CRNOR   Int Int Int       -- condition register nor
    | MFCR    Reg               -- move from condition register

    | MFLR    Reg               -- move from link register
    | FETCHPC Reg               -- pseudo-instruction:
                                -- bcl to next insn, mflr reg
    | HWSYNC                    -- heavy weight sync
    | ISYNC                     -- instruction synchronize
    | LWSYNC                    -- memory barrier
    | NOP                       -- no operation, PowerPC 64 bit
                                -- needs this as place holder to
                                -- reload TOC pointer

-- | Get the registers that are being used by this instruction.
-- regUsage doesn't need to do any trickery for jumps and such.
-- Just state precisely the regs read and written by that insn.
-- The consequences of control flow transfers, as far as register
-- allocation goes, are taken care of by the register allocator.
--
regUsageOfInstr :: Platform -> Instr -> RegUsage
regUsageOfInstr :: Platform -> Instr -> RegUsage
regUsageOfInstr Platform
platform Instr
instr
 = case Instr
instr of
    LD      Format
_ Reg
reg AddrMode
addr       -> ([Reg], [Reg]) -> RegUsage
usage (AddrMode -> [Reg]
regAddr AddrMode
addr, [Reg
reg])
    LDFAR   Format
_ Reg
reg AddrMode
addr       -> ([Reg], [Reg]) -> RegUsage
usage (AddrMode -> [Reg]
regAddr AddrMode
addr, [Reg
reg])
    LDR     Format
_ Reg
reg AddrMode
addr       -> ([Reg], [Reg]) -> RegUsage
usage (AddrMode -> [Reg]
regAddr AddrMode
addr, [Reg
reg])
    LA      Format
_ Reg
reg AddrMode
addr       -> ([Reg], [Reg]) -> RegUsage
usage (AddrMode -> [Reg]
regAddr AddrMode
addr, [Reg
reg])
    ST      Format
_ Reg
reg AddrMode
addr       -> ([Reg], [Reg]) -> RegUsage
usage (Reg
reg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: AddrMode -> [Reg]
regAddr AddrMode
addr, [])
    STFAR   Format
_ Reg
reg AddrMode
addr       -> ([Reg], [Reg]) -> RegUsage
usage (Reg
reg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: AddrMode -> [Reg]
regAddr AddrMode
addr, [])
    STU     Format
_ Reg
reg AddrMode
addr       -> ([Reg], [Reg]) -> RegUsage
usage (Reg
reg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: AddrMode -> [Reg]
regAddr AddrMode
addr, [])
    STC     Format
_ Reg
reg AddrMode
addr       -> ([Reg], [Reg]) -> RegUsage
usage (Reg
reg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: AddrMode -> [Reg]
regAddr AddrMode
addr, [])
    LIS     Reg
reg Imm
_            -> ([Reg], [Reg]) -> RegUsage
usage ([], [Reg
reg])
    LI      Reg
reg Imm
_            -> ([Reg], [Reg]) -> RegUsage
usage ([], [Reg
reg])
    MR      Reg
reg1 Reg
reg2        -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2], [Reg
reg1])
    CMP     Format
_ Reg
reg RI
ri         -> ([Reg], [Reg]) -> RegUsage
usage (Reg
reg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: RI -> [Reg]
regRI RI
ri,[])
    CMPL    Format
_ Reg
reg RI
ri         -> ([Reg], [Reg]) -> RegUsage
usage (Reg
reg Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: RI -> [Reg]
regRI RI
ri,[])
    BCC     Cond
_ BlockId
_ Maybe Bool
_            -> RegUsage
noUsage
    BCCFAR  Cond
_ BlockId
_ Maybe Bool
_            -> RegUsage
noUsage
    JMP     CLabel
_ [Reg]
regs           -> ([Reg], [Reg]) -> RegUsage
usage ([Reg]
regs, [])
    MTCTR   Reg
reg              -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg],[])
    BCTR    [Maybe BlockId]
_ Maybe CLabel
_ [Reg]
regs         -> ([Reg], [Reg]) -> RegUsage
usage ([Reg]
regs, [])
    BL      CLabel
_ [Reg]
params         -> ([Reg], [Reg]) -> RegUsage
usage ([Reg]
params, Platform -> [Reg]
callClobberedRegs Platform
platform)
    BCTRL   [Reg]
params           -> ([Reg], [Reg]) -> RegUsage
usage ([Reg]
params, Platform -> [Reg]
callClobberedRegs Platform
platform)

    ADD     Reg
reg1 Reg
reg2 RI
ri     -> ([Reg], [Reg]) -> RegUsage
usage (Reg
reg2 Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: RI -> [Reg]
regRI RI
ri, [Reg
reg1])
    ADDO    Reg
reg1 Reg
reg2 Reg
reg3   -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2,Reg
reg3], [Reg
reg1])
    ADDC    Reg
reg1 Reg
reg2 Reg
reg3   -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2,Reg
reg3], [Reg
reg1])
    ADDE    Reg
reg1 Reg
reg2 Reg
reg3   -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2,Reg
reg3], [Reg
reg1])
    ADDZE   Reg
reg1 Reg
reg2        -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2], [Reg
reg1])
    ADDIS   Reg
reg1 Reg
reg2 Imm
_      -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2], [Reg
reg1])
    SUBF    Reg
reg1 Reg
reg2 Reg
reg3   -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2,Reg
reg3], [Reg
reg1])
    SUBFO   Reg
reg1 Reg
reg2 Reg
reg3   -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2,Reg
reg3], [Reg
reg1])
    SUBFC   Reg
reg1 Reg
reg2 RI
ri     -> ([Reg], [Reg]) -> RegUsage
usage (Reg
reg2 Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: RI -> [Reg]
regRI RI
ri, [Reg
reg1])
    SUBFE   Reg
reg1 Reg
reg2 Reg
reg3   -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2,Reg
reg3], [Reg
reg1])
    MULL    Format
_ Reg
reg1 Reg
reg2 RI
ri   -> ([Reg], [Reg]) -> RegUsage
usage (Reg
reg2 Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: RI -> [Reg]
regRI RI
ri, [Reg
reg1])
    MULLO   Format
_ Reg
reg1 Reg
reg2 Reg
reg3 -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2,Reg
reg3], [Reg
reg1])
    MFOV    Format
_ Reg
reg            -> ([Reg], [Reg]) -> RegUsage
usage ([], [Reg
reg])
    MULHU   Format
_ Reg
reg1 Reg
reg2 Reg
reg3 -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2,Reg
reg3], [Reg
reg1])
    DIV     Format
_ Bool
_ Reg
reg1 Reg
reg2 Reg
reg3
                             -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2,Reg
reg3], [Reg
reg1])

    AND     Reg
reg1 Reg
reg2 RI
ri    -> ([Reg], [Reg]) -> RegUsage
usage (Reg
reg2 Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: RI -> [Reg]
regRI RI
ri, [Reg
reg1])
    ANDC    Reg
reg1 Reg
reg2 Reg
reg3  -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2,Reg
reg3], [Reg
reg1])
    NAND    Reg
reg1 Reg
reg2 Reg
reg3  -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2,Reg
reg3], [Reg
reg1])
    OR      Reg
reg1 Reg
reg2 RI
ri    -> ([Reg], [Reg]) -> RegUsage
usage (Reg
reg2 Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: RI -> [Reg]
regRI RI
ri, [Reg
reg1])
    ORIS    Reg
reg1 Reg
reg2 Imm
_     -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2], [Reg
reg1])
    XOR     Reg
reg1 Reg
reg2 RI
ri    -> ([Reg], [Reg]) -> RegUsage
usage (Reg
reg2 Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: RI -> [Reg]
regRI RI
ri, [Reg
reg1])
    XORIS   Reg
reg1 Reg
reg2 Imm
_     -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2], [Reg
reg1])
    EXTS    Format
_  Reg
reg1 Reg
reg2    -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2], [Reg
reg1])
    CNTLZ   Format
_  Reg
reg1 Reg
reg2    -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2], [Reg
reg1])
    NEG     Reg
reg1 Reg
reg2       -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2], [Reg
reg1])
    NOT     Reg
reg1 Reg
reg2       -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2], [Reg
reg1])
    SL      Format
_ Reg
reg1 Reg
reg2 RI
ri  -> ([Reg], [Reg]) -> RegUsage
usage (Reg
reg2 Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: RI -> [Reg]
regRI RI
ri, [Reg
reg1])
    SR      Format
_ Reg
reg1 Reg
reg2 RI
ri  -> ([Reg], [Reg]) -> RegUsage
usage (Reg
reg2 Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: RI -> [Reg]
regRI RI
ri, [Reg
reg1])
    SRA     Format
_ Reg
reg1 Reg
reg2 RI
ri  -> ([Reg], [Reg]) -> RegUsage
usage (Reg
reg2 Reg -> [Reg] -> [Reg]
forall a. a -> [a] -> [a]
: RI -> [Reg]
regRI RI
ri, [Reg
reg1])
    RLWINM  Reg
reg1 Reg
reg2 Int
_ Int
_ Int
_ -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2], [Reg
reg1])
    CLRLI   Format
_ Reg
reg1 Reg
reg2 Int
_   -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2], [Reg
reg1])
    CLRRI   Format
_ Reg
reg1 Reg
reg2 Int
_   -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
reg2], [Reg
reg1])

    FADD    Format
_ Reg
r1 Reg
r2 Reg
r3      -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
r2,Reg
r3], [Reg
r1])
    FSUB    Format
_ Reg
r1 Reg
r2 Reg
r3      -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
r2,Reg
r3], [Reg
r1])
    FMUL    Format
_ Reg
r1 Reg
r2 Reg
r3      -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
r2,Reg
r3], [Reg
r1])
    FDIV    Format
_ Reg
r1 Reg
r2 Reg
r3      -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
r2,Reg
r3], [Reg
r1])
    FABS    Reg
r1 Reg
r2           -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
r2], [Reg
r1])
    FNEG    Reg
r1 Reg
r2           -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
r2], [Reg
r1])
    FCMP    Reg
r1 Reg
r2           -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
r1,Reg
r2], [])
    FCTIWZ  Reg
r1 Reg
r2           -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
r2], [Reg
r1])
    FCTIDZ  Reg
r1 Reg
r2           -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
r2], [Reg
r1])
    FCFID   Reg
r1 Reg
r2           -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
r2], [Reg
r1])
    FRSP    Reg
r1 Reg
r2           -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
r2], [Reg
r1])
    MFCR    Reg
reg             -> ([Reg], [Reg]) -> RegUsage
usage ([], [Reg
reg])
    MFLR    Reg
reg             -> ([Reg], [Reg]) -> RegUsage
usage ([], [Reg
reg])
    FETCHPC Reg
reg             -> ([Reg], [Reg]) -> RegUsage
usage ([], [Reg
reg])
    FMADD FMASign
_ Format
_ Reg
rt Reg
ra Reg
rc Reg
rb   -> ([Reg], [Reg]) -> RegUsage
usage ([Reg
ra, Reg
rc, Reg
rb], [Reg
rt])
    Instr
_                       -> RegUsage
noUsage
  where
    usage :: ([Reg], [Reg]) -> RegUsage
usage ([Reg]
src, [Reg]
dst) = [Reg] -> [Reg] -> RegUsage
RU ((Reg -> Bool) -> [Reg] -> [Reg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Platform -> Reg -> Bool
interesting Platform
platform) [Reg]
src)
                          ((Reg -> Bool) -> [Reg] -> [Reg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Platform -> Reg -> Bool
interesting Platform
platform) [Reg]
dst)
    regAddr :: AddrMode -> [Reg]
regAddr (AddrRegReg Reg
r1 Reg
r2) = [Reg
r1, Reg
r2]
    regAddr (AddrRegImm Reg
r1 Imm
_)  = [Reg
r1]

    regRI :: RI -> [Reg]
regRI (RIReg Reg
r) = [Reg
r]
    regRI  RI
_        = []

interesting :: Platform -> Reg -> Bool
interesting :: Platform -> Reg -> Bool
interesting Platform
_        (RegVirtual VirtualReg
_)              = Bool
True
interesting Platform
platform (RegReal (RealRegSingle Int
i)) = Platform -> Int -> Bool
freeReg Platform
platform Int
i


-- | Apply a given mapping to all the register references in this
-- instruction.
patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr
patchRegsOfInstr Instr
instr Reg -> Reg
env
 = case Instr
instr of
    LD      Format
fmt Reg
reg AddrMode
addr    -> Format -> Reg -> AddrMode -> Instr
LD Format
fmt (Reg -> Reg
env Reg
reg) (AddrMode -> AddrMode
fixAddr AddrMode
addr)
    LDFAR   Format
fmt Reg
reg AddrMode
addr    -> Format -> Reg -> AddrMode -> Instr
LDFAR Format
fmt (Reg -> Reg
env Reg
reg) (AddrMode -> AddrMode
fixAddr AddrMode
addr)
    LDR     Format
fmt Reg
reg AddrMode
addr    -> Format -> Reg -> AddrMode -> Instr
LDR Format
fmt (Reg -> Reg
env Reg
reg) (AddrMode -> AddrMode
fixAddr AddrMode
addr)
    LA      Format
fmt Reg
reg AddrMode
addr    -> Format -> Reg -> AddrMode -> Instr
LA Format
fmt (Reg -> Reg
env Reg
reg) (AddrMode -> AddrMode
fixAddr AddrMode
addr)
    ST      Format
fmt Reg
reg AddrMode
addr    -> Format -> Reg -> AddrMode -> Instr
ST Format
fmt (Reg -> Reg
env Reg
reg) (AddrMode -> AddrMode
fixAddr AddrMode
addr)
    STFAR   Format
fmt Reg
reg AddrMode
addr    -> Format -> Reg -> AddrMode -> Instr
STFAR Format
fmt (Reg -> Reg
env Reg
reg) (AddrMode -> AddrMode
fixAddr AddrMode
addr)
    STU     Format
fmt Reg
reg AddrMode
addr    -> Format -> Reg -> AddrMode -> Instr
STU Format
fmt (Reg -> Reg
env Reg
reg) (AddrMode -> AddrMode
fixAddr AddrMode
addr)
    STC     Format
fmt Reg
reg AddrMode
addr    -> Format -> Reg -> AddrMode -> Instr
STC Format
fmt (Reg -> Reg
env Reg
reg) (AddrMode -> AddrMode
fixAddr AddrMode
addr)
    LIS     Reg
reg Imm
imm         -> Reg -> Imm -> Instr
LIS (Reg -> Reg
env Reg
reg) Imm
imm
    LI      Reg
reg Imm
imm         -> Reg -> Imm -> Instr
LI (Reg -> Reg
env Reg
reg) Imm
imm
    MR      Reg
reg1 Reg
reg2       -> Reg -> Reg -> Instr
MR (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2)
    CMP     Format
fmt Reg
reg RI
ri      -> Format -> Reg -> RI -> Instr
CMP Format
fmt (Reg -> Reg
env Reg
reg) (RI -> RI
fixRI RI
ri)
    CMPL    Format
fmt Reg
reg RI
ri      -> Format -> Reg -> RI -> Instr
CMPL Format
fmt (Reg -> Reg
env Reg
reg) (RI -> RI
fixRI RI
ri)
    BCC     Cond
cond BlockId
lbl Maybe Bool
p      -> Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
cond BlockId
lbl Maybe Bool
p
    BCCFAR  Cond
cond BlockId
lbl Maybe Bool
p      -> Cond -> BlockId -> Maybe Bool -> Instr
BCCFAR Cond
cond BlockId
lbl Maybe Bool
p
    JMP     CLabel
l [Reg]
regs          -> CLabel -> [Reg] -> Instr
JMP CLabel
l [Reg]
regs -- global regs will not be remapped
    MTCTR   Reg
reg             -> Reg -> Instr
MTCTR (Reg -> Reg
env Reg
reg)
    BCTR    [Maybe BlockId]
targets Maybe CLabel
lbl [Reg]
rs  -> [Maybe BlockId] -> Maybe CLabel -> [Reg] -> Instr
BCTR [Maybe BlockId]
targets Maybe CLabel
lbl [Reg]
rs
    BL      CLabel
imm [Reg]
argRegs     -> CLabel -> [Reg] -> Instr
BL CLabel
imm [Reg]
argRegs    -- argument regs
    BCTRL   [Reg]
argRegs         -> [Reg] -> Instr
BCTRL [Reg]
argRegs     -- cannot be remapped
    ADD     Reg
reg1 Reg
reg2 RI
ri    -> Reg -> Reg -> RI -> Instr
ADD (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (RI -> RI
fixRI RI
ri)
    ADDO    Reg
reg1 Reg
reg2 Reg
reg3  -> Reg -> Reg -> Reg -> Instr
ADDO (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (Reg -> Reg
env Reg
reg3)
    ADDC    Reg
reg1 Reg
reg2 Reg
reg3  -> Reg -> Reg -> Reg -> Instr
ADDC (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (Reg -> Reg
env Reg
reg3)
    ADDE    Reg
reg1 Reg
reg2 Reg
reg3  -> Reg -> Reg -> Reg -> Instr
ADDE (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (Reg -> Reg
env Reg
reg3)
    ADDZE   Reg
reg1 Reg
reg2       -> Reg -> Reg -> Instr
ADDZE (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2)
    ADDIS   Reg
reg1 Reg
reg2 Imm
imm   -> Reg -> Reg -> Imm -> Instr
ADDIS (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) Imm
imm
    SUBF    Reg
reg1 Reg
reg2 Reg
reg3  -> Reg -> Reg -> Reg -> Instr
SUBF (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (Reg -> Reg
env Reg
reg3)
    SUBFO   Reg
reg1 Reg
reg2 Reg
reg3  -> Reg -> Reg -> Reg -> Instr
SUBFO (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (Reg -> Reg
env Reg
reg3)
    SUBFC   Reg
reg1 Reg
reg2 RI
ri    -> Reg -> Reg -> RI -> Instr
SUBFC (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (RI -> RI
fixRI RI
ri)
    SUBFE   Reg
reg1 Reg
reg2 Reg
reg3  -> Reg -> Reg -> Reg -> Instr
SUBFE (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (Reg -> Reg
env Reg
reg3)
    MULL    Format
fmt Reg
reg1 Reg
reg2 RI
ri
                            -> Format -> Reg -> Reg -> RI -> Instr
MULL Format
fmt (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (RI -> RI
fixRI RI
ri)
    MULLO   Format
fmt Reg
reg1 Reg
reg2 Reg
reg3
                            -> Format -> Reg -> Reg -> Reg -> Instr
MULLO Format
fmt (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (Reg -> Reg
env Reg
reg3)
    MFOV    Format
fmt Reg
reg         -> Format -> Reg -> Instr
MFOV Format
fmt (Reg -> Reg
env Reg
reg)
    MULHU   Format
fmt Reg
reg1 Reg
reg2 Reg
reg3
                            -> Format -> Reg -> Reg -> Reg -> Instr
MULHU Format
fmt (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (Reg -> Reg
env Reg
reg3)
    DIV     Format
fmt Bool
sgn Reg
reg1 Reg
reg2 Reg
reg3
                            -> Format -> Bool -> Reg -> Reg -> Reg -> Instr
DIV Format
fmt Bool
sgn (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (Reg -> Reg
env Reg
reg3)

    AND     Reg
reg1 Reg
reg2 RI
ri    -> Reg -> Reg -> RI -> Instr
AND (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (RI -> RI
fixRI RI
ri)
    ANDC    Reg
reg1 Reg
reg2 Reg
reg3  -> Reg -> Reg -> Reg -> Instr
ANDC (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (Reg -> Reg
env Reg
reg3)
    NAND    Reg
reg1 Reg
reg2 Reg
reg3  -> Reg -> Reg -> Reg -> Instr
NAND (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (Reg -> Reg
env Reg
reg3)
    OR      Reg
reg1 Reg
reg2 RI
ri    -> Reg -> Reg -> RI -> Instr
OR  (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (RI -> RI
fixRI RI
ri)
    ORIS    Reg
reg1 Reg
reg2 Imm
imm   -> Reg -> Reg -> Imm -> Instr
ORIS (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) Imm
imm
    XOR     Reg
reg1 Reg
reg2 RI
ri    -> Reg -> Reg -> RI -> Instr
XOR (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (RI -> RI
fixRI RI
ri)
    XORIS   Reg
reg1 Reg
reg2 Imm
imm   -> Reg -> Reg -> Imm -> Instr
XORIS (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) Imm
imm
    EXTS    Format
fmt Reg
reg1 Reg
reg2   -> Format -> Reg -> Reg -> Instr
EXTS Format
fmt (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2)
    CNTLZ   Format
fmt Reg
reg1 Reg
reg2   -> Format -> Reg -> Reg -> Instr
CNTLZ Format
fmt (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2)
    NEG     Reg
reg1 Reg
reg2       -> Reg -> Reg -> Instr
NEG (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2)
    NOT     Reg
reg1 Reg
reg2       -> Reg -> Reg -> Instr
NOT (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2)
    SL      Format
fmt Reg
reg1 Reg
reg2 RI
ri
                            -> Format -> Reg -> Reg -> RI -> Instr
SL Format
fmt (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (RI -> RI
fixRI RI
ri)
    SR      Format
fmt Reg
reg1 Reg
reg2 RI
ri
                            -> Format -> Reg -> Reg -> RI -> Instr
SR Format
fmt (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (RI -> RI
fixRI RI
ri)
    SRA     Format
fmt Reg
reg1 Reg
reg2 RI
ri
                            -> Format -> Reg -> Reg -> RI -> Instr
SRA Format
fmt (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) (RI -> RI
fixRI RI
ri)
    RLWINM  Reg
reg1 Reg
reg2 Int
sh Int
mb Int
me
                            -> Reg -> Reg -> Int -> Int -> Int -> Instr
RLWINM (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) Int
sh Int
mb Int
me
    CLRLI   Format
fmt Reg
reg1 Reg
reg2 Int
n -> Format -> Reg -> Reg -> Int -> Instr
CLRLI Format
fmt (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) Int
n
    CLRRI   Format
fmt Reg
reg1 Reg
reg2 Int
n -> Format -> Reg -> Reg -> Int -> Instr
CLRRI Format
fmt (Reg -> Reg
env Reg
reg1) (Reg -> Reg
env Reg
reg2) Int
n
    FADD    Format
fmt Reg
r1 Reg
r2 Reg
r3    -> Format -> Reg -> Reg -> Reg -> Instr
FADD Format
fmt (Reg -> Reg
env Reg
r1) (Reg -> Reg
env Reg
r2) (Reg -> Reg
env Reg
r3)
    FSUB    Format
fmt Reg
r1 Reg
r2 Reg
r3    -> Format -> Reg -> Reg -> Reg -> Instr
FSUB Format
fmt (Reg -> Reg
env Reg
r1) (Reg -> Reg
env Reg
r2) (Reg -> Reg
env Reg
r3)
    FMUL    Format
fmt Reg
r1 Reg
r2 Reg
r3    -> Format -> Reg -> Reg -> Reg -> Instr
FMUL Format
fmt (Reg -> Reg
env Reg
r1) (Reg -> Reg
env Reg
r2) (Reg -> Reg
env Reg
r3)
    FDIV    Format
fmt Reg
r1 Reg
r2 Reg
r3    -> Format -> Reg -> Reg -> Reg -> Instr
FDIV Format
fmt (Reg -> Reg
env Reg
r1) (Reg -> Reg
env Reg
r2) (Reg -> Reg
env Reg
r3)
    FABS    Reg
r1 Reg
r2           -> Reg -> Reg -> Instr
FABS (Reg -> Reg
env Reg
r1) (Reg -> Reg
env Reg
r2)
    FNEG    Reg
r1 Reg
r2           -> Reg -> Reg -> Instr
FNEG (Reg -> Reg
env Reg
r1) (Reg -> Reg
env Reg
r2)
    FMADD   FMASign
sgn Format
fmt Reg
r1 Reg
r2 Reg
r3 Reg
r4
                            -> FMASign -> Format -> Reg -> Reg -> Reg -> Reg -> Instr
FMADD FMASign
sgn Format
fmt (Reg -> Reg
env Reg
r1) (Reg -> Reg
env Reg
r2) (Reg -> Reg
env Reg
r3) (Reg -> Reg
env Reg
r4)
    FCMP    Reg
r1 Reg
r2           -> Reg -> Reg -> Instr
FCMP (Reg -> Reg
env Reg
r1) (Reg -> Reg
env Reg
r2)
    FCTIWZ  Reg
r1 Reg
r2           -> Reg -> Reg -> Instr
FCTIWZ (Reg -> Reg
env Reg
r1) (Reg -> Reg
env Reg
r2)
    FCTIDZ  Reg
r1 Reg
r2           -> Reg -> Reg -> Instr
FCTIDZ (Reg -> Reg
env Reg
r1) (Reg -> Reg
env Reg
r2)
    FCFID   Reg
r1 Reg
r2           -> Reg -> Reg -> Instr
FCFID (Reg -> Reg
env Reg
r1) (Reg -> Reg
env Reg
r2)
    FRSP    Reg
r1 Reg
r2           -> Reg -> Reg -> Instr
FRSP (Reg -> Reg
env Reg
r1) (Reg -> Reg
env Reg
r2)
    MFCR    Reg
reg             -> Reg -> Instr
MFCR (Reg -> Reg
env Reg
reg)
    MFLR    Reg
reg             -> Reg -> Instr
MFLR (Reg -> Reg
env Reg
reg)
    FETCHPC Reg
reg             -> Reg -> Instr
FETCHPC (Reg -> Reg
env Reg
reg)
    Instr
_                       -> Instr
instr
  where
    fixAddr :: AddrMode -> AddrMode
fixAddr (AddrRegReg Reg
r1 Reg
r2) = Reg -> Reg -> AddrMode
AddrRegReg (Reg -> Reg
env Reg
r1) (Reg -> Reg
env Reg
r2)
    fixAddr (AddrRegImm Reg
r1 Imm
i)  = Reg -> Imm -> AddrMode
AddrRegImm (Reg -> Reg
env Reg
r1) Imm
i

    fixRI :: RI -> RI
fixRI (RIReg Reg
r) = Reg -> RI
RIReg (Reg -> Reg
env Reg
r)
    fixRI RI
other     = RI
other


--------------------------------------------------------------------------------
-- | Checks whether this instruction is a jump/branch instruction.
-- One that can change the flow of control in a way that the
-- register allocator needs to worry about.
isJumpishInstr :: Instr -> Bool
isJumpishInstr :: Instr -> Bool
isJumpishInstr Instr
instr
 = case Instr
instr of
    BCC{}       -> Bool
True
    BCCFAR{}    -> Bool
True
    BCTR{}      -> Bool
True
    BCTRL{}     -> Bool
True
    BL{}        -> Bool
True
    JMP{}       -> Bool
True
    Instr
_           -> Bool
False


-- | Checks whether this instruction is a jump/branch instruction.
-- One that can change the flow of control in a way that the
-- register allocator needs to worry about.
jumpDestsOfInstr :: Instr -> [BlockId]
jumpDestsOfInstr :: Instr -> [BlockId]
jumpDestsOfInstr Instr
insn
  = case Instr
insn of
        BCC Cond
_ BlockId
id Maybe Bool
_       -> [BlockId
id]
        BCCFAR Cond
_ BlockId
id Maybe Bool
_    -> [BlockId
id]
        BCTR [Maybe BlockId]
targets Maybe CLabel
_ [Reg]
_ -> [BlockId
id | Just BlockId
id <- [Maybe BlockId]
targets]
        Instr
_                -> []


-- | Change the destination of this jump instruction.
-- Used in the linear allocator when adding fixup blocks for join
-- points.
patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr
patchJumpInstr Instr
insn BlockId -> BlockId
patchF
  = case Instr
insn of
        BCC Cond
cc BlockId
id Maybe Bool
p     -> Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
cc (BlockId -> BlockId
patchF BlockId
id) Maybe Bool
p
        BCCFAR Cond
cc BlockId
id Maybe Bool
p  -> Cond -> BlockId -> Maybe Bool -> Instr
BCCFAR Cond
cc (BlockId -> BlockId
patchF BlockId
id) Maybe Bool
p
        BCTR [Maybe BlockId]
ids Maybe CLabel
lbl [Reg]
rs -> [Maybe BlockId] -> Maybe CLabel -> [Reg] -> Instr
BCTR ((Maybe BlockId -> Maybe BlockId)
-> [Maybe BlockId] -> [Maybe BlockId]
forall a b. (a -> b) -> [a] -> [b]
map ((BlockId -> BlockId) -> Maybe BlockId -> Maybe BlockId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BlockId -> BlockId
patchF) [Maybe BlockId]
ids) Maybe CLabel
lbl [Reg]
rs
        Instr
_               -> Instr
insn


-- -----------------------------------------------------------------------------

-- | An instruction to spill a register into a spill slot.
mkSpillInstr
   :: NCGConfig
   -> Reg       -- register to spill
   -> Int       -- current stack delta
   -> Int       -- spill slot to use
   -> [Instr]

mkSpillInstr :: NCGConfig -> Reg -> Int -> Int -> [Instr]
mkSpillInstr NCGConfig
config Reg
reg Int
delta Int
slot
  = let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
        off :: Int
off      = Platform -> Int -> Int
spillSlotToOffset Platform
platform Int
slot
        arch :: Arch
arch     = Platform -> Arch
platformArch Platform
platform
    in
    let fmt :: Format
fmt = case Platform -> Reg -> RegClass
targetClassOfReg Platform
platform Reg
reg of
                RegClass
RcInteger -> case Arch
arch of
                                Arch
ArchPPC -> Format
II32
                                Arch
_       -> Format
II64
                RegClass
RcDouble  -> Format
FF64
                RegClass
_         -> String -> Format
forall a. HasCallStack => String -> a
panic String
"PPC.Instr.mkSpillInstr: no match"
        instr :: Format -> Reg -> AddrMode -> Instr
instr = case Width -> Bool -> Int -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W32 Bool
True (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
delta) of
                Just Imm
_  -> Format -> Reg -> AddrMode -> Instr
ST
                Maybe Imm
Nothing -> Format -> Reg -> AddrMode -> Instr
STFAR -- pseudo instruction: 32 bit offsets

    in [Format -> Reg -> AddrMode -> Instr
instr Format
fmt Reg
reg (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
delta)))]


mkLoadInstr
   :: NCGConfig
   -> Reg       -- register to load
   -> Int       -- current stack delta
   -> Int       -- spill slot to use
   -> [Instr]

mkLoadInstr :: NCGConfig -> Reg -> Int -> Int -> [Instr]
mkLoadInstr NCGConfig
config Reg
reg Int
delta Int
slot
  = let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
        off :: Int
off      = Platform -> Int -> Int
spillSlotToOffset Platform
platform Int
slot
        arch :: Arch
arch     = Platform -> Arch
platformArch Platform
platform
    in
    let fmt :: Format
fmt = case Platform -> Reg -> RegClass
targetClassOfReg Platform
platform Reg
reg of
                RegClass
RcInteger ->  case Arch
arch of
                                 Arch
ArchPPC -> Format
II32
                                 Arch
_       -> Format
II64
                RegClass
RcDouble  -> Format
FF64
                RegClass
_         -> String -> Format
forall a. HasCallStack => String -> a
panic String
"PPC.Instr.mkLoadInstr: no match"
        instr :: Format -> Reg -> AddrMode -> Instr
instr = case Width -> Bool -> Int -> Maybe Imm
forall a. Integral a => Width -> Bool -> a -> Maybe Imm
makeImmediate Width
W32 Bool
True (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
delta) of
                Just Imm
_  -> Format -> Reg -> AddrMode -> Instr
LD
                Maybe Imm
Nothing -> Format -> Reg -> AddrMode -> Instr
LDFAR -- pseudo instruction: 32 bit offsets

    in [Format -> Reg -> AddrMode -> Instr
instr Format
fmt Reg
reg (Reg -> Imm -> AddrMode
AddrRegImm Reg
sp (Int -> Imm
ImmInt (Int
offInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
delta)))]


-- | The size of a minimal stackframe header including minimal
-- parameter save area.
stackFrameHeaderSize :: Platform -> Int
stackFrameHeaderSize :: Platform -> Int
stackFrameHeaderSize Platform
platform
  = case Platform -> OS
platformOS Platform
platform of
      OS
OSAIX    -> Int
24 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4
      OS
_ -> case Platform -> Arch
platformArch Platform
platform of
                             -- header + parameter save area
             Arch
ArchPPC           -> Int
64 -- TODO: check ABI spec
             ArchPPC_64 PPC_64ABI
ELF_V1 -> Int
48 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
             ArchPPC_64 PPC_64ABI
ELF_V2 -> Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
             Arch
_ -> String -> Int
forall a. HasCallStack => String -> a
panic String
"PPC.stackFrameHeaderSize: not defined for this OS"

-- | The maximum number of bytes required to spill a register. PPC32
-- has 32-bit GPRs and 64-bit FPRs, while PPC64 has 64-bit GPRs and
-- 64-bit FPRs. So the maximum is 8 regardless of platforms unlike
-- x86. Note that AltiVec's vector registers are 128-bit wide so we
-- must not use this to spill them.
spillSlotSize :: Int
spillSlotSize :: Int
spillSlotSize = Int
8

-- | The number of spill slots available without allocating more.
maxSpillSlots :: NCGConfig -> Int
maxSpillSlots :: NCGConfig -> Int
maxSpillSlots NCGConfig
config
--  = 0 -- useful for testing allocMoreStack
    = let platform :: Platform
platform = NCGConfig -> Platform
ncgPlatform NCGConfig
config
      in ((NCGConfig -> Int
ncgSpillPreallocSize NCGConfig
config Int -> Int -> Int
forall a. Num a => a -> a -> a
- Platform -> Int
stackFrameHeaderSize Platform
platform)
         Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
spillSlotSize) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

-- | The number of bytes that the stack pointer should be aligned
-- to. This is 16 both on PPC32 and PPC64 ELF (see ELF processor
-- specific supplements).
stackAlign :: Int
stackAlign :: Int
stackAlign = Int
16

-- | Convert a spill slot number to a *byte* offset, with no sign.
spillSlotToOffset :: Platform -> Int -> Int
spillSlotToOffset :: Platform -> Int -> Int
spillSlotToOffset Platform
platform Int
slot
   = Platform -> Int
stackFrameHeaderSize Platform
platform Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
spillSlotSize Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
slot


--------------------------------------------------------------------------------
-- | See if this instruction is telling us the current C stack delta
takeDeltaInstr
    :: Instr
    -> Maybe Int

takeDeltaInstr :: Instr -> Maybe Int
takeDeltaInstr Instr
instr
 = case Instr
instr of
     DELTA Int
i  -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
     Instr
_        -> Maybe Int
forall a. Maybe a
Nothing


isMetaInstr
    :: Instr
    -> Bool

isMetaInstr :: Instr -> Bool
isMetaInstr Instr
instr
 = case Instr
instr of
    COMMENT{}   -> Bool
True
    LOCATION{}  -> Bool
True
    LDATA{}     -> Bool
True
    NEWBLOCK{}  -> Bool
True
    DELTA{}     -> Bool
True
    Instr
_           -> Bool
False


-- | Copy the value in a register to another one.
-- Must work for all register classes.
mkRegRegMoveInstr
    :: Reg
    -> Reg
    -> Instr

mkRegRegMoveInstr :: Reg -> Reg -> Instr
mkRegRegMoveInstr Reg
src Reg
dst
    = Reg -> Reg -> Instr
MR Reg
dst Reg
src


-- | Make an unconditional jump instruction.
mkJumpInstr
    :: BlockId
    -> [Instr]

mkJumpInstr :: BlockId -> [Instr]
mkJumpInstr BlockId
id
    = [Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
id Maybe Bool
forall a. Maybe a
Nothing]


-- | Take the source and destination from this reg -> reg move instruction
-- or Nothing if it's not one
takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)
takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg)
takeRegRegMoveInstr (MR Reg
dst Reg
src) = (Reg, Reg) -> Maybe (Reg, Reg)
forall a. a -> Maybe a
Just (Reg
src,Reg
dst)
takeRegRegMoveInstr Instr
_  = Maybe (Reg, Reg)
forall a. Maybe a
Nothing

-- -----------------------------------------------------------------------------
-- Making far branches

-- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too
-- big, we have to work around this limitation.

makeFarBranches
        :: LabelMap RawCmmStatics
        -> [NatBasicBlock Instr]
        -> [NatBasicBlock Instr]
makeFarBranches :: LabelMap RawCmmStatics
-> [GenBasicBlock Instr] -> [GenBasicBlock Instr]
makeFarBranches LabelMap RawCmmStatics
info_env [GenBasicBlock Instr]
blocks
    | NonEmpty Int -> Int
forall a. NonEmpty a -> a
NE.last NonEmpty Int
blockAddresses Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
nearLimit = [GenBasicBlock Instr]
blocks
    | Bool
otherwise = (Int -> GenBasicBlock Instr -> GenBasicBlock Instr)
-> [Int] -> [GenBasicBlock Instr] -> [GenBasicBlock Instr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> GenBasicBlock Instr -> GenBasicBlock Instr
handleBlock [Int]
blockAddressList [GenBasicBlock Instr]
blocks
    where
        blockAddresses :: NonEmpty Int
blockAddresses = (Int -> Int -> Int) -> Int -> [Int] -> NonEmpty Int
forall (f :: * -> *) b a.
Foldable f =>
(b -> a -> b) -> b -> f a -> NonEmpty b
NE.scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 ([Int] -> NonEmpty Int) -> [Int] -> NonEmpty Int
forall a b. (a -> b) -> a -> b
$ (GenBasicBlock Instr -> Int) -> [GenBasicBlock Instr] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map GenBasicBlock Instr -> Int
forall {a}. GenBasicBlock a -> Int
blockLen [GenBasicBlock Instr]
blocks
        blockAddressList :: [Int]
blockAddressList = NonEmpty Int -> [Int]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList NonEmpty Int
blockAddresses
        blockLen :: GenBasicBlock a -> Int
blockLen (BasicBlock BlockId
_ [a]
instrs) = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
instrs

        handleBlock :: Int -> GenBasicBlock Instr -> GenBasicBlock Instr
handleBlock Int
addr (BasicBlock BlockId
id [Instr]
instrs)
                = BlockId -> [Instr] -> GenBasicBlock Instr
forall i. BlockId -> [i] -> GenBasicBlock i
BasicBlock BlockId
id ((Int -> Instr -> Instr) -> [Int] -> [Instr] -> [Instr]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Instr -> Instr
makeFar [Int
addr..] [Instr]
instrs)

        makeFar :: Int -> Instr -> Instr
makeFar Int
_ (BCC Cond
ALWAYS BlockId
tgt Maybe Bool
_) = Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
ALWAYS BlockId
tgt Maybe Bool
forall a. Maybe a
Nothing
        makeFar Int
addr (BCC Cond
cond BlockId
tgt Maybe Bool
p)
            | Int -> Int
forall a. Num a => a -> a
abs (Int
addr Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
targetAddr) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
nearLimit
            = Cond -> BlockId -> Maybe Bool -> Instr
BCCFAR Cond
cond BlockId
tgt Maybe Bool
p
            | Bool
otherwise
            = Cond -> BlockId -> Maybe Bool -> Instr
BCC Cond
cond BlockId
tgt Maybe Bool
p
            where Just Int
targetAddr = UniqFM BlockId Int -> BlockId -> Maybe Int
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM BlockId Int
blockAddressMap BlockId
tgt
        makeFar Int
_ Instr
other            = Instr
other

        -- 8192 instructions are allowed; let's keep some distance, as
        -- we have a few pseudo-insns that are pretty-printed as
        -- multiple instructions, and it's just not worth the effort
        -- to calculate things exactly
        nearLimit :: Int
nearLimit = Int
7000 Int -> Int -> Int
forall a. Num a => a -> a -> a
- LabelMap RawCmmStatics -> Int
forall a. LabelMap a -> Int
forall (map :: * -> *) a. IsMap map => map a -> Int
mapSize LabelMap RawCmmStatics
info_env Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
maxRetInfoTableSizeW

        blockAddressMap :: UniqFM BlockId Int
blockAddressMap = [(BlockId, Int)] -> UniqFM BlockId Int
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM ([(BlockId, Int)] -> UniqFM BlockId Int)
-> [(BlockId, Int)] -> UniqFM BlockId Int
forall a b. (a -> b) -> a -> b
$ [BlockId] -> [Int] -> [(BlockId, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((GenBasicBlock Instr -> BlockId)
-> [GenBasicBlock Instr] -> [BlockId]
forall a b. (a -> b) -> [a] -> [b]
map GenBasicBlock Instr -> BlockId
forall i. GenBasicBlock i -> BlockId
blockId [GenBasicBlock Instr]
blocks) [Int]
blockAddressList