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

where

import GhcPrelude

import SPARC.CodeGen.CondCode
import SPARC.CodeGen.Amode
import SPARC.CodeGen.Gen64
import SPARC.CodeGen.Base
import SPARC.Stack
import SPARC.Instr
import SPARC.Cond
import SPARC.AddrMode
import SPARC.Imm
import SPARC.Regs
import SPARC.Base
import NCGMonad
import Format
import Reg

import Cmm

import Control.Monad (liftM)
import DynFlags
import OrdList
import 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 expr :: CmmExpr
expr = do
  Register
r <- CmmExpr -> NatM Register
getRegister CmmExpr
expr
  case Register
r of
    Any rep :: Format
rep code :: Reg -> InstrBlock
code -> do
        Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
rep
        (Reg, InstrBlock) -> NatM (Reg, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
tmp, Reg -> InstrBlock
code Reg
tmp)
    Fixed _ reg :: Reg
reg code :: InstrBlock
code ->
        (Reg, InstrBlock) -> NatM (Reg, InstrBlock)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reg
reg, InstrBlock
code)



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

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

getRegister tree :: CmmExpr
tree@(CmmRegOff _ _)
  = do DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       CmmExpr -> NatM Register
getRegister (DynFlags -> CmmExpr -> CmmExpr
mangleIndexTree DynFlags
dflags CmmExpr
tree)

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

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

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

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


-- 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 f :: Rational
f 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 dst :: Reg
dst = [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
            -- the data area
            Section -> CmmStatics -> Instr
LDATA (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) (CmmStatics -> Instr) -> CmmStatics -> Instr
forall a b. (a -> b) -> a -> b
$ CLabel -> [CmmStatic] -> CmmStatics
Statics CLabel
lbl
                         [CmmLit -> CmmStatic
CmmStaticLit (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 d :: Rational
d W64)) = do
    CLabel
lbl <- NatM CLabel
getNewLabelNat
    Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
II32
    let code :: Reg -> InstrBlock
code dst :: Reg
dst = [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
            Section -> CmmStatics -> Instr
LDATA (SectionType -> CLabel -> Section
Section SectionType
ReadOnlyData CLabel
lbl) (CmmStatics -> Instr) -> CmmStatics -> Instr
forall a b. (a -> b) -> a -> b
$ CLabel -> [CmmStatic] -> CmmStatics
Statics CLabel
lbl
                         [CmmLit -> CmmStatic
CmmStaticLit (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 mop :: MachOp
mop [x :: CmmExpr
x])
  = case MachOp
mop of
        -- Floating point negation -------------------------
        MO_F_Neg W32            -> Format -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register
trivialUFCode Format
FF32 (Format -> Reg -> Reg -> Instr
FNEG Format
FF32) CmmExpr
x
        MO_F_Neg 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 rep :: 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 rep :: 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 W64 W32      -> CmmExpr -> NatM Register
coerceDbl2Flt CmmExpr
x
        MO_FF_Conv W32 W64      -> CmmExpr -> NatM Register
coerceFlt2Dbl CmmExpr
x


        -- Float <-> Signed Int conversion -----------------
        MO_FS_Conv from :: Width
from to :: Width
to      -> Width -> Width -> CmmExpr -> NatM Register
coerceFP2Int Width
from Width
to CmmExpr
x
        MO_SF_Conv from :: Width
from to :: Width
to      -> Width -> Width -> CmmExpr -> NatM Register
coerceInt2FP Width
from Width
to CmmExpr
x


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

        -- If it's the same size, then nothing needs to be done.
        MO_UU_Conv from :: Width
from to :: 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 W16 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 255 Width
W8))
        MO_UU_Conv W32 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 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 W32 W16
         -> do  Reg
tmpReg          <- Format -> NatM Reg
getNewRegNat Format
II32
                (xReg :: Reg
xReg, xCode :: InstrBlock
xCode)   <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
                let code :: Reg -> InstrBlock
code dst :: 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 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 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 W8  W16      -> Format -> CmmExpr -> NatM Register
conversionNop (Width -> Format
intFormat Width
W16)  CmmExpr
x
        MO_UU_Conv W8  W32      -> Format -> CmmExpr -> NatM Register
conversionNop (Width -> Format
intFormat Width
W32)  CmmExpr
x
        MO_UU_Conv W16 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 W16 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 255 Width
W8))
        MO_SS_Conv W32 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 255 Width
W8))
        MO_SS_Conv W32 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 65535 Width
W16))

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

        _                       -> String -> NatM Register
forall a. String -> a
panic ("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 mop :: MachOp
mop [x :: CmmExpr
x, y :: CmmExpr
y])
  = case MachOp
mop of
      MO_Eq _           -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
EQQ CmmExpr
x CmmExpr
y
      MO_Ne _           -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condIntReg Cond
NE CmmExpr
x CmmExpr
y

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

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

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

      MO_Add 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 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 rep :: Width
rep -> Width -> CmmExpr -> CmmExpr -> NatM Register
imulMayOflo Width
rep CmmExpr
x CmmExpr
y

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

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

      MO_F_Eq _         -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
EQQ CmmExpr
x CmmExpr
y
      MO_F_Ne _         -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
NE CmmExpr
x CmmExpr
y

      MO_F_Gt _         -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
GTT CmmExpr
x CmmExpr
y
      MO_F_Ge _         -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
GE CmmExpr
x CmmExpr
y
      MO_F_Lt _         -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
LTT CmmExpr
x CmmExpr
y
      MO_F_Le _         -> Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg Cond
LE CmmExpr
x CmmExpr
y

      MO_F_Add  w :: 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  w :: 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  w :: 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 w :: 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 rep :: 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  rep :: 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 rep :: 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 rep :: 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 rep :: 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 rep :: 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 rep :: Width
rep      -> Width
-> (Reg -> RI -> Reg -> Instr)
-> CmmExpr
-> CmmExpr
-> NatM Register
trivialCode Width
rep Reg -> RI -> Reg -> Instr
SRA CmmExpr
x CmmExpr
y

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

getRegister (CmmLoad mem :: CmmExpr
mem pk :: CmmType
pk) = do
    Amode src :: AddrMode
src code :: InstrBlock
code <- CmmExpr -> NatM Amode
getAmode CmmExpr
mem
    let
        code__2 :: Reg -> InstrBlock
code__2 dst :: 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 i :: Integer
i _))
  | 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 dst :: 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 lit :: CmmLit
lit)
  = let imm :: Imm
imm = CmmLit -> Imm
litToImm CmmLit
lit
        code :: Reg -> InstrBlock
code dst :: 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 _
        = String -> NatM Register
forall a. String -> a
panic "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 from :: Width
from to :: Width
to expr :: CmmExpr
expr
 = do   -- load the expr into some register
        (reg :: Reg
reg, e_code :: 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
                        (W8,  W32)      -> 24
                        (W16, W32)      -> 16
                        (W8,  W16)      -> 24
                        _               -> String -> Int
forall a. String -> a
panic "SPARC.CodeGen.Gen32: no match"
        let code :: Reg -> InstrBlock
code dst :: 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 new_rep :: Format
new_rep expr :: 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 False cc :: Bool
cc x :: CmmExpr
x y :: CmmExpr
y
 = do
        (a_reg :: Reg
a_reg, a_code :: InstrBlock
a_code)         <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        (b_reg :: Reg
b_reg, b_code :: InstrBlock
b_code)         <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y

        let code :: Reg -> InstrBlock
code dst :: 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 True cc :: Bool
cc x :: CmmExpr
x y :: CmmExpr
y
 = do
        (a_reg :: Reg
a_reg, a_code :: InstrBlock
a_code)         <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        (b_reg :: Reg
b_reg, b_code :: InstrBlock
b_code)         <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y

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

        let code :: Reg -> InstrBlock
code dst :: 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 16)) Reg
tmp            -- sign extend
                        , Reg -> RI -> Reg -> Instr
SRA  Reg
tmp   (Imm -> RI
RIImm (Int -> Imm
ImmInt 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 False x :: CmmExpr
x y :: CmmExpr
y
 = do
        (a_reg :: Reg
a_reg, a_code :: InstrBlock
a_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        (b_reg :: Reg
b_reg, b_code :: InstrBlock
b_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y

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

        let code :: Reg -> InstrBlock
code dst :: 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 True x :: CmmExpr
x y :: CmmExpr
y
 = do
        (a_reg :: Reg
a_reg, a_code :: InstrBlock
a_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
        (b_reg :: Reg
b_reg, b_code :: 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 dst :: 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 16)) Reg
tmp1_reg -- sign extend
                        , Reg -> RI -> Reg -> Instr
SRA   Reg
tmp1_reg   (Imm -> RI
RIImm (Int -> Imm
ImmInt 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 rep :: Width
rep a :: CmmExpr
a b :: CmmExpr
b
 = do
        (a_reg :: Reg
a_reg, a_code :: InstrBlock
a_code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
a
        (b_reg :: Reg
b_reg, b_code :: 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
                          W32 -> 31
                          W64 -> 63
                          _ -> String -> Int
forall a. String -> a
panic "shift_amt"

        let code :: Reg -> InstrBlock
code dst :: 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 _ instr :: Reg -> RI -> Reg -> Instr
instr x :: CmmExpr
x (CmmLit (CmmInt y :: Integer
y _))
  | Integer -> Bool
forall a. Integral a => a -> Bool
fits13Bits Integer
y
  = do
      (src1 :: Reg
src1, code :: 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 dst :: 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 _ instr :: Reg -> RI -> Reg -> Instr
instr x :: CmmExpr
x y :: CmmExpr
y = do
    (src1 :: Reg
src1, code1 :: InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    (src2 :: Reg
src2, code2 :: InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y
    let
        code__2 :: Reg -> InstrBlock
code__2 dst :: Reg
dst = InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2 InstrBlock -> Instr -> InstrBlock
forall a. OrdList a -> a -> OrdList a
`snocOL`
                      Reg -> 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 pk :: Width
pk instr :: Format -> Reg -> Reg -> Reg -> Instr
instr x :: CmmExpr
x y :: CmmExpr
y = do
    DynFlags
dflags <- NatM DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    (src1 :: Reg
src1, code1 :: InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    (src2 :: Reg
src2, code2 :: InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y
    Reg
tmp <- Format -> NatM Reg
getNewRegNat Format
FF64
    let
        promote :: Reg -> Instr
promote x :: Reg
x = Format -> Format -> Reg -> Reg -> Instr
FxTOy Format
FF32 Format
FF64 Reg
x Reg
tmp

        pk1 :: CmmType
pk1   = DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
x
        pk2 :: CmmType
pk2   = DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
y

        code__2 :: Reg -> InstrBlock
code__2 dst :: 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
format instr :: RI -> Reg -> Instr
instr x :: CmmExpr
x = do
    (src :: Reg
src, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    let
        code__2 :: Reg -> InstrBlock
code__2 dst :: 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 pk :: Format
pk instr :: Reg -> Reg -> Instr
instr x :: CmmExpr
x = do
    (src :: Reg
src, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    let
        code__2 :: Reg -> InstrBlock
code__2 dst :: 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 width1 :: Width
width1 width2 :: Width
width2 x :: CmmExpr
x = do
    (src :: Reg
src, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    let
        code__2 :: Reg -> InstrBlock
code__2 dst :: Reg
dst = InstrBlock
code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
            Format -> Reg -> AddrMode -> Instr
ST (Width -> Format
intFormat Width
width1) Reg
src (Int -> AddrMode
spRel (-2)),
            Format -> AddrMode -> Reg -> Instr
LD (Width -> Format
intFormat Width
width1) (Int -> AddrMode
spRel (-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 width1 :: Width
width1 width2 :: Width
width2 x :: 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

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

        let code2 :: Reg -> InstrBlock
code2 dst :: Reg
dst
                =       InstrBlock
code
                InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL
                        -- convert 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 (-2))
                        , Format -> AddrMode -> Reg -> Instr
LD    Format
iformat2 (Int -> AddrMode
spRel (-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 x :: CmmExpr
x = do
    (src :: Reg
src, code :: 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 (\dst :: 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 x :: CmmExpr
x = do
    (src :: Reg
src, code :: 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 (\dst :: 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 EQQ x :: CmmExpr
x (CmmLit (CmmInt 0 _)) = do
    (src :: Reg
src, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    let
        code__2 :: Reg -> InstrBlock
code__2 dst :: Reg
dst = InstrBlock
code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
            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 (-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 EQQ x :: CmmExpr
x y :: CmmExpr
y = do
    (src1 :: Reg
src1, code1 :: InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    (src2 :: Reg
src2, code2 :: InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y
    let
        code__2 :: Reg -> InstrBlock
code__2 dst :: Reg
dst = InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
            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 (-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 NE x :: CmmExpr
x (CmmLit (CmmInt 0 _)) = do
    (src :: Reg
src, code :: InstrBlock
code) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    let
        code__2 :: Reg -> InstrBlock
code__2 dst :: Reg
dst = InstrBlock
code InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
            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 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 NE x :: CmmExpr
x y :: CmmExpr
y = do
    (src1 :: Reg
src1, code1 :: InstrBlock
code1) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
x
    (src2 :: Reg
src2, code2 :: InstrBlock
code2) <- CmmExpr -> NatM (Reg, InstrBlock)
getSomeReg CmmExpr
y
    let
        code__2 :: Reg -> InstrBlock
code__2 dst :: Reg
dst = InstrBlock
code1 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` InstrBlock
code2 InstrBlock -> InstrBlock -> InstrBlock
forall a. OrdList a -> OrdList a -> OrdList a
`appOL` [Instr] -> InstrBlock
forall a. [a] -> OrdList a
toOL [
            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 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
cond x :: CmmExpr
x y :: CmmExpr
y = do
    BlockId
bid1 <- (BlockId -> BlockId) -> NatM BlockId -> NatM BlockId
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\a :: BlockId
a -> BlockId -> BlockId -> BlockId
forall a b. a -> b -> b
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 (\a :: BlockId
a -> BlockId -> BlockId -> BlockId
forall a b. a -> b -> b
seq BlockId
a BlockId
a) NatM BlockId
getBlockIdNat
    CondCode _ cond :: Cond
cond cond_code :: InstrBlock
cond_code <- Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condIntCode Cond
cond CmmExpr
x CmmExpr
y
    let
        code__2 :: Reg -> InstrBlock
code__2 dst :: 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 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 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
cond x :: CmmExpr
x y :: CmmExpr
y = do
    BlockId
bid1 <- (BlockId -> BlockId) -> NatM BlockId -> NatM BlockId
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (\a :: BlockId
a -> BlockId -> BlockId -> BlockId
forall a b. a -> b -> b
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 (\a :: BlockId
a -> BlockId -> BlockId -> BlockId
forall a b. a -> b -> b
seq BlockId
a BlockId
a) NatM BlockId
getBlockIdNat

    CondCode _ cond :: Cond
cond cond_code :: InstrBlock
cond_code <- Cond -> CmmExpr -> CmmExpr -> NatM CondCode
condFltCode Cond
cond CmmExpr
x CmmExpr
y
    let
        code__2 :: Reg -> InstrBlock
code__2 dst :: 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 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 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)