Expr.hs 22.2 KB
Newer Older
1
{-# LANGUAGE BangPatterns #-}
2
{-# LANGUAGE LambdaCase #-}
3
{-# LANGUAGE FlexibleContexts #-}
4 5
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
6
{-# LANGUAGE UndecidableInstances #-}
7

8
module GHC.Cmm.Expr
9
    ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr
Michal Terepeta's avatar
Michal Terepeta committed
10
    , CmmReg(..), cmmRegType, cmmRegWidth
11 12
    , 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
    , module GHC.Cmm.MachOp
    , module GHC.Cmm.Type
31
    )
32 33
where

34
import GHC.Prelude
35

36
import GHC.Platform
37 38 39 40
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.MachOp
import GHC.Cmm.Type
Sylvain Henry's avatar
Sylvain Henry committed
41
import GHC.Driver.Session
42
import GHC.Utils.Panic (panic)
Sylvain Henry's avatar
Sylvain Henry committed
43
import GHC.Types.Unique
44

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

Sylvain Henry's avatar
Sylvain Henry committed
48
import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf)
49

50
-----------------------------------------------------------------------------
51
--              CmmExpr
52 53 54 55 56
-- An expression.  Expressions have no side effects.
-----------------------------------------------------------------------------

data CmmExpr
  = CmmLit CmmLit               -- Literal
Simon Marlow's avatar
Simon Marlow committed
57
  | CmmLoad !CmmExpr !CmmType   -- Read memory location
Simon Marlow's avatar
Simon Marlow committed
58
  | CmmReg !CmmReg              -- Contents of register
59
  | CmmMachOp MachOp [CmmExpr]  -- Machine operation (+, -, *, etc.)
Simon Marlow's avatar
Simon Marlow committed
60 61
  | CmmStackSlot Area {-# UNPACK #-} !Int
                                -- addressing expression of a stack slot
62
                                -- See Note [CmmStackSlot aliasing]
Simon Marlow's avatar
Simon Marlow committed
63
  | CmmRegOff !CmmReg Int
64 65 66 67 68 69 70 71 72 73 74
        -- 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
75
  CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2
76
  _e1                == _e2                = False
77

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

83 84 85
-- | 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
86
  = Old            -- See Note [Old Area]
Simon Marlow's avatar
Simon Marlow committed
87
  | Young {-# UNPACK #-} !BlockId  -- Invariant: must be a continuation BlockId
88
                   -- See Note [Continuation BlockId] in GHC.Cmm.Node.
89 90
  deriving (Eq, Ord)

91
{- Note [Old Area]
92 93 94 95
~~~~~~~~~~~~~~~~~~
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:
96
  * incoming (overflow) parameters,
97
  * outgoing (overflow) parameter to tail calls,
98
  * outgoing (overflow) result values
99 100 101 102 103 104 105 106
  * 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 -}

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 173 174

{- 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
-}

175
data CmmLit
176
  = CmmInt !Integer  Width
177 178 179 180 181
        -- 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).
182
  | CmmFloat  Rational Width
183
  | CmmVec [CmmLit]                     -- Vector literal
184 185 186
  | CmmLabel    CLabel                  -- Address of label
  | CmmLabelOff CLabel Int              -- Address of label + byte offset

187 188 189 190 191 192
        -- 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
193
        -- position-independent code.
194
  | CmmLabelDiffOff CLabel CLabel Int Width -- label1 - label2 + offset
195 196 197 198 199 200 201
        -- In an expression, the width just has the effect of MO_SS_Conv
        -- from wordWidth to the desired width.
        --
        -- In a static literal, the supported Widths depend on the
        -- architecture: wordWidth is supported on all
        -- architectures. Additionally W32 is supported on x86_64 when
        -- using the small memory model.
202

Simon Marlow's avatar
Simon Marlow committed
203
  | CmmBlock {-# UNPACK #-} !BlockId     -- Code label
204
        -- Invariant: must be a continuation BlockId
205
        -- See Note [Continuation BlockId] in GHC.Cmm.Node.
206

207 208 209 210 211
  | 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
212 213
  deriving Eq

214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246
cmmExprType :: Platform -> CmmExpr -> CmmType
cmmExprType platform = \case
   (CmmLit lit)        -> cmmLitType platform lit
   (CmmLoad _ rep)     -> rep
   (CmmReg reg)        -> cmmRegType platform reg
   (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args)
   (CmmRegOff reg _)   -> cmmRegType platform reg
   (CmmStackSlot _ _)  -> bWord platform -- an address
   -- Careful though: what is stored at the stack slot may be bigger than
   -- an address

cmmLitType :: Platform -> CmmLit -> CmmType
cmmLitType platform = \case
   (CmmInt _ width)     -> cmmBits  width
   (CmmFloat _ width)   -> cmmFloat width
   (CmmVec [])          -> panic "cmmLitType: CmmVec []"
   (CmmVec (l:ls))      -> let ty = cmmLitType platform l
                          in if all (`cmmEqType` ty) (map (cmmLitType platform) ls)
                               then cmmVec (1+length ls) ty
                               else panic "cmmLitType: CmmVec"
   (CmmLabel lbl)       -> cmmLabelType platform lbl
   (CmmLabelOff lbl _)  -> cmmLabelType platform lbl
   (CmmLabelDiffOff _ _ _ width) -> cmmBits width
   (CmmBlock _)         -> bWord platform
   (CmmHighStackMark)   -> bWord platform

cmmLabelType :: Platform -> CLabel -> CmmType
cmmLabelType platform lbl
 | isGcPtrLabel lbl = gcWord platform
 | otherwise        = bWord platform

cmmExprWidth :: Platform -> CmmExpr -> Width
cmmExprWidth platform e = typeWidth (cmmExprType platform e)
247

248 249 250 251 252 253 254
-- | Returns an alignment in bytes of a CmmExpr when it's a statically
-- known integer constant, otherwise returns an alignment of 1 byte.
-- The caller is responsible for using with a sensible CmmExpr
-- argument.
cmmExprAlignment :: CmmExpr -> Alignment
cmmExprAlignment (CmmLit (CmmInt intOff _)) = alignmentOf (fromInteger intOff)
cmmExprAlignment _                          = mkAlignment 1
255 256 257 258 259 260 261 262 263
--------
--- Negation for conditional branches

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

-----------------------------------------------------------------------------
264
--              Local registers
265 266 267
-----------------------------------------------------------------------------

data LocalReg
268
  = LocalReg {-# UNPACK #-} !Unique CmmType
Thomas Schilling's avatar
Thomas Schilling committed
269 270 271
    -- ^ Parameters:
    --   1. Identifier
    --   2. Type
272

273 274 275
instance Eq LocalReg where
  (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2

niteria's avatar
niteria committed
276 277 278
-- 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]
279
instance Ord LocalReg where
niteria's avatar
niteria committed
280
  compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2
281 282 283 284

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

285 286 287
cmmRegType :: Platform -> CmmReg -> CmmType
cmmRegType _        (CmmLocal  reg) = localRegType reg
cmmRegType platform (CmmGlobal reg) = globalRegType platform reg
288

289 290
cmmRegWidth :: Platform -> CmmReg -> Width
cmmRegWidth platform = typeWidth . cmmRegType platform
Michal Terepeta's avatar
Michal Terepeta committed
291

292 293 294 295
localRegType :: LocalReg -> CmmType
localRegType (LocalReg _ rep) = rep

-----------------------------------------------------------------------------
296
--    Register-use information for expressions and other types
297 298
-----------------------------------------------------------------------------

299
-- | Sets of registers
300 301 302 303 304 305 306

-- 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.

307 308 309 310
type RegSet r     = Set r
type LocalRegSet  = RegSet LocalReg
type GlobalRegSet = RegSet GlobalReg

311 312
emptyRegSet             :: RegSet r
nullRegSet              :: RegSet r -> Bool
313 314 315 316 317
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
318 319
sizeRegSet              :: RegSet r -> Int
regSetToList            :: RegSet r -> [r]
320 321 322 323 324 325 326 327 328 329 330 331

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
332

333 334 335 336 337 338
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
339

340 341
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
342

343 344 345 346 347 348 349 350 351 352 353
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
354

355 356 357
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
358

359 360 361
instance DefinerOfRegs GlobalReg CmmReg where
    foldRegsDefd _ _ z (CmmLocal _)    = z
    foldRegsDefd _ f z (CmmGlobal reg) = f z reg
362

363 364
instance Ord r => UserOfRegs r r where
    foldRegsUsed _ f z r = f z r
365

366 367
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
368

369 370
instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
  -- The (Ord r) in the context is necessary here
Sylvain Henry's avatar
Sylvain Henry committed
371
  -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance
372
  foldRegsUsed dflags f !z e = expr z e
373
    where expr z (CmmLit _)          = z
374 375 376 377
          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
378
          expr z (CmmStackSlot _ _)  = z
379

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

384
instance DefinerOfRegs r a => DefinerOfRegs r [a] where
385 386
  foldRegsDefd dflags f set as = foldl' (foldRegsDefd dflags f) set as
  {-# INLINABLE foldRegsDefd #-}
387

388
-----------------------------------------------------------------------------
389
--              Global STG registers
390
-----------------------------------------------------------------------------
391

392
data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
393 394

-----------------------------------------------------------------------------
395
--              Global STG registers
396
-----------------------------------------------------------------------------
397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414
{-
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.

415
Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap
416 417 418 419 420 421
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!
-}

422 423
data GlobalReg
  -- Argument and return registers
424 425 426
  = VanillaReg                  -- pointers, unboxed ints and chars
        {-# UNPACK #-} !Int     -- its number
        VGcPtr
427

428 429
  | FloatReg            -- single-precision floating-point registers
        {-# UNPACK #-} !Int     -- its number
430

431 432
  | DoubleReg           -- double-precision floating-point registers
        {-# UNPACK #-} !Int     -- its number
433

434 435
  | LongReg             -- long int registers (64-bit, really)
        {-# UNPACK #-} !Int     -- its number
436

437
  | XmmReg                      -- 128-bit SIMD vector register
438 439
        {-# UNPACK #-} !Int     -- its number

440
  | YmmReg                      -- 256-bit SIMD vector register
441 442
        {-# UNPACK #-} !Int     -- its number

443
  | ZmmReg                      -- 512-bit SIMD vector register
444 445
        {-# UNPACK #-} !Int     -- its number

446
  -- STG registers
447 448 449 450
  | 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
451 452
  | CCCS                -- Current cost-centre stack
  | CurrentTSO          -- pointer to current thread's TSO
453 454
  | CurrentNursery      -- pointer to allocation area
  | HpAlloc             -- allocation count for heap check failure
455

456 457 458
                -- We keep the address of some commonly-called
                -- functions in the register table, to keep code
                -- size down:
459
  | EagerBlackholeInfo  -- stg_EAGER_BLACKHOLE_info
460 461
  | GCEnter1            -- stg_gc_enter_1
  | GCFun               -- stg_gc_fun
462 463 464 465 466 467 468

  -- 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

469 470 471 472 473 474 475 476 477
  -- 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

478 479 480 481 482
  -- 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

483 484 485
  deriving( Show )

instance Eq GlobalReg where
486
   VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
487 488 489
   FloatReg i == FloatReg j = i==j
   DoubleReg i == DoubleReg j = i==j
   LongReg i == LongReg j = i==j
490 491 492 493 494 495
   -- NOTE: XMM, YMM, ZMM registers actually are the same registers
   -- at least with respect to store at YMM i and then read from XMM i
   -- and similarly for ZMM etc.
   XmmReg i == XmmReg j = i==j
   YmmReg i == YmmReg j = i==j
   ZmmReg i == ZmmReg j = i==j
496 497 498 499
   Sp == Sp = True
   SpLim == SpLim = True
   Hp == Hp = True
   HpLim == HpLim = True
500
   CCCS == CCCS = True
501 502 503
   CurrentTSO == CurrentTSO = True
   CurrentNursery == CurrentNursery = True
   HpAlloc == HpAlloc = True
504
   EagerBlackholeInfo == EagerBlackholeInfo = True
505 506 507
   GCEnter1 == GCEnter1 = True
   GCFun == GCFun = True
   BaseReg == BaseReg = True
508 509
   MachSp == MachSp = True
   UnwindReturnReg == UnwindReturnReg = True
510 511 512 513 514 515 516 517 518
   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
519 520 521
   compare (XmmReg i)    (XmmReg    j) = compare i j
   compare (YmmReg i)    (YmmReg    j) = compare i j
   compare (ZmmReg i)    (ZmmReg    j) = compare i j
522 523 524 525
   compare Sp Sp = EQ
   compare SpLim SpLim = EQ
   compare Hp Hp = EQ
   compare HpLim HpLim = EQ
526
   compare CCCS CCCS = EQ
527 528 529
   compare CurrentTSO CurrentTSO = EQ
   compare CurrentNursery CurrentNursery = EQ
   compare HpAlloc HpAlloc = EQ
530
   compare EagerBlackholeInfo EagerBlackholeInfo = EQ
531 532 533
   compare GCEnter1 GCEnter1 = EQ
   compare GCFun GCFun = EQ
   compare BaseReg BaseReg = EQ
534 535
   compare MachSp MachSp = EQ
   compare UnwindReturnReg UnwindReturnReg = EQ
536 537 538 539 540 541 542 543 544
   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
545 546 547 548 549 550
   compare (XmmReg _) _       = LT
   compare _ (XmmReg _)       = GT
   compare (YmmReg _) _       = LT
   compare _ (YmmReg _)       = GT
   compare (ZmmReg _) _       = LT
   compare _ (ZmmReg _)       = GT
551 552 553 554 555 556 557 558
   compare Sp _ = LT
   compare _ Sp = GT
   compare SpLim _ = LT
   compare _ SpLim = GT
   compare Hp _ = LT
   compare _ Hp = GT
   compare HpLim _ = LT
   compare _ HpLim = GT
559 560
   compare CCCS _ = LT
   compare _ CCCS = GT
561 562 563 564 565 566 567 568 569 570 571 572
   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
573 574 575 576
   compare MachSp _ = LT
   compare _ MachSp = GT
   compare UnwindReturnReg _ = LT
   compare _ UnwindReturnReg = GT
577 578
   compare EagerBlackholeInfo _ = LT
   compare _ EagerBlackholeInfo = GT
579 580

-- convenient aliases
581 582
baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,
  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg  :: CmmReg
tibbe's avatar
tibbe committed
583
baseReg = CmmGlobal BaseReg
584 585
spReg = CmmGlobal Sp
hpReg = CmmGlobal Hp
586
hpLimReg = CmmGlobal HpLim
587 588
spLimReg = CmmGlobal SpLim
nodeReg = CmmGlobal node
589 590 591 592
currentTSOReg = CmmGlobal CurrentTSO
currentNurseryReg = CmmGlobal CurrentNursery
hpAllocReg = CmmGlobal HpAlloc
cccsReg = CmmGlobal CCCS
593 594

node :: GlobalReg
595 596
node = VanillaReg 1 VGcPtr

597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613
globalRegType :: Platform -> GlobalReg -> CmmType
globalRegType platform = \case
   (VanillaReg _ VGcPtr)    -> gcWord platform
   (VanillaReg _ VNonGcPtr) -> bWord platform
   (FloatReg _)             -> cmmFloat W32
   (DoubleReg _)            -> cmmFloat W64
   (LongReg _)              -> cmmBits W64
   -- TODO: improve the internal model of SIMD/vectorized registers
   -- the right design SHOULd improve handling of float and double code too.
   -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim
   (XmmReg _) -> cmmVec 4 (cmmBits W32)
   (YmmReg _) -> cmmVec 8 (cmmBits W32)
   (ZmmReg _) -> cmmVec 16 (cmmBits W32)

   Hp         -> gcWord platform -- The initialiser for all
                                 -- dynamically allocated closures
   _          -> bWord platform
614 615 616 617 618 619

isArgReg :: GlobalReg -> Bool
isArgReg (VanillaReg {}) = True
isArgReg (FloatReg {})   = True
isArgReg (DoubleReg {})  = True
isArgReg (LongReg {})    = True
620
isArgReg (XmmReg {})     = True
621
isArgReg (YmmReg {})     = True
622
isArgReg (ZmmReg {})     = True
623
isArgReg _               = False