-- | Free regs map for SPARC
module RegAlloc.Linear.SPARC.FreeRegs
where

import GhcPrelude

import SPARC.Regs
import RegClass
import Reg

import GHC.Platform.Regs
import Outputable
import GHC.Platform

import Data.Word
import Data.Bits


--------------------------------------------------------------------------------
-- SPARC is like PPC, except for twinning of floating point regs.
--      When we allocate a double reg we must take an even numbered
--      float reg, as well as the one after it.


-- Holds bitmaps showing what registers are currently allocated.
--      The float and double reg bitmaps overlap, but we only alloc
--      float regs into the float map, and double regs into the double map.
--
--      Free regs have a bit set in the corresponding bitmap.
--
data FreeRegs
        = FreeRegs
                !Word32         -- int    reg bitmap    regs  0..31
                !Word32         -- float  reg bitmap    regs 32..63
                !Word32         -- double reg bitmap    regs 32..63

instance Show FreeRegs where
        show :: FreeRegs -> String
show = FreeRegs -> String
showFreeRegs

-- | A reg map where no regs are free to be allocated.
noFreeRegs :: FreeRegs
noFreeRegs :: FreeRegs
noFreeRegs = Word32 -> Word32 -> Word32 -> FreeRegs
FreeRegs Word32
0 Word32
0 Word32
0


-- | The initial set of free regs.
initFreeRegs :: Platform -> FreeRegs
initFreeRegs :: Platform -> FreeRegs
initFreeRegs Platform
platform
 =      (FreeRegs -> RealReg -> FreeRegs)
-> FreeRegs -> [RealReg] -> FreeRegs
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((RealReg -> FreeRegs -> FreeRegs)
-> FreeRegs -> RealReg -> FreeRegs
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((RealReg -> FreeRegs -> FreeRegs)
 -> FreeRegs -> RealReg -> FreeRegs)
-> (RealReg -> FreeRegs -> FreeRegs)
-> FreeRegs
-> RealReg
-> FreeRegs
forall a b. (a -> b) -> a -> b
$ Platform -> RealReg -> FreeRegs -> FreeRegs
releaseReg Platform
platform) FreeRegs
noFreeRegs [RealReg]
allocatableRegs


-- | Get all the free registers of this class.
getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily
getFreeRegs :: RegClass -> FreeRegs -> [RealReg]
getFreeRegs RegClass
cls (FreeRegs Word32
g Word32
f Word32
d)
        | RegClass
RcInteger <- RegClass
cls = (Int -> RealReg) -> [Int] -> [RealReg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> RealReg
RealRegSingle                  ([Int] -> [RealReg]) -> [Int] -> [RealReg]
forall a b. (a -> b) -> a -> b
$ Int -> Word32 -> Word32 -> Int -> [Int]
forall a. (Num a, Bits a) => Int -> a -> a -> Int -> [Int]
go Int
1 Word32
g Word32
1 Int
0
        | RegClass
RcFloat   <- RegClass
cls = (Int -> RealReg) -> [Int] -> [RealReg]
forall a b. (a -> b) -> [a] -> [b]
map Int -> RealReg
RealRegSingle                  ([Int] -> [RealReg]) -> [Int] -> [RealReg]
forall a b. (a -> b) -> a -> b
$ Int -> Word32 -> Word32 -> Int -> [Int]
forall a. (Num a, Bits a) => Int -> a -> a -> Int -> [Int]
go Int
1 Word32
f Word32
1 Int
32
        | RegClass
RcDouble  <- RegClass
cls = (Int -> RealReg) -> [Int] -> [RealReg]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> Int -> Int -> RealReg
RealRegPair Int
i (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))    ([Int] -> [RealReg]) -> [Int] -> [RealReg]
forall a b. (a -> b) -> a -> b
$ Int -> Word32 -> Word32 -> Int -> [Int]
forall a. (Num a, Bits a) => Int -> a -> a -> Int -> [Int]
go Int
2 Word32
d Word32
1 Int
32
        | Bool
otherwise = String -> SDoc -> [RealReg]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"RegAllocLinear.getFreeRegs: Bad register class " (RegClass -> SDoc
forall a. Outputable a => a -> SDoc
ppr RegClass
cls)
        where
                go :: Int -> a -> a -> Int -> [Int]
go Int
_    a
_      a
0    Int
_
                        = []

                go Int
step a
bitmap a
mask Int
ix
                        | a
bitmap a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
mask a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0
                        = Int
ix Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (Int -> a -> a -> Int -> [Int]
go Int
step a
bitmap (a
mask a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
step) (Int -> [Int]) -> Int -> [Int]
forall a b. (a -> b) -> a -> b
$! Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
step)

                        | Bool
otherwise
                        = Int -> a -> a -> Int -> [Int]
go Int
step a
bitmap (a
mask a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
step) (Int -> [Int]) -> Int -> [Int]
forall a b. (a -> b) -> a -> b
$! Int
ix Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
step


-- | Grab a register.
allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs
allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs
allocateReg Platform
platform
         reg :: RealReg
reg@(RealRegSingle Int
r)
             (FreeRegs Word32
g Word32
f Word32
d)

        -- can't allocate free regs
        | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> Int -> Bool
freeReg Platform
platform Int
r
        = String -> SDoc -> FreeRegs
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"SPARC.FreeRegs.allocateReg: not allocating pinned reg" (RealReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr RealReg
reg)

        -- a general purpose reg
        | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
31
        = let   mask :: Word32
mask    = Word32 -> Word32
forall a. Bits a => a -> a
complement (Int -> Word32
bitMask Int
r)
          in    Word32 -> Word32 -> Word32 -> FreeRegs
FreeRegs
                        (Word32
g Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
mask)
                        Word32
f
                        Word32
d

        -- a float reg
        | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
32, Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
63
        = let   mask :: Word32
mask    = Word32 -> Word32
forall a. Bits a => a -> a
complement (Int -> Word32
bitMask (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
32))

                -- the mask of the double this FP reg aliases
                maskLow :: Word32
maskLow = if Int
r Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                                then Word32 -> Word32
forall a. Bits a => a -> a
complement (Int -> Word32
bitMask (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
32))
                                else Word32 -> Word32
forall a. Bits a => a -> a
complement (Int -> Word32
bitMask (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
          in    Word32 -> Word32 -> Word32 -> FreeRegs
FreeRegs
                        Word32
g
                        (Word32
f Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
mask)
                        (Word32
d Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
maskLow)

        | Bool
otherwise
        = String -> SDoc -> FreeRegs
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"SPARC.FreeRegs.releaseReg: not allocating bad reg" (RealReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr RealReg
reg)

allocateReg Platform
_
         reg :: RealReg
reg@(RealRegPair Int
r1 Int
r2)
             (FreeRegs Word32
g Word32
f Word32
d)

        | Int
r1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
32, Int
r1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
63, Int
r1 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        , Int
r2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
32, Int
r2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
63
        = let   mask1 :: Word32
mask1   = Word32 -> Word32
forall a. Bits a => a -> a
complement (Int -> Word32
bitMask (Int
r1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
32))
                mask2 :: Word32
mask2   = Word32 -> Word32
forall a. Bits a => a -> a
complement (Int -> Word32
bitMask (Int
r2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
32))
          in
                Word32 -> Word32 -> Word32 -> FreeRegs
FreeRegs
                        Word32
g
                        ((Word32
f Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
mask1) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
mask2)
                        (Word32
d Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
mask1)

        | Bool
otherwise
        = String -> SDoc -> FreeRegs
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"SPARC.FreeRegs.releaseReg: not allocating bad reg" (RealReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr RealReg
reg)



-- | Release a register from allocation.
--      The register liveness information says that most regs die after a C call,
--      but we still don't want to allocate to some of them.
--
releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs
releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs
releaseReg Platform
platform
         reg :: RealReg
reg@(RealRegSingle Int
r)
        regs :: FreeRegs
regs@(FreeRegs Word32
g Word32
f Word32
d)

        -- don't release pinned reg
        | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Platform -> Int -> Bool
freeReg Platform
platform Int
r
        = FreeRegs
regs

        -- a general purpose reg
        | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
31
        = let   mask :: Word32
mask    = Int -> Word32
bitMask Int
r
          in    Word32 -> Word32 -> Word32 -> FreeRegs
FreeRegs (Word32
g Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
mask) Word32
f Word32
d

        -- a float reg
        | Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
32, Int
r Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
63
        = let   mask :: Word32
mask    = Int -> Word32
bitMask (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
32)

                -- the mask of the double this FP reg aliases
                maskLow :: Word32
maskLow = if Int
r Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                                then Int -> Word32
bitMask (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
32)
                                else Int -> Word32
bitMask (Int
r Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
32 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
          in    Word32 -> Word32 -> Word32 -> FreeRegs
FreeRegs
                        Word32
g
                        (Word32
f Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
mask)
                        (Word32
d Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
maskLow)

        | Bool
otherwise
        = String -> SDoc -> FreeRegs
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"SPARC.FreeRegs.releaseReg: not releasing bad reg" (RealReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr RealReg
reg)

releaseReg Platform
_
         reg :: RealReg
reg@(RealRegPair Int
r1 Int
r2)
             (FreeRegs Word32
g Word32
f Word32
d)

        | Int
r1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
32, Int
r1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
63, Int
r1 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        , Int
r2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
32, Int
r2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
63
        = let   mask1 :: Word32
mask1   = Int -> Word32
bitMask (Int
r1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
32)
                mask2 :: Word32
mask2   = Int -> Word32
bitMask (Int
r2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
32)
          in
                Word32 -> Word32 -> Word32 -> FreeRegs
FreeRegs
                        Word32
g
                        ((Word32
f Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
mask1) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
mask2)
                        (Word32
d Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
mask1)

        | Bool
otherwise
        = String -> SDoc -> FreeRegs
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"SPARC.FreeRegs.releaseReg: not releasing bad reg" (RealReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr RealReg
reg)



bitMask :: Int -> Word32
bitMask :: Int -> Word32
bitMask Int
n       = Word32
1 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
n


showFreeRegs :: FreeRegs -> String
showFreeRegs :: FreeRegs -> String
showFreeRegs FreeRegs
regs
        =  String
"FreeRegs\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"    integer: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([RealReg] -> String
forall a. Show a => a -> String
show ([RealReg] -> String) -> [RealReg] -> String
forall a b. (a -> b) -> a -> b
$ RegClass -> FreeRegs -> [RealReg]
getFreeRegs RegClass
RcInteger FreeRegs
regs)       String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"      float: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([RealReg] -> String
forall a. Show a => a -> String
show ([RealReg] -> String) -> [RealReg] -> String
forall a b. (a -> b) -> a -> b
$ RegClass -> FreeRegs -> [RealReg]
getFreeRegs RegClass
RcFloat   FreeRegs
regs)       String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"     double: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ([RealReg] -> String
forall a. Show a => a -> String
show ([RealReg] -> String) -> [RealReg] -> String
forall a b. (a -> b) -> a -> b
$ RegClass -> FreeRegs -> [RealReg]
getFreeRegs RegClass
RcDouble  FreeRegs
regs)       String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"