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