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 -- | Assign the expression to a temporary register and return an
 605 -- expression referring to this register.
 606 assignTemp_ :: CmmExpr -> FCode CmmExpr
 607 assignTemp_ e = do
 608     reg <- newTemp (cmmExprType e)
 609     stmtC (CmmAssign (CmmLocal reg) e)
 610     return (CmmReg (CmmLocal reg))
 611
 612 newTemp :: CmmType -> FCode LocalReg
 613 newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
 614
 615 -------------------------------------------------------------------------
 616 --
 617 --      Building case analysis
 618 --
 619 -------------------------------------------------------------------------
 620
 621 emitSwitch
 622         :: CmmExpr                -- Tag to switch on
 623         -> [(ConTagZ, CgStmts)]   -- Tagged branches
 624         -> Maybe CgStmts          -- Default branch (if any)
 625         -> ConTagZ -> ConTagZ     -- Min and Max possible values; behaviour
 626                                   --    outside this range is undefined
 627         -> Code
 628
 629 -- ONLY A DEFAULT BRANCH: no case analysis to do
 630 emitSwitch tag_expr [] (Just stmts) _ _
 631   = emitCgStmts stmts
 632
 633 -- Right, off we go
 634 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
 635   =     -- Just sort the branches before calling mk_sritch
 636     do  { mb_deflt_id <-
 637                 case mb_deflt of
 638                   Nothing    -> return Nothing
 639                   Just stmts -> do id <- forkCgStmts stmts; return (Just id)
 640
 641         ; dflags <- getDynFlags
 642         ; let via_C | HscC <- hscTarget dflags = True
 643                     | otherwise                = False
 644
 645         ; stmts <- mk_switch tag_expr (sortLe le branches)
 646                         mb_deflt_id lo_tag hi_tag via_C
 647         ; emitCgStmts stmts
 648         }
 649   where
 650     (t1,_) `le` (t2,_) = t1 <= t2
 651
 652
 653 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
 654           -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
 655           -> FCode CgStmts
 656
 657 -- SINGLETON TAG RANGE: no case analysis to do
 658 mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
 659   | lo_tag == hi_tag
 660   = ASSERT( tag == lo_tag )
 661     return stmts
 662
 663 -- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
 664 mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
 665   = return stmts
 666         -- The simplifier might have eliminated a case
 667         --       so we may have e.g. case xs of
 668         --                               [] -> e
 669         -- In that situation we can be sure the (:) case
 670         -- can't happen, so no need to test
 671
 672 -- SINGLETON BRANCH: one equality check to do
 673 mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
 674   = return (CmmCondBranch cond deflt `consCgStmt` stmts)
 675   where
 676     cond  =  cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
 677         -- We have lo_tag < hi_tag, but there's only one branch,
 678         -- so there must be a default
 679
 680 -- ToDo: we might want to check for the two branch case, where one of
 681 -- the branches is the tag 0, because comparing '== 0' is likely to be
 682 -- more efficient than other kinds of comparison.
 683
 684 -- DENSE TAG RANGE: use a switch statment.
 685 --
 686 -- We also use a switch uncoditionally when compiling via C, because
 687 -- this will get emitted as a C switch statement and the C compiler
 688 -- should do a good job of optimising it.  Also, older GCC versions
 689 -- (2.95 in particular) have problems compiling the complicated
 690 -- if-trees generated by this code, so compiling to a switch every
 691 -- time works around that problem.
 692 --
 693 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
 694   | use_switch  -- Use a switch
 695   = do  { branch_ids <- mapM forkCgStmts (map snd branches)
 696         ; let
 697                 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
 698
 699                 find_branch :: ConTagZ -> Maybe BlockId
 700                 find_branch i = assocDefault mb_deflt tagged_blk_ids i
 701
 702                 -- NB. we have eliminated impossible branches at
 703                 -- either end of the range (see below), so the first
 704                 -- tag of a real branch is real_lo_tag (not lo_tag).
 705                 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
 706
 707                 switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
 708
 709         ; ASSERT(not (all isNothing arms))
 710           return (oneCgStmt switch_stmt)
 711         }
 712
 713   -- if we can knock off a bunch of default cases with one if, then do so
 714   | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
 715   = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
 716        ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
 717              branch = CmmCondBranch cond deflt
 718        ; stmts <- mk_switch tag_expr' branches mb_deflt
 719                         lowest_branch hi_tag via_C
 720        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 721        }
 722
 723   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
 724   = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
 725        ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
 726              branch = CmmCondBranch cond deflt
 727        ; stmts <- mk_switch tag_expr' branches mb_deflt
 728                         lo_tag highest_branch via_C
 729        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 730        }
 731
 732   | otherwise   -- Use an if-tree
 733   = do  { (assign_tag, tag_expr') <- assignTemp' tag_expr
 734                 -- To avoid duplication
 735         ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
 736                                 lo_tag (mid_tag-1) via_C
 737         ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
 738                                 mid_tag hi_tag via_C
 739         ; hi_id <- forkCgStmts hi_stmts
 740         ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
 741               branch_stmt = CmmCondBranch cond hi_id
 742         ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
 743         }
 744         -- we test (e >= mid_tag) rather than (e < mid_tag), because
 745         -- the former works better when e is a comparison, and there
 746         -- are two tags 0 & 1 (mid_tag == 1).  In this case, the code
 747         -- generator can reduce the condition to e itself without
 748         -- having to reverse the sense of the comparison: comparisons
 749         -- can't always be easily reversed (eg. floating
 750         -- pt. comparisons).
 751   where
 752     use_switch   = {- pprTrace "mk_switch" (
 753                         ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
 754                         text "branches:" <+> ppr (map fst branches) <+>
 755                         text "n_branches:" <+> int n_branches <+>
 756                         text "lo_tag:" <+> int lo_tag <+>
 757                         text "hi_tag:" <+> int hi_tag <+>
 758                         text "real_lo_tag:" <+> int real_lo_tag <+>
 759                         text "real_hi_tag:" <+> int real_hi_tag) $ -}
 760                    ASSERT( n_branches > 1 && n_tags > 1 )
 761                    n_tags > 2 && (via_C || (dense && big_enough))
 762                  -- up to 4 branches we use a decision tree, otherwise
 763                  -- a switch (== jump table in the NCG).  This seems to be
 764                  -- optimal, and corresponds with what gcc does.
 765     big_enough   = n_branches > 4
 766     dense        = n_branches > (n_tags `div` 2)
 767     n_branches   = length branches
 768
 769     -- ignore default slots at each end of the range if there's
 770     -- no default branch defined.
 771     lowest_branch  = fst (head branches)
 772     highest_branch = fst (last branches)
 773
 774     real_lo_tag
 775         | isNothing mb_deflt = lowest_branch
 776         | otherwise          = lo_tag
 777
 778     real_hi_tag
 779         | isNothing mb_deflt = highest_branch
 780         | otherwise          = hi_tag
 781
 782     n_tags = real_hi_tag - real_lo_tag + 1
 783
 784         -- INVARIANT: Provided hi_tag > lo_tag (which is true)
 785         --      lo_tag <= mid_tag < hi_tag
 786         --      lo_branches have tags <  mid_tag
 787         --      hi_branches have tags >= mid_tag
 788
 789     (mid_tag,_) = branches !! (n_branches `div` 2)
 790         -- 2 branches => n_branches `div` 2 = 1
 791         --            => branches !! 1 give the *second* tag
 792         -- There are always at least 2 branches here
 793
 794     (lo_branches, hi_branches) = span is_lo branches
 795     is_lo (t,_) = t < mid_tag
 796
 797
 798 assignTemp' e
 799   | isTrivialCmmExpr e = return (CmmNop, e)
 800   | otherwise          = do { reg <- newTemp (cmmExprType e)
 801                             ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
 802
 803 emitLitSwitch :: CmmExpr                        -- Tag to switch on
 804               -> [(Literal, CgStmts)]           -- Tagged branches
 805               -> CgStmts                        -- Default branch (always)
 806               -> Code                           -- Emit the code
 807 -- Used for general literals, whose size might not be a word,
 808 -- where there is always a default case, and where we don't know
 809 -- the range of values for certain.  For simplicity we always generate a tree.
 810 --
 811 -- ToDo: for integers we could do better here, perhaps by generalising
 812 -- mk_switch and using that.  --SDM 15/09/2004
 813 emitLitSwitch scrut [] deflt
 814   = emitCgStmts deflt
 815 emitLitSwitch scrut branches deflt_blk
 816   = do  { scrut' <- assignTemp scrut
 817         ; deflt_blk_id <- forkCgStmts deflt_blk
 818         ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
 819         ; emitCgStmts blk }
 820   where
 821     le (t1,_) (t2,_) = t1 <= t2
 822
 823 mk_lit_switch :: CmmExpr -> BlockId
 824               -> [(Literal,CgStmts)]
 825               -> FCode CgStmts
 826 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
 827   = return (consCgStmt if_stmt blk)
 828   where
 829     cmm_lit = mkSimpleLit lit
 830     rep     = cmmLitType cmm_lit
 831     ne      = if isFloatType rep then MO_F_Ne else MO_Ne
 832     cond    = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit]
 833     if_stmt = CmmCondBranch cond deflt_blk_id
 834
 835 mk_lit_switch scrut deflt_blk_id branches
 836   = do  { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
 837         ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
 838         ; lo_blk_id <- forkCgStmts lo_blk
 839         ; let if_stmt = CmmCondBranch cond lo_blk_id
 840         ; return (if_stmt `consCgStmt` hi_blk) }
 841   where
 842     n_branches = length branches
 843     (mid_lit,_) = branches !! (n_branches `div` 2)
 844         -- See notes above re mid_tag
 845
 846     (lo_branches, hi_branches) = span is_lo branches
 847     is_lo (t,_) = t < mid_lit
 848
 849     cond    = CmmMachOp (mkLtOp mid_lit)
 850                         [scrut, CmmLit (mkSimpleLit mid_lit)]
 851
 852 -------------------------------------------------------------------------
 853 --
 854 --      Simultaneous assignment
 855 --
 856 -------------------------------------------------------------------------
 857
 858
 859 emitSimultaneously :: CmmStmts -> Code
 860 -- Emit code to perform the assignments in the
 861 -- input simultaneously, using temporary variables when necessary.
 862 --
 863 -- The Stmts must be:
 864 --      CmmNop, CmmComment, CmmAssign, CmmStore
 865 -- and nothing else
 866
 867
 868 -- We use the strongly-connected component algorithm, in which
 869 --      * the vertices are the statements
 870 --      * an edge goes from s1 to s2 iff
 871 --              s1 assigns to something s2 uses
 872 --        that is, if s1 should *follow* s2 in the final order
 873
 874 type CVertex = (Int, CmmStmt)   -- Give each vertex a unique number,
 875                                 -- for fast comparison
 876
 877 emitSimultaneously stmts
 878   = codeOnly $
 879     case filterOut isNopStmt (stmtList stmts) of
 880         -- Remove no-ops
 881       []        -> nopC
 882       [stmt]    -> stmtC stmt   -- It's often just one stmt
 883       stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
 884
 885 doSimultaneously1 :: [CVertex] -> Code
 886 doSimultaneously1 vertices
 887   = let
 888         edges = [ (vertex, key1, edges_from stmt1)
 889                 | vertex@(key1, stmt1) <- vertices
 890                 ]
 891         edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
 892                                     stmt1 `mustFollow` stmt2
 893                            ]
 894         components = stronglyConnCompFromEdgedVertices edges
 895
 896         -- do_components deal with one strongly-connected component
 897         -- Not cyclic, or singleton?  Just do it
 898         do_component (AcyclicSCC (n,stmt))  = stmtC stmt
 899         do_component (CyclicSCC [(n,stmt)]) = stmtC stmt
 900
 901                 -- Cyclic?  Then go via temporaries.  Pick one to
 902                 -- break the loop and try again with the rest.
 903         do_component (CyclicSCC ((n,first_stmt) : rest))
 904           = do  { from_temp <- go_via_temp first_stmt
 905                 ; doSimultaneously1 rest
 906                 ; stmtC from_temp }
 907
 908         go_via_temp (CmmAssign dest src)
 909           = do  { tmp <- newTemp (cmmRegType dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
 910                 ; stmtC (CmmAssign (CmmLocal tmp) src)
 911                 ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
 912         go_via_temp (CmmStore dest src)
 913           = do  { tmp <- newTemp (cmmExprType src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong
 914                 ; stmtC (CmmAssign (CmmLocal tmp) src)
 915                 ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
 916     in
 917     mapCs do_component components
 918
 919 mustFollow :: CmmStmt -> CmmStmt -> Bool
 920 CmmAssign reg _  `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
 921 CmmStore loc e   `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprType e)) stmt
 922 CmmNop           `mustFollow` stmt = False
 923 CmmComment _     `mustFollow` stmt = False
 924
 925
 926 anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
 927 -- True if the fn is true of any input of the stmt
 928 anySrc p (CmmAssign _ e)    = p e
 929 anySrc p (CmmStore e1 e2)   = p e1 || p e2      -- Might be used in either side
 930 anySrc p (CmmComment _)     = False
 931 anySrc p CmmNop             = False
 932 anySrc p other              = True              -- Conservative
 933
 934 locUsedIn :: CmmExpr -> CmmType -> CmmExpr -> Bool
 935 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
 936 -- 'e'.  Returns True if it's not sure.
 937 locUsedIn loc rep (CmmLit _)         = False
 938 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
 939 locUsedIn loc rep (CmmReg reg')      = False
 940 locUsedIn loc rep (CmmRegOff reg' _) = False
 941 locUsedIn loc rep (CmmMachOp _ es)   = any (locUsedIn loc rep) es
 942
 943 possiblySameLoc :: CmmExpr -> CmmType -> CmmExpr -> CmmType -> Bool
 944 -- Assumes that distinct registers (eg Hp, Sp) do not
 945 -- point to the same location, nor any offset thereof.
 946 possiblySameLoc (CmmReg r1)       rep1 (CmmReg r2)      rep2  = r1==r2
 947 possiblySameLoc (CmmReg r1)       rep1 (CmmRegOff r2 0) rep2  = r1==r2
 948 possiblySameLoc (CmmRegOff r1 0)  rep1 (CmmReg r2)      rep2  = r1==r2
 949 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
 950   = r1==r2 && end1 > start2 && end2 > start1
 951   where
 952     end1 = start1 + widthInBytes (typeWidth rep1)
 953     end2 = start2 + widthInBytes (typeWidth rep2)
 954
 955 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
 956 possiblySameLoc l1 rep1 l2         rep2 = True  -- Conservative
 957
 958 -------------------------------------------------------------------------
 959 --
 960 --      Static Reference Tables
 961 --
 962 -------------------------------------------------------------------------
 963
 964 -- There is just one SRT for each top level binding; all the nested
 965 -- bindings use sub-sections of this SRT.  The label is passed down to
 966 -- the nested bindings via the monad.
 967
 968 getSRTInfo :: FCode C_SRT
 969 getSRTInfo = do
 970   srt_lbl <- getSRTLabel
 971   srt <- getSRT
 972   case srt of
 973     -- TODO: Should we panic in this case?
 974     -- Someone obviously thinks there should be an SRT
 975     NoSRT -> return NoC_SRT
 976     SRTEntries {} -> panic "getSRTInfo: SRTEntries.  Perhaps you forgot to run SimplStg?"
 977     SRT off len bmp
 978       | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
 979       -> do id <- newUnique
 980             let srt_desc_lbl = mkLargeSRTLabel id
 981             emitRODataLits "getSRTInfo" srt_desc_lbl
 982              ( cmmLabelOffW srt_lbl off
 983                : mkWordCLit (fromIntegral len)
 984                : map mkWordCLit bmp)
 985             return (C_SRT srt_desc_lbl 0 srt_escape)
 986
 987     SRT off len bmp
 988       | otherwise
 989       -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
 990                 -- The fromIntegral converts to StgHalfWord
 991
 992 srt_escape = (-1) :: StgHalfWord
 993
 994 clHasCafRefs :: ClosureInfo -> CafInfo
 995 clHasCafRefs (ClosureInfo {closureSRT = srt}) =
 996   case srt of NoC_SRT -> NoCafRefs
 997               _       -> MayHaveCafRefs
 998 clHasCafRefs (ConInfo {}) = NoCafRefs
 999
1000 -- -----------------------------------------------------------------------------
1001 --
1002 -- STG/Cmm GlobalReg
1003 --
1004 -- -----------------------------------------------------------------------------
1005
1006 -- | Here is where the STG register map is defined for each target arch.
1007 -- The order matters (for the llvm backend anyway)! We must make sure to
1008 -- maintain the order here with the order used in the LLVM calling conventions.
1009 -- Note that also, this isn't all registers, just the ones that are currently
1010 -- possbily mapped to real registers.
1011 activeStgRegs :: [GlobalReg]
1012 activeStgRegs = [
1013 #ifdef REG_Base
1014     BaseReg
1015 #endif
1016 #ifdef REG_Sp
1017     ,Sp
1018 #endif
1019 #ifdef REG_Hp
1020     ,Hp
1021 #endif
1022 #ifdef REG_R1
1023     ,VanillaReg 1 VGcPtr
1024 #endif
1025 #ifdef REG_R2
1026     ,VanillaReg 2 VGcPtr
1027 #endif
1028 #ifdef REG_R3
1029     ,VanillaReg 3 VGcPtr
1030 #endif
1031 #ifdef REG_R4
1032     ,VanillaReg 4 VGcPtr
1033 #endif
1034 #ifdef REG_R5
1035     ,VanillaReg 5 VGcPtr
1036 #endif
1037 #ifdef REG_R6
1038     ,VanillaReg 6 VGcPtr
1039 #endif
1040 #ifdef REG_R7
1041     ,VanillaReg 7 VGcPtr
1042 #endif
1043 #ifdef REG_R8
1044     ,VanillaReg 8 VGcPtr
1045 #endif
1046 #ifdef REG_SpLim
1047     ,SpLim
1048 #endif
1049 #ifdef REG_F1
1050     ,FloatReg 1
1051 #endif
1052 #ifdef REG_F2
1053     ,FloatReg 2
1054 #endif
1055 #ifdef REG_F3
1056     ,FloatReg 3
1057 #endif
1058 #ifdef REG_F4
1059     ,FloatReg 4
1060 #endif
1061 #ifdef REG_D1
1062     ,DoubleReg 1
1063 #endif
1064 #ifdef REG_D2
1065     ,DoubleReg 2
1066 #endif
1067     ]
1068
1069 -- | We map STG registers onto appropriate CmmExprs.  Either they map
1070 -- to real machine registers or stored as offsets from BaseReg.  Given
1071 -- a GlobalReg, get_GlobalReg_addr always produces the
1072 -- register table address for it.
1073 get_GlobalReg_addr :: GlobalReg -> CmmExpr
1074 get_GlobalReg_addr BaseReg = regTableOffset 0
1075 get_GlobalReg_addr mid     = get_Regtable_addr_from_offset
1076                                 (globalRegType mid) (baseRegOffset mid)
1077
1078 -- Calculate a literal representing an offset into the register table.
1079 -- Used when we don't have an actual BaseReg to offset from.
1080 regTableOffset n =
1081   CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
1082
1083 get_Regtable_addr_from_offset   :: CmmType -> Int -> CmmExpr
1084 get_Regtable_addr_from_offset rep offset =
1085 #ifdef REG_Base
1086   CmmRegOff (CmmGlobal BaseReg) offset
1087 #else
1088   regTableOffset offset
1089 #endif
1090
1091 -- | Fixup global registers so that they assign to locations within the
1092 -- RegTable if they aren't pinned for the current target.
1093 fixStgRegisters :: RawCmmTop -> RawCmmTop
1094 fixStgRegisters top@(CmmData _ _) = top
1095
1096 fixStgRegisters (CmmProc info lbl (ListGraph blocks)) =
1097   let blocks' = map fixStgRegBlock blocks
1098   in CmmProc info lbl $ ListGraph blocks'
1099
1100 fixStgRegBlock :: CmmBasicBlock -> CmmBasicBlock
1101 fixStgRegBlock (BasicBlock id stmts) =
1102   let stmts' = map fixStgRegStmt stmts
1103   in BasicBlock id stmts'
1104
1105 fixStgRegStmt :: CmmStmt -> CmmStmt
1106 fixStgRegStmt stmt
1107   = case stmt of
1108         CmmAssign (CmmGlobal reg) src ->
1109             let src' = fixStgRegExpr src
1110                 baseAddr = get_GlobalReg_addr reg
1111             in case reg `elem` activeStgRegs of
1112                 True  -> CmmAssign (CmmGlobal reg) src'
1113                 False -> CmmStore baseAddr src'
1114
1115         CmmAssign reg src ->
1116             let src' = fixStgRegExpr src
1117             in CmmAssign reg src'
1118
1119         CmmStore addr src -> CmmStore (fixStgRegExpr addr) (fixStgRegExpr src)
1120
1121         CmmCall target regs args srt returns ->
1122             let target' = case target of
1123                     CmmCallee e conv -> CmmCallee (fixStgRegExpr e) conv
1124                     other            -> other
1125                 args' = map (\(CmmHinted arg hint) ->
1126                                 (CmmHinted (fixStgRegExpr arg) hint)) args
1127             in CmmCall target' regs args' srt returns
1128
1129         CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr test) dest
1130
1131         CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr expr) ids
1132
1133         CmmJump addr regs -> CmmJump (fixStgRegExpr addr) regs
1134
1135         -- CmmNop, CmmComment, CmmBranch, CmmReturn
1136         _other -> stmt
1137
1138
1139 fixStgRegExpr :: CmmExpr ->  CmmExpr
1140 fixStgRegExpr expr
1141   = case expr of
1142         CmmLoad addr ty -> CmmLoad (fixStgRegExpr addr) ty
1143
1144         CmmMachOp mop args -> CmmMachOp mop args'
1145             where args' = map fixStgRegExpr args
1146
1147         CmmReg (CmmGlobal reg) ->
1148             -- Replace register leaves with appropriate StixTrees for
1149             -- the given target.  MagicIds which map to a reg on this
1150             -- arch are left unchanged.  For the rest, BaseReg is taken
1151             -- to mean the address of the reg table in MainCapability,
1152             -- and for all others we generate an indirection to its
1153             -- location in the register table.
1154             case reg `elem` activeStgRegs of
1155                 True  -> expr
1156                 False ->
1157                     let baseAddr = get_GlobalReg_addr reg
1158                     in case reg of
1159                         BaseReg -> fixStgRegExpr baseAddr
1160                         _other  -> fixStgRegExpr
1161                                     (CmmLoad baseAddr (globalRegType reg))
1162
1163         CmmRegOff (CmmGlobal reg) offset ->
1164             -- RegOf leaves are just a shorthand form. If the reg maps
1165             -- to a real reg, we keep the shorthand, otherwise, we just
1166             -- expand it and defer to the above code.
1167             case reg `elem` activeStgRegs of
1168                 True  -> expr
1169                 False -> fixStgRegExpr (CmmMachOp (MO_Add wordWidth) [
1170                                     CmmReg (CmmGlobal reg),
1171                                     CmmLit (CmmInt (fromIntegral offset)
1172                                                 wordWidth)])
1173
1174         -- CmmLit, CmmReg (CmmLocal), CmmStackSlot
1175         _other -> expr
1176