Merge remote-tracking branch 'origin/type-nats' into type-nats-merge
[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 CmmReg where
221 foldRegsUsed f z (CmmLocal reg) = f z reg
222 foldRegsUsed _ z (CmmGlobal _) = z
223
224 instance DefinerOfLocalRegs CmmReg where
225 foldRegsDefd f z (CmmLocal reg) = f z reg
226 foldRegsDefd _ z (CmmGlobal _) = z
227
228 instance UserOfLocalRegs LocalReg where
229 foldRegsUsed f z r = f z r
230
231 instance DefinerOfLocalRegs LocalReg where
232 foldRegsDefd f z r = f z r
233
234 instance UserOfLocalRegs RegSet where
235 foldRegsUsed f = foldUniqSet (flip f)
236
237 instance UserOfLocalRegs CmmExpr where
238 foldRegsUsed f z e = expr z e
239 where expr z (CmmLit _) = z
240 expr z (CmmLoad addr _) = foldRegsUsed f z addr
241 expr z (CmmReg r) = foldRegsUsed f z r
242 expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs
243 expr z (CmmRegOff r _) = foldRegsUsed f z r
244 expr z (CmmStackSlot _ _) = z
245
246 instance UserOfLocalRegs a => UserOfLocalRegs [a] where
247 foldRegsUsed _ set [] = set
248 foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
249
250 instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
251 foldRegsDefd _ set [] = set
252 foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
253
254 instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
255 foldRegsDefd _ set Nothing = set
256 foldRegsDefd f set (Just x) = foldRegsDefd f set x
257
258 -----------------------------------------------------------------------------
259 -- Another reg utility
260
261 regUsedIn :: CmmReg -> CmmExpr -> Bool
262 _ `regUsedIn` CmmLit _ = False
263 reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
264 reg `regUsedIn` CmmReg reg' = reg == reg'
265 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
266 reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
267 _ `regUsedIn` CmmStackSlot _ _ = False
268
269 -----------------------------------------------------------------------------
270 -- Stack slots
271 -----------------------------------------------------------------------------
272
273 isStackSlotOf :: CmmExpr -> LocalReg -> Bool
274 isStackSlotOf (CmmStackSlot (RegSlot r) _) r' = r == r'
275 isStackSlotOf _ _ = False
276
277 regSlot :: LocalReg -> CmmExpr
278 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
279
280 -----------------------------------------------------------------------------
281 -- Stack slot use information for expressions and other types [_$_]
282 -----------------------------------------------------------------------------
283
284 -- Fold over the area, the offset into the area, and the width of the subarea.
285 class UserOfSlots a where
286 foldSlotsUsed :: (b -> SubArea -> b) -> b -> a -> b
287
288 class DefinerOfSlots a where
289 foldSlotsDefd :: (b -> SubArea -> b) -> b -> a -> b
290
291 instance UserOfSlots CmmExpr where
292 foldSlotsUsed f z e = expr z e
293 where expr z (CmmLit _) = z
294 expr z (CmmLoad (CmmStackSlot a i) ty) = f z (a, i, widthInBytes $ typeWidth ty)
295 expr z (CmmLoad addr _) = foldSlotsUsed f z addr
296 expr z (CmmReg _) = z
297 expr z (CmmMachOp _ exprs) = foldSlotsUsed f z exprs
298 expr z (CmmRegOff _ _) = z
299 expr z (CmmStackSlot _ _) = z
300
301 instance UserOfSlots a => UserOfSlots [a] where
302 foldSlotsUsed _ set [] = set
303 foldSlotsUsed f set (x:xs) = foldSlotsUsed f (foldSlotsUsed f set x) xs
304
305 instance DefinerOfSlots a => DefinerOfSlots [a] where
306 foldSlotsDefd _ set [] = set
307 foldSlotsDefd f set (x:xs) = foldSlotsDefd f (foldSlotsDefd f set x) xs
308
309 instance DefinerOfSlots SubArea where
310 foldSlotsDefd f z a = f z a
311
312 -----------------------------------------------------------------------------
313 -- Global STG registers
314 -----------------------------------------------------------------------------
315
316 data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
317 -- TEMPORARY!!!
318
319 -----------------------------------------------------------------------------
320 -- Global STG registers
321 -----------------------------------------------------------------------------
322 vgcFlag :: CmmType -> VGcPtr
323 vgcFlag ty | isGcPtrType ty = VGcPtr
324 | otherwise = VNonGcPtr
325
326 data GlobalReg
327 -- Argument and return registers
328 = VanillaReg -- pointers, unboxed ints and chars
329 {-# UNPACK #-} !Int -- its number
330 VGcPtr
331
332 | FloatReg -- single-precision floating-point registers
333 {-# UNPACK #-} !Int -- its number
334
335 | DoubleReg -- double-precision floating-point registers
336 {-# UNPACK #-} !Int -- its number
337
338 | LongReg -- long int registers (64-bit, really)
339 {-# UNPACK #-} !Int -- its number
340
341 -- STG registers
342 | Sp -- Stack ptr; points to last occupied stack location.
343 | SpLim -- Stack limit
344 | Hp -- Heap ptr; points to last occupied heap location.
345 | HpLim -- Heap limit register
346 | CCCS -- Current cost-centre stack
347 | CurrentTSO -- pointer to current thread's TSO
348 | CurrentNursery -- pointer to allocation area
349 | HpAlloc -- allocation count for heap check failure
350
351 -- We keep the address of some commonly-called
352 -- functions in the register table, to keep code
353 -- size down:
354 | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info
355 | GCEnter1 -- stg_gc_enter_1
356 | GCFun -- stg_gc_fun
357
358 -- Base offset for the register table, used for accessing registers
359 -- which do not have real registers assigned to them. This register
360 -- will only appear after we have expanded GlobalReg into memory accesses
361 -- (where necessary) in the native code generator.
362 | BaseReg
363
364 -- Base Register for PIC (position-independent code) calculations
365 -- Only used inside the native code generator. It's exact meaning differs
366 -- from platform to platform (see module PositionIndependentCode).
367 | PicBaseReg
368
369 deriving( Show )
370
371 instance Eq GlobalReg where
372 VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
373 FloatReg i == FloatReg j = i==j
374 DoubleReg i == DoubleReg j = i==j
375 LongReg i == LongReg j = i==j
376 Sp == Sp = True
377 SpLim == SpLim = True
378 Hp == Hp = True
379 HpLim == HpLim = True
380 CurrentTSO == CurrentTSO = True
381 CurrentNursery == CurrentNursery = True
382 HpAlloc == HpAlloc = True
383 GCEnter1 == GCEnter1 = True
384 GCFun == GCFun = True
385 BaseReg == BaseReg = True
386 PicBaseReg == PicBaseReg = True
387 _r1 == _r2 = False
388
389 instance Ord GlobalReg where
390 compare (VanillaReg i _) (VanillaReg j _) = compare i j
391 -- Ignore type when seeking clashes
392 compare (FloatReg i) (FloatReg j) = compare i j
393 compare (DoubleReg i) (DoubleReg j) = compare i j
394 compare (LongReg i) (LongReg j) = compare i j
395 compare Sp Sp = EQ
396 compare SpLim SpLim = EQ
397 compare Hp Hp = EQ
398 compare HpLim HpLim = EQ
399 compare CCCS CCCS = EQ
400 compare CurrentTSO CurrentTSO = EQ
401 compare CurrentNursery CurrentNursery = EQ
402 compare HpAlloc HpAlloc = EQ
403 compare EagerBlackholeInfo EagerBlackholeInfo = EQ
404 compare GCEnter1 GCEnter1 = EQ
405 compare GCFun GCFun = EQ
406 compare BaseReg BaseReg = EQ
407 compare PicBaseReg PicBaseReg = EQ
408 compare (VanillaReg _ _) _ = LT
409 compare _ (VanillaReg _ _) = GT
410 compare (FloatReg _) _ = LT
411 compare _ (FloatReg _) = GT
412 compare (DoubleReg _) _ = LT
413 compare _ (DoubleReg _) = GT
414 compare (LongReg _) _ = LT
415 compare _ (LongReg _) = GT
416 compare Sp _ = LT
417 compare _ Sp = GT
418 compare SpLim _ = LT
419 compare _ SpLim = GT
420 compare Hp _ = LT
421 compare _ Hp = GT
422 compare HpLim _ = LT
423 compare _ HpLim = GT
424 compare CCCS _ = LT
425 compare _ CCCS = GT
426 compare CurrentTSO _ = LT
427 compare _ CurrentTSO = GT
428 compare CurrentNursery _ = LT
429 compare _ CurrentNursery = GT
430 compare HpAlloc _ = LT
431 compare _ HpAlloc = GT
432 compare GCEnter1 _ = LT
433 compare _ GCEnter1 = GT
434 compare GCFun _ = LT
435 compare _ GCFun = GT
436 compare BaseReg _ = LT
437 compare _ BaseReg = GT
438 compare EagerBlackholeInfo _ = LT
439 compare _ EagerBlackholeInfo = GT
440
441 -- convenient aliases
442 baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg
443 baseReg = CmmGlobal BaseReg
444 spReg = CmmGlobal Sp
445 hpReg = CmmGlobal Hp
446 spLimReg = CmmGlobal SpLim
447 nodeReg = CmmGlobal node
448
449 node :: GlobalReg
450 node = VanillaReg 1 VGcPtr
451
452 globalRegType :: GlobalReg -> CmmType
453 globalRegType (VanillaReg _ VGcPtr) = gcWord
454 globalRegType (VanillaReg _ VNonGcPtr) = bWord
455 globalRegType (FloatReg _) = cmmFloat W32
456 globalRegType (DoubleReg _) = cmmFloat W64
457 globalRegType (LongReg _) = cmmBits W64
458 globalRegType Hp = gcWord -- The initialiser for all
459 -- dynamically allocated closures
460 globalRegType _ = bWord