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