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