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