Merge branch 'master' of http://darcs.haskell.org/ghc
[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.Set (Set)
36 import qualified Data.Set as Set
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 {-# UNPACK #-} !Int
49 -- 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 {-# UNPACK #-} !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 {-# UNPACK #-} !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 a => UserOfLocalRegs (Maybe a) where
228 foldRegsUsed f z (Just x) = foldRegsUsed f z x
229 foldRegsUsed _ z Nothing = z
230
231 instance UserOfLocalRegs CmmReg where
232 foldRegsUsed f z (CmmLocal reg) = f z reg
233 foldRegsUsed _ z (CmmGlobal _) = z
234
235 instance DefinerOfLocalRegs CmmReg where
236 foldRegsDefd f z (CmmLocal reg) = f z reg
237 foldRegsDefd _ z (CmmGlobal _) = z
238
239 instance UserOfLocalRegs LocalReg where
240 foldRegsUsed f z r = f z r
241
242 instance DefinerOfLocalRegs LocalReg where
243 foldRegsDefd f z r = f z r
244
245 instance UserOfLocalRegs RegSet where
246 foldRegsUsed f = Set.fold (flip f)
247
248 instance UserOfLocalRegs CmmExpr where
249 foldRegsUsed f z e = expr z e
250 where expr z (CmmLit _) = z
251 expr z (CmmLoad addr _) = foldRegsUsed f z addr
252 expr z (CmmReg r) = foldRegsUsed f z r
253 expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs
254 expr z (CmmRegOff r _) = foldRegsUsed f z r
255 expr z (CmmStackSlot _ _) = z
256
257 instance UserOfLocalRegs a => UserOfLocalRegs [a] where
258 foldRegsUsed _ set [] = set
259 foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
260
261 instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
262 foldRegsDefd _ set [] = set
263 foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
264
265 instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
266 foldRegsDefd _ set Nothing = set
267 foldRegsDefd f set (Just x) = foldRegsDefd f set x
268
269 -----------------------------------------------------------------------------
270 -- Another reg utility
271
272 regUsedIn :: CmmReg -> CmmExpr -> Bool
273 _ `regUsedIn` CmmLit _ = False
274 reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
275 reg `regUsedIn` CmmReg reg' = reg == reg'
276 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
277 reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
278 _ `regUsedIn` CmmStackSlot _ _ = False
279
280 -----------------------------------------------------------------------------
281 -- Global STG registers
282 -----------------------------------------------------------------------------
283
284 data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
285 -- TEMPORARY!!!
286
287 -----------------------------------------------------------------------------
288 -- Global STG registers
289 -----------------------------------------------------------------------------
290 vgcFlag :: CmmType -> VGcPtr
291 vgcFlag ty | isGcPtrType ty = VGcPtr
292 | otherwise = VNonGcPtr
293
294 data GlobalReg
295 -- Argument and return registers
296 = VanillaReg -- pointers, unboxed ints and chars
297 {-# UNPACK #-} !Int -- its number
298 VGcPtr
299
300 | FloatReg -- single-precision floating-point registers
301 {-# UNPACK #-} !Int -- its number
302
303 | DoubleReg -- double-precision floating-point registers
304 {-# UNPACK #-} !Int -- its number
305
306 | LongReg -- long int registers (64-bit, really)
307 {-# UNPACK #-} !Int -- its number
308
309 -- STG registers
310 | Sp -- Stack ptr; points to last occupied stack location.
311 | SpLim -- Stack limit
312 | Hp -- Heap ptr; points to last occupied heap location.
313 | HpLim -- Heap limit register
314 | CCCS -- Current cost-centre stack
315 | CurrentTSO -- pointer to current thread's TSO
316 | CurrentNursery -- pointer to allocation area
317 | HpAlloc -- allocation count for heap check failure
318
319 -- We keep the address of some commonly-called
320 -- functions in the register table, to keep code
321 -- size down:
322 | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info
323 | GCEnter1 -- stg_gc_enter_1
324 | GCFun -- stg_gc_fun
325
326 -- Base offset for the register table, used for accessing registers
327 -- which do not have real registers assigned to them. This register
328 -- will only appear after we have expanded GlobalReg into memory accesses
329 -- (where necessary) in the native code generator.
330 | BaseReg
331
332 -- Base Register for PIC (position-independent code) calculations
333 -- Only used inside the native code generator. It's exact meaning differs
334 -- from platform to platform (see module PositionIndependentCode).
335 | PicBaseReg
336
337 deriving( Show )
338
339 instance Eq GlobalReg where
340 VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
341 FloatReg i == FloatReg j = i==j
342 DoubleReg i == DoubleReg j = i==j
343 LongReg i == LongReg j = i==j
344 Sp == Sp = True
345 SpLim == SpLim = True
346 Hp == Hp = True
347 HpLim == HpLim = True
348 CurrentTSO == CurrentTSO = True
349 CurrentNursery == CurrentNursery = True
350 HpAlloc == HpAlloc = True
351 GCEnter1 == GCEnter1 = True
352 GCFun == GCFun = True
353 BaseReg == BaseReg = True
354 PicBaseReg == PicBaseReg = True
355 _r1 == _r2 = False
356
357 instance Ord GlobalReg where
358 compare (VanillaReg i _) (VanillaReg j _) = compare i j
359 -- Ignore type when seeking clashes
360 compare (FloatReg i) (FloatReg j) = compare i j
361 compare (DoubleReg i) (DoubleReg j) = compare i j
362 compare (LongReg i) (LongReg j) = compare i j
363 compare Sp Sp = EQ
364 compare SpLim SpLim = EQ
365 compare Hp Hp = EQ
366 compare HpLim HpLim = EQ
367 compare CCCS CCCS = EQ
368 compare CurrentTSO CurrentTSO = EQ
369 compare CurrentNursery CurrentNursery = EQ
370 compare HpAlloc HpAlloc = EQ
371 compare EagerBlackholeInfo EagerBlackholeInfo = EQ
372 compare GCEnter1 GCEnter1 = EQ
373 compare GCFun GCFun = EQ
374 compare BaseReg BaseReg = EQ
375 compare PicBaseReg PicBaseReg = EQ
376 compare (VanillaReg _ _) _ = LT
377 compare _ (VanillaReg _ _) = GT
378 compare (FloatReg _) _ = LT
379 compare _ (FloatReg _) = GT
380 compare (DoubleReg _) _ = LT
381 compare _ (DoubleReg _) = GT
382 compare (LongReg _) _ = LT
383 compare _ (LongReg _) = GT
384 compare Sp _ = LT
385 compare _ Sp = GT
386 compare SpLim _ = LT
387 compare _ SpLim = GT
388 compare Hp _ = LT
389 compare _ Hp = GT
390 compare HpLim _ = LT
391 compare _ HpLim = GT
392 compare CCCS _ = LT
393 compare _ CCCS = GT
394 compare CurrentTSO _ = LT
395 compare _ CurrentTSO = GT
396 compare CurrentNursery _ = LT
397 compare _ CurrentNursery = GT
398 compare HpAlloc _ = LT
399 compare _ HpAlloc = GT
400 compare GCEnter1 _ = LT
401 compare _ GCEnter1 = GT
402 compare GCFun _ = LT
403 compare _ GCFun = GT
404 compare BaseReg _ = LT
405 compare _ BaseReg = GT
406 compare EagerBlackholeInfo _ = LT
407 compare _ EagerBlackholeInfo = GT
408
409 -- convenient aliases
410 baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg
411 baseReg = CmmGlobal BaseReg
412 spReg = CmmGlobal Sp
413 hpReg = CmmGlobal Hp
414 spLimReg = CmmGlobal SpLim
415 nodeReg = CmmGlobal node
416
417 node :: GlobalReg
418 node = VanillaReg 1 VGcPtr
419
420 globalRegType :: GlobalReg -> CmmType
421 globalRegType (VanillaReg _ VGcPtr) = gcWord
422 globalRegType (VanillaReg _ VNonGcPtr) = bWord
423 globalRegType (FloatReg _) = cmmFloat W32
424 globalRegType (DoubleReg _) = cmmFloat W64
425 globalRegType (LongReg _) = cmmBits W64
426 globalRegType Hp = gcWord -- The initialiser for all
427 -- dynamically allocated closures
428 globalRegType _ = bWord