implement RegSet by Set, not UniqSet
[ghc.git] / compiler / cmm / CmmExpr.hs
1
2 {-# OPTIONS -fno-warn-tabs #-}
3 -- The above warning supression flag is a temporary kludge.
4 -- While working on this module you are encouraged to remove it and
5 -- detab the module (please do the detabbing in a separate patch). See
6 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
7 -- for details
8
9 module CmmExpr
10 ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
11 , CmmReg(..), cmmRegType
12 , CmmLit(..), cmmLitType
13 , LocalReg(..), localRegType
14 , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg
15 , VGcPtr(..), vgcFlag -- Temporary!
16 , DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
17 , DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed
18 , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
19 , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
20 , regSetToList
21 , regUsedIn, regSlot
22 , Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, isStackSlotOf
23 , module CmmMachOp
24 , module CmmType
25 )
26 where
27
28 #include "HsVersions.h"
29
30 import CmmType
31 import CmmMachOp
32 import BlockId
33 import CLabel
34 import Unique
35
36 import Data.Map (Map)
37 import Data.Set (Set)
38 import qualified Data.Set as Set
39
40 -----------------------------------------------------------------------------
41 -- CmmExpr
42 -- An expression. Expressions have no side effects.
43 -----------------------------------------------------------------------------
44
45 data CmmExpr
46 = CmmLit CmmLit -- Literal
47 | CmmLoad CmmExpr CmmType -- Read memory location
48 | CmmReg CmmReg -- Contents of register
49 | CmmMachOp MachOp [CmmExpr] -- Machine operation (+, -, *, etc.)
50 | CmmStackSlot Area Int -- addressing expression of a stack slot
51 | CmmRegOff CmmReg Int
52 -- CmmRegOff reg i
53 -- ** is shorthand only, meaning **
54 -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
55 -- where rep = typeWidth (cmmRegType reg)
56
57 instance Eq CmmExpr where -- Equality ignores the types
58 CmmLit l1 == CmmLit l2 = l1==l2
59 CmmLoad e1 _ == CmmLoad e2 _ = e1==e2
60 CmmReg r1 == CmmReg r2 = r1==r2
61 CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2
62 CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2
63 CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2
64 _e1 == _e2 = False
65
66 data CmmReg
67 = CmmLocal {-# UNPACK #-} !LocalReg
68 | CmmGlobal GlobalReg
69 deriving( Eq, Ord )
70
71 -- | A stack area is either the stack slot where a variable is spilled
72 -- or the stack space where function arguments and results are passed.
73 data Area
74 = RegSlot LocalReg
75 | CallArea AreaId
76 deriving (Eq, Ord)
77
78 data AreaId
79 = Old -- See Note [Old Area]
80 | Young BlockId -- Invariant: must be a continuation BlockId
81 -- See Note [Continuation BlockId] in CmmNode.
82 deriving (Eq, Ord)
83
84 {- Note [Old Area]
85 ~~~~~~~~~~~~~~~~~~
86 There is a single call area 'Old', allocated at the extreme old
87 end of the stack frame (ie just younger than the return address)
88 which holds:
89 * incoming (overflow) parameters,
90 * outgoing (overflow) parameter to tail calls,
91 * outgoing (overflow) result values
92 * the update frame (if any)
93
94 Its size is the max of all these requirements. On entry, the stack
95 pointer will point to the youngest incoming parameter, which is not
96 necessarily at the young end of the Old area.
97
98 End of note -}
99
100 type SubArea = (Area, Int, Int) -- area, offset, width
101 type SubAreaSet = Map Area [SubArea]
102
103 type AreaMap = Map Area Int
104 -- Byte offset of the oldest byte of the Area,
105 -- relative to the oldest byte of the Old Area
106
107 data CmmLit
108 = CmmInt !Integer Width
109 -- Interpretation: the 2's complement representation of the value
110 -- is truncated to the specified size. This is easier than trying
111 -- to keep the value within range, because we don't know whether
112 -- it will be used as a signed or unsigned value (the CmmType doesn't
113 -- distinguish between signed & unsigned).
114 | CmmFloat Rational Width
115 | CmmLabel CLabel -- Address of label
116 | CmmLabelOff CLabel Int -- Address of label + byte offset
117
118 -- Due to limitations in the C backend, the following
119 -- MUST ONLY be used inside the info table indicated by label2
120 -- (label2 must be the info label), and label1 must be an
121 -- SRT, a slow entrypoint or a large bitmap (see the Mangler)
122 -- Don't use it at all unless tablesNextToCode.
123 -- It is also used inside the NCG during when generating
124 -- position-independent code.
125 | CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset
126
127 | CmmBlock BlockId -- Code label
128 -- Invariant: must be a continuation BlockId
129 -- See Note [Continuation BlockId] in CmmNode.
130
131 | CmmHighStackMark -- stands for the max stack space used during a procedure
132 deriving Eq
133
134 cmmExprType :: CmmExpr -> CmmType
135 cmmExprType (CmmLit lit) = cmmLitType lit
136 cmmExprType (CmmLoad _ rep) = rep
137 cmmExprType (CmmReg reg) = cmmRegType reg
138 cmmExprType (CmmMachOp op args) = machOpResultType op (map cmmExprType args)
139 cmmExprType (CmmRegOff reg _) = cmmRegType reg
140 cmmExprType (CmmStackSlot _ _) = bWord -- an address
141 -- Careful though: what is stored at the stack slot may be bigger than
142 -- an address
143
144 cmmLitType :: CmmLit -> CmmType
145 cmmLitType (CmmInt _ width) = cmmBits width
146 cmmLitType (CmmFloat _ width) = cmmFloat width
147 cmmLitType (CmmLabel lbl) = cmmLabelType lbl
148 cmmLitType (CmmLabelOff lbl _) = cmmLabelType lbl
149 cmmLitType (CmmLabelDiffOff {}) = bWord
150 cmmLitType (CmmBlock _) = bWord
151 cmmLitType (CmmHighStackMark) = bWord
152
153 cmmLabelType :: CLabel -> CmmType
154 cmmLabelType lbl | isGcPtrLabel lbl = gcWord
155 | otherwise = bWord
156
157 cmmExprWidth :: CmmExpr -> Width
158 cmmExprWidth e = typeWidth (cmmExprType e)
159
160 --------
161 --- Negation for conditional branches
162
163 maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
164 maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
165 return (CmmMachOp op' args)
166 maybeInvertCmmExpr _ = Nothing
167
168 -----------------------------------------------------------------------------
169 -- Local registers
170 -----------------------------------------------------------------------------
171
172 data LocalReg
173 = LocalReg {-# UNPACK #-} !Unique CmmType
174 -- ^ Parameters:
175 -- 1. Identifier
176 -- 2. Type
177
178 instance Eq LocalReg where
179 (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
180
181 instance Ord LocalReg where
182 compare (LocalReg u1 _) (LocalReg u2 _) = compare u1 u2
183
184 instance Uniquable LocalReg where
185 getUnique (LocalReg uniq _) = uniq
186
187 cmmRegType :: CmmReg -> CmmType
188 cmmRegType (CmmLocal reg) = localRegType reg
189 cmmRegType (CmmGlobal reg) = globalRegType reg
190
191 localRegType :: LocalReg -> CmmType
192 localRegType (LocalReg _ rep) = rep
193
194 -----------------------------------------------------------------------------
195 -- Register-use information for expressions and other types
196 -----------------------------------------------------------------------------
197
198 -- | Sets of local registers
199
200 -- These are used for dataflow facts, and a common operation is taking
201 -- the union of two RegSets and then asking whether the union is the
202 -- same as one of the inputs. UniqSet isn't good here, because
203 -- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary
204 -- Sets.
205
206 type RegSet = Set LocalReg
207 emptyRegSet :: RegSet
208 nullRegSet :: RegSet -> Bool
209 elemRegSet :: LocalReg -> RegSet -> Bool
210 extendRegSet :: RegSet -> LocalReg -> RegSet
211 deleteFromRegSet :: RegSet -> LocalReg -> RegSet
212 mkRegSet :: [LocalReg] -> RegSet
213 minusRegSet, plusRegSet, timesRegSet :: RegSet -> RegSet -> RegSet
214 sizeRegSet :: RegSet -> Int
215 regSetToList :: RegSet -> [LocalReg]
216
217 emptyRegSet = Set.empty
218 nullRegSet = Set.null
219 elemRegSet = Set.member
220 extendRegSet = flip Set.insert
221 deleteFromRegSet = flip Set.delete
222 mkRegSet = Set.fromList
223 minusRegSet = Set.difference
224 plusRegSet = Set.union
225 timesRegSet = Set.intersection
226 sizeRegSet = Set.size
227 regSetToList = Set.toList
228
229 class UserOfLocalRegs a where
230 foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b
231
232 class DefinerOfLocalRegs a where
233 foldRegsDefd :: (b -> LocalReg -> b) -> b -> a -> b
234
235 filterRegsUsed :: UserOfLocalRegs e => (LocalReg -> Bool) -> e -> RegSet
236 filterRegsUsed p e =
237 foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs)
238 emptyRegSet e
239
240 instance UserOfLocalRegs CmmReg where
241 foldRegsUsed f z (CmmLocal reg) = f z reg
242 foldRegsUsed _ z (CmmGlobal _) = z
243
244 instance DefinerOfLocalRegs CmmReg where
245 foldRegsDefd f z (CmmLocal reg) = f z reg
246 foldRegsDefd _ z (CmmGlobal _) = z
247
248 instance UserOfLocalRegs LocalReg where
249 foldRegsUsed f z r = f z r
250
251 instance DefinerOfLocalRegs LocalReg where
252 foldRegsDefd f z r = f z r
253
254 instance UserOfLocalRegs RegSet where
255 foldRegsUsed f = Set.fold (flip f)
256
257 instance UserOfLocalRegs CmmExpr where
258 foldRegsUsed f z e = expr z e
259 where expr z (CmmLit _) = z
260 expr z (CmmLoad addr _) = foldRegsUsed f z addr
261 expr z (CmmReg r) = foldRegsUsed f z r
262 expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs
263 expr z (CmmRegOff r _) = foldRegsUsed f z r
264 expr z (CmmStackSlot _ _) = z
265
266 instance UserOfLocalRegs a => UserOfLocalRegs [a] where
267 foldRegsUsed _ set [] = set
268 foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
269
270 instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
271 foldRegsDefd _ set [] = set
272 foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
273
274 instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
275 foldRegsDefd _ set Nothing = set
276 foldRegsDefd f set (Just x) = foldRegsDefd f set x
277
278 -----------------------------------------------------------------------------
279 -- Another reg utility
280
281 regUsedIn :: CmmReg -> CmmExpr -> Bool
282 _ `regUsedIn` CmmLit _ = False
283 reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
284 reg `regUsedIn` CmmReg reg' = reg == reg'
285 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
286 reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
287 _ `regUsedIn` CmmStackSlot _ _ = False
288
289 -----------------------------------------------------------------------------
290 -- Stack slots
291 -----------------------------------------------------------------------------
292
293 isStackSlotOf :: CmmExpr -> LocalReg -> Bool
294 isStackSlotOf (CmmStackSlot (RegSlot r) _) r' = r == r'
295 isStackSlotOf _ _ = False
296
297 regSlot :: LocalReg -> CmmExpr
298 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
299
300 -----------------------------------------------------------------------------
301 -- Stack slot use information for expressions and other types [_$_]
302 -----------------------------------------------------------------------------
303
304 -- Fold over the area, the offset into the area, and the width of the subarea.
305 class UserOfSlots a where
306 foldSlotsUsed :: (b -> SubArea -> b) -> b -> a -> b
307
308 class DefinerOfSlots a where
309 foldSlotsDefd :: (b -> SubArea -> b) -> b -> a -> b
310
311 instance UserOfSlots CmmExpr where
312 foldSlotsUsed f z e = expr z e
313 where expr z (CmmLit _) = z
314 expr z (CmmLoad (CmmStackSlot a i) ty) = f z (a, i, widthInBytes $ typeWidth ty)
315 expr z (CmmLoad addr _) = foldSlotsUsed f z addr
316 expr z (CmmReg _) = z
317 expr z (CmmMachOp _ exprs) = foldSlotsUsed f z exprs
318 expr z (CmmRegOff _ _) = z
319 expr z (CmmStackSlot _ _) = z
320
321 instance UserOfSlots a => UserOfSlots [a] where
322 foldSlotsUsed _ set [] = set
323 foldSlotsUsed f set (x:xs) = foldSlotsUsed f (foldSlotsUsed f set x) xs
324
325 instance DefinerOfSlots a => DefinerOfSlots [a] where
326 foldSlotsDefd _ set [] = set
327 foldSlotsDefd f set (x:xs) = foldSlotsDefd f (foldSlotsDefd f set x) xs
328
329 instance DefinerOfSlots SubArea where
330 foldSlotsDefd f z a = f z a
331
332 -----------------------------------------------------------------------------
333 -- Global STG registers
334 -----------------------------------------------------------------------------
335
336 data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
337 -- TEMPORARY!!!
338
339 -----------------------------------------------------------------------------
340 -- Global STG registers
341 -----------------------------------------------------------------------------
342 vgcFlag :: CmmType -> VGcPtr
343 vgcFlag ty | isGcPtrType ty = VGcPtr
344 | otherwise = VNonGcPtr
345
346 data GlobalReg
347 -- Argument and return registers
348 = VanillaReg -- pointers, unboxed ints and chars
349 {-# UNPACK #-} !Int -- its number
350 VGcPtr
351
352 | FloatReg -- single-precision floating-point registers
353 {-# UNPACK #-} !Int -- its number
354
355 | DoubleReg -- double-precision floating-point registers
356 {-# UNPACK #-} !Int -- its number
357
358 | LongReg -- long int registers (64-bit, really)
359 {-# UNPACK #-} !Int -- its number
360
361 -- STG registers
362 | Sp -- Stack ptr; points to last occupied stack location.
363 | SpLim -- Stack limit
364 | Hp -- Heap ptr; points to last occupied heap location.
365 | HpLim -- Heap limit register
366 | CCCS -- Current cost-centre stack
367 | CurrentTSO -- pointer to current thread's TSO
368 | CurrentNursery -- pointer to allocation area
369 | HpAlloc -- allocation count for heap check failure
370
371 -- We keep the address of some commonly-called
372 -- functions in the register table, to keep code
373 -- size down:
374 | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info
375 | GCEnter1 -- stg_gc_enter_1
376 | GCFun -- stg_gc_fun
377
378 -- Base offset for the register table, used for accessing registers
379 -- which do not have real registers assigned to them. This register
380 -- will only appear after we have expanded GlobalReg into memory accesses
381 -- (where necessary) in the native code generator.
382 | BaseReg
383
384 -- Base Register for PIC (position-independent code) calculations
385 -- Only used inside the native code generator. It's exact meaning differs
386 -- from platform to platform (see module PositionIndependentCode).
387 | PicBaseReg
388
389 deriving( Show )
390
391 instance Eq GlobalReg where
392 VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
393 FloatReg i == FloatReg j = i==j
394 DoubleReg i == DoubleReg j = i==j
395 LongReg i == LongReg j = i==j
396 Sp == Sp = True
397 SpLim == SpLim = True
398 Hp == Hp = True
399 HpLim == HpLim = True
400 CurrentTSO == CurrentTSO = True
401 CurrentNursery == CurrentNursery = True
402 HpAlloc == HpAlloc = True
403 GCEnter1 == GCEnter1 = True
404 GCFun == GCFun = True
405 BaseReg == BaseReg = True
406 PicBaseReg == PicBaseReg = True
407 _r1 == _r2 = False
408
409 instance Ord GlobalReg where
410 compare (VanillaReg i _) (VanillaReg j _) = compare i j
411 -- Ignore type when seeking clashes
412 compare (FloatReg i) (FloatReg j) = compare i j
413 compare (DoubleReg i) (DoubleReg j) = compare i j
414 compare (LongReg i) (LongReg j) = compare i j
415 compare Sp Sp = EQ
416 compare SpLim SpLim = EQ
417 compare Hp Hp = EQ
418 compare HpLim HpLim = EQ
419 compare CCCS CCCS = EQ
420 compare CurrentTSO CurrentTSO = EQ
421 compare CurrentNursery CurrentNursery = EQ
422 compare HpAlloc HpAlloc = EQ
423 compare EagerBlackholeInfo EagerBlackholeInfo = EQ
424 compare GCEnter1 GCEnter1 = EQ
425 compare GCFun GCFun = EQ
426 compare BaseReg BaseReg = EQ
427 compare PicBaseReg PicBaseReg = EQ
428 compare (VanillaReg _ _) _ = LT
429 compare _ (VanillaReg _ _) = GT
430 compare (FloatReg _) _ = LT
431 compare _ (FloatReg _) = GT
432 compare (DoubleReg _) _ = LT
433 compare _ (DoubleReg _) = GT
434 compare (LongReg _) _ = LT
435 compare _ (LongReg _) = GT
436 compare Sp _ = LT
437 compare _ Sp = GT
438 compare SpLim _ = LT
439 compare _ SpLim = GT
440 compare Hp _ = LT
441 compare _ Hp = GT
442 compare HpLim _ = LT
443 compare _ HpLim = GT
444 compare CCCS _ = LT
445 compare _ CCCS = GT
446 compare CurrentTSO _ = LT
447 compare _ CurrentTSO = GT
448 compare CurrentNursery _ = LT
449 compare _ CurrentNursery = GT
450 compare HpAlloc _ = LT
451 compare _ HpAlloc = GT
452 compare GCEnter1 _ = LT
453 compare _ GCEnter1 = GT
454 compare GCFun _ = LT
455 compare _ GCFun = GT
456 compare BaseReg _ = LT
457 compare _ BaseReg = GT
458 compare EagerBlackholeInfo _ = LT
459 compare _ EagerBlackholeInfo = GT
460
461 -- convenient aliases
462 baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg
463 baseReg = CmmGlobal BaseReg
464 spReg = CmmGlobal Sp
465 hpReg = CmmGlobal Hp
466 spLimReg = CmmGlobal SpLim
467 nodeReg = CmmGlobal node
468
469 node :: GlobalReg
470 node = VanillaReg 1 VGcPtr
471
472 globalRegType :: GlobalReg -> CmmType
473 globalRegType (VanillaReg _ VGcPtr) = gcWord
474 globalRegType (VanillaReg _ VNonGcPtr) = bWord
475 globalRegType (FloatReg _) = cmmFloat W32
476 globalRegType (DoubleReg _) = cmmFloat W64
477 globalRegType (LongReg _) = cmmBits W64
478 globalRegType Hp = gcWord -- The initialiser for all
479 -- dynamically allocated closures
480 globalRegType _ = bWord