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