compiler/cmm/CmmExpr.hs

   1
   2 module CmmExpr
   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
  13     , regUsedIn
  14     , Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, isStackSlotOf
  15     , module CmmMachOp
  16     , module CmmType
  17     )
  18 where
  19
  20 #include "HsVersions.h"
  21
  22 import CmmType
  23 import CmmMachOp
  24 import BlockId
  25 import CLabel
  26 import Unique
  27 import UniqSet
  28
  29 import Data.Map (Map)
  30
  31 -----------------------------------------------------------------------------
  32 --              CmmExpr
  33 -- An expression.  Expressions have no side effects.
  34 -----------------------------------------------------------------------------
  35
  36 data CmmExpr
  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
  43         -- CmmRegOff reg i
  44         --        ** is shorthand only, meaning **
  45         -- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep)))
  46         --      where rep = cmmRegType reg
  47
  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
  55   _e1               == _e2               = False
  56
  57 data CmmReg
  58   = CmmLocal  LocalReg
  59   | CmmGlobal GlobalReg
  60   deriving( Eq, Ord )
  61
  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.
  64 data Area
  65   = RegSlot  LocalReg
  66   | CallArea AreaId
  67   deriving (Eq, Ord)
  68
  69 data AreaId
  70   = Old            -- See Note [Old Area]
  71   | Young BlockId
  72   deriving (Eq, Ord)
  73
  74 {- Note [Old Area]
  75 ~~~~~~~~~~~~~~~~~~
  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)
  78 which holds:
  79   * incoming (overflow) parameters,
  80   * outgoing (overflow) parameter to tail calls,
  81   * outgoing (overflow) result values
  82   * the update frame (if any)
  83
  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.
  87
  88 End of note -}
  89
  90 type SubArea    = (Area, Int, Int) -- area, offset, width
  91 type SubAreaSet = Map Area [SubArea]
  92
  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
  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   | CmmLabel    CLabel                  -- Address of label
 106   | CmmLabelOff CLabel Int              -- Address of label + byte offset
 107
 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
 118   deriving Eq
 119
 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
 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
 136
 137 cmmLabelType :: CLabel -> CmmType
 138 cmmLabelType lbl | isGcPtrLabel lbl = gcWord
 139                  | otherwise        = bWord
 140
 141 cmmExprWidth :: CmmExpr -> Width
 142 cmmExprWidth e = typeWidth (cmmExprType e)
 143
 144 --------
 145 --- Negation for conditional branches
 146
 147 maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
 148 maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
 149                                             return (CmmMachOp op' args)
 150 maybeInvertCmmExpr _ = Nothing
 151
 152 -----------------------------------------------------------------------------
 153 --              Local registers
 154 -----------------------------------------------------------------------------
 155
 156 data LocalReg
 157   = LocalReg !Unique CmmType
 158     -- ^ Parameters:
 159     --   1. Identifier
 160     --   2. Type
 161
 162 instance Eq LocalReg where
 163   (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
 164
 165 instance Ord LocalReg where
 166   compare (LocalReg u1 _) (LocalReg u2 _) = compare u1 u2
 167
 168 instance Uniquable LocalReg where
 169   getUnique (LocalReg uniq _) = uniq
 170
 171 cmmRegType :: CmmReg -> CmmType
 172 cmmRegType (CmmLocal  reg)      = localRegType reg
 173 cmmRegType (CmmGlobal reg)      = globalRegType reg
 174
 175 localRegType :: LocalReg -> CmmType
 176 localRegType (LocalReg _ rep) = rep
 177
 178 -----------------------------------------------------------------------------
 179 --    Register-use information for expressions and other types
 180 -----------------------------------------------------------------------------
 181
 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
 190
 191 emptyRegSet      = emptyUniqSet
 192 elemRegSet       = elementOfUniqSet
 193 extendRegSet     = addOneToUniqSet
 194 deleteFromRegSet = delOneFromUniqSet
 195 mkRegSet         = mkUniqSet
 196 minusRegSet      = minusUniqSet
 197 plusRegSet       = unionUniqSets
 198 timesRegSet      = intersectUniqSets
 199
 200 class UserOfLocalRegs a where
 201   foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b
 202
 203 class DefinerOfLocalRegs a where
 204   foldRegsDefd :: (b -> LocalReg -> b) -> b -> a -> b
 205
 206 filterRegsUsed :: UserOfLocalRegs e => (LocalReg -> Bool) -> e -> RegSet
 207 filterRegsUsed p e =
 208     foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs)
 209                  emptyRegSet e
 210
 211 instance UserOfLocalRegs CmmReg where
 212     foldRegsUsed f z (CmmLocal reg) = f z reg
 213     foldRegsUsed _ z (CmmGlobal _)  = z
 214
 215 instance DefinerOfLocalRegs CmmReg where
 216     foldRegsDefd f z (CmmLocal reg) = f z reg
 217     foldRegsDefd _ z (CmmGlobal _)  = z
 218
 219 instance UserOfLocalRegs LocalReg where
 220     foldRegsUsed f z r = f z r
 221
 222 instance DefinerOfLocalRegs LocalReg where
 223     foldRegsDefd f z r = f z r
 224
 225 instance UserOfLocalRegs RegSet where
 226     foldRegsUsed f = foldUniqSet (flip f)
 227
 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
 236
 237 instance UserOfLocalRegs a => UserOfLocalRegs [a] where
 238   foldRegsUsed _ set [] = set
 239   foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
 240
 241 instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
 242   foldRegsDefd _ set [] = set
 243   foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
 244
 245 instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
 246   foldRegsDefd _ set Nothing  = set
 247   foldRegsDefd f set (Just x) = foldRegsDefd f set x
 248
 249 -----------------------------------------------------------------------------
 250 -- Another reg utility
 251
 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
 259
 260 -----------------------------------------------------------------------------
 261 --    Stack slots
 262 -----------------------------------------------------------------------------
 263
 264 isStackSlotOf :: CmmExpr -> LocalReg -> Bool
 265 isStackSlotOf (CmmStackSlot (RegSlot r) _) r' = r == r'
 266 isStackSlotOf _ _ = False
 267
 268 -----------------------------------------------------------------------------
 269 --    Stack slot use information for expressions and other types [_$_]
 270 -----------------------------------------------------------------------------
 271
 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
 275
 276 class DefinerOfSlots a where
 277   foldSlotsDefd :: (b -> SubArea -> b) -> b -> a -> b
 278
 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
 288
 289 instance UserOfSlots a => UserOfSlots [a] where
 290   foldSlotsUsed _ set [] = set
 291   foldSlotsUsed f set (x:xs) = foldSlotsUsed f (foldSlotsUsed f set x) xs
 292
 293 instance DefinerOfSlots a => DefinerOfSlots [a] where
 294   foldSlotsDefd _ set [] = set
 295   foldSlotsDefd f set (x:xs) = foldSlotsDefd f (foldSlotsDefd f set x) xs
 296
 297 instance DefinerOfSlots SubArea where
 298     foldSlotsDefd f z a = f z a
 299
 300 -----------------------------------------------------------------------------
 301 --              Global STG registers
 302 -----------------------------------------------------------------------------
 303
 304 data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
 305         -- TEMPORARY!!!
 306
 307 -----------------------------------------------------------------------------
 308 --              Global STG registers
 309 -----------------------------------------------------------------------------
 310 vgcFlag :: CmmType -> VGcPtr
 311 vgcFlag ty | isGcPtrType ty = VGcPtr
 312            | otherwise      = VNonGcPtr
 313
 314 data GlobalReg
 315   -- Argument and return registers
 316   = VanillaReg                  -- pointers, unboxed ints and chars
 317         {-# UNPACK #-} !Int     -- its number
 318         VGcPtr
 319
 320   | FloatReg            -- single-precision floating-point registers
 321         {-# UNPACK #-} !Int     -- its number
 322
 323   | DoubleReg           -- double-precision floating-point registers
 324         {-# UNPACK #-} !Int     -- its number
 325
 326   | LongReg             -- long int registers (64-bit, really)
 327         {-# UNPACK #-} !Int     -- its number
 328
 329   -- STG registers
 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
 337
 338                 -- We keep the address of some commonly-called
 339                 -- functions in the register table, to keep code
 340                 -- size down:
 341   | EagerBlackholeInfo  -- stg_EAGER_BLACKHOLE_info
 342   | GCEnter1            -- stg_gc_enter_1
 343   | GCFun               -- stg_gc_fun
 344
 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.
 349   | BaseReg
 350
 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).
 354   | PicBaseReg
 355
 356   deriving( Show )
 357
 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
 363    Sp == Sp = True
 364    SpLim == SpLim = True
 365    Hp == Hp = 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
 374    _r1 == _r2 = False
 375
 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
 382    compare Sp Sp = EQ
 383    compare SpLim SpLim = EQ
 384    compare Hp Hp = 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
 402    compare Sp _ = LT
 403    compare _ Sp = GT
 404    compare SpLim _ = LT
 405    compare _ SpLim = GT
 406    compare Hp _ = LT
 407    compare _ Hp = GT
 408    compare HpLim _ = LT
 409    compare _ HpLim = 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
 418    compare GCFun _ = LT
 419    compare _ GCFun = GT
 420    compare BaseReg _ = LT
 421    compare _ BaseReg = GT
 422    compare EagerBlackholeInfo _ = LT
 423    compare _ EagerBlackholeInfo = GT
 424
 425 -- convenient aliases
 426 spReg, hpReg, spLimReg, nodeReg :: CmmReg
 427 spReg = CmmGlobal Sp
 428 hpReg = CmmGlobal Hp
 429 spLimReg = CmmGlobal SpLim
 430 nodeReg = CmmGlobal node
 431
 432 node :: GlobalReg
 433 node = VanillaReg 1 VGcPtr
 434
 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