CmmExpr.hs 21.1 KB
Newer Older
1
{-# LANGUAGE BangPatterns #-}
2
{-# LANGUAGE CPP #-}
3
{-# LANGUAGE FlexibleContexts #-}
4 5
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
6
{-# LANGUAGE UndecidableInstances #-}
7 8

module CmmExpr
9
    ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
10 11 12
    , CmmReg(..), cmmRegType
    , CmmLit(..), cmmLitType
    , LocalReg(..), localRegType
13 14 15 16
    , GlobalReg(..), isArgReg, globalRegType
    , spReg, hpReg, spLimReg, hpLimReg, nodeReg
    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg
    , node, baseReg
17
    , VGcPtr(..)
18 19

    , DefinerOfRegs, UserOfRegs
20
    , foldRegsDefd, foldRegsUsed
21 22 23 24 25 26
    , foldLocalRegsDefd, foldLocalRegsUsed

    , RegSet, LocalRegSet, GlobalRegSet
    , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
    , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
    , regSetToList
27

Simon Marlow's avatar
Simon Marlow committed
28
    , Area(..)
29 30 31
    , module CmmMachOp
    , module CmmType
    )
32 33
where

34 35
import GhcPrelude

36
import BlockId
37
import CLabel
38 39
import CmmMachOp
import CmmType
40
import DynFlags
41
import Outputable (panic)
42
import Unique
43

44
import Data.Set (Set)
45
import Data.List
46
import qualified Data.Set as Set
47

48
-----------------------------------------------------------------------------
49
--              CmmExpr
50 51 52 53 54
-- An expression.  Expressions have no side effects.
-----------------------------------------------------------------------------

data CmmExpr
  = CmmLit CmmLit               -- Literal
Simon Marlow's avatar
Simon Marlow committed
55
  | CmmLoad !CmmExpr !CmmType   -- Read memory location
Simon Marlow's avatar
Simon Marlow committed
56
  | CmmReg !CmmReg              -- Contents of register
57
  | CmmMachOp MachOp [CmmExpr]  -- Machine operation (+, -, *, etc.)
Simon Marlow's avatar
Simon Marlow committed
58 59
  | CmmStackSlot Area {-# UNPACK #-} !Int
                                -- addressing expression of a stack slot
60
                                -- See Note [CmmStackSlot aliasing]
Simon Marlow's avatar
Simon Marlow committed
61
  | CmmRegOff !CmmReg Int
62 63 64 65 66 67 68 69 70 71 72
        -- CmmRegOff reg i
        --        ** is shorthand only, meaning **
        -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
        --      where rep = typeWidth (cmmRegType reg)

instance Eq CmmExpr where       -- Equality ignores the types
  CmmLit l1          == CmmLit l2          = l1==l2
  CmmLoad e1 _       == CmmLoad e2 _       = e1==e2
  CmmReg r1          == CmmReg r2          = r1==r2
  CmmRegOff r1 i1    == CmmRegOff r2 i2    = r1==r2 && i1==i2
  CmmMachOp op1 es1  == CmmMachOp op2 es2  = op1==op2 && es1==es2
73
  CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2
74
  _e1                == _e2                = False
75

76
data CmmReg
77
  = CmmLocal  {-# UNPACK #-} !LocalReg
78
  | CmmGlobal GlobalReg
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
79
  deriving( Eq, Ord )
80

81 82 83
-- | A stack area is either the stack slot where a variable is spilled
-- or the stack space where function arguments and results are passed.
data Area
84
  = Old            -- See Note [Old Area]
Simon Marlow's avatar
Simon Marlow committed
85
  | Young {-# UNPACK #-} !BlockId  -- Invariant: must be a continuation BlockId
86
                   -- See Note [Continuation BlockId] in CmmNode.
87 88
  deriving (Eq, Ord)

89
{- Note [Old Area]
90 91 92 93
~~~~~~~~~~~~~~~~~~
There is a single call area 'Old', allocated at the extreme old
end of the stack frame (ie just younger than the return address)
which holds:
94
  * incoming (overflow) parameters,
95
  * outgoing (overflow) parameter to tail calls,
96
  * outgoing (overflow) result values
97 98 99 100 101 102 103 104
  * the update frame (if any)

Its size is the max of all these requirements.  On entry, the stack
pointer will point to the youngest incoming parameter, which is not
necessarily at the young end of the Old area.

End of note -}

105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172

{- Note [CmmStackSlot aliasing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When do two CmmStackSlots alias?

 - T[old+N] aliases with U[young(L)+M] for all T, U, L, N and M
 - T[old+N] aliases with U[old+M] only if the areas actually overlap

Or more informally, different Areas may overlap with each other.

An alternative semantics, that we previously had, was that different
Areas do not overlap.  The problem that lead to redefining the
semantics of stack areas is described below.

e.g. if we had

    x = Sp[old + 8]
    y = Sp[old + 16]

    Sp[young(L) + 8]  = L
    Sp[young(L) + 16] = y
    Sp[young(L) + 24] = x
    call f() returns to L

if areas semantically do not overlap, then we might optimise this to

    Sp[young(L) + 8]  = L
    Sp[young(L) + 16] = Sp[old + 8]
    Sp[young(L) + 24] = Sp[old + 16]
    call f() returns to L

and now young(L) cannot be allocated at the same place as old, and we
are doomed to use more stack.

  - old+8  conflicts with young(L)+8
  - old+16 conflicts with young(L)+16 and young(L)+8

so young(L)+8 == old+24 and we get

    Sp[-8]  = L
    Sp[-16] = Sp[8]
    Sp[-24] = Sp[0]
    Sp -= 24
    call f() returns to L

However, if areas are defined to be "possibly overlapping" in the
semantics, then we cannot commute any loads/stores of old with
young(L), and we will be able to re-use both old+8 and old+16 for
young(L).

    x = Sp[8]
    y = Sp[0]

    Sp[8] = L
    Sp[0] = y
    Sp[-8] = x
    Sp = Sp - 8
    call f() returns to L

Now, the assignments of y go away,

    x = Sp[8]
    Sp[8] = L
    Sp[-8] = x
    Sp = Sp - 8
    call f() returns to L
-}

173
data CmmLit
174
  = CmmInt !Integer  Width
175 176 177 178 179
        -- Interpretation: the 2's complement representation of the value
        -- is truncated to the specified size.  This is easier than trying
        -- to keep the value within range, because we don't know whether
        -- it will be used as a signed or unsigned value (the CmmType doesn't
        -- distinguish between signed & unsigned).
180
  | CmmFloat  Rational Width
181
  | CmmVec [CmmLit]                     -- Vector literal
182 183 184
  | CmmLabel    CLabel                  -- Address of label
  | CmmLabelOff CLabel Int              -- Address of label + byte offset

185 186 187 188 189 190
        -- Due to limitations in the C backend, the following
        -- MUST ONLY be used inside the info table indicated by label2
        -- (label2 must be the info label), and label1 must be an
        -- SRT, a slow entrypoint or a large bitmap (see the Mangler)
        -- Don't use it at all unless tablesNextToCode.
        -- It is also used inside the NCG during when generating
191
        -- position-independent code.
192
  | CmmLabelDiffOff CLabel CLabel Int   -- label1 - label2 + offset
193

Simon Marlow's avatar
Simon Marlow committed
194
  | CmmBlock {-# UNPACK #-} !BlockId     -- Code label
195 196 197
        -- Invariant: must be a continuation BlockId
        -- See Note [Continuation BlockId] in CmmNode.

198 199 200 201 202
  | CmmHighStackMark -- A late-bound constant that stands for the max
                     -- #bytes of stack space used during a procedure.
                     -- During the stack-layout pass, CmmHighStackMark
                     -- is replaced by a CmmInt for the actual number
                     -- of bytes used
203 204
  deriving Eq

205 206 207 208 209 210 211
cmmExprType :: DynFlags -> CmmExpr -> CmmType
cmmExprType dflags (CmmLit lit)        = cmmLitType dflags lit
cmmExprType _      (CmmLoad _ rep)     = rep
cmmExprType dflags (CmmReg reg)        = cmmRegType dflags reg
cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args)
cmmExprType dflags (CmmRegOff reg _)   = cmmRegType dflags reg
cmmExprType dflags (CmmStackSlot _ _)  = bWord dflags -- an address
212 213
-- Careful though: what is stored at the stack slot may be bigger than
-- an address
214

215 216 217
cmmLitType :: DynFlags -> CmmLit -> CmmType
cmmLitType _      (CmmInt _ width)     = cmmBits  width
cmmLitType _      (CmmFloat _ width)   = cmmFloat width
218 219 220 221 222
cmmLitType _      (CmmVec [])          = panic "cmmLitType: CmmVec []"
cmmLitType cflags (CmmVec (l:ls))      = let ty = cmmLitType cflags l
                                         in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls)
                                            then cmmVec (1+length ls) ty
                                            else panic "cmmLitType: CmmVec"
223 224 225 226 227
cmmLitType dflags (CmmLabel lbl)       = cmmLabelType dflags lbl
cmmLitType dflags (CmmLabelOff lbl _)  = cmmLabelType dflags lbl
cmmLitType dflags (CmmLabelDiffOff {}) = bWord dflags
cmmLitType dflags (CmmBlock _)         = bWord dflags
cmmLitType dflags (CmmHighStackMark)   = bWord dflags
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
228

229 230
cmmLabelType :: DynFlags -> CLabel -> CmmType
cmmLabelType dflags lbl
231
 | isGcPtrLabel lbl = gcWord dflags
232
 | otherwise        = bWord dflags
233

234 235
cmmExprWidth :: DynFlags -> CmmExpr -> Width
cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)
236 237 238 239 240 241 242 243 244 245

--------
--- Negation for conditional branches

maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
                                            return (CmmMachOp op' args)
maybeInvertCmmExpr _ = Nothing

-----------------------------------------------------------------------------
246
--              Local registers
247 248 249
-----------------------------------------------------------------------------

data LocalReg
250
  = LocalReg {-# UNPACK #-} !Unique CmmType
Thomas Schilling's avatar
Thomas Schilling committed
251 252 253
    -- ^ Parameters:
    --   1. Identifier
    --   2. Type
254

255 256 257
instance Eq LocalReg where
  (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2

niteria's avatar
niteria committed
258 259 260
-- This is non-deterministic but we do not currently support deterministic
-- code-generation. See Note [Unique Determinism and code generation]
-- See Note [No Ord for Unique]
261
instance Ord LocalReg where
niteria's avatar
niteria committed
262
  compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2
263 264 265 266

instance Uniquable LocalReg where
  getUnique (LocalReg uniq _) = uniq

267 268 269
cmmRegType :: DynFlags -> CmmReg -> CmmType
cmmRegType _      (CmmLocal  reg) = localRegType reg
cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg
270 271 272 273 274

localRegType :: LocalReg -> CmmType
localRegType (LocalReg _ rep) = rep

-----------------------------------------------------------------------------
275
--    Register-use information for expressions and other types
276 277
-----------------------------------------------------------------------------

278
-- | Sets of registers
279 280 281 282 283 284 285

-- These are used for dataflow facts, and a common operation is taking
-- the union of two RegSets and then asking whether the union is the
-- same as one of the inputs.  UniqSet isn't good here, because
-- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary
-- Sets.

286 287 288 289
type RegSet r     = Set r
type LocalRegSet  = RegSet LocalReg
type GlobalRegSet = RegSet GlobalReg

290 291
emptyRegSet             :: RegSet r
nullRegSet              :: RegSet r -> Bool
292 293 294 295 296
elemRegSet              :: Ord r => r -> RegSet r -> Bool
extendRegSet            :: Ord r => RegSet r -> r -> RegSet r
deleteFromRegSet        :: Ord r => RegSet r -> r -> RegSet r
mkRegSet                :: Ord r => [r] -> RegSet r
minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r
297 298
sizeRegSet              :: RegSet r -> Int
regSetToList            :: RegSet r -> [r]
299 300 301 302 303 304 305 306 307 308 309 310

emptyRegSet      = Set.empty
nullRegSet       = Set.null
elemRegSet       = Set.member
extendRegSet     = flip Set.insert
deleteFromRegSet = flip Set.delete
mkRegSet         = Set.fromList
minusRegSet      = Set.difference
plusRegSet       = Set.union
timesRegSet      = Set.intersection
sizeRegSet       = Set.size
regSetToList     = Set.toList
311

312 313 314 315 316 317
class Ord r => UserOfRegs r a where
  foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b

foldLocalRegsUsed :: UserOfRegs LocalReg a
                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsUsed = foldRegsUsed
318

319 320
class Ord r => DefinerOfRegs r a where
  foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
321

322 323 324 325 326 327 328 329 330 331 332
foldLocalRegsDefd :: DefinerOfRegs LocalReg a
                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsDefd = foldRegsDefd

instance UserOfRegs LocalReg CmmReg where
    foldRegsUsed _ f z (CmmLocal reg) = f z reg
    foldRegsUsed _ _ z (CmmGlobal _)  = z

instance DefinerOfRegs LocalReg CmmReg where
    foldRegsDefd _ f z (CmmLocal reg) = f z reg
    foldRegsDefd _ _ z (CmmGlobal _)  = z
333

334 335 336
instance UserOfRegs GlobalReg CmmReg where
    foldRegsUsed _ _ z (CmmLocal _)    = z
    foldRegsUsed _ f z (CmmGlobal reg) = f z reg
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
337

338 339 340
instance DefinerOfRegs GlobalReg CmmReg where
    foldRegsDefd _ _ z (CmmLocal _)    = z
    foldRegsDefd _ f z (CmmGlobal reg) = f z reg
341

342 343
instance Ord r => UserOfRegs r r where
    foldRegsUsed _ f z r = f z r
344

345 346
instance Ord r => DefinerOfRegs r r where
    foldRegsDefd _ f z r = f z r
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
347

348 349 350
instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
  -- The (Ord r) in the context is necessary here
  -- See Note [Recursive superclasses] in TcInstDcls
351
  foldRegsUsed dflags f !z e = expr z e
352
    where expr z (CmmLit _)          = z
353 354 355 356
          expr z (CmmLoad addr _)    = foldRegsUsed dflags f z addr
          expr z (CmmReg r)          = foldRegsUsed dflags f z r
          expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs
          expr z (CmmRegOff r _)     = foldRegsUsed dflags f z r
357
          expr z (CmmStackSlot _ _)  = z
358

359
instance UserOfRegs r a => UserOfRegs r [a] where
360 361
  foldRegsUsed dflags f set as = foldl' (foldRegsUsed dflags f) set as
  {-# INLINABLE foldRegsUsed #-}
dias@eecs.harvard.edu's avatar
dias@eecs.harvard.edu committed
362

363
instance DefinerOfRegs r a => DefinerOfRegs r [a] where
364 365
  foldRegsDefd dflags f set as = foldl' (foldRegsDefd dflags f) set as
  {-# INLINABLE foldRegsDefd #-}
366

367
-----------------------------------------------------------------------------
368
--              Global STG registers
369
-----------------------------------------------------------------------------
370

371
data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
372 373

-----------------------------------------------------------------------------
374
--              Global STG registers
375
-----------------------------------------------------------------------------
376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400
{-
Note [Overlapping global registers]

The backend might not faithfully implement the abstraction of the STG
machine with independent registers for different values of type
GlobalReg. Specifically, certain pairs of registers (r1, r2) may
overlap in the sense that a store to r1 invalidates the value in r2,
and vice versa.

Currently this occurs only on the x86_64 architecture where FloatReg n
and DoubleReg n are assigned the same microarchitectural register, in
order to allow functions to receive more Float# or Double# arguments
in registers (as opposed to on the stack).

There are no specific rules about which registers might overlap with
which other registers, but presumably it's safe to assume that nothing
will overlap with special registers like Sp or BaseReg.

Use CmmUtils.regsOverlap to determine whether two GlobalRegs overlap
on a particular platform. The instance Eq GlobalReg is syntactic
equality of STG registers and does not take overlap into
account. However it is still used in UserOfRegs/DefinerOfRegs and
there are likely still bugs there, beware!
-}

401 402
data GlobalReg
  -- Argument and return registers
403 404 405
  = VanillaReg                  -- pointers, unboxed ints and chars
        {-# UNPACK #-} !Int     -- its number
        VGcPtr
406

407 408
  | FloatReg            -- single-precision floating-point registers
        {-# UNPACK #-} !Int     -- its number
409

410 411
  | DoubleReg           -- double-precision floating-point registers
        {-# UNPACK #-} !Int     -- its number
412

413 414
  | LongReg             -- long int registers (64-bit, really)
        {-# UNPACK #-} !Int     -- its number
415

416
  | XmmReg                      -- 128-bit SIMD vector register
417 418
        {-# UNPACK #-} !Int     -- its number

419
  | YmmReg                      -- 256-bit SIMD vector register
420 421
        {-# UNPACK #-} !Int     -- its number

422
  | ZmmReg                      -- 512-bit SIMD vector register
423 424
        {-# UNPACK #-} !Int     -- its number

425
  -- STG registers
426 427 428 429
  | Sp                  -- Stack ptr; points to last occupied stack location.
  | SpLim               -- Stack limit
  | Hp                  -- Heap ptr; points to last occupied heap location.
  | HpLim               -- Heap limit register
430 431
  | CCCS                -- Current cost-centre stack
  | CurrentTSO          -- pointer to current thread's TSO
432 433
  | CurrentNursery      -- pointer to allocation area
  | HpAlloc             -- allocation count for heap check failure
434

435 436 437
                -- We keep the address of some commonly-called
                -- functions in the register table, to keep code
                -- size down:
438
  | EagerBlackholeInfo  -- stg_EAGER_BLACKHOLE_info
439 440
  | GCEnter1            -- stg_gc_enter_1
  | GCFun               -- stg_gc_fun
441 442 443 444 445 446 447

  -- Base offset for the register table, used for accessing registers
  -- which do not have real registers assigned to them.  This register
  -- will only appear after we have expanded GlobalReg into memory accesses
  -- (where necessary) in the native code generator.
  | BaseReg

448 449 450 451 452 453 454 455 456
  -- The register used by the platform for the C stack pointer. This is
  -- a break in the STG abstraction used exclusively to setup stack unwinding
  -- information.
  | MachSp

  -- The is a dummy register used to indicate to the stack unwinder where
  -- a routine would return to.
  | UnwindReturnReg

457 458 459 460 461
  -- Base Register for PIC (position-independent code) calculations
  -- Only used inside the native code generator. It's exact meaning differs
  -- from platform to platform (see module PositionIndependentCode).
  | PicBaseReg

462 463 464
  deriving( Show )

instance Eq GlobalReg where
465
   VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
466 467 468
   FloatReg i == FloatReg j = i==j
   DoubleReg i == DoubleReg j = i==j
   LongReg i == LongReg j = i==j
469
   XmmReg i == XmmReg j = i==j
470
   YmmReg i == YmmReg j = i==j
471
   ZmmReg i == ZmmReg j = i==j
472 473 474 475
   Sp == Sp = True
   SpLim == SpLim = True
   Hp == Hp = True
   HpLim == HpLim = True
476
   CCCS == CCCS = True
477 478 479
   CurrentTSO == CurrentTSO = True
   CurrentNursery == CurrentNursery = True
   HpAlloc == HpAlloc = True
480
   EagerBlackholeInfo == EagerBlackholeInfo = True
481 482 483
   GCEnter1 == GCEnter1 = True
   GCFun == GCFun = True
   BaseReg == BaseReg = True
484 485
   MachSp == MachSp = True
   UnwindReturnReg == UnwindReturnReg = True
486 487 488 489 490 491 492 493 494
   PicBaseReg == PicBaseReg = True
   _r1 == _r2 = False

instance Ord GlobalReg where
   compare (VanillaReg i _) (VanillaReg j _) = compare i j
     -- Ignore type when seeking clashes
   compare (FloatReg i)  (FloatReg  j) = compare i j
   compare (DoubleReg i) (DoubleReg j) = compare i j
   compare (LongReg i)   (LongReg   j) = compare i j
495
   compare (XmmReg i)    (XmmReg    j) = compare i j
496
   compare (YmmReg i)    (YmmReg    j) = compare i j
497
   compare (ZmmReg i)    (ZmmReg    j) = compare i j
498 499 500 501
   compare Sp Sp = EQ
   compare SpLim SpLim = EQ
   compare Hp Hp = EQ
   compare HpLim HpLim = EQ
502
   compare CCCS CCCS = EQ
503 504 505
   compare CurrentTSO CurrentTSO = EQ
   compare CurrentNursery CurrentNursery = EQ
   compare HpAlloc HpAlloc = EQ
506
   compare EagerBlackholeInfo EagerBlackholeInfo = EQ
507 508 509
   compare GCEnter1 GCEnter1 = EQ
   compare GCFun GCFun = EQ
   compare BaseReg BaseReg = EQ
510 511
   compare MachSp MachSp = EQ
   compare UnwindReturnReg UnwindReturnReg = EQ
512 513 514 515 516 517 518 519 520
   compare PicBaseReg PicBaseReg = EQ
   compare (VanillaReg _ _) _ = LT
   compare _ (VanillaReg _ _) = GT
   compare (FloatReg _) _     = LT
   compare _ (FloatReg _)     = GT
   compare (DoubleReg _) _    = LT
   compare _ (DoubleReg _)    = GT
   compare (LongReg _) _      = LT
   compare _ (LongReg _)      = GT
521 522
   compare (XmmReg _) _       = LT
   compare _ (XmmReg _)       = GT
523 524
   compare (YmmReg _) _       = LT
   compare _ (YmmReg _)       = GT
525 526
   compare (ZmmReg _) _       = LT
   compare _ (ZmmReg _)       = GT
527 528 529 530 531 532 533 534
   compare Sp _ = LT
   compare _ Sp = GT
   compare SpLim _ = LT
   compare _ SpLim = GT
   compare Hp _ = LT
   compare _ Hp = GT
   compare HpLim _ = LT
   compare _ HpLim = GT
535 536
   compare CCCS _ = LT
   compare _ CCCS = GT
537 538 539 540 541 542 543 544 545 546 547 548
   compare CurrentTSO _ = LT
   compare _ CurrentTSO = GT
   compare CurrentNursery _ = LT
   compare _ CurrentNursery = GT
   compare HpAlloc _ = LT
   compare _ HpAlloc = GT
   compare GCEnter1 _ = LT
   compare _ GCEnter1 = GT
   compare GCFun _ = LT
   compare _ GCFun = GT
   compare BaseReg _ = LT
   compare _ BaseReg = GT
549 550 551 552
   compare MachSp _ = LT
   compare _ MachSp = GT
   compare UnwindReturnReg _ = LT
   compare _ UnwindReturnReg = GT
553 554
   compare EagerBlackholeInfo _ = LT
   compare _ EagerBlackholeInfo = GT
555 556

-- convenient aliases
557 558
baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,
  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg  :: CmmReg
tibbe's avatar
tibbe committed
559
baseReg = CmmGlobal BaseReg
560 561
spReg = CmmGlobal Sp
hpReg = CmmGlobal Hp
562
hpLimReg = CmmGlobal HpLim
563 564
spLimReg = CmmGlobal SpLim
nodeReg = CmmGlobal node
565 566 567 568
currentTSOReg = CmmGlobal CurrentTSO
currentNurseryReg = CmmGlobal CurrentNursery
hpAllocReg = CmmGlobal HpAlloc
cccsReg = CmmGlobal CCCS
569 570

node :: GlobalReg
571 572
node = VanillaReg 1 VGcPtr

573
globalRegType :: DynFlags -> GlobalReg -> CmmType
574
globalRegType dflags (VanillaReg _ VGcPtr)    = gcWord dflags
575 576 577 578
globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags
globalRegType _      (FloatReg _)      = cmmFloat W32
globalRegType _      (DoubleReg _)     = cmmFloat W64
globalRegType _      (LongReg _)       = cmmBits W64
579
globalRegType _      (XmmReg _)        = cmmVec 4 (cmmBits W32)
580
globalRegType _      (YmmReg _)        = cmmVec 8 (cmmBits W32)
581
globalRegType _      (ZmmReg _)        = cmmVec 16 (cmmBits W32)
582

583 584
globalRegType dflags Hp                = gcWord dflags
                                            -- The initialiser for all
585
                                            -- dynamically allocated closures
586
globalRegType dflags _                 = bWord dflags
587 588 589 590 591 592

isArgReg :: GlobalReg -> Bool
isArgReg (VanillaReg {}) = True
isArgReg (FloatReg {})   = True
isArgReg (DoubleReg {})  = True
isArgReg (LongReg {})    = True
593
isArgReg (XmmReg {})     = True
594
isArgReg (YmmReg {})     = True
595
isArgReg (ZmmReg {})     = True
596
isArgReg _               = False