-- | Evaluation of 32 bit values.
module GHC.CmmToAsm.SPARC.CodeGen.Gen32 (
        getSomeReg,
        getRegister
)

where

import GHC.Prelude

import GHC.CmmToAsm.SPARC.CodeGen.CondCode
import GHC.CmmToAsm.SPARC.CodeGen.Amode
import GHC.CmmToAsm.SPARC.CodeGen.Gen64
import GHC.CmmToAsm.SPARC.CodeGen.Base
import GHC.CmmToAsm.SPARC.Stack
import GHC.CmmToAsm.SPARC.Instr
import GHC.CmmToAsm.SPARC.Cond
import GHC.CmmToAsm.SPARC.AddrMode
import GHC.CmmToAsm.SPARC.Imm
import GHC.CmmToAsm.SPARC.Regs
import GHC.CmmToAsm.SPARC.Base
import GHC.CmmToAsm.Monad
import GHC.CmmToAsm.Format
import GHC.Platform.Reg

import GHC.Cmm

import Control.Monad (liftM)
import GHC.Data.OrdList
import GHC.Utils.Outputable

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



-- | Make code to evaluate a 32 bit expression.
--
getRegister :: CmmExpr -> NatM Register

getRegister :: CmmExpr -> NatM Register
getRegister (CmmReg CmmReg
reg)
  = do Platform
platform <- NatM Platform
getPlatform
       Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> Reg -> InstrBlock -> Register
Fixed (CmmType -> Format
cmmTypeFormat (Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
reg))
                     (Platform -> CmmReg -> Reg
getRegisterReg Platform
platform CmmReg
reg) InstrBlock
forall a. OrdList a
nilOL)

getRegister tree :: CmmExpr
tree@(CmmRegOff CmmReg
_ Int
_)
  = do Platform
platform <- NatM Platform
getPlatform
       CmmExpr -> NatM Register
getRegister (Platform -> CmmExpr -> CmmExpr
mangleIndexTree Platform
platform CmmExpr
tree)

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

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

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

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


-- Load a literal float into a float register.
--      The actual literal is stored in a new data area, and we load it
--      at runtime.
getRegister (CmmLit (CmmFloat Rational
f Width
W32)) = do

    -- a label for the new data area
    CLabel
lbl <- NatM CLabel
getNewLabelNat
    Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
II32

    let code :: Reg -> InstrBlock
code Reg
dst = [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
            -- the data area
            Section -> RawCmmStatics -> Instr
LDATA (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) (RawCmmStatics -> Instr) -> RawCmmStatics -> Instr
forall a b. (a -> b) -> a -> b
$ CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl
                         [CmmLit -> CmmStatic
CmmStaticLit (Rational -> Width -> CmmLit
CmmFloat Rational
f Width
W32)],

            -- load the literal
            Imm -> Reg -> Instr
SETHI (Imm -> Imm
HI (CLabel -> Imm
ImmCLbl CLabel
lbl)) Reg
tmp,
            Format -> AddrMode -> Reg -> Instr
LD Format
II32 (Reg -> Imm -> AddrMode
AddrRegImm Reg
tmp (Imm -> Imm
LO (CLabel -> Imm
ImmCLbl CLabel
lbl))) Reg
dst]

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

getRegister (CmmLit (CmmFloat Rational
d Width
W64)) = do
    CLabel
lbl <- NatM CLabel
getNewLabelNat
    Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
II32
    let code :: Reg -> InstrBlock
code Reg
dst = [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
            Section -> RawCmmStatics -> Instr
LDATA (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) (RawCmmStatics -> Instr) -> RawCmmStatics -> Instr
forall a b. (a -> b) -> a -> b
$ CLabel -> [CmmStatic] -> RawCmmStatics
forall (rawOnly :: Bool).
CLabel -> [CmmStatic] -> GenCmmStatics rawOnly
CmmStaticsRaw CLabel
lbl
                         [CmmLit -> CmmStatic
CmmStaticLit (Rational -> Width -> CmmLit
CmmFloat Rational
d Width
W64)],
            Imm -> Reg -> Instr
SETHI (Imm -> Imm
HI (CLabel -> Imm
ImmCLbl CLabel
lbl)) Reg
tmp,
            Format -> AddrMode -> Reg -> Instr
LD Format
II64 (Reg -> Imm -> AddrMode
AddrRegImm Reg
tmp (Imm -> Imm
LO (CLabel -> Imm
ImmCLbl CLabel
lbl))) Reg
dst]
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
FF64 Reg -> InstrBlock
code)


-- Unary machine ops
getRegister (CmmMachOp MachOp
mop [CmmExpr
x])
  = case MachOp
mop of
        -- Floating point negation -------------------------
        MO_F_Neg Width
W32            -> Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUFCode Format
FF32 (Format -> Reg -> Reg -> Instr
FNEG Format
FF32) CmmExpr
x
        MO_F_Neg Width
W64            -> Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUFCode Format
FF64 (Format -> Reg -> Reg -> Instr
FNEG Format
FF64) CmmExpr
x


        -- Integer negation --------------------------------
        MO_S_Neg Width
rep            -> Format -> (RI -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUCode (Width -> Format
intFormat Width
rep) (Bool -> Bool -> Reg -> RI -> Reg -> Instr
SUB Bool
False Bool
False Reg
g0) CmmExpr
x
        MO_Not Width
rep              -> Format -> (RI -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUCode (Width -> Format
intFormat Width
rep) (Bool -> Reg -> RI -> Reg -> Instr
XNOR Bool
False Reg
g0) CmmExpr
x


        -- Float word size conversion ----------------------
        MO_FF_Conv Width
W64 Width
W32      -> CmmExpr -> NatM Register
coerceDbl2Flt CmmExpr
x
        MO_FF_Conv Width
W32 Width
W64      -> CmmExpr -> NatM Register
coerceFlt2Dbl CmmExpr
x


        -- Float <-> Signed Int conversion -----------------
        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


        -- Unsigned integer word size conversions ----------

        -- If it's the same size, then nothing needs to be done.
        MO_UU_Conv Width
from Width
to
         | Width
from Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
to           -> Format -> CmmExpr -> NatM Register
conversionNop (Width -> Format
intFormat Width
to)  CmmExpr
x

        -- To narrow an unsigned word, mask out the high bits to simulate what would
        --      happen if we copied the value into a smaller register.
        MO_UU_Conv Width
W16 Width
W8       -> Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
W8  (Bool -> Reg -> RI -> Reg -> Instr
AND Bool
False) CmmExpr
x (CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
255 Width
W8))
        MO_UU_Conv Width
W32 Width
W8       -> Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
W8  (Bool -> Reg -> RI -> Reg -> Instr
AND Bool
False) CmmExpr
x (CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
255 Width
W8))

        -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8
        --      case because the only way we can load it is via SETHI, which needs 2 ops.
        --      Do some shifts to chop out the high bits instead.
        MO_UU_Conv Width
W32 Width
W16
         -> do  Reg
tmpReg          <- Format -> NatM Reg
getNewRegNat Format
II32
                (Reg
xReg, InstrBlock
xCode)   <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
                let code :: Reg -> InstrBlock
code Reg
dst
                        =       InstrBlock
xCode
                        InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL
                                [ Reg -> RI -> Reg -> Instr
SLL Reg
xReg   (Imm -> RI
RIImm (Imm -> RI) -> Imm -> RI
forall a b. (a -> b) -> a -> b
$ Int -> Imm
ImmInt Int
16) Reg
tmpReg
                                , Reg -> RI -> Reg -> Instr
SRL Reg
tmpReg (Imm -> RI
RIImm (Imm -> RI) -> Imm -> RI
forall a b. (a -> b) -> a -> b
$ Int -> Imm
ImmInt Int
16) Reg
dst]

                Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return  (Register -> NatM Register) -> Register -> NatM Register
forall a b. (a -> b) -> a -> b
$ Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 Reg -> InstrBlock
code

                --       trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))

        -- To widen an unsigned word we don't have to do anything.
        --      Just leave it in the same register and mark the result as the new size.
        MO_UU_Conv Width
W8  Width
W16      -> Format -> CmmExpr -> NatM Register
conversionNop (Width -> Format
intFormat Width
W16)  CmmExpr
x
        MO_UU_Conv Width
W8  Width
W32      -> Format -> CmmExpr -> NatM Register
conversionNop (Width -> Format
intFormat Width
W32)  CmmExpr
x
        MO_UU_Conv Width
W16 Width
W32      -> Format -> CmmExpr -> NatM Register
conversionNop (Width -> Format
intFormat Width
W32)  CmmExpr
x


        -- Signed integer word size conversions ------------

        -- Mask out high bits when narrowing them
        MO_SS_Conv Width
W16 Width
W8       -> Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
W8  (Bool -> Reg -> RI -> Reg -> Instr
AND Bool
False) CmmExpr
x (CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
255 Width
W8))
        MO_SS_Conv Width
W32 Width
W8       -> Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
W8  (Bool -> Reg -> RI -> Reg -> Instr
AND Bool
False) CmmExpr
x (CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
255 Width
W8))
        MO_SS_Conv Width
W32 Width
W16      -> Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
W16 (Bool -> Reg -> RI -> Reg -> Instr
AND Bool
False) CmmExpr
x (CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt Integer
65535 Width
W16))

        -- Sign extend signed words when widening them.
        MO_SS_Conv Width
W8  Width
W16      -> Width -> Width -> CmmExpr -> NatM Register
integerExtend Width
W8  Width
W16 CmmExpr
x
        MO_SS_Conv Width
W8  Width
W32      -> Width -> Width -> CmmExpr -> NatM Register
integerExtend Width
W8  Width
W32 CmmExpr
x
        MO_SS_Conv Width
W16 Width
W32      -> Width -> Width -> CmmExpr -> NatM Register
integerExtend Width
W16 Width
W32 CmmExpr
x

        MachOp
_                       -> String -> NatM Register
forall a. String -> a
panic (String
"Unknown unary mach op: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ MachOp -> String
forall a. Show a => a -> String
show MachOp
mop)


-- Binary machine ops
getRegister (CmmMachOp MachOp
mop [CmmExpr
x, CmmExpr
y])
  = case MachOp
mop of
      MO_Eq Width
_           -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
EQQ CmmExpr
x CmmExpr
y
      MO_Ne Width
_           -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
NE CmmExpr
x CmmExpr
y

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

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

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

      MO_Add Width
W32        -> Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
W32 (Bool -> Bool -> Reg -> RI -> Reg -> Instr
ADD Bool
False Bool
False) CmmExpr
x CmmExpr
y
      MO_Sub Width
W32        -> Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
W32 (Bool -> Bool -> Reg -> RI -> Reg -> Instr
SUB Bool
False Bool
False) CmmExpr
x CmmExpr
y

      MO_S_MulMayOflo Width
rep -> Width -> CmmExpr -> CmmExpr -> NatM Register
imulMayOflo Width
rep CmmExpr
x CmmExpr
y

      MO_S_Quot Width
W32     -> Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register
idiv Bool
True  Bool
False CmmExpr
x CmmExpr
y
      MO_U_Quot Width
W32     -> Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register
idiv Bool
False Bool
False CmmExpr
x CmmExpr
y

      MO_S_Rem  Width
W32     -> Bool -> CmmExpr -> CmmExpr -> NatM Register
irem Bool
True  CmmExpr
x CmmExpr
y
      MO_U_Rem  Width
W32     -> Bool -> CmmExpr -> CmmExpr -> NatM Register
irem Bool
False CmmExpr
x CmmExpr
y

      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_F_Add  Width
w       -> Width
-> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialFCode Width
w Format -> Reg -> Reg -> Reg -> Instr
FADD CmmExpr
x CmmExpr
y
      MO_F_Sub  Width
w       -> Width
-> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialFCode Width
w Format -> Reg -> Reg -> Reg -> Instr
FSUB CmmExpr
x CmmExpr
y
      MO_F_Mul  Width
w       -> Width
-> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialFCode Width
w Format -> Reg -> Reg -> Reg -> Instr
FMUL CmmExpr
x CmmExpr
y
      MO_F_Quot Width
w       -> Width
-> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialFCode Width
w Format -> Reg -> Reg -> Reg -> Instr
FDIV CmmExpr
x CmmExpr
y

      MO_And Width
rep        -> Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep (Bool -> Reg -> RI -> Reg -> Instr
AND Bool
False) CmmExpr
x CmmExpr
y
      MO_Or  Width
rep        -> Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep (Bool -> Reg -> RI -> Reg -> Instr
OR  Bool
False) CmmExpr
x CmmExpr
y
      MO_Xor Width
rep        -> Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep (Bool -> Reg -> RI -> Reg -> Instr
XOR Bool
False) CmmExpr
x CmmExpr
y

      MO_Mul Width
rep        -> Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep (Bool -> Reg -> RI -> Reg -> Instr
SMUL Bool
False) CmmExpr
x CmmExpr
y

      MO_Shl Width
rep        -> Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Reg -> RI -> Reg -> Instr
SLL  CmmExpr
x CmmExpr
y
      MO_U_Shr Width
rep      -> Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Reg -> RI -> Reg -> Instr
SRL CmmExpr
x CmmExpr
y
      MO_S_Shr Width
rep      -> Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Reg -> RI -> Reg -> Instr
SRA CmmExpr
x CmmExpr
y

      MachOp
_                 -> String -> SDoc -> NatM Register
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"getRegister(sparc) - binary CmmMachOp (1)" (MachOp -> SDoc
pprMachOp MachOp
mop)

getRegister (CmmLoad CmmExpr
mem CmmType
pk) = do
    Amode AddrMode
src InstrBlock
code <- CmmExpr -> NatM Amode
getAmode CmmExpr
mem
    let
        code__2 :: Reg -> InstrBlock
code__2 Reg
dst     = InstrBlock
code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> AddrMode -> Reg -> Instr
LD (CmmType -> Format
cmmTypeFormat CmmType
pk) AddrMode
src Reg
dst
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any (CmmType -> Format
cmmTypeFormat CmmType
pk) Reg -> InstrBlock
code__2)

getRegister (CmmLit (CmmInt Integer
i Width
_))
  | Integer -> Bool
forall a. Integral a => a -> Bool
fits13Bits Integer
i
  = let
        src :: Imm
src = Int -> Imm
ImmInt (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
i)
        code :: Reg -> InstrBlock
code Reg
dst = Instr -> InstrBlock
forall a. a -> OrdList a
unitOL (Bool -> Reg -> RI -> Reg -> Instr
OR Bool
False Reg
g0 (Imm -> RI
RIImm Imm
src) Reg
dst)
    in
        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 Reg -> InstrBlock
code)

getRegister (CmmLit CmmLit
lit)
  = let imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
        code :: Reg -> InstrBlock
code Reg
dst = [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
            Imm -> Reg -> Instr
SETHI (Imm -> Imm
HI Imm
imm) Reg
dst,
            Bool -> Reg -> RI -> Reg -> Instr
OR Bool
False Reg
dst (Imm -> RI
RIImm (Imm -> Imm
LO Imm
imm)) Reg
dst]
    in Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 Reg -> InstrBlock
code)


getRegister CmmExpr
_
        = String -> NatM Register
forall a. String -> a
panic String
"SPARC.CodeGen.Gen32.getRegister: no match"


-- | sign extend and widen
integerExtend
        :: Width                -- ^ width of source expression
        -> Width                -- ^ width of result
        -> CmmExpr              -- ^ source expression
        -> NatM Register

integerExtend :: Width -> Width -> CmmExpr -> NatM Register
integerExtend Width
from Width
to CmmExpr
expr
 = do   -- load the expr into some register
        (Reg
reg, InstrBlock
e_code)   <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
expr
        Reg
tmp             <- Format -> NatM Reg
getNewRegNat Format
II32
        let bitCount :: Int
bitCount
                = case (Width
from, Width
to) of
                        (Width
W8,  Width
W32)      -> Int
24
                        (Width
W16, Width
W32)      -> Int
16
                        (Width
W8,  Width
W16)      -> Int
24
                        (Width, Width)
_               -> String -> Int
forall a. String -> a
panic String
"SPARC.CodeGen.Gen32: no match"
        let code :: Reg -> InstrBlock
code Reg
dst
                = InstrBlock
e_code

                -- local shift word left to load the sign bit
                InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`  Reg -> RI -> Reg -> Instr
SLL Reg
reg (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
bitCount)) Reg
tmp

                -- arithmetic shift right to sign extend
                InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`  Reg -> RI -> Reg -> Instr
SRA Reg
tmp (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
bitCount)) Reg
dst

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


-- | For nop word format conversions we set the resulting value to have the
--      required size, but don't need to generate any actual code.
--
conversionNop
        :: Format -> CmmExpr -> NatM Register

conversionNop :: Format -> CmmExpr -> NatM Register
conversionNop Format
new_rep CmmExpr
expr
 = do   Register
e_code <- CmmExpr -> NatM Register
getRegister CmmExpr
expr
        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Register -> Format -> Register
setFormatOfRegister Register
e_code Format
new_rep)



-- | Generate an integer division instruction.
idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register

-- For unsigned division with a 32 bit numerator,
--              we can just clear the Y register.
idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register
idiv Bool
False Bool
cc CmmExpr
x CmmExpr
y
 = do
        (Reg
a_reg, InstrBlock
a_code)         <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        (Reg
b_reg, InstrBlock
b_code)         <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y

        let code :: Reg -> InstrBlock
code Reg
dst
                =       InstrBlock
a_code
                InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
b_code
                InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL
                        [ Reg -> Reg -> Instr
WRY  Reg
g0 Reg
g0
                        , Bool -> Reg -> RI -> Reg -> Instr
UDIV Bool
cc Reg
a_reg (Reg -> RI
RIReg Reg
b_reg) Reg
dst]

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


-- For _signed_ division with a 32 bit numerator,
--              we have to sign extend the numerator into the Y register.
idiv Bool
True Bool
cc CmmExpr
x CmmExpr
y
 = do
        (Reg
a_reg, InstrBlock
a_code)         <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        (Reg
b_reg, InstrBlock
b_code)         <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y

        Reg
tmp                     <- Format -> NatM Reg
getNewRegNat Format
II32

        let code :: Reg -> InstrBlock
code Reg
dst
                =       InstrBlock
a_code
                InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
b_code
                InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL
                        [ Reg -> RI -> Reg -> Instr
SRA  Reg
a_reg (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
16)) Reg
tmp            -- sign extend
                        , Reg -> RI -> Reg -> Instr
SRA  Reg
tmp   (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
16)) Reg
tmp

                        , Reg -> Reg -> Instr
WRY  Reg
tmp Reg
g0
                        , Bool -> Reg -> RI -> Reg -> Instr
SDIV Bool
cc Reg
a_reg (Reg -> RI
RIReg Reg
b_reg) Reg
dst]

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


-- | Do an integer remainder.
--
--       NOTE:  The SPARC v8 architecture manual says that integer division
--              instructions _may_ generate a remainder, depending on the implementation.
--              If so it is _recommended_ that the remainder is placed in the Y register.
--
--          The UltraSparc 2007 manual says Y is _undefined_ after division.
--
--              The SPARC T2 doesn't store the remainder, not sure about the others.
--              It's probably best not to worry about it, and just generate our own
--              remainders.
--
irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register

-- For unsigned operands:
--              Division is between a 64 bit numerator and a 32 bit denominator,
--              so we still have to clear the Y register.
irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register
irem Bool
False CmmExpr
x CmmExpr
y
 = do
        (Reg
a_reg, InstrBlock
a_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        (Reg
b_reg, InstrBlock
b_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y

        Reg
tmp_reg         <- Format -> NatM Reg
getNewRegNat Format
II32

        let code :: Reg -> InstrBlock
code Reg
dst
                =       InstrBlock
a_code
                InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
b_code
                InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL
                        [ Reg -> Reg -> Instr
WRY   Reg
g0 Reg
g0
                        , Bool -> Reg -> RI -> Reg -> Instr
UDIV  Bool
False         Reg
a_reg (Reg -> RI
RIReg Reg
b_reg) Reg
tmp_reg
                        , Bool -> Reg -> RI -> Reg -> Instr
UMUL  Bool
False       Reg
tmp_reg (Reg -> RI
RIReg Reg
b_reg) Reg
tmp_reg
                        , Bool -> Bool -> Reg -> RI -> Reg -> Instr
SUB   Bool
False Bool
False   Reg
a_reg (Reg -> RI
RIReg Reg
tmp_reg) Reg
dst]

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



-- For signed operands:
--              Make sure to sign extend into the Y register, or the remainder
--              will have the wrong sign when the numerator is negative.
--
--      TODO:   When sign extending, GCC only shifts the a_reg right by 17 bits,
--              not the full 32. Not sure why this is, something to do with overflow?
--              If anyone cares enough about the speed of signed remainder they
--              can work it out themselves (then tell me). -- BL 2009/01/20
irem Bool
True CmmExpr
x CmmExpr
y
 = do
        (Reg
a_reg, InstrBlock
a_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        (Reg
b_reg, InstrBlock
b_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y

        Reg
tmp1_reg        <- Format -> NatM Reg
getNewRegNat Format
II32
        Reg
tmp2_reg        <- Format -> NatM Reg
getNewRegNat Format
II32

        let code :: Reg -> InstrBlock
code Reg
dst
                =       InstrBlock
a_code
                InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
b_code
                InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL
                        [ Reg -> RI -> Reg -> Instr
SRA   Reg
a_reg      (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
16)) Reg
tmp1_reg -- sign extend
                        , Reg -> RI -> Reg -> Instr
SRA   Reg
tmp1_reg   (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
16)) Reg
tmp1_reg -- sign extend
                        , Reg -> Reg -> Instr
WRY   Reg
tmp1_reg Reg
g0

                        , Bool -> Reg -> RI -> Reg -> Instr
SDIV  Bool
False          Reg
a_reg (Reg -> RI
RIReg Reg
b_reg)    Reg
tmp2_reg
                        , Bool -> Reg -> RI -> Reg -> Instr
SMUL  Bool
False       Reg
tmp2_reg (Reg -> RI
RIReg Reg
b_reg)    Reg
tmp2_reg
                        , Bool -> Bool -> Reg -> RI -> Reg -> Instr
SUB   Bool
False Bool
False    Reg
a_reg (Reg -> RI
RIReg Reg
tmp2_reg) Reg
dst]

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


imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register
imulMayOflo Width
rep CmmExpr
a CmmExpr
b
 = do
        (Reg
a_reg, InstrBlock
a_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
a
        (Reg
b_reg, InstrBlock
b_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
b
        Reg
res_lo <- Format -> NatM Reg
getNewRegNat Format
II32
        Reg
res_hi <- Format -> NatM Reg
getNewRegNat Format
II32

        let shift_amt :: Int
shift_amt  = case Width
rep of
                          Width
W32 -> Int
31
                          Width
W64 -> Int
63
                          Width
_ -> String -> Int
forall a. String -> a
panic String
"shift_amt"

        let code :: Reg -> InstrBlock
code Reg
dst = InstrBlock
a_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
b_code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL`
                       [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
                           Bool -> Reg -> RI -> Reg -> Instr
SMUL Bool
False Reg
a_reg (Reg -> RI
RIReg Reg
b_reg) Reg
res_lo,
                           Reg -> Instr
RDY Reg
res_hi,
                           Reg -> RI -> Reg -> Instr
SRA Reg
res_lo (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
shift_amt)) Reg
res_lo,
                           Bool -> Bool -> Reg -> RI -> Reg -> Instr
SUB Bool
False Bool
False Reg
res_lo (Reg -> RI
RIReg Reg
res_hi) Reg
dst
                        ]
        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 Reg -> InstrBlock
code)


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

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

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

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

trivialCode :: Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
_ Reg -> RI -> Reg -> Instr
instr CmmExpr
x (CmmLit (CmmInt Integer
y Width
_))
  | Integer -> Bool
forall a. Integral a => a -> Bool
fits13Bits Integer
y
  = do
      (Reg
src1, InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
      let
        src2 :: Imm
src2 = Int -> Imm
ImmInt (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
y)
        code__2 :: Reg -> InstrBlock
code__2 Reg
dst = InstrBlock
code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> RI -> Reg -> Instr
instr Reg
src1 (Imm -> RI
RIImm Imm
src2) Reg
dst
      Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 Reg -> InstrBlock
code__2)


trivialCode Width
_ Reg -> RI -> Reg -> Instr
instr CmmExpr
x CmmExpr
y = do
    (Reg
src1, InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    (Reg
src2, InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y
    let
        code__2 :: Reg -> InstrBlock
code__2 Reg
dst = InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2 InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                      Reg -> RI -> Reg -> Instr
instr Reg
src1 (Reg -> RI
RIReg Reg
src2) Reg
dst
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 Reg -> InstrBlock
code__2)


trivialFCode
        :: Width
        -> (Format -> Reg -> Reg -> Reg -> Instr)
        -> CmmExpr
        -> CmmExpr
        -> NatM Register

trivialFCode :: Width
-> (Format -> Reg -> Reg -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialFCode Width
pk Format -> Reg -> Reg -> Reg -> Instr
instr CmmExpr
x CmmExpr
y = do
    Platform
platform <- NatM Platform
getPlatform
    (Reg
src1, InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    (Reg
src2, InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y
    Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
FF64
    let
        promote :: Reg -> Instr
promote Reg
x = Format -> Format -> Reg -> Reg -> Instr
FxTOy Format
FF32 Format
FF64 Reg
x Reg
tmp

        pk1 :: CmmType
pk1   = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
x
        pk2 :: CmmType
pk2   = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
y

        code__2 :: Reg -> InstrBlock
code__2 Reg
dst =
                if CmmType
pk1 CmmType -> CmmType -> Bool
`cmmEqType` CmmType
pk2 then
                    InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2 InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                    Format -> Reg -> Reg -> Reg -> Instr
instr (Width -> Format
floatFormat Width
pk) Reg
src1 Reg
src2 Reg
dst
                else if CmmType -> Width
typeWidth CmmType
pk1 Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Width
W32 then
                    InstrBlock
code1 InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
promote Reg
src1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2 InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                    Format -> Reg -> Reg -> Reg -> Instr
instr Format
FF64 Reg
tmp Reg
src2 Reg
dst
                else
                    InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2 InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Reg -> Instr
promote Reg
src2 InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                    Format -> Reg -> Reg -> Reg -> Instr
instr Format
FF64 Reg
src1 Reg
tmp Reg
dst
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any (CmmType -> Format
cmmTypeFormat (CmmType -> Format) -> CmmType -> Format
forall a b. (a -> b) -> a -> b
$ if CmmType
pk1 CmmType -> CmmType -> Bool
`cmmEqType` CmmType
pk2 then CmmType
pk1 else Width -> CmmType
cmmFloat Width
W64)
                Reg -> InstrBlock
code__2)



trivialUCode
        :: Format
        -> (RI -> Reg -> Instr)
        -> CmmExpr
        -> NatM Register

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


trivialUFCode
        :: Format
        -> (Reg -> Reg -> Instr)
        -> CmmExpr
        -> NatM Register

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




-- Coercions -------------------------------------------------------------------

-- | Coerce a integer value to floating point
coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP Width
width1 Width
width2 CmmExpr
x = do
    (Reg
src, InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    let
        code__2 :: Reg -> InstrBlock
code__2 Reg
dst = InstrBlock
code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
            Format -> Reg -> AddrMode -> Instr
ST (Width -> Format
intFormat Width
width1) Reg
src (Int -> AddrMode
spRel (-Int
2)),
            Format -> AddrMode -> Reg -> Instr
LD (Width -> Format
intFormat Width
width1) (Int -> AddrMode
spRel (-Int
2)) Reg
dst,
            Format -> Format -> Reg -> Reg -> Instr
FxTOy (Width -> Format
intFormat Width
width1) (Width -> Format
floatFormat Width
width2) Reg
dst Reg
dst]
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any (Width -> Format
floatFormat (Width -> Format) -> Width -> Format
forall a b. (a -> b) -> a -> b
$ Width
width2) Reg -> InstrBlock
code__2)



-- | Coerce a floating point value to integer
--
--   NOTE: On sparc v9 there are no instructions to move a value from an
--         FP register directly to an int register, so we have to use a load/store.
--
coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int Width
width1 Width
width2 CmmExpr
x
 = do   let fformat1 :: Format
fformat1      = Width -> Format
floatFormat Width
width1
            fformat2 :: Format
fformat2      = Width -> Format
floatFormat Width
width2

            iformat2 :: Format
iformat2      = Width -> Format
intFormat   Width
width2

        (Reg
fsrc, InstrBlock
code)    <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        Reg
fdst            <- Format -> NatM Reg
getNewRegNat Format
fformat2

        let code2 :: Reg -> InstrBlock
code2 Reg
dst
                =       InstrBlock
code
                InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL
                        -- convert float to int format, leaving it in a float reg.
                        [ Format -> Format -> Reg -> Reg -> Instr
FxTOy Format
fformat1 Format
iformat2 Reg
fsrc Reg
fdst

                        -- store the int into mem, then load it back to move
                        --      it into an actual int reg.
                        , Format -> Reg -> AddrMode -> Instr
ST    Format
fformat2 Reg
fdst (Int -> AddrMode
spRel (-Int
2))
                        , Format -> AddrMode -> Reg -> Instr
LD    Format
iformat2 (Int -> AddrMode
spRel (-Int
2)) Reg
dst]

        Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
iformat2 Reg -> InstrBlock
code2)


-- | Coerce a double precision floating point value to single precision.
coerceDbl2Flt :: CmmExpr -> NatM Register
coerceDbl2Flt :: CmmExpr -> NatM Register
coerceDbl2Flt CmmExpr
x = do
    (Reg
src, InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
FF32 (\Reg
dst -> InstrBlock
code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Format -> Reg -> Reg -> Instr
FxTOy Format
FF64 Format
FF32 Reg
src Reg
dst))


-- | Coerce a single precision floating point value to double precision
coerceFlt2Dbl :: CmmExpr -> NatM Register
coerceFlt2Dbl :: CmmExpr -> NatM Register
coerceFlt2Dbl CmmExpr
x = do
    (Reg
src, InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
FF64 (\Reg
dst -> InstrBlock
code InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL` Format -> Format -> Reg -> Reg -> Instr
FxTOy Format
FF32 Format
FF64 Reg
src Reg
dst))




-- Condition Codes -------------------------------------------------------------
--
-- Evaluate a comparison, and get the result into a register.
--
-- Do not fill the delay slots here. you will confuse the register allocator.
--
condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
EQQ CmmExpr
x (CmmLit (CmmInt Integer
0 Width
_)) = do
    (Reg
src, InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    let
        code__2 :: Reg -> InstrBlock
code__2 Reg
dst = InstrBlock
code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
            Bool -> Bool -> Reg -> RI -> Reg -> Instr
SUB Bool
False Bool
True Reg
g0 (Reg -> RI
RIReg Reg
src) Reg
g0,
            Bool -> Bool -> Reg -> RI -> Reg -> Instr
SUB Bool
True Bool
False Reg
g0 (Imm -> RI
RIImm (Int -> Imm
ImmInt (-Int
1))) Reg
dst]
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 Reg -> InstrBlock
code__2)

condIntReg Cond
EQQ CmmExpr
x CmmExpr
y = do
    (Reg
src1, InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    (Reg
src2, InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y
    let
        code__2 :: Reg -> InstrBlock
code__2 Reg
dst = InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
            Bool -> Reg -> RI -> Reg -> Instr
XOR Bool
False Reg
src1 (Reg -> RI
RIReg Reg
src2) Reg
dst,
            Bool -> Bool -> Reg -> RI -> Reg -> Instr
SUB Bool
False Bool
True Reg
g0 (Reg -> RI
RIReg Reg
dst) Reg
g0,
            Bool -> Bool -> Reg -> RI -> Reg -> Instr
SUB Bool
True Bool
False Reg
g0 (Imm -> RI
RIImm (Int -> Imm
ImmInt (-Int
1))) Reg
dst]
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 Reg -> InstrBlock
code__2)

condIntReg Cond
NE CmmExpr
x (CmmLit (CmmInt Integer
0 Width
_)) = do
    (Reg
src, InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    let
        code__2 :: Reg -> InstrBlock
code__2 Reg
dst = InstrBlock
code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
            Bool -> Bool -> Reg -> RI -> Reg -> Instr
SUB Bool
False Bool
True Reg
g0 (Reg -> RI
RIReg Reg
src) Reg
g0,
            Bool -> Bool -> Reg -> RI -> Reg -> Instr
ADD Bool
True Bool
False Reg
g0 (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
0)) Reg
dst]
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 Reg -> InstrBlock
code__2)

condIntReg Cond
NE CmmExpr
x CmmExpr
y = do
    (Reg
src1, InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    (Reg
src2, InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y
    let
        code__2 :: Reg -> InstrBlock
code__2 Reg
dst = InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
            Bool -> Reg -> RI -> Reg -> Instr
XOR Bool
False Reg
src1 (Reg -> RI
RIReg Reg
src2) Reg
dst,
            Bool -> Bool -> Reg -> RI -> Reg -> Instr
SUB Bool
False Bool
True Reg
g0 (Reg -> RI
RIReg Reg
dst) Reg
g0,
            Bool -> Bool -> Reg -> RI -> Reg -> Instr
ADD Bool
True Bool
False Reg
g0 (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
0)) Reg
dst]
    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 Reg -> InstrBlock
code__2)

condIntReg Cond
cond CmmExpr
x CmmExpr
y = do
    BlockId
bid1 <- (BlockId -> BlockId) -> NatM BlockId -> NatM BlockId
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\BlockId
a -> BlockId -> BlockId -> BlockId
seq BlockId
a BlockId
a) NatM BlockId
getBlockIdNat
    BlockId
bid2 <- (BlockId -> BlockId) -> NatM BlockId -> NatM BlockId
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\BlockId
a -> BlockId -> BlockId -> BlockId
seq BlockId
a BlockId
a) NatM BlockId
getBlockIdNat
    CondCode Bool
_ Cond
cond InstrBlock
cond_code <- Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
cond CmmExpr
x CmmExpr
y
    let
        code__2 :: Reg -> InstrBlock
code__2 Reg
dst
         =      InstrBlock
cond_code
          InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL
                [ Cond -> Bool -> BlockId -> Instr
BI Cond
cond Bool
False BlockId
bid1
                , Instr
NOP

                , Bool -> Reg -> RI -> Reg -> Instr
OR Bool
False Reg
g0 (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
0)) Reg
dst
                , Cond -> Bool -> BlockId -> Instr
BI Cond
ALWAYS Bool
False BlockId
bid2
                , Instr
NOP

                , BlockId -> Instr
NEWBLOCK BlockId
bid1
                , Bool -> Reg -> RI -> Reg -> Instr
OR Bool
False Reg
g0 (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
1)) Reg
dst
                , Cond -> Bool -> BlockId -> Instr
BI Cond
ALWAYS Bool
False BlockId
bid2
                , Instr
NOP

                , BlockId -> Instr
NEWBLOCK BlockId
bid2]

    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 Reg -> InstrBlock
code__2)


condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
cond CmmExpr
x CmmExpr
y = do
    BlockId
bid1 <- (BlockId -> BlockId) -> NatM BlockId -> NatM BlockId
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\BlockId
a -> BlockId -> BlockId -> BlockId
seq BlockId
a BlockId
a) NatM BlockId
getBlockIdNat
    BlockId
bid2 <- (BlockId -> BlockId) -> NatM BlockId -> NatM BlockId
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\BlockId
a -> BlockId -> BlockId -> BlockId
seq BlockId
a BlockId
a) NatM BlockId
getBlockIdNat

    CondCode Bool
_ Cond
cond InstrBlock
cond_code <- Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
cond CmmExpr
x CmmExpr
y
    let
        code__2 :: Reg -> InstrBlock
code__2 Reg
dst
         =      InstrBlock
cond_code
          InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL
                [ Instr
NOP
                , Cond -> Bool -> BlockId -> Instr
BF Cond
cond Bool
False BlockId
bid1
                , Instr
NOP

                , Bool -> Reg -> RI -> Reg -> Instr
OR Bool
False Reg
g0 (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
0)) Reg
dst
                , Cond -> Bool -> BlockId -> Instr
BI Cond
ALWAYS Bool
False BlockId
bid2
                , Instr
NOP

                , BlockId -> Instr
NEWBLOCK BlockId
bid1
                , Bool -> Reg -> RI -> Reg -> Instr
OR Bool
False Reg
g0 (Imm -> RI
RIImm (Int -> Imm
ImmInt Int
1)) Reg
dst
                , Cond -> Bool -> BlockId -> Instr
BI Cond
ALWAYS Bool
False BlockId
bid2
                , Instr
NOP

                , BlockId -> Instr
NEWBLOCK BlockId
bid2 ]

    Register -> NatM Register
forall (m :: * -> *) a. Monad m => a -> m a
return (Format -> (Reg -> InstrBlock) -> Register
Any Format
II32 Reg -> InstrBlock
code__2)