3 ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
4 , CmmReg(..), cmmRegType
5 , CmmLit(..), cmmLitType
6 , LocalReg(..), localRegType
7 , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node
8 , VGcPtr(..), vgcFlag -- Temporary!
9 , DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed
10 , DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed
11 , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
12 , plusRegSet, minusRegSet, timesRegSet
14 , Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, isStackSlotOf
20 #include "HsVersions.h"
31 -----------------------------------------------------------------------------
33 -- An expression. Expressions have no side effects.
34 -----------------------------------------------------------------------------
37 = CmmLit CmmLit -- Literal
38 | CmmLoad CmmExpr CmmType -- Read memory location
39 | CmmReg CmmReg -- Contents of register
40 | CmmMachOp MachOp [CmmExpr] -- Machine operation (+, -, *, etc.)
41 | CmmStackSlot Area Int -- addressing expression of a stack slot
42 | CmmRegOff CmmReg Int
44 -- ** is shorthand only, meaning **
45 -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
46 -- where rep = typeWidth (cmmRegType reg)
48 instance Eq CmmExpr where -- Equality ignores the types
49 CmmLit l1 == CmmLit l2 = l1==l2
50 CmmLoad e1 _ == CmmLoad e2 _ = e1==e2
51 CmmReg r1 == CmmReg r2 = r1==r2
52 CmmRegOff r1 i1 == CmmRegOff r2 i2 = r1==r2 && i1==i2
53 CmmMachOp op1 es1 == CmmMachOp op2 es2 = op1==op2 && es1==es2
54 CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2
62 -- | A stack area is either the stack slot where a variable is spilled
63 -- or the stack space where function arguments and results are passed.
70 = Old -- See Note [Old Area]
76 There is a single call area 'Old', allocated at the extreme old
77 end of the stack frame (ie just younger than the return address)
79 * incoming (overflow) parameters,
80 * outgoing (overflow) parameter to tail calls,
81 * outgoing (overflow) result values
82 * the update frame (if any)
84 Its size is the max of all these requirements. On entry, the stack
85 pointer will point to the youngest incoming parameter, which is not
86 necessarily at the young end of the Old area.
90 type SubArea = (Area, Int, Int) -- area, offset, width
91 type SubAreaSet = Map Area [SubArea]
93 type AreaMap = Map Area Int
94 -- Byte offset of the oldest byte of the Area,
95 -- relative to the oldest byte of the Old Area
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 | CmmLabel CLabel -- Address of label
106 | CmmLabelOff CLabel Int -- Address of label + byte offset
108 -- Due to limitations in the C backend, the following
109 -- MUST ONLY be used inside the info table indicated by label2
110 -- (label2 must be the info label), and label1 must be an
111 -- SRT, a slow entrypoint or a large bitmap (see the Mangler)
112 -- Don't use it at all unless tablesNextToCode.
113 -- It is also used inside the NCG during when generating
114 -- position-independent code.
115 | CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset
116 | CmmBlock BlockId -- Code label
117 | CmmHighStackMark -- stands for the max stack space used during a procedure
120 cmmExprType :: CmmExpr -> CmmType
121 cmmExprType (CmmLit lit) = cmmLitType lit
122 cmmExprType (CmmLoad _ rep) = rep
123 cmmExprType (CmmReg reg) = cmmRegType reg
124 cmmExprType (CmmMachOp op args) = machOpResultType op (map cmmExprType args)
125 cmmExprType (CmmRegOff reg _) = cmmRegType reg
126 cmmExprType (CmmStackSlot _ _) = bWord -- an address
127 -- Careful though: what is stored at the stack slot may be bigger than
130 cmmLitType :: CmmLit -> CmmType
131 cmmLitType (CmmInt _ width) = cmmBits width
132 cmmLitType (CmmFloat _ width) = cmmFloat width
133 cmmLitType (CmmLabel lbl) = cmmLabelType lbl
134 cmmLitType (CmmLabelOff lbl _) = cmmLabelType lbl
135 cmmLitType (CmmLabelDiffOff {}) = bWord
136 cmmLitType (CmmBlock _) = bWord
137 cmmLitType (CmmHighStackMark) = bWord
139 cmmLabelType :: CLabel -> CmmType
140 cmmLabelType lbl | isGcPtrLabel lbl = gcWord
143 cmmExprWidth :: CmmExpr -> Width
144 cmmExprWidth e = typeWidth (cmmExprType e)
147 --- Negation for conditional branches
149 maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
150 maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
151 return (CmmMachOp op' args)
152 maybeInvertCmmExpr _ = Nothing
154 -----------------------------------------------------------------------------
156 -----------------------------------------------------------------------------
159 = LocalReg !Unique CmmType
164 instance Eq LocalReg where
165 (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
167 instance Ord LocalReg where
168 compare (LocalReg u1 _) (LocalReg u2 _) = compare u1 u2
170 instance Uniquable LocalReg where
171 getUnique (LocalReg uniq _) = uniq
173 cmmRegType :: CmmReg -> CmmType
174 cmmRegType (CmmLocal reg) = localRegType reg
175 cmmRegType (CmmGlobal reg) = globalRegType reg
177 localRegType :: LocalReg -> CmmType
178 localRegType (LocalReg _ rep) = rep
180 -----------------------------------------------------------------------------
181 -- Register-use information for expressions and other types
182 -----------------------------------------------------------------------------
184 -- | Sets of local registers
185 type RegSet = UniqSet LocalReg
186 emptyRegSet :: RegSet
187 elemRegSet :: LocalReg -> RegSet -> Bool
188 extendRegSet :: RegSet -> LocalReg -> RegSet
189 deleteFromRegSet :: RegSet -> LocalReg -> RegSet
190 mkRegSet :: [LocalReg] -> RegSet
191 minusRegSet, plusRegSet, timesRegSet :: RegSet -> RegSet -> RegSet
193 emptyRegSet = emptyUniqSet
194 elemRegSet = elementOfUniqSet
195 extendRegSet = addOneToUniqSet
196 deleteFromRegSet = delOneFromUniqSet
198 minusRegSet = minusUniqSet
199 plusRegSet = unionUniqSets
200 timesRegSet = intersectUniqSets
202 class UserOfLocalRegs a where
203 foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b
205 class DefinerOfLocalRegs a where
206 foldRegsDefd :: (b -> LocalReg -> b) -> b -> a -> b
208 filterRegsUsed :: UserOfLocalRegs e => (LocalReg -> Bool) -> e -> RegSet
210 foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs)
213 instance UserOfLocalRegs CmmReg where
214 foldRegsUsed f z (CmmLocal reg) = f z reg
215 foldRegsUsed _ z (CmmGlobal _) = z
217 instance DefinerOfLocalRegs CmmReg where
218 foldRegsDefd f z (CmmLocal reg) = f z reg
219 foldRegsDefd _ z (CmmGlobal _) = z
221 instance UserOfLocalRegs LocalReg where
222 foldRegsUsed f z r = f z r
224 instance DefinerOfLocalRegs LocalReg where
225 foldRegsDefd f z r = f z r
227 instance UserOfLocalRegs RegSet where
228 foldRegsUsed f = foldUniqSet (flip f)
230 instance UserOfLocalRegs CmmExpr where
231 foldRegsUsed f z e = expr z e
232 where expr z (CmmLit _) = z
233 expr z (CmmLoad addr _) = foldRegsUsed f z addr
234 expr z (CmmReg r) = foldRegsUsed f z r
235 expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs
236 expr z (CmmRegOff r _) = foldRegsUsed f z r
237 expr z (CmmStackSlot _ _) = z
239 instance UserOfLocalRegs a => UserOfLocalRegs [a] where
240 foldRegsUsed _ set [] = set
241 foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
243 instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
244 foldRegsDefd _ set [] = set
245 foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
247 instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
248 foldRegsDefd _ set Nothing = set
249 foldRegsDefd f set (Just x) = foldRegsDefd f set x
251 -----------------------------------------------------------------------------
252 -- Another reg utility
254 regUsedIn :: CmmReg -> CmmExpr -> Bool
255 _ `regUsedIn` CmmLit _ = False
256 reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
257 reg `regUsedIn` CmmReg reg' = reg == reg'
258 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
259 reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
260 _ `regUsedIn` CmmStackSlot _ _ = False
262 -----------------------------------------------------------------------------
264 -----------------------------------------------------------------------------
266 isStackSlotOf :: CmmExpr -> LocalReg -> Bool
267 isStackSlotOf (CmmStackSlot (RegSlot r) _) r' = r == r'
268 isStackSlotOf _ _ = False
270 -----------------------------------------------------------------------------
271 -- Stack slot use information for expressions and other types [_$_]
272 -----------------------------------------------------------------------------
274 -- Fold over the area, the offset into the area, and the width of the subarea.
275 class UserOfSlots a where
276 foldSlotsUsed :: (b -> SubArea -> b) -> b -> a -> b
278 class DefinerOfSlots a where
279 foldSlotsDefd :: (b -> SubArea -> b) -> b -> a -> b
281 instance UserOfSlots CmmExpr where
282 foldSlotsUsed f z e = expr z e
283 where expr z (CmmLit _) = z
284 expr z (CmmLoad (CmmStackSlot a i) ty) = f z (a, i, widthInBytes $ typeWidth ty)
285 expr z (CmmLoad addr _) = foldSlotsUsed f z addr
286 expr z (CmmReg _) = z
287 expr z (CmmMachOp _ exprs) = foldSlotsUsed f z exprs
288 expr z (CmmRegOff _ _) = z
289 expr z (CmmStackSlot _ _) = z
291 instance UserOfSlots a => UserOfSlots [a] where
292 foldSlotsUsed _ set [] = set
293 foldSlotsUsed f set (x:xs) = foldSlotsUsed f (foldSlotsUsed f set x) xs
295 instance DefinerOfSlots a => DefinerOfSlots [a] where
296 foldSlotsDefd _ set [] = set
297 foldSlotsDefd f set (x:xs) = foldSlotsDefd f (foldSlotsDefd f set x) xs
299 instance DefinerOfSlots SubArea where
300 foldSlotsDefd f z a = f z a
302 -----------------------------------------------------------------------------
303 -- Global STG registers
304 -----------------------------------------------------------------------------
306 data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
309 -----------------------------------------------------------------------------
310 -- Global STG registers
311 -----------------------------------------------------------------------------
312 vgcFlag :: CmmType -> VGcPtr
313 vgcFlag ty | isGcPtrType ty = VGcPtr
314 | otherwise = VNonGcPtr
317 -- Argument and return registers
318 = VanillaReg -- pointers, unboxed ints and chars
319 {-# UNPACK #-} !Int -- its number
322 | FloatReg -- single-precision floating-point registers
323 {-# UNPACK #-} !Int -- its number
325 | DoubleReg -- double-precision floating-point registers
326 {-# UNPACK #-} !Int -- its number
328 | LongReg -- long int registers (64-bit, really)
329 {-# UNPACK #-} !Int -- its number
332 | Sp -- Stack ptr; points to last occupied stack location.
333 | SpLim -- Stack limit
334 | Hp -- Heap ptr; points to last occupied heap location.
335 | HpLim -- Heap limit register
336 | CurrentTSO -- pointer to current thread's TSO
337 | CurrentNursery -- pointer to allocation area
338 | HpAlloc -- allocation count for heap check failure
340 -- We keep the address of some commonly-called
341 -- functions in the register table, to keep code
343 | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info
344 | GCEnter1 -- stg_gc_enter_1
345 | GCFun -- stg_gc_fun
347 -- Base offset for the register table, used for accessing registers
348 -- which do not have real registers assigned to them. This register
349 -- will only appear after we have expanded GlobalReg into memory accesses
350 -- (where necessary) in the native code generator.
353 -- Base Register for PIC (position-independent code) calculations
354 -- Only used inside the native code generator. It's exact meaning differs
355 -- from platform to platform (see module PositionIndependentCode).
360 instance Eq GlobalReg where
361 VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
362 FloatReg i == FloatReg j = i==j
363 DoubleReg i == DoubleReg j = i==j
364 LongReg i == LongReg j = i==j
366 SpLim == SpLim = True
368 HpLim == HpLim = True
369 CurrentTSO == CurrentTSO = True
370 CurrentNursery == CurrentNursery = True
371 HpAlloc == HpAlloc = True
372 GCEnter1 == GCEnter1 = True
373 GCFun == GCFun = True
374 BaseReg == BaseReg = True
375 PicBaseReg == PicBaseReg = True
378 instance Ord GlobalReg where
379 compare (VanillaReg i _) (VanillaReg j _) = compare i j
380 -- Ignore type when seeking clashes
381 compare (FloatReg i) (FloatReg j) = compare i j
382 compare (DoubleReg i) (DoubleReg j) = compare i j
383 compare (LongReg i) (LongReg j) = compare i j
385 compare SpLim SpLim = EQ
387 compare HpLim HpLim = EQ
388 compare CurrentTSO CurrentTSO = EQ
389 compare CurrentNursery CurrentNursery = EQ
390 compare HpAlloc HpAlloc = EQ
391 compare EagerBlackholeInfo EagerBlackholeInfo = EQ
392 compare GCEnter1 GCEnter1 = EQ
393 compare GCFun GCFun = EQ
394 compare BaseReg BaseReg = EQ
395 compare PicBaseReg PicBaseReg = EQ
396 compare (VanillaReg _ _) _ = LT
397 compare _ (VanillaReg _ _) = GT
398 compare (FloatReg _) _ = LT
399 compare _ (FloatReg _) = GT
400 compare (DoubleReg _) _ = LT
401 compare _ (DoubleReg _) = GT
402 compare (LongReg _) _ = LT
403 compare _ (LongReg _) = GT
412 compare CurrentTSO _ = LT
413 compare _ CurrentTSO = GT
414 compare CurrentNursery _ = LT
415 compare _ CurrentNursery = GT
416 compare HpAlloc _ = LT
417 compare _ HpAlloc = GT
418 compare GCEnter1 _ = LT
419 compare _ GCEnter1 = GT
422 compare BaseReg _ = LT
423 compare _ BaseReg = GT
424 compare EagerBlackholeInfo _ = LT
425 compare _ EagerBlackholeInfo = GT
427 -- convenient aliases
428 spReg, hpReg, spLimReg, nodeReg :: CmmReg
431 spLimReg = CmmGlobal SpLim
432 nodeReg = CmmGlobal node
435 node = VanillaReg 1 VGcPtr
437 globalRegType :: GlobalReg -> CmmType
438 globalRegType (VanillaReg _ VGcPtr) = gcWord
439 globalRegType (VanillaReg _ VNonGcPtr) = bWord
440 globalRegType (FloatReg _) = cmmFloat W32
441 globalRegType (DoubleReg _) = cmmFloat W64
442 globalRegType (LongReg _) = cmmBits W64
443 globalRegType Hp = gcWord -- The initialiser for all
444 -- dynamically allocated closures
445 globalRegType _ = bWord