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