compiler/codeGen/CgUtils.hs

   1 {-# OPTIONS -w #-}
   2 -- The above warning supression flag is a temporary kludge.
   3 -- While working on this module you are encouraged to remove it and fix
   4 -- any warnings in the module. See
   5 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
   6 -- for details
   7
   8 -----------------------------------------------------------------------------
   9 --
  10 -- Code generator utilities; mostly monadic
  11 --
  12 -- (c) The University of Glasgow 2004-2006
  13 --
  14 -----------------------------------------------------------------------------
  15
  16 module CgUtils (
  17         addIdReps,
  18         cgLit,
  19         emitDataLits, mkDataLits,
  20         emitRODataLits, mkRODataLits,
  21         emitIf, emitIfThenElse,
  22         emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
  23         assignTemp, assignTemp_, newTemp,
  24         emitSimultaneously,
  25         emitSwitch, emitLitSwitch,
  26         tagToClosure,
  27
  28         callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
  29         activeStgRegs, fixStgRegisters,
  30
  31         cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
  32         cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
  33         cmmOffsetExprW, cmmOffsetExprB,
  34         cmmRegOffW, cmmRegOffB,
  35         cmmLabelOffW, cmmLabelOffB,
  36         cmmOffsetW, cmmOffsetB,
  37         cmmOffsetLitW, cmmOffsetLitB,
  38         cmmLoadIndexW,
  39         cmmConstrTag, cmmConstrTag1,
  40
  41         tagForCon, tagCons, isSmallFamily,
  42         cmmUntag, cmmIsTagged, cmmGetTag,
  43
  44         addToMem, addToMemE,
  45         mkWordCLit,
  46         mkStringCLit, mkByteStringCLit,
  47         packHalfWordsCLit,
  48         blankWord,
  49
  50         getSRTInfo, clHasCafRefs
  51   ) where
  52
  53 #include "HsVersions.h"
  54 #include "../includes/stg/MachRegs.h"
  55
  56 import BlockId
  57 import CgMonad
  58 import TyCon
  59 import DataCon
  60 import Id
  61 import IdInfo
  62 import Constants
  63 import SMRep
  64 import OldCmm
  65 import OldCmmUtils
  66 import CLabel
  67 import ForeignCall
  68 import ClosureInfo
  69 import StgSyn (SRT(..))
  70 import Module
  71 import Literal
  72 import Digraph
  73 import ListSetOps
  74 import Util
  75 import DynFlags
  76 import FastString
  77 import PackageConfig
  78 import Outputable
  79
  80 import Data.Char
  81 import Data.Bits
  82 import Data.Word
  83 import Data.Maybe
  84
  85 -------------------------------------------------------------------------
  86 --
  87 --      Random small functions
  88 --
  89 -------------------------------------------------------------------------
  90
  91 addIdReps :: [Id] -> [(CgRep, Id)]
  92 addIdReps ids = [(idCgRep id, id) | id <- ids]
  93
  94 -------------------------------------------------------------------------
  95 --
  96 --      Literals
  97 --
  98 -------------------------------------------------------------------------
  99
 100 cgLit :: Literal -> FCode CmmLit
 101 cgLit (MachStr s) = mkByteStringCLit (bytesFS s)
 102  -- not unpackFS; we want the UTF-8 byte stream.
 103 cgLit other_lit   = return (mkSimpleLit other_lit)
 104
 105 mkSimpleLit :: Literal -> CmmLit
 106 mkSimpleLit (MachChar   c)    = CmmInt (fromIntegral (ord c)) wordWidth
 107 mkSimpleLit MachNullAddr      = zeroCLit
 108 mkSimpleLit (MachInt i)       = CmmInt i wordWidth
 109 mkSimpleLit (MachInt64 i)     = CmmInt i W64
 110 mkSimpleLit (MachWord i)      = CmmInt i wordWidth
 111 mkSimpleLit (MachWord64 i)    = CmmInt i W64
 112 mkSimpleLit (MachFloat r)     = CmmFloat r W32
 113 mkSimpleLit (MachDouble r)    = CmmFloat r W64
 114 mkSimpleLit (MachLabel fs ms fod)
 115         = CmmLabel (mkForeignLabel fs ms labelSrc fod)
 116         where
 117                 -- TODO: Literal labels might not actually be in the current package...
 118                 labelSrc = ForeignLabelInThisPackage
 119
 120 mkLtOp :: Literal -> MachOp
 121 -- On signed literals we must do a signed comparison
 122 mkLtOp (MachInt _)    = MO_S_Lt wordWidth
 123 mkLtOp (MachFloat _)  = MO_F_Lt W32
 124 mkLtOp (MachDouble _) = MO_F_Lt W64
 125 mkLtOp lit            = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit)))
 126
 127
 128 ---------------------------------------------------
 129 --
 130 --      Cmm data type functions
 131 --
 132 ---------------------------------------------------
 133
 134 -----------------------
 135 -- The "B" variants take byte offsets
 136 cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
 137 cmmRegOffB = cmmRegOff
 138
 139 cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr
 140 cmmOffsetB = cmmOffset
 141
 142 cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr
 143 cmmOffsetExprB = cmmOffsetExpr
 144
 145 cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
 146 cmmLabelOffB = cmmLabelOff
 147
 148 cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
 149 cmmOffsetLitB = cmmOffsetLit
 150
 151 -----------------------
 152 -- The "W" variants take word offsets
 153 cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
 154 -- The second arg is a *word* offset; need to change it to bytes
 155 cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
 156 cmmOffsetExprW e wd_off = cmmIndexExpr wordWidth e wd_off
 157
 158 cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
 159 cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)
 160
 161 cmmRegOffW :: CmmReg -> WordOff -> CmmExpr
 162 cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE)
 163
 164 cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit
 165 cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off)
 166
 167 cmmLabelOffW :: CLabel -> WordOff -> CmmLit
 168 cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)
 169
 170 cmmLoadIndexW :: CmmExpr -> Int -> CmmType -> CmmExpr
 171 cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty
 172
 173 -----------------------
 174 cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord :: CmmExpr -> CmmExpr -> CmmExpr
 175 cmmOrWord  e1 e2 = CmmMachOp mo_wordOr  [e1, e2]
 176 cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
 177 cmmNeWord  e1 e2 = CmmMachOp mo_wordNe  [e1, e2]
 178 cmmEqWord  e1 e2 = CmmMachOp mo_wordEq  [e1, e2]
 179 cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
 180 cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
 181 cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
 182 --cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
 183 cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
 184 cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2]
 185 cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
 186 cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2]
 187
 188 cmmNegate :: CmmExpr -> CmmExpr
 189 cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
 190 cmmNegate e                       = CmmMachOp (MO_S_Neg (cmmExprWidth e)) [e]
 191
 192 blankWord :: CmmStatic
 193 blankWord = CmmUninitialised wORD_SIZE
 194
 195 -- Tagging --
 196 -- Tag bits mask
 197 --cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
 198 cmmTagMask = CmmLit (mkIntCLit tAG_MASK)
 199 cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK))
 200
 201 -- Used to untag a possibly tagged pointer
 202 -- A static label need not be untagged
 203 cmmUntag e@(CmmLit (CmmLabel _)) = e
 204 -- Default case
 205 cmmUntag e = (e `cmmAndWord` cmmPointerMask)
 206
 207 cmmGetTag e = (e `cmmAndWord` cmmTagMask)
 208
 209 -- Test if a closure pointer is untagged
 210 cmmIsTagged e = (e `cmmAndWord` cmmTagMask)
 211                  `cmmNeWord` CmmLit zeroCLit
 212
 213 cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1))
 214 -- Get constructor tag, but one based.
 215 cmmConstrTag1 e = e `cmmAndWord` cmmTagMask
 216
 217 {-
 218    The family size of a data type (the number of constructors)
 219    can be either:
 220     * small, if the family size < 2**tag_bits
 221     * big, otherwise.
 222
 223    Small families can have the constructor tag in the tag
 224    bits.
 225    Big families only use the tag value 1 to represent
 226    evaluatedness.
 227 -}
 228 isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
 229
 230 tagForCon con = tag
 231     where
 232     con_tag           = dataConTagZ con
 233     fam_size   = tyConFamilySize (dataConTyCon con)
 234     tag | isSmallFamily fam_size = con_tag + 1
 235         | otherwise              = 1
 236
 237 --Tag an expression, to do: refactor, this appears in some other module.
 238 tagCons con expr = cmmOffsetB expr (tagForCon con)
 239
 240 -- Copied from CgInfoTbls.hs
 241 -- We keep the *zero-indexed* tag in the srt_len field of the info
 242 -- table of a data constructor.
 243 dataConTagZ :: DataCon -> ConTagZ
 244 dataConTagZ con = dataConTag con - fIRST_TAG
 245
 246 -----------------------
 247 --      Making literals
 248
 249 mkWordCLit :: StgWord -> CmmLit
 250 mkWordCLit wd = CmmInt (fromIntegral wd) wordWidth
 251
 252 packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
 253 -- Make a single word literal in which the lower_half_word is
 254 -- at the lower address, and the upper_half_word is at the
 255 -- higher address
 256 -- ToDo: consider using half-word lits instead
 257 --       but be careful: that's vulnerable when reversed
 258 packHalfWordsCLit lower_half_word upper_half_word
 259 #ifdef WORDS_BIGENDIAN
 260    = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
 261                  .|. fromIntegral upper_half_word)
 262 #else
 263    = mkWordCLit ((fromIntegral lower_half_word)
 264                  .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
 265 #endif
 266
 267 --------------------------------------------------------------------------
 268 --
 269 -- Incrementing a memory location
 270 --
 271 --------------------------------------------------------------------------
 272
 273 addToMem :: Width       -- rep of the counter
 274          -> CmmExpr     -- Address
 275          -> Int         -- What to add (a word)
 276          -> CmmStmt
 277 addToMem width ptr n = addToMemE width ptr (CmmLit (CmmInt (toInteger n) width))
 278
 279 addToMemE :: Width      -- rep of the counter
 280           -> CmmExpr    -- Address
 281           -> CmmExpr    -- What to add (a word-typed expression)
 282           -> CmmStmt
 283 addToMemE width ptr n
 284   = CmmStore ptr (CmmMachOp (MO_Add width) [CmmLoad ptr (cmmBits width), n])
 285
 286 -------------------------------------------------------------------------
 287 --
 288 --      Converting a closure tag to a closure for enumeration types
 289 --      (this is the implementation of tagToEnum#).
 290 --
 291 -------------------------------------------------------------------------
 292
 293 tagToClosure :: TyCon -> CmmExpr -> CmmExpr
 294 tagToClosure tycon tag
 295   = CmmLoad (cmmOffsetExprW closure_tbl tag) gcWord
 296   where closure_tbl = CmmLit (CmmLabel lbl)
 297         lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
 298
 299 -------------------------------------------------------------------------
 300 --
 301 --      Conditionals and rts calls
 302 --
 303 -------------------------------------------------------------------------
 304
 305 emitIf :: CmmExpr       -- Boolean
 306        -> Code          -- Then part
 307        -> Code
 308 -- Emit (if e then x)
 309 -- ToDo: reverse the condition to avoid the extra branch instruction if possible
 310 -- (some conditionals aren't reversible. eg. floating point comparisons cannot
 311 -- be inverted because there exist some values for which both comparisons
 312 -- return False, such as NaN.)
 313 emitIf cond then_part
 314   = do { then_id <- newLabelC
 315        ; join_id <- newLabelC
 316        ; stmtC (CmmCondBranch cond then_id)
 317        ; stmtC (CmmBranch join_id)
 318        ; labelC then_id
 319        ; then_part
 320        ; labelC join_id
 321        }
 322
 323 emitIfThenElse :: CmmExpr       -- Boolean
 324                 -> Code         -- Then part
 325                 -> Code         -- Else part
 326                 -> Code
 327 -- Emit (if e then x else y)
 328 emitIfThenElse cond then_part else_part
 329   = do { then_id <- newLabelC
 330        ; join_id <- newLabelC
 331        ; stmtC (CmmCondBranch cond then_id)
 332        ; else_part
 333        ; stmtC (CmmBranch join_id)
 334        ; labelC then_id
 335        ; then_part
 336        ; labelC join_id
 337        }
 338
 339
 340 -- | Emit code to call a Cmm function.
 341 emitRtsCall
 342    :: PackageId                 -- ^ package the function is in
 343    -> FastString                -- ^ name of function
 344    -> [CmmHinted CmmExpr]       -- ^ function args
 345    -> Bool                      -- ^ whether this is a safe call
 346    -> Code                      -- ^ cmm code
 347
 348 emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe
 349    -- The 'Nothing' says "save all global registers"
 350
 351 emitRtsCallWithVols :: PackageId -> FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code
 352 emitRtsCallWithVols pkg fun args vols safe
 353    = emitRtsCall' [] pkg fun args (Just vols) safe
 354
 355 emitRtsCallWithResult
 356    :: LocalReg -> ForeignHint
 357    -> PackageId -> FastString
 358    -> [CmmHinted CmmExpr] -> Bool -> Code
 359 emitRtsCallWithResult res hint pkg fun args safe
 360    = emitRtsCall' [CmmHinted res hint] pkg fun args Nothing safe
 361
 362 -- Make a call to an RTS C procedure
 363 emitRtsCall'
 364    :: [CmmHinted LocalReg]
 365    -> PackageId
 366    -> FastString
 367    -> [CmmHinted CmmExpr]
 368    -> Maybe [GlobalReg]
 369    -> Bool -- True <=> CmmSafe call
 370    -> Code
 371 emitRtsCall' res pkg fun args vols safe = do
 372   safety <- if safe
 373             then getSRTInfo >>= (return . CmmSafe)
 374             else return CmmUnsafe
 375   stmtsC caller_save
 376   stmtC (CmmCall target res args safety CmmMayReturn)
 377   stmtsC caller_load
 378   where
 379     (caller_save, caller_load) = callerSaveVolatileRegs vols
 380     target   = CmmCallee fun_expr CCallConv
 381     fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
 382
 383 -----------------------------------------------------------------------------
 384 --
 385 --      Caller-Save Registers
 386 --
 387 -----------------------------------------------------------------------------
 388
 389 -- Here we generate the sequence of saves/restores required around a
 390 -- foreign call instruction.
 391
 392 -- TODO: reconcile with includes/Regs.h
 393 --  * Regs.h claims that BaseReg should be saved last and loaded first
 394 --    * This might not have been tickled before since BaseReg is callee save
 395 --  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
 396 callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
 397 callerSaveVolatileRegs vols = (caller_save, caller_load)
 398   where
 399     caller_save = foldr ($!) [] (map callerSaveGlobalReg    regs_to_save)
 400     caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save)
 401
 402     system_regs = [Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery,
 403                    {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ]
 404
 405     regs_to_save = system_regs ++ vol_list
 406
 407     vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
 408
 409     all_of_em = [ VanillaReg n VNonGcPtr | n <- [0..mAX_Vanilla_REG] ]
 410                         -- The VNonGcPtr is a lie, but I don't think it matters
 411              ++ [ FloatReg   n | n <- [0..mAX_Float_REG] ]
 412              ++ [ DoubleReg  n | n <- [0..mAX_Double_REG] ]
 413              ++ [ LongReg    n | n <- [0..mAX_Long_REG] ]
 414
 415     callerSaveGlobalReg reg next
 416         | callerSaves reg =
 417                 CmmStore (get_GlobalReg_addr reg)
 418                          (CmmReg (CmmGlobal reg)) : next
 419         | otherwise = next
 420
 421     callerRestoreGlobalReg reg next
 422         | callerSaves reg =
 423                 CmmAssign (CmmGlobal reg)
 424                           (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
 425                         : next
 426         | otherwise = next
 427
 428
 429 -- | Returns @True@ if this global register is stored in a caller-saves
 430 -- machine register.
 431
 432 callerSaves :: GlobalReg -> Bool
 433
 434 #ifdef CALLER_SAVES_Base
 435 callerSaves BaseReg             = True
 436 #endif
 437 #ifdef CALLER_SAVES_R1
 438 callerSaves (VanillaReg 1 _)    = True
 439 #endif
 440 #ifdef CALLER_SAVES_R2
 441 callerSaves (VanillaReg 2 _)    = True
 442 #endif
 443 #ifdef CALLER_SAVES_R3
 444 callerSaves (VanillaReg 3 _)    = True
 445 #endif
 446 #ifdef CALLER_SAVES_R4
 447 callerSaves (VanillaReg 4 _)    = True
 448 #endif
 449 #ifdef CALLER_SAVES_R5
 450 callerSaves (VanillaReg 5 _)    = True
 451 #endif
 452 #ifdef CALLER_SAVES_R6
 453 callerSaves (VanillaReg 6 _)    = True
 454 #endif
 455 #ifdef CALLER_SAVES_R7
 456 callerSaves (VanillaReg 7 _)    = True
 457 #endif
 458 #ifdef CALLER_SAVES_R8
 459 callerSaves (VanillaReg 8 _)    = True
 460 #endif
 461 #ifdef CALLER_SAVES_F1
 462 callerSaves (FloatReg 1)        = True
 463 #endif
 464 #ifdef CALLER_SAVES_F2
 465 callerSaves (FloatReg 2)        = True
 466 #endif
 467 #ifdef CALLER_SAVES_F3
 468 callerSaves (FloatReg 3)        = True
 469 #endif
 470 #ifdef CALLER_SAVES_F4
 471 callerSaves (FloatReg 4)        = True
 472 #endif
 473 #ifdef CALLER_SAVES_D1
 474 callerSaves (DoubleReg 1)       = True
 475 #endif
 476 #ifdef CALLER_SAVES_D2
 477 callerSaves (DoubleReg 2)       = True
 478 #endif
 479 #ifdef CALLER_SAVES_L1
 480 callerSaves (LongReg 1)         = True
 481 #endif
 482 #ifdef CALLER_SAVES_Sp
 483 callerSaves Sp                  = True
 484 #endif
 485 #ifdef CALLER_SAVES_SpLim
 486 callerSaves SpLim               = True
 487 #endif
 488 #ifdef CALLER_SAVES_Hp
 489 callerSaves Hp                  = True
 490 #endif
 491 #ifdef CALLER_SAVES_HpLim
 492 callerSaves HpLim               = True
 493 #endif
 494 #ifdef CALLER_SAVES_CurrentTSO
 495 callerSaves CurrentTSO          = True
 496 #endif
 497 #ifdef CALLER_SAVES_CurrentNursery
 498 callerSaves CurrentNursery      = True
 499 #endif
 500 callerSaves _                   = False
 501
 502
 503 -- -----------------------------------------------------------------------------
 504 -- Information about global registers
 505
 506 baseRegOffset :: GlobalReg -> Int
 507
 508 baseRegOffset (VanillaReg 1 _)    = oFFSET_StgRegTable_rR1
 509 baseRegOffset (VanillaReg 2 _)    = oFFSET_StgRegTable_rR2
 510 baseRegOffset (VanillaReg 3 _)    = oFFSET_StgRegTable_rR3
 511 baseRegOffset (VanillaReg 4 _)    = oFFSET_StgRegTable_rR4
 512 baseRegOffset (VanillaReg 5 _)    = oFFSET_StgRegTable_rR5
 513 baseRegOffset (VanillaReg 6 _)    = oFFSET_StgRegTable_rR6
 514 baseRegOffset (VanillaReg 7 _)    = oFFSET_StgRegTable_rR7
 515 baseRegOffset (VanillaReg 8 _)    = oFFSET_StgRegTable_rR8
 516 baseRegOffset (VanillaReg 9 _)    = oFFSET_StgRegTable_rR9
 517 baseRegOffset (VanillaReg 10 _)   = oFFSET_StgRegTable_rR10
 518 baseRegOffset (FloatReg  1)       = oFFSET_StgRegTable_rF1
 519 baseRegOffset (FloatReg  2)       = oFFSET_StgRegTable_rF2
 520 baseRegOffset (FloatReg  3)       = oFFSET_StgRegTable_rF3
 521 baseRegOffset (FloatReg  4)       = oFFSET_StgRegTable_rF4
 522 baseRegOffset (DoubleReg 1)       = oFFSET_StgRegTable_rD1
 523 baseRegOffset (DoubleReg 2)       = oFFSET_StgRegTable_rD2
 524 baseRegOffset Sp                  = oFFSET_StgRegTable_rSp
 525 baseRegOffset SpLim               = oFFSET_StgRegTable_rSpLim
 526 baseRegOffset (LongReg 1)         = oFFSET_StgRegTable_rL1
 527 baseRegOffset Hp                  = oFFSET_StgRegTable_rHp
 528 baseRegOffset HpLim               = oFFSET_StgRegTable_rHpLim
 529 baseRegOffset CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO
 530 baseRegOffset CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery
 531 baseRegOffset HpAlloc             = oFFSET_StgRegTable_rHpAlloc
 532 baseRegOffset EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo
 533 baseRegOffset GCEnter1            = oFFSET_stgGCEnter1
 534 baseRegOffset GCFun               = oFFSET_stgGCFun
 535 baseRegOffset BaseReg             = panic "baseRegOffset:BaseReg"
 536 baseRegOffset _                   = panic "baseRegOffset:other"
 537
 538
 539 -------------------------------------------------------------------------
 540 --
 541 --      Strings generate a top-level data block
 542 --
 543 -------------------------------------------------------------------------
 544
 545 emitDataLits :: CLabel -> [CmmLit] -> Code
 546 -- Emit a data-segment data block
 547 emitDataLits lbl lits
 548   = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 549
 550 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
 551 -- Emit a data-segment data block
 552 mkDataLits lbl lits
 553   = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 554
 555 emitRODataLits :: String -> CLabel -> [CmmLit] -> Code
 556 -- Emit a read-only data block
 557 emitRODataLits caller lbl lits
 558   = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
 559     where section | any needsRelocation lits = RelocatableReadOnlyData
 560                   | otherwise                = ReadOnlyData
 561           needsRelocation (CmmLabel _)      = True
 562           needsRelocation (CmmLabelOff _ _) = True
 563           needsRelocation _                 = False
 564
 565 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
 566 mkRODataLits lbl lits
 567   = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
 568   where section | any needsRelocation lits = RelocatableReadOnlyData
 569                 | otherwise                = ReadOnlyData
 570         needsRelocation (CmmLabel _)      = True
 571         needsRelocation (CmmLabelOff _ _) = True
 572         needsRelocation _                 = False
 573
 574 mkStringCLit :: String -> FCode CmmLit
 575 -- Make a global definition for the string,
 576 -- and return its label
 577 mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str)
 578
 579 mkByteStringCLit :: [Word8] -> FCode CmmLit
 580 mkByteStringCLit bytes
 581   = do  { uniq <- newUnique
 582         ; let lbl = mkStringLitLabel uniq
 583         ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
 584         ; return (CmmLabel lbl) }
 585
 586 -------------------------------------------------------------------------
 587 --
 588 --      Assigning expressions to temporaries
 589 --
 590 -------------------------------------------------------------------------
 591
 592 -- | If the expression is trivial, return it.  Otherwise, assign the
 593 -- expression to a temporary register and return an expression
 594 -- referring to this register.
 595 assignTemp :: CmmExpr -> FCode CmmExpr
 596 -- For a non-trivial expression, e, create a local
 597 -- variable and assign the expression to it
 598 assignTemp e
 599   | isTrivialCmmExpr e = return e
 600   | otherwise          = do { reg <- newTemp (cmmExprType e)
 601                             ; stmtC (CmmAssign (CmmLocal reg) e)
 602                             ; return (CmmReg (CmmLocal reg)) }
 603
 604 -- | If the expression is trivial and doesn't refer to a global
 605 -- register, return it.  Otherwise, assign the expression to a
 606 -- temporary register and return an expression referring to this
 607 -- register.
 608 assignTemp_ :: CmmExpr -> FCode CmmExpr
 609 assignTemp_ e
 610     | isTrivialCmmExpr e && hasNoGlobalRegs e = return e
 611     | otherwise = do
 612         reg <- newTemp (cmmExprType e)
 613         stmtC (CmmAssign (CmmLocal reg) e)
 614         return (CmmReg (CmmLocal reg))
 615
 616 newTemp :: CmmType -> FCode LocalReg
 617 newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
 618
 619 -------------------------------------------------------------------------
 620 --
 621 --      Building case analysis
 622 --
 623 -------------------------------------------------------------------------
 624
 625 emitSwitch
 626         :: CmmExpr                -- Tag to switch on
 627         -> [(ConTagZ, CgStmts)]   -- Tagged branches
 628         -> Maybe CgStmts          -- Default branch (if any)
 629         -> ConTagZ -> ConTagZ     -- Min and Max possible values; behaviour
 630                                   --    outside this range is undefined
 631         -> Code
 632
 633 -- ONLY A DEFAULT BRANCH: no case analysis to do
 634 emitSwitch tag_expr [] (Just stmts) _ _
 635   = emitCgStmts stmts
 636
 637 -- Right, off we go
 638 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
 639   =     -- Just sort the branches before calling mk_sritch
 640     do  { mb_deflt_id <-
 641                 case mb_deflt of
 642                   Nothing    -> return Nothing
 643                   Just stmts -> do id <- forkCgStmts stmts; return (Just id)
 644
 645         ; dflags <- getDynFlags
 646         ; let via_C | HscC <- hscTarget dflags = True
 647                     | otherwise                = False
 648
 649         ; stmts <- mk_switch tag_expr (sortLe le branches)
 650                         mb_deflt_id lo_tag hi_tag via_C
 651         ; emitCgStmts stmts
 652         }
 653   where
 654     (t1,_) `le` (t2,_) = t1 <= t2
 655
 656
 657 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
 658           -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
 659           -> FCode CgStmts
 660
 661 -- SINGLETON TAG RANGE: no case analysis to do
 662 mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
 663   | lo_tag == hi_tag
 664   = ASSERT( tag == lo_tag )
 665     return stmts
 666
 667 -- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
 668 mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
 669   = return stmts
 670         -- The simplifier might have eliminated a case
 671         --       so we may have e.g. case xs of
 672         --                               [] -> e
 673         -- In that situation we can be sure the (:) case
 674         -- can't happen, so no need to test
 675
 676 -- SINGLETON BRANCH: one equality check to do
 677 mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
 678   = return (CmmCondBranch cond deflt `consCgStmt` stmts)
 679   where
 680     cond  =  cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
 681         -- We have lo_tag < hi_tag, but there's only one branch,
 682         -- so there must be a default
 683
 684 -- ToDo: we might want to check for the two branch case, where one of
 685 -- the branches is the tag 0, because comparing '== 0' is likely to be
 686 -- more efficient than other kinds of comparison.
 687
 688 -- DENSE TAG RANGE: use a switch statment.
 689 --
 690 -- We also use a switch uncoditionally when compiling via C, because
 691 -- this will get emitted as a C switch statement and the C compiler
 692 -- should do a good job of optimising it.  Also, older GCC versions
 693 -- (2.95 in particular) have problems compiling the complicated
 694 -- if-trees generated by this code, so compiling to a switch every
 695 -- time works around that problem.
 696 --
 697 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
 698   | use_switch  -- Use a switch
 699   = do  { branch_ids <- mapM forkCgStmts (map snd branches)
 700         ; let
 701                 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
 702
 703                 find_branch :: ConTagZ -> Maybe BlockId
 704                 find_branch i = assocDefault mb_deflt tagged_blk_ids i
 705
 706                 -- NB. we have eliminated impossible branches at
 707                 -- either end of the range (see below), so the first
 708                 -- tag of a real branch is real_lo_tag (not lo_tag).
 709                 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
 710
 711                 switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
 712
 713         ; ASSERT(not (all isNothing arms))
 714           return (oneCgStmt switch_stmt)
 715         }
 716
 717   -- if we can knock off a bunch of default cases with one if, then do so
 718   | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
 719   = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
 720        ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
 721              branch = CmmCondBranch cond deflt
 722        ; stmts <- mk_switch tag_expr' branches mb_deflt
 723                         lowest_branch hi_tag via_C
 724        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 725        }
 726
 727   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
 728   = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
 729        ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
 730              branch = CmmCondBranch cond deflt
 731        ; stmts <- mk_switch tag_expr' branches mb_deflt
 732                         lo_tag highest_branch via_C
 733        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 734        }
 735
 736   | otherwise   -- Use an if-tree
 737   = do  { (assign_tag, tag_expr') <- assignTemp' tag_expr
 738                 -- To avoid duplication
 739         ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
 740                                 lo_tag (mid_tag-1) via_C
 741         ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
 742                                 mid_tag hi_tag via_C
 743         ; hi_id <- forkCgStmts hi_stmts
 744         ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
 745               branch_stmt = CmmCondBranch cond hi_id
 746         ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
 747         }
 748         -- we test (e >= mid_tag) rather than (e < mid_tag), because
 749         -- the former works better when e is a comparison, and there
 750         -- are two tags 0 & 1 (mid_tag == 1).  In this case, the code
 751         -- generator can reduce the condition to e itself without
 752         -- having to reverse the sense of the comparison: comparisons
 753         -- can't always be easily reversed (eg. floating
 754         -- pt. comparisons).
 755   where
 756     use_switch   = {- pprTrace "mk_switch" (
 757                         ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
 758                         text "branches:" <+> ppr (map fst branches) <+>
 759                         text "n_branches:" <+> int n_branches <+>
 760                         text "lo_tag:" <+> int lo_tag <+>
 761                         text "hi_tag:" <+> int hi_tag <+>
 762                         text "real_lo_tag:" <+> int real_lo_tag <+>
 763                         text "real_hi_tag:" <+> int real_hi_tag) $ -}
 764                    ASSERT( n_branches > 1 && n_tags > 1 )
 765                    n_tags > 2 && (via_C || (dense && big_enough))
 766                  -- up to 4 branches we use a decision tree, otherwise
 767                  -- a switch (== jump table in the NCG).  This seems to be
 768                  -- optimal, and corresponds with what gcc does.
 769     big_enough   = n_branches > 4
 770     dense        = n_branches > (n_tags `div` 2)
 771     n_branches   = length branches
 772
 773     -- ignore default slots at each end of the range if there's
 774     -- no default branch defined.
 775     lowest_branch  = fst (head branches)
 776     highest_branch = fst (last branches)
 777
 778     real_lo_tag
 779         | isNothing mb_deflt = lowest_branch
 780         | otherwise          = lo_tag
 781
 782     real_hi_tag
 783         | isNothing mb_deflt = highest_branch
 784         | otherwise          = hi_tag
 785
 786     n_tags = real_hi_tag - real_lo_tag + 1
 787
 788         -- INVARIANT: Provided hi_tag > lo_tag (which is true)
 789         --      lo_tag <= mid_tag < hi_tag
 790         --      lo_branches have tags <  mid_tag
 791         --      hi_branches have tags >= mid_tag
 792
 793     (mid_tag,_) = branches !! (n_branches `div` 2)
 794         -- 2 branches => n_branches `div` 2 = 1
 795         --            => branches !! 1 give the *second* tag
 796         -- There are always at least 2 branches here
 797
 798     (lo_branches, hi_branches) = span is_lo branches
 799     is_lo (t,_) = t < mid_tag
 800
 801
 802 assignTemp' e
 803   | isTrivialCmmExpr e = return (CmmNop, e)
 804   | otherwise          = do { reg <- newTemp (cmmExprType e)
 805                             ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
 806
 807 emitLitSwitch :: CmmExpr                        -- Tag to switch on
 808               -> [(Literal, CgStmts)]           -- Tagged branches
 809               -> CgStmts                        -- Default branch (always)
 810               -> Code                           -- Emit the code
 811 -- Used for general literals, whose size might not be a word,
 812 -- where there is always a default case, and where we don't know
 813 -- the range of values for certain.  For simplicity we always generate a tree.
 814 --
 815 -- ToDo: for integers we could do better here, perhaps by generalising
 816 -- mk_switch and using that.  --SDM 15/09/2004
 817 emitLitSwitch scrut [] deflt
 818   = emitCgStmts deflt
 819 emitLitSwitch scrut branches deflt_blk
 820   = do  { scrut' <- assignTemp scrut
 821         ; deflt_blk_id <- forkCgStmts deflt_blk
 822         ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
 823         ; emitCgStmts blk }
 824   where
 825     le (t1,_) (t2,_) = t1 <= t2
 826
 827 mk_lit_switch :: CmmExpr -> BlockId
 828               -> [(Literal,CgStmts)]
 829               -> FCode CgStmts
 830 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
 831   = return (consCgStmt if_stmt blk)
 832   where
 833     cmm_lit = mkSimpleLit lit
 834     rep     = cmmLitType cmm_lit
 835     ne      = if isFloatType rep then MO_F_Ne else MO_Ne
 836     cond    = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit]
 837     if_stmt = CmmCondBranch cond deflt_blk_id
 838
 839 mk_lit_switch scrut deflt_blk_id branches
 840   = do  { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
 841         ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
 842         ; lo_blk_id <- forkCgStmts lo_blk
 843         ; let if_stmt = CmmCondBranch cond lo_blk_id
 844         ; return (if_stmt `consCgStmt` hi_blk) }
 845   where
 846     n_branches = length branches
 847     (mid_lit,_) = branches !! (n_branches `div` 2)
 848         -- See notes above re mid_tag
 849
 850     (lo_branches, hi_branches) = span is_lo branches
 851     is_lo (t,_) = t < mid_lit
 852
 853     cond    = CmmMachOp (mkLtOp mid_lit)
 854                         [scrut, CmmLit (mkSimpleLit mid_lit)]
 855
 856 -------------------------------------------------------------------------
 857 --
 858 --      Simultaneous assignment
 859 --
 860 -------------------------------------------------------------------------
 861
 862
 863 emitSimultaneously :: CmmStmts -> Code
 864 -- Emit code to perform the assignments in the
 865 -- input simultaneously, using temporary variables when necessary.
 866 --
 867 -- The Stmts must be:
 868 --      CmmNop, CmmComment, CmmAssign, CmmStore
 869 -- and nothing else
 870
 871
 872 -- We use the strongly-connected component algorithm, in which
 873 --      * the vertices are the statements
 874 --      * an edge goes from s1 to s2 iff
 875 --              s1 assigns to something s2 uses
 876 --        that is, if s1 should *follow* s2 in the final order
 877
 878 type CVertex = (Int, CmmStmt)   -- Give each vertex a unique number,
 879                                 -- for fast comparison
 880
 881 emitSimultaneously stmts
 882   = codeOnly $
 883     case filterOut isNopStmt (stmtList stmts) of
 884         -- Remove no-ops
 885       []        -> nopC
 886       [stmt]    -> stmtC stmt   -- It's often just one stmt
 887       stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
 888
 889 doSimultaneously1 :: [CVertex] -> Code
 890 doSimultaneously1 vertices
 891   = let
 892         edges = [ (vertex, key1, edges_from stmt1)
 893                 | vertex@(key1, stmt1) <- vertices
 894                 ]
 895         edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
 896                                     stmt1 `mustFollow` stmt2
 897                            ]
 898         components = stronglyConnCompFromEdgedVertices edges
 899
 900         -- do_components deal with one strongly-connected component
 901         -- Not cyclic, or singleton?  Just do it
 902         do_component (AcyclicSCC (n,stmt))  = stmtC stmt
 903         do_component (CyclicSCC [(n,stmt)]) = stmtC stmt
 904
 905                 -- Cyclic?  Then go via temporaries.  Pick one to
 906                 -- break the loop and try again with the rest.
 907         do_component (CyclicSCC ((n,first_stmt) : rest))
 908           = do  { from_temp <- go_via_temp first_stmt
 909                 ; doSimultaneously1 rest
 910                 ; stmtC from_temp }
 911
 912         go_via_temp (CmmAssign dest src)
 913           = do  { tmp <- newTemp (cmmRegType dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
 914                 ; stmtC (CmmAssign (CmmLocal tmp) src)
 915                 ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
 916         go_via_temp (CmmStore dest src)
 917           = do  { tmp <- newTemp (cmmExprType src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong
 918                 ; stmtC (CmmAssign (CmmLocal tmp) src)
 919                 ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
 920     in
 921     mapCs do_component components
 922
 923 mustFollow :: CmmStmt -> CmmStmt -> Bool
 924 CmmAssign reg _  `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
 925 CmmStore loc e   `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprType e)) stmt
 926 CmmNop           `mustFollow` stmt = False
 927 CmmComment _     `mustFollow` stmt = False
 928
 929
 930 anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
 931 -- True if the fn is true of any input of the stmt
 932 anySrc p (CmmAssign _ e)    = p e
 933 anySrc p (CmmStore e1 e2)   = p e1 || p e2      -- Might be used in either side
 934 anySrc p (CmmComment _)     = False
 935 anySrc p CmmNop             = False
 936 anySrc p other              = True              -- Conservative
 937
 938 locUsedIn :: CmmExpr -> CmmType -> CmmExpr -> Bool
 939 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
 940 -- 'e'.  Returns True if it's not sure.
 941 locUsedIn loc rep (CmmLit _)         = False
 942 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
 943 locUsedIn loc rep (CmmReg reg')      = False
 944 locUsedIn loc rep (CmmRegOff reg' _) = False
 945 locUsedIn loc rep (CmmMachOp _ es)   = any (locUsedIn loc rep) es
 946
 947 possiblySameLoc :: CmmExpr -> CmmType -> CmmExpr -> CmmType -> Bool
 948 -- Assumes that distinct registers (eg Hp, Sp) do not
 949 -- point to the same location, nor any offset thereof.
 950 possiblySameLoc (CmmReg r1)       rep1 (CmmReg r2)      rep2  = r1==r2
 951 possiblySameLoc (CmmReg r1)       rep1 (CmmRegOff r2 0) rep2  = r1==r2
 952 possiblySameLoc (CmmRegOff r1 0)  rep1 (CmmReg r2)      rep2  = r1==r2
 953 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
 954   = r1==r2 && end1 > start2 && end2 > start1
 955   where
 956     end1 = start1 + widthInBytes (typeWidth rep1)
 957     end2 = start2 + widthInBytes (typeWidth rep2)
 958
 959 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
 960 possiblySameLoc l1 rep1 l2         rep2 = True  -- Conservative
 961
 962 -------------------------------------------------------------------------
 963 --
 964 --      Static Reference Tables
 965 --
 966 -------------------------------------------------------------------------
 967
 968 -- There is just one SRT for each top level binding; all the nested
 969 -- bindings use sub-sections of this SRT.  The label is passed down to
 970 -- the nested bindings via the monad.
 971
 972 getSRTInfo :: FCode C_SRT
 973 getSRTInfo = do
 974   srt_lbl <- getSRTLabel
 975   srt <- getSRT
 976   case srt of
 977     -- TODO: Should we panic in this case?
 978     -- Someone obviously thinks there should be an SRT
 979     NoSRT -> return NoC_SRT
 980     SRTEntries {} -> panic "getSRTInfo: SRTEntries.  Perhaps you forgot to run SimplStg?"
 981     SRT off len bmp
 982       | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
 983       -> do id <- newUnique
 984             let srt_desc_lbl = mkLargeSRTLabel id
 985             emitRODataLits "getSRTInfo" srt_desc_lbl
 986              ( cmmLabelOffW srt_lbl off
 987                : mkWordCLit (fromIntegral len)
 988                : map mkWordCLit bmp)
 989             return (C_SRT srt_desc_lbl 0 srt_escape)
 990
 991     SRT off len bmp
 992       | otherwise
 993       -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
 994                 -- The fromIntegral converts to StgHalfWord
 995
 996 srt_escape = (-1) :: StgHalfWord
 997
 998 clHasCafRefs :: ClosureInfo -> CafInfo
 999 clHasCafRefs (ClosureInfo {closureSRT = srt}) =
1000   case srt of NoC_SRT -> NoCafRefs
1001               _       -> MayHaveCafRefs
1002 clHasCafRefs (ConInfo {}) = NoCafRefs
1003
1004 -- -----------------------------------------------------------------------------
1005 --
1006 -- STG/Cmm GlobalReg
1007 --
1008 -- -----------------------------------------------------------------------------
1009
1010 -- | Here is where the STG register map is defined for each target arch.
1011 -- The order matters (for the llvm backend anyway)! We must make sure to
1012 -- maintain the order here with the order used in the LLVM calling conventions.
1013 -- Note that also, this isn't all registers, just the ones that are currently
1014 -- possbily mapped to real registers.
1015 activeStgRegs :: [GlobalReg]
1016 activeStgRegs = [
1017 #ifdef REG_Base
1018     BaseReg
1019 #endif
1020 #ifdef REG_Sp
1021     ,Sp
1022 #endif
1023 #ifdef REG_Hp
1024     ,Hp
1025 #endif
1026 #ifdef REG_R1
1027     ,VanillaReg 1 VGcPtr
1028 #endif
1029 #ifdef REG_R2
1030     ,VanillaReg 2 VGcPtr
1031 #endif
1032 #ifdef REG_R3
1033     ,VanillaReg 3 VGcPtr
1034 #endif
1035 #ifdef REG_R4
1036     ,VanillaReg 4 VGcPtr
1037 #endif
1038 #ifdef REG_R5
1039     ,VanillaReg 5 VGcPtr
1040 #endif
1041 #ifdef REG_R6
1042     ,VanillaReg 6 VGcPtr
1043 #endif
1044 #ifdef REG_R7
1045     ,VanillaReg 7 VGcPtr
1046 #endif
1047 #ifdef REG_R8
1048     ,VanillaReg 8 VGcPtr
1049 #endif
1050 #ifdef REG_SpLim
1051     ,SpLim
1052 #endif
1053 #ifdef REG_F1
1054     ,FloatReg 1
1055 #endif
1056 #ifdef REG_F2
1057     ,FloatReg 2
1058 #endif
1059 #ifdef REG_F3
1060     ,FloatReg 3
1061 #endif
1062 #ifdef REG_F4
1063     ,FloatReg 4
1064 #endif
1065 #ifdef REG_D1
1066     ,DoubleReg 1
1067 #endif
1068 #ifdef REG_D2
1069     ,DoubleReg 2
1070 #endif
1071     ]
1072
1073 -- | We map STG registers onto appropriate CmmExprs.  Either they map
1074 -- to real machine registers or stored as offsets from BaseReg.  Given
1075 -- a GlobalReg, get_GlobalReg_addr always produces the
1076 -- register table address for it.
1077 get_GlobalReg_addr :: GlobalReg -> CmmExpr
1078 get_GlobalReg_addr BaseReg = regTableOffset 0
1079 get_GlobalReg_addr mid     = get_Regtable_addr_from_offset
1080                                 (globalRegType mid) (baseRegOffset mid)
1081
1082 -- Calculate a literal representing an offset into the register table.
1083 -- Used when we don't have an actual BaseReg to offset from.
1084 regTableOffset n =
1085   CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
1086
1087 get_Regtable_addr_from_offset   :: CmmType -> Int -> CmmExpr
1088 get_Regtable_addr_from_offset rep offset =
1089 #ifdef REG_Base
1090   CmmRegOff (CmmGlobal BaseReg) offset
1091 #else
1092   regTableOffset offset
1093 #endif
1094
1095 -- | Fixup global registers so that they assign to locations within the
1096 -- RegTable if they aren't pinned for the current target.
1097 fixStgRegisters :: RawCmmTop -> RawCmmTop
1098 fixStgRegisters top@(CmmData _ _) = top
1099
1100 fixStgRegisters (CmmProc info lbl (ListGraph blocks)) =
1101   let blocks' = map fixStgRegBlock blocks
1102   in CmmProc info lbl $ ListGraph blocks'
1103
1104 fixStgRegBlock :: CmmBasicBlock -> CmmBasicBlock
1105 fixStgRegBlock (BasicBlock id stmts) =
1106   let stmts' = map fixStgRegStmt stmts
1107   in BasicBlock id stmts'
1108
1109 fixStgRegStmt :: CmmStmt -> CmmStmt
1110 fixStgRegStmt stmt
1111   = case stmt of
1112         CmmAssign (CmmGlobal reg) src ->
1113             let src' = fixStgRegExpr src
1114                 baseAddr = get_GlobalReg_addr reg
1115             in case reg `elem` activeStgRegs of
1116                 True  -> CmmAssign (CmmGlobal reg) src'
1117                 False -> CmmStore baseAddr src'
1118
1119         CmmAssign reg src ->
1120             let src' = fixStgRegExpr src
1121             in CmmAssign reg src'
1122
1123         CmmStore addr src -> CmmStore (fixStgRegExpr addr) (fixStgRegExpr src)
1124
1125         CmmCall target regs args srt returns ->
1126             let target' = case target of
1127                     CmmCallee e conv -> CmmCallee (fixStgRegExpr e) conv
1128                     other            -> other
1129                 args' = map (\(CmmHinted arg hint) ->
1130                                 (CmmHinted (fixStgRegExpr arg) hint)) args
1131             in CmmCall target' regs args' srt returns
1132
1133         CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr test) dest
1134
1135         CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr expr) ids
1136
1137         CmmJump addr regs -> CmmJump (fixStgRegExpr addr) regs
1138
1139         -- CmmNop, CmmComment, CmmBranch, CmmReturn
1140         _other -> stmt
1141
1142
1143 fixStgRegExpr :: CmmExpr ->  CmmExpr
1144 fixStgRegExpr expr
1145   = case expr of
1146         CmmLoad addr ty -> CmmLoad (fixStgRegExpr addr) ty
1147
1148         CmmMachOp mop args -> CmmMachOp mop args'
1149             where args' = map fixStgRegExpr args
1150
1151         CmmReg (CmmGlobal reg) ->
1152             -- Replace register leaves with appropriate StixTrees for
1153             -- the given target.  MagicIds which map to a reg on this
1154             -- arch are left unchanged.  For the rest, BaseReg is taken
1155             -- to mean the address of the reg table in MainCapability,
1156             -- and for all others we generate an indirection to its
1157             -- location in the register table.
1158             case reg `elem` activeStgRegs of
1159                 True  -> expr
1160                 False ->
1161                     let baseAddr = get_GlobalReg_addr reg
1162                     in case reg of
1163                         BaseReg -> fixStgRegExpr baseAddr
1164                         _other  -> fixStgRegExpr
1165                                     (CmmLoad baseAddr (globalRegType reg))
1166
1167         CmmRegOff (CmmGlobal reg) offset ->
1168             -- RegOf leaves are just a shorthand form. If the reg maps
1169             -- to a real reg, we keep the shorthand, otherwise, we just
1170             -- expand it and defer to the above code.
1171             case reg `elem` activeStgRegs of
1172                 True  -> expr
1173                 False -> fixStgRegExpr (CmmMachOp (MO_Add wordWidth) [
1174                                     CmmReg (CmmGlobal reg),
1175                                     CmmLit (CmmInt (fromIntegral offset)
1176                                                 wordWidth)])
1177
1178         -- CmmLit, CmmReg (CmmLocal), CmmStackSlot
1179         _other -> expr
1180