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