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_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 -----------------------------------------------------------------------------
 271 --    Stack slot use information for expressions and other types [_$_]
 272 -----------------------------------------------------------------------------
 273
 274 -- Fold over the area, the offset into the area, and the width of the subarea.
 275 class UserOfSlots a where
 276   foldSlotsUsed :: (b -> SubArea -> b) -> b -> a -> b
 277
 278 class DefinerOfSlots a where
 279   foldSlotsDefd :: (b -> SubArea -> b) -> b -> a -> b
 280
 281 instance UserOfSlots CmmExpr where
 282   foldSlotsUsed f z e = expr z e
 283     where expr z (CmmLit _)          = z
 284           expr z (CmmLoad (CmmStackSlot a i) ty) = f z (a, i, widthInBytes $ typeWidth ty)
 285           expr z (CmmLoad addr _)    = foldSlotsUsed f z addr
 286           expr z (CmmReg _)          = z
 287           expr z (CmmMachOp _ exprs) = foldSlotsUsed f z exprs
 288           expr z (CmmRegOff _ _)     = z
 289           expr z (CmmStackSlot _ _)  = z
 290
 291 instance UserOfSlots a => UserOfSlots [a] where
 292   foldSlotsUsed _ set [] = set
 293   foldSlotsUsed f set (x:xs) = foldSlotsUsed f (foldSlotsUsed f set x) xs
 294
 295 instance DefinerOfSlots a => DefinerOfSlots [a] where
 296   foldSlotsDefd _ set [] = set
 297   foldSlotsDefd f set (x:xs) = foldSlotsDefd f (foldSlotsDefd f set x) xs
 298
 299 instance DefinerOfSlots SubArea where
 300     foldSlotsDefd f z a = f z a
 301
 302 -----------------------------------------------------------------------------
 303 --              Global STG registers
 304 -----------------------------------------------------------------------------
 305
 306 data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
 307         -- TEMPORARY!!!
 308
 309 -----------------------------------------------------------------------------
 310 --              Global STG registers
 311 -----------------------------------------------------------------------------
 312 vgcFlag :: CmmType -> VGcPtr
 313 vgcFlag ty | isGcPtrType ty = VGcPtr
 314            | otherwise      = VNonGcPtr
 315
 316 data GlobalReg
 317   -- Argument and return registers
 318   = VanillaReg                  -- pointers, unboxed ints and chars
 319         {-# UNPACK #-} !Int     -- its number
 320         VGcPtr
 321
 322   | FloatReg            -- single-precision floating-point registers
 323         {-# UNPACK #-} !Int     -- its number
 324
 325   | DoubleReg           -- double-precision floating-point registers
 326         {-# UNPACK #-} !Int     -- its number
 327
 328   | LongReg             -- long int registers (64-bit, really)
 329         {-# UNPACK #-} !Int     -- its number
 330
 331   -- STG registers
 332   | Sp                  -- Stack ptr; points to last occupied stack location.
 333   | SpLim               -- Stack limit
 334   | Hp                  -- Heap ptr; points to last occupied heap location.
 335   | HpLim               -- Heap limit register
 336   | CurrentTSO          -- pointer to current thread's TSO
 337   | CurrentNursery      -- pointer to allocation area
 338   | HpAlloc             -- allocation count for heap check failure
 339
 340                 -- We keep the address of some commonly-called
 341                 -- functions in the register table, to keep code
 342                 -- size down:
 343   | EagerBlackholeInfo  -- stg_EAGER_BLACKHOLE_info
 344   | GCEnter1            -- stg_gc_enter_1
 345   | GCFun               -- stg_gc_fun
 346
 347   -- Base offset for the register table, used for accessing registers
 348   -- which do not have real registers assigned to them.  This register
 349   -- will only appear after we have expanded GlobalReg into memory accesses
 350   -- (where necessary) in the native code generator.
 351   | BaseReg
 352
 353   -- Base Register for PIC (position-independent code) calculations
 354   -- Only used inside the native code generator. It's exact meaning differs
 355   -- from platform to platform (see module PositionIndependentCode).
 356   | PicBaseReg
 357
 358   deriving( Show )
 359
 360 instance Eq GlobalReg where
 361    VanillaReg i _ == VanillaReg j _ = i==j      -- Ignore type when seeking clashes
 362    FloatReg i == FloatReg j = i==j
 363    DoubleReg i == DoubleReg j = i==j
 364    LongReg i == LongReg j = i==j
 365    Sp == Sp = True
 366    SpLim == SpLim = True
 367    Hp == Hp = True
 368    HpLim == HpLim = True
 369    CurrentTSO == CurrentTSO = True
 370    CurrentNursery == CurrentNursery = True
 371    HpAlloc == HpAlloc = True
 372    GCEnter1 == GCEnter1 = True
 373    GCFun == GCFun = True
 374    BaseReg == BaseReg = True
 375    PicBaseReg == PicBaseReg = True
 376    _r1 == _r2 = False
 377
 378 instance Ord GlobalReg where
 379    compare (VanillaReg i _) (VanillaReg j _) = compare i j
 380      -- Ignore type when seeking clashes
 381    compare (FloatReg i)  (FloatReg  j) = compare i j
 382    compare (DoubleReg i) (DoubleReg j) = compare i j
 383    compare (LongReg i)   (LongReg   j) = compare i j
 384    compare Sp Sp = EQ
 385    compare SpLim SpLim = EQ
 386    compare Hp Hp = EQ
 387    compare HpLim HpLim = EQ
 388    compare CurrentTSO CurrentTSO = EQ
 389    compare CurrentNursery CurrentNursery = EQ
 390    compare HpAlloc HpAlloc = EQ
 391    compare EagerBlackholeInfo EagerBlackholeInfo = EQ
 392    compare GCEnter1 GCEnter1 = EQ
 393    compare GCFun GCFun = EQ
 394    compare BaseReg BaseReg = EQ
 395    compare PicBaseReg PicBaseReg = EQ
 396    compare (VanillaReg _ _) _ = LT
 397    compare _ (VanillaReg _ _) = GT
 398    compare (FloatReg _) _     = LT
 399    compare _ (FloatReg _)     = GT
 400    compare (DoubleReg _) _    = LT
 401    compare _ (DoubleReg _)    = GT
 402    compare (LongReg _) _      = LT
 403    compare _ (LongReg _)      = GT
 404    compare Sp _ = LT
 405    compare _ Sp = GT
 406    compare SpLim _ = LT
 407    compare _ SpLim = GT
 408    compare Hp _ = LT
 409    compare _ Hp = GT
 410    compare HpLim _ = LT
 411    compare _ HpLim = GT
 412    compare CurrentTSO _ = LT
 413    compare _ CurrentTSO = GT
 414    compare CurrentNursery _ = LT
 415    compare _ CurrentNursery = GT
 416    compare HpAlloc _ = LT
 417    compare _ HpAlloc = GT
 418    compare GCEnter1 _ = LT
 419    compare _ GCEnter1 = GT
 420    compare GCFun _ = LT
 421    compare _ GCFun = GT
 422    compare BaseReg _ = LT
 423    compare _ BaseReg = GT
 424    compare EagerBlackholeInfo _ = LT
 425    compare _ EagerBlackholeInfo = GT
 426
 427 -- convenient aliases
 428 spReg, hpReg, spLimReg, nodeReg :: CmmReg
 429 spReg = CmmGlobal Sp
 430 hpReg = CmmGlobal Hp
 431 spLimReg = CmmGlobal SpLim
 432 nodeReg = CmmGlobal node
 433
 434 node :: GlobalReg
 435 node = VanillaReg 1 VGcPtr
 436
 437 globalRegType :: GlobalReg -> CmmType
 438 globalRegType (VanillaReg _ VGcPtr)    = gcWord
 439 globalRegType (VanillaReg _ VNonGcPtr) = bWord
 440 globalRegType (FloatReg _)      = cmmFloat W32
 441 globalRegType (DoubleReg _)     = cmmFloat W64
 442 globalRegType (LongReg _)       = cmmBits W64
 443 globalRegType Hp                = gcWord        -- The initialiser for all
 444                                                 -- dynamically allocated closures
 445 globalRegType _                 = bWord