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