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, baseReg
   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, regSlot
  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_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
  46         --      where rep = typeWidth (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 -- Careful though: what is stored at the stack slot may be bigger than
 128 -- an address
 129
 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
 138
 139 cmmLabelType :: CLabel -> CmmType
 140 cmmLabelType lbl | isGcPtrLabel lbl = gcWord
 141                  | otherwise        = bWord
 142
 143 cmmExprWidth :: CmmExpr -> Width
 144 cmmExprWidth e = typeWidth (cmmExprType e)
 145
 146 --------
 147 --- Negation for conditional branches
 148
 149 maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
 150 maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
 151                                             return (CmmMachOp op' args)
 152 maybeInvertCmmExpr _ = Nothing
 153
 154 -----------------------------------------------------------------------------
 155 --              Local registers
 156 -----------------------------------------------------------------------------
 157
 158 data LocalReg
 159   = LocalReg !Unique CmmType
 160     -- ^ Parameters:
 161     --   1. Identifier
 162     --   2. Type
 163
 164 instance Eq LocalReg where
 165   (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
 166
 167 instance Ord LocalReg where
 168   compare (LocalReg u1 _) (LocalReg u2 _) = compare u1 u2
 169
 170 instance Uniquable LocalReg where
 171   getUnique (LocalReg uniq _) = uniq
 172
 173 cmmRegType :: CmmReg -> CmmType
 174 cmmRegType (CmmLocal  reg)      = localRegType reg
 175 cmmRegType (CmmGlobal reg)      = globalRegType reg
 176
 177 localRegType :: LocalReg -> CmmType
 178 localRegType (LocalReg _ rep) = rep
 179
 180 -----------------------------------------------------------------------------
 181 --    Register-use information for expressions and other types
 182 -----------------------------------------------------------------------------
 183
 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
 192
 193 emptyRegSet      = emptyUniqSet
 194 elemRegSet       = elementOfUniqSet
 195 extendRegSet     = addOneToUniqSet
 196 deleteFromRegSet = delOneFromUniqSet
 197 mkRegSet         = mkUniqSet
 198 minusRegSet      = minusUniqSet
 199 plusRegSet       = unionUniqSets
 200 timesRegSet      = intersectUniqSets
 201
 202 class UserOfLocalRegs a where
 203   foldRegsUsed :: (b -> LocalReg -> b) -> b -> a -> b
 204
 205 class DefinerOfLocalRegs a where
 206   foldRegsDefd :: (b -> LocalReg -> b) -> b -> a -> b
 207
 208 filterRegsUsed :: UserOfLocalRegs e => (LocalReg -> Bool) -> e -> RegSet
 209 filterRegsUsed p e =
 210     foldRegsUsed (\regs r -> if p r then extendRegSet regs r else regs)
 211                  emptyRegSet e
 212
 213 instance UserOfLocalRegs CmmReg where
 214     foldRegsUsed f z (CmmLocal reg) = f z reg
 215     foldRegsUsed _ z (CmmGlobal _)  = z
 216
 217 instance DefinerOfLocalRegs CmmReg where
 218     foldRegsDefd f z (CmmLocal reg) = f z reg
 219     foldRegsDefd _ z (CmmGlobal _)  = z
 220
 221 instance UserOfLocalRegs LocalReg where
 222     foldRegsUsed f z r = f z r
 223
 224 instance DefinerOfLocalRegs LocalReg where
 225     foldRegsDefd f z r = f z r
 226
 227 instance UserOfLocalRegs RegSet where
 228     foldRegsUsed f = foldUniqSet (flip f)
 229
 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
 238
 239 instance UserOfLocalRegs a => UserOfLocalRegs [a] where
 240   foldRegsUsed _ set [] = set
 241   foldRegsUsed f set (x:xs) = foldRegsUsed f (foldRegsUsed f set x) xs
 242
 243 instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where
 244   foldRegsDefd _ set [] = set
 245   foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs
 246
 247 instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where
 248   foldRegsDefd _ set Nothing  = set
 249   foldRegsDefd f set (Just x) = foldRegsDefd f set x
 250
 251 -----------------------------------------------------------------------------
 252 -- Another reg utility
 253
 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
 261
 262 -----------------------------------------------------------------------------
 263 --    Stack slots
 264 -----------------------------------------------------------------------------
 265
 266 isStackSlotOf :: CmmExpr -> LocalReg -> Bool
 267 isStackSlotOf (CmmStackSlot (RegSlot r) _) r' = r == r'
 268 isStackSlotOf _ _ = False
 269
 270 regSlot :: LocalReg -> CmmExpr
 271 regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
 272
 273 -----------------------------------------------------------------------------
 274 --    Stack slot use information for expressions and other types [_$_]
 275 -----------------------------------------------------------------------------
 276
 277 -- Fold over the area, the offset into the area, and the width of the subarea.
 278 class UserOfSlots a where
 279   foldSlotsUsed :: (b -> SubArea -> b) -> b -> a -> b
 280
 281 class DefinerOfSlots a where
 282   foldSlotsDefd :: (b -> SubArea -> b) -> b -> a -> b
 283
 284 instance UserOfSlots CmmExpr where
 285   foldSlotsUsed f z e = expr z e
 286     where expr z (CmmLit _)          = z
 287           expr z (CmmLoad (CmmStackSlot a i) ty) = f z (a, i, widthInBytes $ typeWidth ty)
 288           expr z (CmmLoad addr _)    = foldSlotsUsed f z addr
 289           expr z (CmmReg _)          = z
 290           expr z (CmmMachOp _ exprs) = foldSlotsUsed f z exprs
 291           expr z (CmmRegOff _ _)     = z
 292           expr z (CmmStackSlot _ _)  = z
 293
 294 instance UserOfSlots a => UserOfSlots [a] where
 295   foldSlotsUsed _ set [] = set
 296   foldSlotsUsed f set (x:xs) = foldSlotsUsed f (foldSlotsUsed f set x) xs
 297
 298 instance DefinerOfSlots a => DefinerOfSlots [a] where
 299   foldSlotsDefd _ set [] = set
 300   foldSlotsDefd f set (x:xs) = foldSlotsDefd f (foldSlotsDefd f set x) xs
 301
 302 instance DefinerOfSlots SubArea where
 303     foldSlotsDefd f z a = f z a
 304
 305 -----------------------------------------------------------------------------
 306 --              Global STG registers
 307 -----------------------------------------------------------------------------
 308
 309 data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
 310         -- TEMPORARY!!!
 311
 312 -----------------------------------------------------------------------------
 313 --              Global STG registers
 314 -----------------------------------------------------------------------------
 315 vgcFlag :: CmmType -> VGcPtr
 316 vgcFlag ty | isGcPtrType ty = VGcPtr
 317            | otherwise      = VNonGcPtr
 318
 319 data GlobalReg
 320   -- Argument and return registers
 321   = VanillaReg                  -- pointers, unboxed ints and chars
 322         {-# UNPACK #-} !Int     -- its number
 323         VGcPtr
 324
 325   | FloatReg            -- single-precision floating-point registers
 326         {-# UNPACK #-} !Int     -- its number
 327
 328   | DoubleReg           -- double-precision floating-point registers
 329         {-# UNPACK #-} !Int     -- its number
 330
 331   | LongReg             -- long int registers (64-bit, really)
 332         {-# UNPACK #-} !Int     -- its number
 333
 334   -- STG registers
 335   | Sp                  -- Stack ptr; points to last occupied stack location.
 336   | SpLim               -- Stack limit
 337   | Hp                  -- Heap ptr; points to last occupied heap location.
 338   | HpLim               -- Heap limit register
 339   | CurrentTSO          -- pointer to current thread's TSO
 340   | CurrentNursery      -- pointer to allocation area
 341   | HpAlloc             -- allocation count for heap check failure
 342
 343                 -- We keep the address of some commonly-called
 344                 -- functions in the register table, to keep code
 345                 -- size down:
 346   | EagerBlackholeInfo  -- stg_EAGER_BLACKHOLE_info
 347   | GCEnter1            -- stg_gc_enter_1
 348   | GCFun               -- stg_gc_fun
 349
 350   -- Base offset for the register table, used for accessing registers
 351   -- which do not have real registers assigned to them.  This register
 352   -- will only appear after we have expanded GlobalReg into memory accesses
 353   -- (where necessary) in the native code generator.
 354   | BaseReg
 355
 356   -- Base Register for PIC (position-independent code) calculations
 357   -- Only used inside the native code generator. It's exact meaning differs
 358   -- from platform to platform (see module PositionIndependentCode).
 359   | PicBaseReg
 360
 361   deriving( Show )
 362
 363 instance Eq GlobalReg where
 364    VanillaReg i _ == VanillaReg j _ = i==j      -- Ignore type when seeking clashes
 365    FloatReg i == FloatReg j = i==j
 366    DoubleReg i == DoubleReg j = i==j
 367    LongReg i == LongReg j = i==j
 368    Sp == Sp = True
 369    SpLim == SpLim = True
 370    Hp == Hp = True
 371    HpLim == HpLim = True
 372    CurrentTSO == CurrentTSO = True
 373    CurrentNursery == CurrentNursery = True
 374    HpAlloc == HpAlloc = True
 375    GCEnter1 == GCEnter1 = True
 376    GCFun == GCFun = True
 377    BaseReg == BaseReg = True
 378    PicBaseReg == PicBaseReg = True
 379    _r1 == _r2 = False
 380
 381 instance Ord GlobalReg where
 382    compare (VanillaReg i _) (VanillaReg j _) = compare i j
 383      -- Ignore type when seeking clashes
 384    compare (FloatReg i)  (FloatReg  j) = compare i j
 385    compare (DoubleReg i) (DoubleReg j) = compare i j
 386    compare (LongReg i)   (LongReg   j) = compare i j
 387    compare Sp Sp = EQ
 388    compare SpLim SpLim = EQ
 389    compare Hp Hp = EQ
 390    compare HpLim HpLim = EQ
 391    compare CurrentTSO CurrentTSO = EQ
 392    compare CurrentNursery CurrentNursery = EQ
 393    compare HpAlloc HpAlloc = EQ
 394    compare EagerBlackholeInfo EagerBlackholeInfo = EQ
 395    compare GCEnter1 GCEnter1 = EQ
 396    compare GCFun GCFun = EQ
 397    compare BaseReg BaseReg = EQ
 398    compare PicBaseReg PicBaseReg = EQ
 399    compare (VanillaReg _ _) _ = LT
 400    compare _ (VanillaReg _ _) = GT
 401    compare (FloatReg _) _     = LT
 402    compare _ (FloatReg _)     = GT
 403    compare (DoubleReg _) _    = LT
 404    compare _ (DoubleReg _)    = GT
 405    compare (LongReg _) _      = LT
 406    compare _ (LongReg _)      = GT
 407    compare Sp _ = LT
 408    compare _ Sp = GT
 409    compare SpLim _ = LT
 410    compare _ SpLim = GT
 411    compare Hp _ = LT
 412    compare _ Hp = GT
 413    compare HpLim _ = LT
 414    compare _ HpLim = GT
 415    compare CurrentTSO _ = LT
 416    compare _ CurrentTSO = GT
 417    compare CurrentNursery _ = LT
 418    compare _ CurrentNursery = GT
 419    compare HpAlloc _ = LT
 420    compare _ HpAlloc = GT
 421    compare GCEnter1 _ = LT
 422    compare _ GCEnter1 = GT
 423    compare GCFun _ = LT
 424    compare _ GCFun = GT
 425    compare BaseReg _ = LT
 426    compare _ BaseReg = GT
 427    compare EagerBlackholeInfo _ = LT
 428    compare _ EagerBlackholeInfo = GT
 429
 430 -- convenient aliases
 431 baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg
 432 baseReg = CmmGlobal BaseReg
 433 spReg = CmmGlobal Sp
 434 hpReg = CmmGlobal Hp
 435 spLimReg = CmmGlobal SpLim
 436 nodeReg = CmmGlobal node
 437
 438 node :: GlobalReg
 439 node = VanillaReg 1 VGcPtr
 440
 441 globalRegType :: GlobalReg -> CmmType
 442 globalRegType (VanillaReg _ VGcPtr)    = gcWord
 443 globalRegType (VanillaReg _ VNonGcPtr) = bWord
 444 globalRegType (FloatReg _)      = cmmFloat W32
 445 globalRegType (DoubleReg _)     = cmmFloat W64
 446 globalRegType (LongReg _)       = cmmBits W64
 447 globalRegType Hp                = gcWord        -- The initialiser for all
 448                                                 -- dynamically allocated closures
 449 globalRegType _                 = bWord