Merge remote-tracking branch 'origin/master' into type-nats
[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
20 , regUsedIn, regSlot
21 , Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, isStackSlotOf
22 , module CmmMachOp
23 , module CmmType
24 )
25 where
26
27 #include "HsVersions.h"
28
29 import CmmType
30 import CmmMachOp
31 import BlockId
32 import CLabel
33 import Unique
34 import UniqSet
35
36 import Data.Map (Map)
37
38 -----------------------------------------------------------------------------
39 -- CmmExpr
40 -- An expression. Expressions have no side effects.
41 -----------------------------------------------------------------------------
42
43 data CmmExpr
44 = CmmLit CmmLit -- Literal
45 | CmmLoad CmmExpr CmmType -- Read memory location
46 | CmmReg CmmReg -- Contents of register
47 | CmmMachOp MachOp [CmmExpr] -- Machine operation (+, -, *, etc.)
48 | CmmStackSlot Area Int -- addressing expression of a stack slot
49 | CmmRegOff CmmReg Int
50 -- CmmRegOff reg i
51 -- ** is shorthand only, meaning **
52 -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
53 -- where rep = typeWidth (cmmRegType reg)
54
55 instance Eq CmmExpr where -- Equality ignores the types
56 CmmLit l1 == CmmLit l2 = l1==l2
57 CmmLoad e1 _ == CmmLoad e2 _ = e1==e2
58 CmmReg r1 == CmmReg r2 = r1==r2
59 CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2
60 CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2
61 CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2
62 _e1 == _e2 = False
63
64 data CmmReg
65 = CmmLocal LocalReg
66 | CmmGlobal GlobalReg
67 deriving( Eq, Ord )
68
69 -- | A stack area is either the stack slot where a variable is spilled
70 -- or the stack space where function arguments and results are passed.
71 data Area
72 = RegSlot LocalReg
73 | CallArea AreaId
74 deriving (Eq, Ord)
75
76 data AreaId
77 = Old -- See Note [Old Area]
78 | Young BlockId
79 deriving (Eq, Ord)
80
81 {- Note [Old Area]
82 ~~~~~~~~~~~~~~~~~~
83 There is a single call area 'Old', allocated at the extreme old
84 end of the stack frame (ie just younger than the return address)
85 which holds:
86 * incoming (overflow) parameters,
87 * outgoing (overflow) parameter to tail calls,
88 * outgoing (overflow) result values
89 * the update frame (if any)
90
91 Its size is the max of all these requirements. On entry, the stack
92 pointer will point to the youngest incoming parameter, which is not
93 necessarily at the young end of the Old area.
94
95 End of note -}
96
97 type SubArea = (Area, Int, Int) -- area, offset, width
98 type SubAreaSet = Map Area [SubArea]
99
100 type AreaMap = Map Area Int
101 -- Byte offset of the oldest byte of the Area,
102 -- relative to the oldest byte of the Old Area
103
104 data CmmLit
105 = CmmInt Integer Width
106 -- Interpretation: the 2's complement representation of the value
107 -- is truncated to the specified size. This is easier than trying
108 -- to keep the value within range, because we don't know whether
109 -- it will be used as a signed or unsigned value (the CmmType doesn't
110 -- distinguish between signed & unsigned).
111 | CmmFloat Rational Width
112 | CmmLabel CLabel -- Address of label
113 | CmmLabelOff CLabel Int -- Address of label + byte offset
114
115 -- Due to limitations in the C backend, the following
116 -- MUST ONLY be used inside the info table indicated by label2
117 -- (label2 must be the info label), and label1 must be an
118 -- SRT, a slow entrypoint or a large bitmap (see the Mangler)
119 -- Don't use it at all unless tablesNextToCode.
120 -- It is also used inside the NCG during when generating
121 -- position-independent code.
122 | CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset
123 | CmmBlock BlockId -- Code label
124 | CmmHighStackMark -- stands for the max stack space used during a procedure
125 deriving Eq
126
127 cmmExprType :: CmmExpr -> CmmType
128 cmmExprType (CmmLit lit) = cmmLitType lit
129 cmmExprType (CmmLoad _ rep) = rep
130 cmmExprType (CmmReg reg) = cmmRegType reg
131 cmmExprType (CmmMachOp op args) = machOpResultType op (map cmmExprType args)
132 cmmExprType (CmmRegOff reg _) = cmmRegType reg
133 cmmExprType (CmmStackSlot _ _) = bWord -- an address
134 -- Careful though: what is stored at the stack slot may be bigger than
135 -- an address
136
137 cmmLitType :: CmmLit -> CmmType
138 cmmLitType (CmmInt _ width) = cmmBits width
139 cmmLitType (CmmFloat _ width) = cmmFloat width
140 cmmLitType (CmmLabel lbl) = cmmLabelType lbl
141 cmmLitType (CmmLabelOff lbl _) = cmmLabelType lbl
142 cmmLitType (CmmLabelDiffOff {}) = bWord
143 cmmLitType (CmmBlock _) = bWord
144 cmmLitType (CmmHighStackMark) = bWord
145
146 cmmLabelType :: CLabel -> CmmType
147 cmmLabelType lbl | isGcPtrLabel lbl = gcWord
148 | otherwise = bWord
149
150 cmmExprWidth :: CmmExpr -> Width
151 cmmExprWidth e = typeWidth (cmmExprType e)
152
153 --------
154 --- Negation for conditional branches
155
156 maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
157 maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
158 return (CmmMachOp op' args)
159 maybeInvertCmmExpr _ = Nothing
160
161 -----------------------------------------------------------------------------
162 -- Local registers
163 -----------------------------------------------------------------------------
164
165 data LocalReg
166 = LocalReg !Unique CmmType
167 -- ^ Parameters:
168 -- 1. Identifier
169 -- 2. Type
170
171 instance Eq LocalReg where
172 (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
173
174 instance Ord LocalReg where
175 compare (LocalReg u1 _) (LocalReg u2 _) = compare u1 u2
176
177 instance Uniquable LocalReg where
178 getUnique (LocalReg uniq _) = uniq
179
180 cmmRegType :: CmmReg -> CmmType
181 cmmRegType (CmmLocal reg) = localRegType reg
182 cmmRegType (CmmGlobal reg) = globalRegType reg
183
184 localRegType :: LocalReg -> CmmType
185 localRegType (LocalReg _ rep) = rep
186
187 -----------------------------------------------------------------------------
188 -- Register-use information for expressions and other types
189 -----------------------------------------------------------------------------
190
191 -- | Sets of local registers
192 type RegSet = UniqSet LocalReg
193 emptyRegSet :: RegSet
194 elemRegSet :: LocalReg -> RegSet -> Bool
195 extendRegSet :: RegSet -> LocalReg -> RegSet
196 deleteFromRegSet :: RegSet -> LocalReg -> RegSet
197 mkRegSet :: [LocalReg] -> RegSet
198 minusRegSet, plusRegSet, timesRegSet :: RegSet -> RegSet -> RegSet
199
200 emptyRegSet = emptyUniqSet
201 elemRegSet = elementOfUniqSet
202 extendRegSet = addOneToUniqSet
203 deleteFromRegSet = delOneFromUniqSet
204 mkRegSet = mkUniqSet
205 minusRegSet = minusUniqSet
206 plusRegSet = unionUniqSets
207 timesRegSet = intersectUniqSets
208
209 class UserOfLocalRegs a where
210 foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b
211
212 class DefinerOfLocalRegs a where
213 foldRegsDefd :: (b -> LocalReg -> b) -> b -> a -> b
214
215 filterRegsUsed :: UserOfLocalRegs e => (LocalReg -> Bool) -> e -> RegSet
216 filterRegsUsed p e =
217 foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs)
218 emptyRegSet e
219
220 instance UserOfLocalRegs a => UserOfLocalRegs (Maybe a) where
221 foldRegsUsed f z (Just x) = foldRegsUsed f z x
222 foldRegsUsed _ z Nothing = z
223
224 instance UserOfLocalRegs CmmReg where
225 foldRegsUsed f z (CmmLocal reg) = f z reg
226 foldRegsUsed _ z (CmmGlobal _) = z
227
228 instance DefinerOfLocalRegs CmmReg where
229 foldRegsDefd f z (CmmLocal reg) = f z reg
230 foldRegsDefd _ z (CmmGlobal _) = z
231
232 instance UserOfLocalRegs LocalReg where
233 foldRegsUsed f z r = f z r
234
235 instance DefinerOfLocalRegs LocalReg where
236 foldRegsDefd f z r = f z r
237
238 instance UserOfLocalRegs RegSet where
239 foldRegsUsed f = foldUniqSet (flip f)
240
241 instance UserOfLocalRegs CmmExpr where
242 foldRegsUsed f z e = expr z e
243 where expr z (CmmLit _) = z
244 expr z (CmmLoad addr _) = foldRegsUsed f z addr
245 expr z (CmmReg r) = foldRegsUsed f z r
246 expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs
247 expr z (CmmRegOff r _) = foldRegsUsed f z r
248 expr z (CmmStackSlot _ _) = z
249
250 instance UserOfLocalRegs a => UserOfLocalRegs [a] where
251 foldRegsUsed _ set [] = set
252 foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
253
254 instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
255 foldRegsDefd _ set [] = set
256 foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
257
258 instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
259 foldRegsDefd _ set Nothing = set
260 foldRegsDefd f set (Just x) = foldRegsDefd f set x
261
262 -----------------------------------------------------------------------------
263 -- Another reg utility
264
265 regUsedIn :: CmmReg -> CmmExpr -> Bool
266 _ `regUsedIn` CmmLit _ = False
267 reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
268 reg `regUsedIn` CmmReg reg' = reg == reg'
269 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
270 reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
271 _ `regUsedIn` CmmStackSlot _ _ = False
272
273 -----------------------------------------------------------------------------
274 -- Stack slots
275 -----------------------------------------------------------------------------
276
277 isStackSlotOf :: CmmExpr -> LocalReg -> Bool
278 isStackSlotOf (CmmStackSlot (RegSlot r) _) r' = r == r'
279 isStackSlotOf _ _ = False
280
281 regSlot :: LocalReg -> CmmExpr
282 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
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