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