6b6e67c6124f93e804da83e3ee44c16a08c4acf8
[ghc.git] / compiler / nativeGen / RegAlloc / Linear / SPARC / FreeRegs.hs
1
2 -- | Free regs map for SPARC
3 module RegAlloc.Linear.SPARC.FreeRegs
4 where
5
6 import SPARC.Regs
7 import RegClass
8 import Reg
9
10 import CodeGen.Platform
11 import Outputable
12 import Platform
13 import FastBool
14
15 import Data.Word
16 import Data.Bits
17 -- import Data.List
18
19
20 --------------------------------------------------------------------------------
21 -- SPARC is like PPC, except for twinning of floating point regs.
22 -- When we allocate a double reg we must take an even numbered
23 -- float reg, as well as the one after it.
24
25
26 -- Holds bitmaps showing what registers are currently allocated.
27 -- The float and double reg bitmaps overlap, but we only alloc
28 -- float regs into the float map, and double regs into the double map.
29 --
30 -- Free regs have a bit set in the corresponding bitmap.
31 --
32 data FreeRegs
33 = FreeRegs
34 !Word32 -- int reg bitmap regs 0..31
35 !Word32 -- float reg bitmap regs 32..63
36 !Word32 -- double reg bitmap regs 32..63
37
38 instance Show FreeRegs where
39 show = showFreeRegs
40
41 -- | A reg map where no regs are free to be allocated.
42 noFreeRegs :: FreeRegs
43 noFreeRegs = FreeRegs 0 0 0
44
45
46 -- | The initial set of free regs.
47 initFreeRegs :: Platform -> FreeRegs
48 initFreeRegs platform
49 = foldr (releaseReg platform) noFreeRegs allocatableRegs
50
51
52 -- | Get all the free registers of this class.
53 getFreeRegs :: RegClass -> FreeRegs -> [RealReg] -- lazily
54 getFreeRegs cls (FreeRegs g f d)
55 | RcInteger <- cls = map RealRegSingle $ go 1 g 1 0
56 | RcFloat <- cls = map RealRegSingle $ go 1 f 1 32
57 | RcDouble <- cls = map (\i -> RealRegPair i (i+1)) $ go 2 d 1 32
58 | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls)
59 where
60 go _ _ 0 _
61 = []
62
63 go step bitmap mask ix
64 | bitmap .&. mask /= 0
65 = ix : (go step bitmap (mask `shiftL` step) $! ix + step)
66
67 | otherwise
68 = go step bitmap (mask `shiftL` step) $! ix + step
69
70
71 -- | Grab a register.
72 allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs
73 allocateReg platform
74 reg@(RealRegSingle r)
75 (FreeRegs g f d)
76
77 -- can't allocate free regs
78 | not $ isFastTrue (freeReg platform r)
79 = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg)
80
81 -- a general purpose reg
82 | r <= 31
83 = let mask = complement (bitMask r)
84 in FreeRegs
85 (g .&. mask)
86 f
87 d
88
89 -- a float reg
90 | r >= 32, r <= 63
91 = let mask = complement (bitMask (r - 32))
92
93 -- the mask of the double this FP reg aliases
94 maskLow = if r `mod` 2 == 0
95 then complement (bitMask (r - 32))
96 else complement (bitMask (r - 32 - 1))
97 in FreeRegs
98 g
99 (f .&. mask)
100 (d .&. maskLow)
101
102 | otherwise
103 = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)
104
105 allocateReg _
106 reg@(RealRegPair r1 r2)
107 (FreeRegs g f d)
108
109 | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0
110 , r2 >= 32, r2 <= 63
111 = let mask1 = complement (bitMask (r1 - 32))
112 mask2 = complement (bitMask (r2 - 32))
113 in
114 FreeRegs
115 g
116 ((f .&. mask1) .&. mask2)
117 (d .&. mask1)
118
119 | otherwise
120 = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)
121
122
123
124 -- | Release a register from allocation.
125 -- The register liveness information says that most regs die after a C call,
126 -- but we still don't want to allocate to some of them.
127 --
128 releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs
129 releaseReg platform
130 reg@(RealRegSingle r)
131 regs@(FreeRegs g f d)
132
133 -- don't release pinned reg
134 | not $ isFastTrue (freeReg platform r)
135 = regs
136
137 -- a general purpose reg
138 | r <= 31
139 = let mask = bitMask r
140 in FreeRegs (g .|. mask) f d
141
142 -- a float reg
143 | r >= 32, r <= 63
144 = let mask = bitMask (r - 32)
145
146 -- the mask of the double this FP reg aliases
147 maskLow = if r `mod` 2 == 0
148 then bitMask (r - 32)
149 else bitMask (r - 32 - 1)
150 in FreeRegs
151 g
152 (f .|. mask)
153 (d .|. maskLow)
154
155 | otherwise
156 = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)
157
158 releaseReg _
159 reg@(RealRegPair r1 r2)
160 (FreeRegs g f d)
161
162 | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0
163 , r2 >= 32, r2 <= 63
164 = let mask1 = bitMask (r1 - 32)
165 mask2 = bitMask (r2 - 32)
166 in
167 FreeRegs
168 g
169 ((f .|. mask1) .|. mask2)
170 (d .|. mask1)
171
172 | otherwise
173 = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)
174
175
176
177 bitMask :: Int -> Word32
178 bitMask n = 1 `shiftL` n
179
180
181 showFreeRegs :: FreeRegs -> String
182 showFreeRegs regs
183 = "FreeRegs\n"
184 ++ " integer: " ++ (show $ getFreeRegs RcInteger regs) ++ "\n"
185 ++ " float: " ++ (show $ getFreeRegs RcFloat regs) ++ "\n"
186 ++ " double: " ++ (show $ getFreeRegs RcDouble regs) ++ "\n"
187