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_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep)))
46 -- where rep = 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
128 cmmLitType :: CmmLit -> CmmType
129 cmmLitType (CmmInt _ width) = cmmBits width
130 cmmLitType (CmmFloat _ width) = cmmFloat width
131 cmmLitType (CmmLabel lbl) = cmmLabelType lbl
132 cmmLitType (CmmLabelOff lbl _) = cmmLabelType lbl
133 cmmLitType (CmmLabelDiffOff {}) = bWord
134 cmmLitType (CmmBlock _) = bWord
135 cmmLitType (CmmHighStackMark) = bWord
137 cmmLabelType :: CLabel -> CmmType
138 cmmLabelType lbl | isGcPtrLabel lbl = gcWord
141 cmmExprWidth :: CmmExpr -> Width
142 cmmExprWidth e = typeWidth (cmmExprType e)
145 --- Negation for conditional branches
147 maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
148 maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
149 return (CmmMachOp op' args)
150 maybeInvertCmmExpr _ = Nothing
152 -----------------------------------------------------------------------------
154 -----------------------------------------------------------------------------
157 = LocalReg !Unique CmmType
162 instance Eq LocalReg where
163 (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
165 instance Ord LocalReg where
166 compare (LocalReg u1 _) (LocalReg u2 _) = compare u1 u2
168 instance Uniquable LocalReg where
169 getUnique (LocalReg uniq _) = uniq
171 cmmRegType :: CmmReg -> CmmType
172 cmmRegType (CmmLocal reg) = localRegType reg
173 cmmRegType (CmmGlobal reg) = globalRegType reg
175 localRegType :: LocalReg -> CmmType
176 localRegType (LocalReg _ rep) = rep
178 -----------------------------------------------------------------------------
179 -- Register-use information for expressions and other types
180 -----------------------------------------------------------------------------
182 -- | Sets of local registers
183 type RegSet = UniqSet LocalReg
184 emptyRegSet :: RegSet
185 elemRegSet :: LocalReg -> RegSet -> Bool
186 extendRegSet :: RegSet -> LocalReg -> RegSet
187 deleteFromRegSet :: RegSet -> LocalReg -> RegSet
188 mkRegSet :: [LocalReg] -> RegSet
189 minusRegSet, plusRegSet, timesRegSet :: RegSet -> RegSet -> RegSet
191 emptyRegSet = emptyUniqSet
192 elemRegSet = elementOfUniqSet
193 extendRegSet = addOneToUniqSet
194 deleteFromRegSet = delOneFromUniqSet
196 minusRegSet = minusUniqSet
197 plusRegSet = unionUniqSets
198 timesRegSet = intersectUniqSets
200 class UserOfLocalRegs a where
201 foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b
203 class DefinerOfLocalRegs a where
204 foldRegsDefd :: (b -> LocalReg -> b) -> b -> a -> b
206 filterRegsUsed :: UserOfLocalRegs e => (LocalReg -> Bool) -> e -> RegSet
208 foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs)
211 instance UserOfLocalRegs CmmReg where
212 foldRegsUsed f z (CmmLocal reg) = f z reg
213 foldRegsUsed _ z (CmmGlobal _) = z
215 instance DefinerOfLocalRegs CmmReg where
216 foldRegsDefd f z (CmmLocal reg) = f z reg
217 foldRegsDefd _ z (CmmGlobal _) = z
219 instance UserOfLocalRegs LocalReg where
220 foldRegsUsed f z r = f z r
222 instance DefinerOfLocalRegs LocalReg where
223 foldRegsDefd f z r = f z r
225 instance UserOfLocalRegs RegSet where
226 foldRegsUsed f = foldUniqSet (flip f)
228 instance UserOfLocalRegs CmmExpr where
229 foldRegsUsed f z e = expr z e
230 where expr z (CmmLit _) = z
231 expr z (CmmLoad addr _) = foldRegsUsed f z addr
232 expr z (CmmReg r) = foldRegsUsed f z r
233 expr z (CmmMachOp _ exprs) = foldRegsUsed f z exprs
234 expr z (CmmRegOff r _) = foldRegsUsed f z r
235 expr z (CmmStackSlot _ _) = z
237 instance UserOfLocalRegs a => UserOfLocalRegs [a] where
238 foldRegsUsed _ set [] = set
239 foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
241 instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
242 foldRegsDefd _ set [] = set
243 foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
245 instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
246 foldRegsDefd _ set Nothing = set
247 foldRegsDefd f set (Just x) = foldRegsDefd f set x
249 -----------------------------------------------------------------------------
250 -- Another reg utility
252 regUsedIn :: CmmReg -> CmmExpr -> Bool
253 _ `regUsedIn` CmmLit _ = False
254 reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
255 reg `regUsedIn` CmmReg reg' = reg == reg'
256 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
257 reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
258 _ `regUsedIn` CmmStackSlot _ _ = False
260 -----------------------------------------------------------------------------
262 -----------------------------------------------------------------------------
264 isStackSlotOf :: CmmExpr -> LocalReg -> Bool
265 isStackSlotOf (CmmStackSlot (RegSlot r) _) r' = r == r'
266 isStackSlotOf _ _ = False
268 -----------------------------------------------------------------------------
269 -- Stack slot use information for expressions and other types [_$_]
270 -----------------------------------------------------------------------------
272 -- Fold over the area, the offset into the area, and the width of the subarea.
273 class UserOfSlots a where
274 foldSlotsUsed :: (b -> SubArea -> b) -> b -> a -> b
276 class DefinerOfSlots a where
277 foldSlotsDefd :: (b -> SubArea -> b) -> b -> a -> b
279 instance UserOfSlots CmmExpr where
280 foldSlotsUsed f z e = expr z e
281 where expr z (CmmLit _) = z
282 expr z (CmmLoad (CmmStackSlot a i) ty) = f z (a, i, widthInBytes $ typeWidth ty)
283 expr z (CmmLoad addr _) = foldSlotsUsed f z addr
284 expr z (CmmReg _) = z
285 expr z (CmmMachOp _ exprs) = foldSlotsUsed f z exprs
286 expr z (CmmRegOff _ _) = z
287 expr z (CmmStackSlot _ _) = z
289 instance UserOfSlots a => UserOfSlots [a] where
290 foldSlotsUsed _ set [] = set
291 foldSlotsUsed f set (x:xs) = foldSlotsUsed f (foldSlotsUsed f set x) xs
293 instance DefinerOfSlots a => DefinerOfSlots [a] where
294 foldSlotsDefd _ set [] = set
295 foldSlotsDefd f set (x:xs) = foldSlotsDefd f (foldSlotsDefd f set x) xs
297 instance DefinerOfSlots SubArea where
298 foldSlotsDefd f z a = f z a
300 -----------------------------------------------------------------------------
301 -- Global STG registers
302 -----------------------------------------------------------------------------
304 data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
307 -----------------------------------------------------------------------------
308 -- Global STG registers
309 -----------------------------------------------------------------------------
310 vgcFlag :: CmmType -> VGcPtr
311 vgcFlag ty | isGcPtrType ty = VGcPtr
312 | otherwise = VNonGcPtr
315 -- Argument and return registers
316 = VanillaReg -- pointers, unboxed ints and chars
317 {-# UNPACK #-} !Int -- its number
320 | FloatReg -- single-precision floating-point registers
321 {-# UNPACK #-} !Int -- its number
323 | DoubleReg -- double-precision floating-point registers
324 {-# UNPACK #-} !Int -- its number
326 | LongReg -- long int registers (64-bit, really)
327 {-# UNPACK #-} !Int -- its number
330 | Sp -- Stack ptr; points to last occupied stack location.
331 | SpLim -- Stack limit
332 | Hp -- Heap ptr; points to last occupied heap location.
333 | HpLim -- Heap limit register
334 | CurrentTSO -- pointer to current thread's TSO
335 | CurrentNursery -- pointer to allocation area
336 | HpAlloc -- allocation count for heap check failure
338 -- We keep the address of some commonly-called
339 -- functions in the register table, to keep code
341 | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info
342 | GCEnter1 -- stg_gc_enter_1
343 | GCFun -- stg_gc_fun
345 -- Base offset for the register table, used for accessing registers
346 -- which do not have real registers assigned to them. This register
347 -- will only appear after we have expanded GlobalReg into memory accesses
348 -- (where necessary) in the native code generator.
351 -- Base Register for PIC (position-independent code) calculations
352 -- Only used inside the native code generator. It's exact meaning differs
353 -- from platform to platform (see module PositionIndependentCode).
358 instance Eq GlobalReg where
359 VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
360 FloatReg i == FloatReg j = i==j
361 DoubleReg i == DoubleReg j = i==j
362 LongReg i == LongReg j = i==j
364 SpLim == SpLim = True
366 HpLim == HpLim = True
367 CurrentTSO == CurrentTSO = True
368 CurrentNursery == CurrentNursery = True
369 HpAlloc == HpAlloc = True
370 GCEnter1 == GCEnter1 = True
371 GCFun == GCFun = True
372 BaseReg == BaseReg = True
373 PicBaseReg == PicBaseReg = True
376 instance Ord GlobalReg where
377 compare (VanillaReg i _) (VanillaReg j _) = compare i j
378 -- Ignore type when seeking clashes
379 compare (FloatReg i) (FloatReg j) = compare i j
380 compare (DoubleReg i) (DoubleReg j) = compare i j
381 compare (LongReg i) (LongReg j) = compare i j
383 compare SpLim SpLim = EQ
385 compare HpLim HpLim = EQ
386 compare CurrentTSO CurrentTSO = EQ
387 compare CurrentNursery CurrentNursery = EQ
388 compare HpAlloc HpAlloc = EQ
389 compare EagerBlackholeInfo EagerBlackholeInfo = EQ
390 compare GCEnter1 GCEnter1 = EQ
391 compare GCFun GCFun = EQ
392 compare BaseReg BaseReg = EQ
393 compare PicBaseReg PicBaseReg = EQ
394 compare (VanillaReg _ _) _ = LT
395 compare _ (VanillaReg _ _) = GT
396 compare (FloatReg _) _ = LT
397 compare _ (FloatReg _) = GT
398 compare (DoubleReg _) _ = LT
399 compare _ (DoubleReg _) = GT
400 compare (LongReg _) _ = LT
401 compare _ (LongReg _) = GT
410 compare CurrentTSO _ = LT
411 compare _ CurrentTSO = GT
412 compare CurrentNursery _ = LT
413 compare _ CurrentNursery = GT
414 compare HpAlloc _ = LT
415 compare _ HpAlloc = GT
416 compare GCEnter1 _ = LT
417 compare _ GCEnter1 = GT
420 compare BaseReg _ = LT
421 compare _ BaseReg = GT
422 compare EagerBlackholeInfo _ = LT
423 compare _ EagerBlackholeInfo = GT
425 -- convenient aliases
426 spReg, hpReg, spLimReg, nodeReg :: CmmReg
429 spLimReg = CmmGlobal SpLim
430 nodeReg = CmmGlobal node
433 node = VanillaReg 1 VGcPtr
435 globalRegType :: GlobalReg -> CmmType
436 globalRegType (VanillaReg _ VGcPtr) = gcWord
437 globalRegType (VanillaReg _ VNonGcPtr) = bWord
438 globalRegType (FloatReg _) = cmmFloat W32
439 globalRegType (DoubleReg _) = cmmFloat W64
440 globalRegType (LongReg _) = cmmBits W64
441 globalRegType Hp = gcWord -- The initialiser for all
442 -- dynamically allocated closures
443 globalRegType _ = bWord