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