Merge branch 'master' of /Users/benl/devel/ghc/ghc-head
[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_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
46 -- where rep = typeWidth (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 -- Careful though: what is stored at the stack slot may be bigger than
128 -- an address
129
130 cmmLitType :: CmmLit -> CmmType
131 cmmLitType (CmmInt _ width) = cmmBits width
132 cmmLitType (CmmFloat _ width) = cmmFloat width
133 cmmLitType (CmmLabel lbl) = cmmLabelType lbl
134 cmmLitType (CmmLabelOff lbl _) = cmmLabelType lbl
135 cmmLitType (CmmLabelDiffOff {}) = bWord
136 cmmLitType (CmmBlock _) = bWord
137 cmmLitType (CmmHighStackMark) = bWord
138
139 cmmLabelType :: CLabel -> CmmType
140 cmmLabelType lbl | isGcPtrLabel lbl = gcWord
141 | otherwise = bWord
142
143 cmmExprWidth :: CmmExpr -> Width
144 cmmExprWidth e = typeWidth (cmmExprType e)
145
146 --------
147 --- Negation for conditional branches
148
149 maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
150 maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
151 return (CmmMachOp op' args)
152 maybeInvertCmmExpr _ = Nothing
153
154 -----------------------------------------------------------------------------
155 -- Local registers
156 -----------------------------------------------------------------------------
157
158 data LocalReg
159 = LocalReg !Unique CmmType
160 -- ^ Parameters:
161 -- 1. Identifier
162 -- 2. Type
163
164 instance Eq LocalReg where
165 (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
166
167 instance Ord LocalReg where
168 compare (LocalReg u1 _) (LocalReg u2 _) = compare u1 u2
169
170 instance Uniquable LocalReg where
171 getUnique (LocalReg uniq _) = uniq
172
173 cmmRegType :: CmmReg -> CmmType
174 cmmRegType (CmmLocal reg) = localRegType reg
175 cmmRegType (CmmGlobal reg) = globalRegType reg
176
177 localRegType :: LocalReg -> CmmType
178 localRegType (LocalReg _ rep) = rep
179
180 -----------------------------------------------------------------------------
181 -- Register-use information for expressions and other types
182 -----------------------------------------------------------------------------
183
184 -- | Sets of local registers
185 type RegSet = UniqSet LocalReg
186 emptyRegSet :: RegSet
187 elemRegSet :: LocalReg -> RegSet -> Bool
188 extendRegSet :: RegSet -> LocalReg -> RegSet
189 deleteFromRegSet :: RegSet -> LocalReg -> RegSet
190 mkRegSet :: [LocalReg] -> RegSet
191 minusRegSet, plusRegSet, timesRegSet :: RegSet -> RegSet -> RegSet
192
193 emptyRegSet = emptyUniqSet
194 elemRegSet = elementOfUniqSet
195 extendRegSet = addOneToUniqSet
196 deleteFromRegSet = delOneFromUniqSet
197 mkRegSet = mkUniqSet
198 minusRegSet = minusUniqSet
199 plusRegSet = unionUniqSets
200 timesRegSet = intersectUniqSets
201
202 class UserOfLocalRegs a where
203 foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b
204
205 class DefinerOfLocalRegs a where
206 foldRegsDefd :: (b -> LocalReg -> b) -> b -> a -> b
207
208 filterRegsUsed :: UserOfLocalRegs e => (LocalReg -> Bool) -> e -> RegSet
209 filterRegsUsed p e =
210 foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs)
211 emptyRegSet e
212
213 instance UserOfLocalRegs CmmReg where
214 foldRegsUsed f z (CmmLocal reg) = f z reg
215 foldRegsUsed _ z (CmmGlobal _) = z
216
217 instance DefinerOfLocalRegs CmmReg where
218 foldRegsDefd f z (CmmLocal reg) = f z reg
219 foldRegsDefd _ z (CmmGlobal _) = z
220
221 instance UserOfLocalRegs LocalReg where
222 foldRegsUsed f z r = f z r
223
224 instance DefinerOfLocalRegs LocalReg where
225 foldRegsDefd f z r = f z r
226
227 instance UserOfLocalRegs RegSet where
228 foldRegsUsed f = foldUniqSet (flip f)
229
230 instance UserOfLocalRegs CmmExpr where
231 foldRegsUsed f z e = expr z e
232 where expr z (CmmLit _) = z
233 expr z (CmmLoad addr _) = foldRegsUsed f z addr
234 expr z (CmmReg r) = foldRegsUsed f z r
235 expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs
236 expr z (CmmRegOff r _) = foldRegsUsed f z r
237 expr z (CmmStackSlot _ _) = z
238
239 instance UserOfLocalRegs a => UserOfLocalRegs [a] where
240 foldRegsUsed _ set [] = set
241 foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
242
243 instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
244 foldRegsDefd _ set [] = set
245 foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
246
247 instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
248 foldRegsDefd _ set Nothing = set
249 foldRegsDefd f set (Just x) = foldRegsDefd f set x
250
251 -----------------------------------------------------------------------------
252 -- Another reg utility
253
254 regUsedIn :: CmmReg -> CmmExpr -> Bool
255 _ `regUsedIn` CmmLit _ = False
256 reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
257 reg `regUsedIn` CmmReg reg' = reg == reg'
258 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
259 reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
260 _ `regUsedIn` CmmStackSlot _ _ = False
261
262 -----------------------------------------------------------------------------
263 -- Stack slots
264 -----------------------------------------------------------------------------
265
266 isStackSlotOf :: CmmExpr -> LocalReg -> Bool
267 isStackSlotOf (CmmStackSlot (RegSlot r) _) r' = r == r'
268 isStackSlotOf _ _ = False
269
270 -----------------------------------------------------------------------------
271 -- Stack slot use information for expressions and other types [_$_]
272 -----------------------------------------------------------------------------
273
274 -- Fold over the area, the offset into the area, and the width of the subarea.
275 class UserOfSlots a where
276 foldSlotsUsed :: (b -> SubArea -> b) -> b -> a -> b
277
278 class DefinerOfSlots a where
279 foldSlotsDefd :: (b -> SubArea -> b) -> b -> a -> b
280
281 instance UserOfSlots CmmExpr where
282 foldSlotsUsed f z e = expr z e
283 where expr z (CmmLit _) = z
284 expr z (CmmLoad (CmmStackSlot a i) ty) = f z (a, i, widthInBytes $ typeWidth ty)
285 expr z (CmmLoad addr _) = foldSlotsUsed f z addr
286 expr z (CmmReg _) = z
287 expr z (CmmMachOp _ exprs) = foldSlotsUsed f z exprs
288 expr z (CmmRegOff _ _) = z
289 expr z (CmmStackSlot _ _) = z
290
291 instance UserOfSlots a => UserOfSlots [a] where
292 foldSlotsUsed _ set [] = set
293 foldSlotsUsed f set (x:xs) = foldSlotsUsed f (foldSlotsUsed f set x) xs
294
295 instance DefinerOfSlots a => DefinerOfSlots [a] where
296 foldSlotsDefd _ set [] = set
297 foldSlotsDefd f set (x:xs) = foldSlotsDefd f (foldSlotsDefd f set x) xs
298
299 instance DefinerOfSlots SubArea where
300 foldSlotsDefd f z a = f z a
301
302 -----------------------------------------------------------------------------
303 -- Global STG registers
304 -----------------------------------------------------------------------------
305
306 data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
307 -- TEMPORARY!!!
308
309 -----------------------------------------------------------------------------
310 -- Global STG registers
311 -----------------------------------------------------------------------------
312 vgcFlag :: CmmType -> VGcPtr
313 vgcFlag ty | isGcPtrType ty = VGcPtr
314 | otherwise = VNonGcPtr
315
316 data GlobalReg
317 -- Argument and return registers
318 = VanillaReg -- pointers, unboxed ints and chars
319 {-# UNPACK #-} !Int -- its number
320 VGcPtr
321
322 | FloatReg -- single-precision floating-point registers
323 {-# UNPACK #-} !Int -- its number
324
325 | DoubleReg -- double-precision floating-point registers
326 {-# UNPACK #-} !Int -- its number
327
328 | LongReg -- long int registers (64-bit, really)
329 {-# UNPACK #-} !Int -- its number
330
331 -- STG registers
332 | Sp -- Stack ptr; points to last occupied stack location.
333 | SpLim -- Stack limit
334 | Hp -- Heap ptr; points to last occupied heap location.
335 | HpLim -- Heap limit register
336 | CurrentTSO -- pointer to current thread's TSO
337 | CurrentNursery -- pointer to allocation area
338 | HpAlloc -- allocation count for heap check failure
339
340 -- We keep the address of some commonly-called
341 -- functions in the register table, to keep code
342 -- size down:
343 | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info
344 | GCEnter1 -- stg_gc_enter_1
345 | GCFun -- stg_gc_fun
346
347 -- Base offset for the register table, used for accessing registers
348 -- which do not have real registers assigned to them. This register
349 -- will only appear after we have expanded GlobalReg into memory accesses
350 -- (where necessary) in the native code generator.
351 | BaseReg
352
353 -- Base Register for PIC (position-independent code) calculations
354 -- Only used inside the native code generator. It's exact meaning differs
355 -- from platform to platform (see module PositionIndependentCode).
356 | PicBaseReg
357
358 deriving( Show )
359
360 instance Eq GlobalReg where
361 VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
362 FloatReg i == FloatReg j = i==j
363 DoubleReg i == DoubleReg j = i==j
364 LongReg i == LongReg j = i==j
365 Sp == Sp = True
366 SpLim == SpLim = True
367 Hp == Hp = True
368 HpLim == HpLim = True
369 CurrentTSO == CurrentTSO = True
370 CurrentNursery == CurrentNursery = True
371 HpAlloc == HpAlloc = True
372 GCEnter1 == GCEnter1 = True
373 GCFun == GCFun = True
374 BaseReg == BaseReg = True
375 PicBaseReg == PicBaseReg = True
376 _r1 == _r2 = False
377
378 instance Ord GlobalReg where
379 compare (VanillaReg i _) (VanillaReg j _) = compare i j
380 -- Ignore type when seeking clashes
381 compare (FloatReg i) (FloatReg j) = compare i j
382 compare (DoubleReg i) (DoubleReg j) = compare i j
383 compare (LongReg i) (LongReg j) = compare i j
384 compare Sp Sp = EQ
385 compare SpLim SpLim = EQ
386 compare Hp Hp = EQ
387 compare HpLim HpLim = EQ
388 compare CurrentTSO CurrentTSO = EQ
389 compare CurrentNursery CurrentNursery = EQ
390 compare HpAlloc HpAlloc = EQ
391 compare EagerBlackholeInfo EagerBlackholeInfo = EQ
392 compare GCEnter1 GCEnter1 = EQ
393 compare GCFun GCFun = EQ
394 compare BaseReg BaseReg = EQ
395 compare PicBaseReg PicBaseReg = EQ
396 compare (VanillaReg _ _) _ = LT
397 compare _ (VanillaReg _ _) = GT
398 compare (FloatReg _) _ = LT
399 compare _ (FloatReg _) = GT
400 compare (DoubleReg _) _ = LT
401 compare _ (DoubleReg _) = GT
402 compare (LongReg _) _ = LT
403 compare _ (LongReg _) = GT
404 compare Sp _ = LT
405 compare _ Sp = GT
406 compare SpLim _ = LT
407 compare _ SpLim = GT
408 compare Hp _ = LT
409 compare _ Hp = GT
410 compare HpLim _ = LT
411 compare _ HpLim = GT
412 compare CurrentTSO _ = LT
413 compare _ CurrentTSO = GT
414 compare CurrentNursery _ = LT
415 compare _ CurrentNursery = GT
416 compare HpAlloc _ = LT
417 compare _ HpAlloc = GT
418 compare GCEnter1 _ = LT
419 compare _ GCEnter1 = GT
420 compare GCFun _ = LT
421 compare _ GCFun = GT
422 compare BaseReg _ = LT
423 compare _ BaseReg = GT
424 compare EagerBlackholeInfo _ = LT
425 compare _ EagerBlackholeInfo = GT
426
427 -- convenient aliases
428 spReg, hpReg, spLimReg, nodeReg :: CmmReg
429 spReg = CmmGlobal Sp
430 hpReg = CmmGlobal Hp
431 spLimReg = CmmGlobal SpLim
432 nodeReg = CmmGlobal node
433
434 node :: GlobalReg
435 node = VanillaReg 1 VGcPtr
436
437 globalRegType :: GlobalReg -> CmmType
438 globalRegType (VanillaReg _ VGcPtr) = gcWord
439 globalRegType (VanillaReg _ VNonGcPtr) = bWord
440 globalRegType (FloatReg _) = cmmFloat W32
441 globalRegType (DoubleReg _) = cmmFloat W64
442 globalRegType (LongReg _) = cmmBits W64
443 globalRegType Hp = gcWord -- The initialiser for all
444 -- dynamically allocated closures
445 globalRegType _ = bWord