dce962443bb02d90c88eb0e1853cdcd629bd2b61
[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 -- stands for the max stack space used during a procedure
123 deriving Eq
124
125 cmmExprType :: DynFlags -> CmmExpr -> CmmType
126 cmmExprType dflags (CmmLit lit) = cmmLitType dflags lit
127 cmmExprType _ (CmmLoad _ rep) = rep
128 cmmExprType dflags (CmmReg reg) = cmmRegType dflags reg
129 cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args)
130 cmmExprType dflags (CmmRegOff reg _) = cmmRegType dflags reg
131 cmmExprType dflags (CmmStackSlot _ _) = bWord dflags -- an address
132 -- Careful though: what is stored at the stack slot may be bigger than
133 -- an address
134
135 cmmLitType :: DynFlags -> CmmLit -> CmmType
136 cmmLitType _ (CmmInt _ width) = cmmBits width
137 cmmLitType _ (CmmFloat _ width) = cmmFloat width
138 cmmLitType _ (CmmVec []) = panic "cmmLitType: CmmVec []"
139 cmmLitType cflags (CmmVec (l:ls)) = let ty = cmmLitType cflags l
140 in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls)
141 then cmmVec (1+length ls) ty
142 else panic "cmmLitType: CmmVec"
143 cmmLitType dflags (CmmLabel lbl) = cmmLabelType dflags lbl
144 cmmLitType dflags (CmmLabelOff lbl _) = cmmLabelType dflags lbl
145 cmmLitType dflags (CmmLabelDiffOff {}) = bWord dflags
146 cmmLitType dflags (CmmBlock _) = bWord dflags
147 cmmLitType dflags (CmmHighStackMark) = bWord dflags
148
149 cmmLabelType :: DynFlags -> CLabel -> CmmType
150 cmmLabelType dflags lbl
151 | isGcPtrLabel lbl = gcWord dflags
152 | otherwise = bWord dflags
153
154 cmmExprWidth :: DynFlags -> CmmExpr -> Width
155 cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)
156
157 --------
158 --- Negation for conditional branches
159
160 maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
161 maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
162 return (CmmMachOp op' args)
163 maybeInvertCmmExpr _ = Nothing
164
165 -----------------------------------------------------------------------------
166 -- Local registers
167 -----------------------------------------------------------------------------
168
169 data LocalReg
170 = LocalReg {-# UNPACK #-} !Unique CmmType
171 -- ^ Parameters:
172 -- 1. Identifier
173 -- 2. Type
174
175 instance Eq LocalReg where
176 (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
177
178 instance Ord LocalReg where
179 compare (LocalReg u1 _) (LocalReg u2 _) = compare u1 u2
180
181 instance Uniquable LocalReg where
182 getUnique (LocalReg uniq _) = uniq
183
184 cmmRegType :: DynFlags -> CmmReg -> CmmType
185 cmmRegType _ (CmmLocal reg) = localRegType reg
186 cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg
187
188 localRegType :: LocalReg -> CmmType
189 localRegType (LocalReg _ rep) = rep
190
191 -----------------------------------------------------------------------------
192 -- Register-use information for expressions and other types
193 -----------------------------------------------------------------------------
194
195 -- | Sets of registers
196
197 -- These are used for dataflow facts, and a common operation is taking
198 -- the union of two RegSets and then asking whether the union is the
199 -- same as one of the inputs. UniqSet isn't good here, because
200 -- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary
201 -- Sets.
202
203 type RegSet r = Set r
204 type LocalRegSet = RegSet LocalReg
205 type GlobalRegSet = RegSet GlobalReg
206
207 emptyRegSet :: Ord r => RegSet r
208 nullRegSet :: Ord r => RegSet r -> Bool
209 elemRegSet :: Ord r => r -> RegSet r -> Bool
210 extendRegSet :: Ord r => RegSet r -> r -> RegSet r
211 deleteFromRegSet :: Ord r => RegSet r -> r -> RegSet r
212 mkRegSet :: Ord r => [r] -> RegSet r
213 minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r
214 sizeRegSet :: Ord r => RegSet r -> Int
215 regSetToList :: Ord r => RegSet r -> [r]
216
217 emptyRegSet = Set.empty
218 nullRegSet = Set.null
219 elemRegSet = Set.member
220 extendRegSet = flip Set.insert
221 deleteFromRegSet = flip Set.delete
222 mkRegSet = Set.fromList
223 minusRegSet = Set.difference
224 plusRegSet = Set.union
225 timesRegSet = Set.intersection
226 sizeRegSet = Set.size
227 regSetToList = Set.toList
228
229 class Ord r => UserOfRegs r a where
230 foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b
231
232 foldLocalRegsUsed :: UserOfRegs LocalReg a
233 => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
234 foldLocalRegsUsed = foldRegsUsed
235
236 class Ord r => DefinerOfRegs r a where
237 foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b
238
239 foldLocalRegsDefd :: DefinerOfRegs LocalReg a
240 => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
241 foldLocalRegsDefd = foldRegsDefd
242
243 filterRegsUsed :: UserOfRegs r e => DynFlags -> (r -> Bool) -> e -> RegSet r
244 filterRegsUsed dflags p e =
245 foldRegsUsed dflags
246 (\regs r -> if p r then extendRegSet regs r else regs)
247 emptyRegSet e
248
249 instance UserOfRegs LocalReg CmmReg where
250 foldRegsUsed _ f z (CmmLocal reg) = f z reg
251 foldRegsUsed _ _ z (CmmGlobal _) = z
252
253 instance DefinerOfRegs LocalReg CmmReg where
254 foldRegsDefd _ f z (CmmLocal reg) = f z reg
255 foldRegsDefd _ _ z (CmmGlobal _) = z
256
257 instance UserOfRegs GlobalReg CmmReg where
258 foldRegsUsed _ _ z (CmmLocal _) = z
259 foldRegsUsed _ f z (CmmGlobal reg) = f z reg
260
261 instance DefinerOfRegs GlobalReg CmmReg where
262 foldRegsDefd _ _ z (CmmLocal _) = z
263 foldRegsDefd _ f z (CmmGlobal reg) = f z reg
264
265 instance Ord r => UserOfRegs r r where
266 foldRegsUsed _ f z r = f z r
267
268 instance Ord r => DefinerOfRegs r r where
269 foldRegsDefd _ f z r = f z r
270
271 instance Ord r => UserOfRegs r (RegSet r) where
272 foldRegsUsed _ f = Set.fold (flip f)
273
274 instance UserOfRegs r CmmReg => UserOfRegs r CmmExpr where
275 foldRegsUsed dflags f z e = expr z e
276 where expr z (CmmLit _) = z
277 expr z (CmmLoad addr _) = foldRegsUsed dflags f z addr
278 expr z (CmmReg r) = foldRegsUsed dflags f z r
279 expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs
280 expr z (CmmRegOff r _) = foldRegsUsed dflags f z r
281 expr z (CmmStackSlot _ _) = z
282
283 instance UserOfRegs r a => UserOfRegs r (Maybe a) where
284 foldRegsUsed dflags f z (Just x) = foldRegsUsed dflags f z x
285 foldRegsUsed _ _ z Nothing = z
286
287 instance UserOfRegs r a => UserOfRegs r [a] where
288 foldRegsUsed _ _ set [] = set
289 foldRegsUsed dflags f set (x:xs) = foldRegsUsed dflags f (foldRegsUsed dflags f set x) xs
290
291 instance DefinerOfRegs r a => DefinerOfRegs r [a] where
292 foldRegsDefd _ _ set [] = set
293 foldRegsDefd dflags f set (x:xs) = foldRegsDefd dflags f (foldRegsDefd dflags f set x) xs
294
295 instance DefinerOfRegs r a => DefinerOfRegs r (Maybe a) where
296 foldRegsDefd _ _ set Nothing = set
297 foldRegsDefd dflags f set (Just x) = foldRegsDefd dflags f set x
298
299 -----------------------------------------------------------------------------
300 -- Another reg utility
301
302 regUsedIn :: CmmReg -> CmmExpr -> Bool
303 _ `regUsedIn` CmmLit _ = False
304 reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
305 reg `regUsedIn` CmmReg reg' = reg == reg'
306 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
307 reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
308 _ `regUsedIn` CmmStackSlot _ _ = False
309
310 -----------------------------------------------------------------------------
311 -- Global STG registers
312 -----------------------------------------------------------------------------
313
314 data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
315 -- TEMPORARY!!!
316
317 -----------------------------------------------------------------------------
318 -- Global STG registers
319 -----------------------------------------------------------------------------
320 vgcFlag :: CmmType -> VGcPtr
321 vgcFlag ty | isGcPtrType ty = VGcPtr
322 | otherwise = VNonGcPtr
323
324 data GlobalReg
325 -- Argument and return registers
326 = VanillaReg -- pointers, unboxed ints and chars
327 {-# UNPACK #-} !Int -- its number
328 VGcPtr
329
330 | FloatReg -- single-precision floating-point registers
331 {-# UNPACK #-} !Int -- its number
332
333 | DoubleReg -- double-precision floating-point registers
334 {-# UNPACK #-} !Int -- its number
335
336 | LongReg -- long int registers (64-bit, really)
337 {-# UNPACK #-} !Int -- its number
338
339 -- STG registers
340 | Sp -- Stack ptr; points to last occupied stack location.
341 | SpLim -- Stack limit
342 | Hp -- Heap ptr; points to last occupied heap location.
343 | HpLim -- Heap limit register
344 | CCCS -- Current cost-centre stack
345 | CurrentTSO -- pointer to current thread's TSO
346 | CurrentNursery -- pointer to allocation area
347 | HpAlloc -- allocation count for heap check failure
348
349 -- We keep the address of some commonly-called
350 -- functions in the register table, to keep code
351 -- size down:
352 | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info
353 | GCEnter1 -- stg_gc_enter_1
354 | GCFun -- stg_gc_fun
355
356 -- Base offset for the register table, used for accessing registers
357 -- which do not have real registers assigned to them. This register
358 -- will only appear after we have expanded GlobalReg into memory accesses
359 -- (where necessary) in the native code generator.
360 | BaseReg
361
362 -- Base Register for PIC (position-independent code) calculations
363 -- Only used inside the native code generator. It's exact meaning differs
364 -- from platform to platform (see module PositionIndependentCode).
365 | PicBaseReg
366
367 deriving( Show )
368
369 instance Eq GlobalReg where
370 VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
371 FloatReg i == FloatReg j = i==j
372 DoubleReg i == DoubleReg j = i==j
373 LongReg i == LongReg j = i==j
374 Sp == Sp = True
375 SpLim == SpLim = True
376 Hp == Hp = True
377 HpLim == HpLim = True
378 CCCS == CCCS = True
379 CurrentTSO == CurrentTSO = True
380 CurrentNursery == CurrentNursery = True
381 HpAlloc == HpAlloc = True
382 EagerBlackholeInfo == EagerBlackholeInfo = 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 :: DynFlags -> GlobalReg -> CmmType
453 globalRegType dflags (VanillaReg _ VGcPtr) = gcWord dflags
454 globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags
455 globalRegType _ (FloatReg _) = cmmFloat W32
456 globalRegType _ (DoubleReg _) = cmmFloat W64
457 globalRegType _ (LongReg _) = cmmBits W64
458 globalRegType dflags Hp = gcWord dflags
459 -- The initialiser for all
460 -- dynamically allocated closures
461 globalRegType dflags _ = bWord dflags
462
463 isArgReg :: GlobalReg -> Bool
464 isArgReg (VanillaReg {}) = True
465 isArgReg (FloatReg {}) = True
466 isArgReg (DoubleReg {}) = True
467 isArgReg (LongReg {}) = True
468 isArgReg _ = False