Add support for passing SSE vectors in registers.
[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 | XmmReg -- 128-bit SIMD vector register
340 {-# UNPACK #-} !Int -- its number
341
342 -- STG registers
343 | Sp -- Stack ptr; points to last occupied stack location.
344 | SpLim -- Stack limit
345 | Hp -- Heap ptr; points to last occupied heap location.
346 | HpLim -- Heap limit register
347 | CCCS -- Current cost-centre stack
348 | CurrentTSO -- pointer to current thread's TSO
349 | CurrentNursery -- pointer to allocation area
350 | HpAlloc -- allocation count for heap check failure
351
352 -- We keep the address of some commonly-called
353 -- functions in the register table, to keep code
354 -- size down:
355 | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info
356 | GCEnter1 -- stg_gc_enter_1
357 | GCFun -- stg_gc_fun
358
359 -- Base offset for the register table, used for accessing registers
360 -- which do not have real registers assigned to them. This register
361 -- will only appear after we have expanded GlobalReg into memory accesses
362 -- (where necessary) in the native code generator.
363 | BaseReg
364
365 -- Base Register for PIC (position-independent code) calculations
366 -- Only used inside the native code generator. It's exact meaning differs
367 -- from platform to platform (see module PositionIndependentCode).
368 | PicBaseReg
369
370 deriving( Show )
371
372 instance Eq GlobalReg where
373 VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
374 FloatReg i == FloatReg j = i==j
375 DoubleReg i == DoubleReg j = i==j
376 LongReg i == LongReg j = i==j
377 XmmReg i == XmmReg j = i==j
378 Sp == Sp = True
379 SpLim == SpLim = True
380 Hp == Hp = True
381 HpLim == HpLim = True
382 CCCS == CCCS = True
383 CurrentTSO == CurrentTSO = True
384 CurrentNursery == CurrentNursery = True
385 HpAlloc == HpAlloc = True
386 EagerBlackholeInfo == EagerBlackholeInfo = True
387 GCEnter1 == GCEnter1 = True
388 GCFun == GCFun = True
389 BaseReg == BaseReg = True
390 PicBaseReg == PicBaseReg = True
391 _r1 == _r2 = False
392
393 instance Ord GlobalReg where
394 compare (VanillaReg i _) (VanillaReg j _) = compare i j
395 -- Ignore type when seeking clashes
396 compare (FloatReg i) (FloatReg j) = compare i j
397 compare (DoubleReg i) (DoubleReg j) = compare i j
398 compare (LongReg i) (LongReg j) = compare i j
399 compare (XmmReg i) (XmmReg j) = compare i j
400 compare Sp Sp = EQ
401 compare SpLim SpLim = EQ
402 compare Hp Hp = EQ
403 compare HpLim HpLim = EQ
404 compare CCCS CCCS = EQ
405 compare CurrentTSO CurrentTSO = EQ
406 compare CurrentNursery CurrentNursery = EQ
407 compare HpAlloc HpAlloc = EQ
408 compare EagerBlackholeInfo EagerBlackholeInfo = EQ
409 compare GCEnter1 GCEnter1 = EQ
410 compare GCFun GCFun = EQ
411 compare BaseReg BaseReg = EQ
412 compare PicBaseReg PicBaseReg = EQ
413 compare (VanillaReg _ _) _ = LT
414 compare _ (VanillaReg _ _) = GT
415 compare (FloatReg _) _ = LT
416 compare _ (FloatReg _) = GT
417 compare (DoubleReg _) _ = LT
418 compare _ (DoubleReg _) = GT
419 compare (LongReg _) _ = LT
420 compare _ (LongReg _) = GT
421 compare (XmmReg _) _ = LT
422 compare _ (XmmReg _) = GT
423 compare Sp _ = LT
424 compare _ Sp = GT
425 compare SpLim _ = LT
426 compare _ SpLim = GT
427 compare Hp _ = LT
428 compare _ Hp = GT
429 compare HpLim _ = LT
430 compare _ HpLim = GT
431 compare CCCS _ = LT
432 compare _ CCCS = GT
433 compare CurrentTSO _ = LT
434 compare _ CurrentTSO = GT
435 compare CurrentNursery _ = LT
436 compare _ CurrentNursery = GT
437 compare HpAlloc _ = LT
438 compare _ HpAlloc = GT
439 compare GCEnter1 _ = LT
440 compare _ GCEnter1 = GT
441 compare GCFun _ = LT
442 compare _ GCFun = GT
443 compare BaseReg _ = LT
444 compare _ BaseReg = GT
445 compare EagerBlackholeInfo _ = LT
446 compare _ EagerBlackholeInfo = GT
447
448 -- convenient aliases
449 baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg
450 baseReg = CmmGlobal BaseReg
451 spReg = CmmGlobal Sp
452 hpReg = CmmGlobal Hp
453 spLimReg = CmmGlobal SpLim
454 nodeReg = CmmGlobal node
455
456 node :: GlobalReg
457 node = VanillaReg 1 VGcPtr
458
459 globalRegType :: DynFlags -> GlobalReg -> CmmType
460 globalRegType dflags (VanillaReg _ VGcPtr) = gcWord dflags
461 globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags
462 globalRegType _ (FloatReg _) = cmmFloat W32
463 globalRegType _ (DoubleReg _) = cmmFloat W64
464 globalRegType _ (LongReg _) = cmmBits W64
465 globalRegType _ (XmmReg _) = cmmVec 4 (cmmBits W32)
466
467 globalRegType dflags Hp = gcWord dflags
468 -- The initialiser for all
469 -- dynamically allocated closures
470 globalRegType dflags _ = bWord dflags
471
472 isArgReg :: GlobalReg -> Bool
473 isArgReg (VanillaReg {}) = True
474 isArgReg (FloatReg {}) = True
475 isArgReg (DoubleReg {}) = True
476 isArgReg (LongReg {}) = True
477 isArgReg (XmmReg {}) = True
478 isArgReg _ = False