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