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