SPARC.hs 5.89 KB
Newer Older
1
{-# LANGUAGE CPP #-}
2
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3 4

-- | Free regs map for SPARC
Sylvain Henry's avatar
Sylvain Henry committed
5
module GHC.CmmToAsm.Reg.Linear.SPARC where
6

7
import GHC.Prelude
8

Sylvain Henry's avatar
Sylvain Henry committed
9 10 11
import GHC.CmmToAsm.SPARC.Regs
import GHC.Platform.Reg.Class
import GHC.Platform.Reg
12

13
import GHC.Platform.Regs
14
import GHC.Utils.Outputable
15
import GHC.Utils.Panic
John Ericson's avatar
John Ericson committed
16
import GHC.Platform
17 18 19 20

import Data.Word
import Data.Bits

21

22 23
--------------------------------------------------------------------------------
-- SPARC is like PPC, except for twinning of floating point regs.
benl's avatar
benl committed
24 25
--      When we allocate a double reg we must take an even numbered
--      float reg, as well as the one after it.
26 27 28


-- Holds bitmaps showing what registers are currently allocated.
benl's avatar
benl committed
29 30
--      The float and double reg bitmaps overlap, but we only alloc
--      float regs into the float map, and double regs into the double map.
31
--
benl's avatar
benl committed
32
--      Free regs have a bit set in the corresponding bitmap.
33
--
34 35
data FreeRegs
        = FreeRegs
benl's avatar
benl committed
36 37 38
                !Word32         -- int    reg bitmap    regs  0..31
                !Word32         -- float  reg bitmap    regs 32..63
                !Word32         -- double reg bitmap    regs 32..63
39

40
instance Show FreeRegs where
benl's avatar
benl committed
41
        show = showFreeRegs
42

43 44 45
instance Outputable FreeRegs where
        ppr = text . showFreeRegs

46 47 48 49 50 51
-- | A reg map where no regs are free to be allocated.
noFreeRegs :: FreeRegs
noFreeRegs = FreeRegs 0 0 0


-- | The initial set of free regs.
52 53
initFreeRegs :: Platform -> FreeRegs
initFreeRegs platform
54
 =      foldl' (flip $ releaseReg platform) noFreeRegs allocatableRegs
55

56

57
-- | Get all the free registers of this class.
Gabor Greif's avatar
Gabor Greif committed
58
getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily
59
getFreeRegs cls (FreeRegs g f d)
60 61 62
        | RcInteger <- cls = map RealRegSingle                  $ go 1 g 1 0
        | RcFloat   <- cls = map RealRegSingle                  $ go 1 f 1 32
        | RcDouble  <- cls = map (\i -> RealRegPair i (i+1))    $ go 2 d 1 32
63
#if __GLASGOW_HASKELL__ <= 810
benl's avatar
benl committed
64
        | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls)
65
#endif
benl's avatar
benl committed
66 67 68
        where
                go _    _      0    _
                        = []
69

70 71 72
                go step bitmap mask ix
                        | bitmap .&. mask /= 0
                        = ix : (go step bitmap (mask `shiftL` step) $! ix + step)
73

74
                        | otherwise
benl's avatar
benl committed
75
                        = go step bitmap (mask `shiftL` step) $! ix + step
76 77 78


-- | Grab a register.
79 80
allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs
allocateReg platform
benl's avatar
benl committed
81 82 83 84
         reg@(RealRegSingle r)
             (FreeRegs g f d)

        -- can't allocate free regs
thomie's avatar
thomie committed
85
        | not $ freeReg platform r
benl's avatar
benl committed
86
        = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg)
87

benl's avatar
benl committed
88 89 90
        -- a general purpose reg
        | r <= 31
        = let   mask    = complement (bitMask r)
91 92 93
          in    FreeRegs
                        (g .&. mask)
                        f
benl's avatar
benl committed
94 95 96 97 98
                        d

        -- a float reg
        | r >= 32, r <= 63
        = let   mask    = complement (bitMask (r - 32))
99

benl's avatar
benl committed
100 101 102 103 104 105 106 107 108 109 110
                -- the mask of the double this FP reg aliases
                maskLow = if r `mod` 2 == 0
                                then complement (bitMask (r - 32))
                                else complement (bitMask (r - 32 - 1))
          in    FreeRegs
                        g
                        (f .&. mask)
                        (d .&. maskLow)

        | otherwise
        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)
111

112
allocateReg _
benl's avatar
benl committed
113
         reg@(RealRegPair r1 r2)
114
             (FreeRegs g f d)
115

benl's avatar
benl committed
116 117 118 119 120 121 122 123 124
        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0
        , r2 >= 32, r2 <= 63
        = let   mask1   = complement (bitMask (r1 - 32))
                mask2   = complement (bitMask (r2 - 32))
          in
                FreeRegs
                        g
                        ((f .&. mask1) .&. mask2)
                        (d .&. mask1)
125

benl's avatar
benl committed
126 127
        | otherwise
        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)
128

129 130 131


-- | Release a register from allocation.
132
--      The register liveness information says that most regs die after a C call,
benl's avatar
benl committed
133
--      but we still don't want to allocate to some of them.
134
--
135 136
releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs
releaseReg platform
137
         reg@(RealRegSingle r)
benl's avatar
benl committed
138 139 140
        regs@(FreeRegs g f d)

        -- don't release pinned reg
thomie's avatar
thomie committed
141
        | not $ freeReg platform r
benl's avatar
benl committed
142 143 144
        = regs

        -- a general purpose reg
145
        | r <= 31
benl's avatar
benl committed
146 147 148 149 150 151
        = let   mask    = bitMask r
          in    FreeRegs (g .|. mask) f d

        -- a float reg
        | r >= 32, r <= 63
        = let   mask    = bitMask (r - 32)
152

benl's avatar
benl committed
153 154 155 156
                -- the mask of the double this FP reg aliases
                maskLow = if r `mod` 2 == 0
                                then bitMask (r - 32)
                                else bitMask (r - 32 - 1)
157 158
          in    FreeRegs
                        g
benl's avatar
benl committed
159 160 161 162 163
                        (f .|. mask)
                        (d .|. maskLow)

        | otherwise
        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)
164

165
releaseReg _
166
         reg@(RealRegPair r1 r2)
benl's avatar
benl committed
167 168 169 170 171 172 173 174 175 176 177
             (FreeRegs g f d)

        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0
        , r2 >= 32, r2 <= 63
        = let   mask1   = bitMask (r1 - 32)
                mask2   = bitMask (r2 - 32)
          in
                FreeRegs
                        g
                        ((f .|. mask1) .|. mask2)
                        (d .|. mask1)
178

benl's avatar
benl committed
179 180
        | otherwise
        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)
181

182 183 184


bitMask :: Int -> Word32
benl's avatar
benl committed
185
bitMask n       = 1 `shiftL` n
186 187 188 189


showFreeRegs :: FreeRegs -> String
showFreeRegs regs
benl's avatar
benl committed
190 191 192 193
        =  "FreeRegs\n"
        ++ "    integer: " ++ (show $ getFreeRegs RcInteger regs)       ++ "\n"
        ++ "      float: " ++ (show $ getFreeRegs RcFloat   regs)       ++ "\n"
        ++ "     double: " ++ (show $ getFreeRegs RcDouble  regs)       ++ "\n"