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 fod) = CmmLabel (mkForeignLabel fs ms is_dyn fod)
 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        ; join_id <- newLabelC
 326        ; stmtC (CmmCondBranch cond then_id)
 327        ; else_part
 328        ; stmtC (CmmBranch join_id)
 329        ; labelC then_id
 330        ; then_part
 331        ; labelC join_id
 332        }
 333
 334 emitRtsCall :: LitString -> [CmmHinted CmmExpr] -> Bool -> Code
 335 emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
 336    -- The 'Nothing' says "save all global registers"
 337
 338 emitRtsCallWithVols :: LitString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code
 339 emitRtsCallWithVols fun args vols safe
 340    = emitRtsCall' [] fun args (Just vols) safe
 341
 342 emitRtsCallWithResult :: LocalReg -> ForeignHint -> LitString
 343         -> [CmmHinted CmmExpr] -> Bool -> Code
 344 emitRtsCallWithResult res hint fun args safe
 345    = emitRtsCall' [CmmHinted res hint] fun args Nothing safe
 346
 347 -- Make a call to an RTS C procedure
 348 emitRtsCall'
 349    :: [CmmHinted LocalReg]
 350    -> LitString
 351    -> [CmmHinted CmmExpr]
 352    -> Maybe [GlobalReg]
 353    -> Bool -- True <=> CmmSafe call
 354    -> Code
 355 emitRtsCall' res fun args vols safe = do
 356   safety <- if safe
 357             then getSRTInfo >>= (return . CmmSafe)
 358             else return CmmUnsafe
 359   stmtsC caller_save
 360   stmtC (CmmCall target res args safety CmmMayReturn)
 361   stmtsC caller_load
 362   where
 363     (caller_save, caller_load) = callerSaveVolatileRegs vols
 364     target   = CmmCallee fun_expr CCallConv
 365     fun_expr = mkLblExpr (mkRtsCodeLabel fun)
 366
 367 -----------------------------------------------------------------------------
 368 --
 369 --      Caller-Save Registers
 370 --
 371 -----------------------------------------------------------------------------
 372
 373 -- Here we generate the sequence of saves/restores required around a
 374 -- foreign call instruction.
 375
 376 -- TODO: reconcile with includes/Regs.h
 377 --  * Regs.h claims that BaseReg should be saved last and loaded first
 378 --    * This might not have been tickled before since BaseReg is callee save
 379 --  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
 380 callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
 381 callerSaveVolatileRegs vols = (caller_save, caller_load)
 382   where
 383     caller_save = foldr ($!) [] (map callerSaveGlobalReg    regs_to_save)
 384     caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save)
 385
 386     system_regs = [Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery,
 387                    {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ]
 388
 389     regs_to_save = system_regs ++ vol_list
 390
 391     vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
 392
 393     all_of_em = [ VanillaReg n VNonGcPtr | n <- [0..mAX_Vanilla_REG] ]
 394                         -- The VNonGcPtr is a lie, but I don't think it matters
 395              ++ [ FloatReg   n | n <- [0..mAX_Float_REG] ]
 396              ++ [ DoubleReg  n | n <- [0..mAX_Double_REG] ]
 397              ++ [ LongReg    n | n <- [0..mAX_Long_REG] ]
 398
 399     callerSaveGlobalReg reg next
 400         | callerSaves reg =
 401                 CmmStore (get_GlobalReg_addr reg)
 402                          (CmmReg (CmmGlobal reg)) : next
 403         | otherwise = next
 404
 405     callerRestoreGlobalReg reg next
 406         | callerSaves reg =
 407                 CmmAssign (CmmGlobal reg)
 408                           (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
 409                         : next
 410         | otherwise = next
 411
 412 -- -----------------------------------------------------------------------------
 413 -- Global registers
 414
 415 -- We map STG registers onto appropriate CmmExprs.  Either they map
 416 -- to real machine registers or stored as offsets from BaseReg.  Given
 417 -- a GlobalReg, get_GlobalReg_addr always produces the
 418 -- register table address for it.
 419 -- (See also get_GlobalReg_reg_or_addr in MachRegs)
 420
 421 get_GlobalReg_addr              :: GlobalReg -> CmmExpr
 422 get_GlobalReg_addr BaseReg = regTableOffset 0
 423 get_GlobalReg_addr mid     = get_Regtable_addr_from_offset
 424                                 (globalRegType mid) (baseRegOffset mid)
 425
 426 -- Calculate a literal representing an offset into the register table.
 427 -- Used when we don't have an actual BaseReg to offset from.
 428 regTableOffset n =
 429   CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
 430
 431 get_Regtable_addr_from_offset   :: CmmType -> Int -> CmmExpr
 432 get_Regtable_addr_from_offset rep offset =
 433 #ifdef REG_Base
 434   CmmRegOff (CmmGlobal BaseReg) offset
 435 #else
 436   regTableOffset offset
 437 #endif
 438
 439
 440 -- | Returns @True@ if this global register is stored in a caller-saves
 441 -- machine register.
 442
 443 callerSaves :: GlobalReg -> Bool
 444
 445 #ifdef CALLER_SAVES_Base
 446 callerSaves BaseReg             = True
 447 #endif
 448 #ifdef CALLER_SAVES_R1
 449 callerSaves (VanillaReg 1 _)    = True
 450 #endif
 451 #ifdef CALLER_SAVES_R2
 452 callerSaves (VanillaReg 2 _)    = True
 453 #endif
 454 #ifdef CALLER_SAVES_R3
 455 callerSaves (VanillaReg 3 _)    = True
 456 #endif
 457 #ifdef CALLER_SAVES_R4
 458 callerSaves (VanillaReg 4 _)    = True
 459 #endif
 460 #ifdef CALLER_SAVES_R5
 461 callerSaves (VanillaReg 5 _)    = True
 462 #endif
 463 #ifdef CALLER_SAVES_R6
 464 callerSaves (VanillaReg 6 _)    = True
 465 #endif
 466 #ifdef CALLER_SAVES_R7
 467 callerSaves (VanillaReg 7 _)    = True
 468 #endif
 469 #ifdef CALLER_SAVES_R8
 470 callerSaves (VanillaReg 8 _)    = True
 471 #endif
 472 #ifdef CALLER_SAVES_F1
 473 callerSaves (FloatReg 1)        = True
 474 #endif
 475 #ifdef CALLER_SAVES_F2
 476 callerSaves (FloatReg 2)        = True
 477 #endif
 478 #ifdef CALLER_SAVES_F3
 479 callerSaves (FloatReg 3)        = True
 480 #endif
 481 #ifdef CALLER_SAVES_F4
 482 callerSaves (FloatReg 4)        = True
 483 #endif
 484 #ifdef CALLER_SAVES_D1
 485 callerSaves (DoubleReg 1)       = True
 486 #endif
 487 #ifdef CALLER_SAVES_D2
 488 callerSaves (DoubleReg 2)       = True
 489 #endif
 490 #ifdef CALLER_SAVES_L1
 491 callerSaves (LongReg 1)         = True
 492 #endif
 493 #ifdef CALLER_SAVES_Sp
 494 callerSaves Sp                  = True
 495 #endif
 496 #ifdef CALLER_SAVES_SpLim
 497 callerSaves SpLim               = True
 498 #endif
 499 #ifdef CALLER_SAVES_Hp
 500 callerSaves Hp                  = True
 501 #endif
 502 #ifdef CALLER_SAVES_HpLim
 503 callerSaves HpLim               = True
 504 #endif
 505 #ifdef CALLER_SAVES_CurrentTSO
 506 callerSaves CurrentTSO          = True
 507 #endif
 508 #ifdef CALLER_SAVES_CurrentNursery
 509 callerSaves CurrentNursery      = True
 510 #endif
 511 callerSaves _                   = False
 512
 513
 514 -- -----------------------------------------------------------------------------
 515 -- Information about global registers
 516
 517 baseRegOffset :: GlobalReg -> Int
 518
 519 baseRegOffset (VanillaReg 1 _)    = oFFSET_StgRegTable_rR1
 520 baseRegOffset (VanillaReg 2 _)    = oFFSET_StgRegTable_rR2
 521 baseRegOffset (VanillaReg 3 _)    = oFFSET_StgRegTable_rR3
 522 baseRegOffset (VanillaReg 4 _)    = oFFSET_StgRegTable_rR4
 523 baseRegOffset (VanillaReg 5 _)    = oFFSET_StgRegTable_rR5
 524 baseRegOffset (VanillaReg 6 _)    = oFFSET_StgRegTable_rR6
 525 baseRegOffset (VanillaReg 7 _)    = oFFSET_StgRegTable_rR7
 526 baseRegOffset (VanillaReg 8 _)    = oFFSET_StgRegTable_rR8
 527 baseRegOffset (VanillaReg 9 _)    = oFFSET_StgRegTable_rR9
 528 baseRegOffset (VanillaReg 10 _)   = oFFSET_StgRegTable_rR10
 529 baseRegOffset (FloatReg  1)       = oFFSET_StgRegTable_rF1
 530 baseRegOffset (FloatReg  2)       = oFFSET_StgRegTable_rF2
 531 baseRegOffset (FloatReg  3)       = oFFSET_StgRegTable_rF3
 532 baseRegOffset (FloatReg  4)       = oFFSET_StgRegTable_rF4
 533 baseRegOffset (DoubleReg 1)       = oFFSET_StgRegTable_rD1
 534 baseRegOffset (DoubleReg 2)       = oFFSET_StgRegTable_rD2
 535 baseRegOffset Sp                  = oFFSET_StgRegTable_rSp
 536 baseRegOffset SpLim               = oFFSET_StgRegTable_rSpLim
 537 baseRegOffset (LongReg 1)         = oFFSET_StgRegTable_rL1
 538 baseRegOffset Hp                  = oFFSET_StgRegTable_rHp
 539 baseRegOffset HpLim               = oFFSET_StgRegTable_rHpLim
 540 baseRegOffset CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO
 541 baseRegOffset CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery
 542 baseRegOffset HpAlloc             = oFFSET_StgRegTable_rHpAlloc
 543 baseRegOffset EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo
 544 baseRegOffset GCEnter1            = oFFSET_stgGCEnter1
 545 baseRegOffset GCFun               = oFFSET_stgGCFun
 546 baseRegOffset BaseReg             = panic "baseRegOffset:BaseReg"
 547 baseRegOffset _                   = panic "baseRegOffset:other"
 548
 549
 550 -------------------------------------------------------------------------
 551 --
 552 --      Strings generate a top-level data block
 553 --
 554 -------------------------------------------------------------------------
 555
 556 emitDataLits :: CLabel -> [CmmLit] -> Code
 557 -- Emit a data-segment data block
 558 emitDataLits lbl lits
 559   = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 560
 561 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
 562 -- Emit a data-segment data block
 563 mkDataLits lbl lits
 564   = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 565
 566 emitRODataLits :: String -> CLabel -> [CmmLit] -> Code
 567 -- Emit a read-only data block
 568 emitRODataLits caller lbl lits
 569   = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
 570     where section | any needsRelocation lits = RelocatableReadOnlyData
 571                   | otherwise                = ReadOnlyData
 572           needsRelocation (CmmLabel _)      = True
 573           needsRelocation (CmmLabelOff _ _) = True
 574           needsRelocation _                 = False
 575
 576 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
 577 mkRODataLits lbl lits
 578   = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
 579   where section | any needsRelocation lits = RelocatableReadOnlyData
 580                 | otherwise                = ReadOnlyData
 581         needsRelocation (CmmLabel _)      = True
 582         needsRelocation (CmmLabelOff _ _) = True
 583         needsRelocation _                 = False
 584
 585 mkStringCLit :: String -> FCode CmmLit
 586 -- Make a global definition for the string,
 587 -- and return its label
 588 mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str)
 589
 590 mkByteStringCLit :: [Word8] -> FCode CmmLit
 591 mkByteStringCLit bytes
 592   = do  { uniq <- newUnique
 593         ; let lbl = mkStringLitLabel uniq
 594         ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
 595         ; return (CmmLabel lbl) }
 596
 597 -------------------------------------------------------------------------
 598 --
 599 --      Assigning expressions to temporaries
 600 --
 601 -------------------------------------------------------------------------
 602
 603 assignTemp :: CmmExpr -> FCode CmmExpr
 604 -- For a non-trivial expression, e, create a local
 605 -- variable and assign the expression to it
 606 assignTemp e
 607   | isTrivialCmmExpr e = return e
 608   | otherwise          = do { reg <- newTemp (cmmExprType e)
 609                             ; stmtC (CmmAssign (CmmLocal reg) e)
 610                             ; return (CmmReg (CmmLocal reg)) }
 611
 612 newTemp :: CmmType -> FCode LocalReg
 613 newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
 614
 615 -------------------------------------------------------------------------
 616 --
 617 --      Building case analysis
 618 --
 619 -------------------------------------------------------------------------
 620
 621 emitSwitch
 622         :: CmmExpr                -- Tag to switch on
 623         -> [(ConTagZ, CgStmts)]   -- Tagged branches
 624         -> Maybe CgStmts          -- Default branch (if any)
 625         -> ConTagZ -> ConTagZ     -- Min and Max possible values; behaviour
 626                                   --    outside this range is undefined
 627         -> Code
 628
 629 -- ONLY A DEFAULT BRANCH: no case analysis to do
 630 emitSwitch tag_expr [] (Just stmts) _ _
 631   = emitCgStmts stmts
 632
 633 -- Right, off we go
 634 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
 635   =     -- Just sort the branches before calling mk_sritch
 636     do  { mb_deflt_id <-
 637                 case mb_deflt of
 638                   Nothing    -> return Nothing
 639                   Just stmts -> do id <- forkCgStmts stmts; return (Just id)
 640
 641         ; dflags <- getDynFlags
 642         ; let via_C | HscC <- hscTarget dflags = True
 643                     | otherwise                = False
 644
 645         ; stmts <- mk_switch tag_expr (sortLe le branches)
 646                         mb_deflt_id lo_tag hi_tag via_C
 647         ; emitCgStmts stmts
 648         }
 649   where
 650     (t1,_) `le` (t2,_) = t1 <= t2
 651
 652
 653 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
 654           -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
 655           -> FCode CgStmts
 656
 657 -- SINGLETON TAG RANGE: no case analysis to do
 658 mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
 659   | lo_tag == hi_tag
 660   = ASSERT( tag == lo_tag )
 661     return stmts
 662
 663 -- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
 664 mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
 665   = return stmts
 666         -- The simplifier might have eliminated a case
 667         --       so we may have e.g. case xs of
 668         --                               [] -> e
 669         -- In that situation we can be sure the (:) case
 670         -- can't happen, so no need to test
 671
 672 -- SINGLETON BRANCH: one equality check to do
 673 mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
 674   = return (CmmCondBranch cond deflt `consCgStmt` stmts)
 675   where
 676     cond  =  cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
 677         -- We have lo_tag < hi_tag, but there's only one branch,
 678         -- so there must be a default
 679
 680 -- ToDo: we might want to check for the two branch case, where one of
 681 -- the branches is the tag 0, because comparing '== 0' is likely to be
 682 -- more efficient than other kinds of comparison.
 683
 684 -- DENSE TAG RANGE: use a switch statment.
 685 --
 686 -- We also use a switch uncoditionally when compiling via C, because
 687 -- this will get emitted as a C switch statement and the C compiler
 688 -- should do a good job of optimising it.  Also, older GCC versions
 689 -- (2.95 in particular) have problems compiling the complicated
 690 -- if-trees generated by this code, so compiling to a switch every
 691 -- time works around that problem.
 692 --
 693 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
 694   | use_switch  -- Use a switch
 695   = do  { branch_ids <- mapM forkCgStmts (map snd branches)
 696         ; let
 697                 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
 698
 699                 find_branch :: ConTagZ -> Maybe BlockId
 700                 find_branch i = assocDefault mb_deflt tagged_blk_ids i
 701
 702                 -- NB. we have eliminated impossible branches at
 703                 -- either end of the range (see below), so the first
 704                 -- tag of a real branch is real_lo_tag (not lo_tag).
 705                 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
 706
 707                 switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
 708
 709         ; ASSERT(not (all isNothing arms))
 710           return (oneCgStmt switch_stmt)
 711         }
 712
 713   -- if we can knock off a bunch of default cases with one if, then do so
 714   | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
 715   = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
 716        ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
 717              branch = CmmCondBranch cond deflt
 718        ; stmts <- mk_switch tag_expr' branches mb_deflt
 719                         lowest_branch hi_tag via_C
 720        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 721        }
 722
 723   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
 724   = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
 725        ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
 726              branch = CmmCondBranch cond deflt
 727        ; stmts <- mk_switch tag_expr' branches mb_deflt
 728                         lo_tag highest_branch via_C
 729        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 730        }
 731
 732   | otherwise   -- Use an if-tree
 733   = do  { (assign_tag, tag_expr') <- assignTemp' tag_expr
 734                 -- To avoid duplication
 735         ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
 736                                 lo_tag (mid_tag-1) via_C
 737         ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
 738                                 mid_tag hi_tag via_C
 739         ; hi_id <- forkCgStmts hi_stmts
 740         ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
 741               branch_stmt = CmmCondBranch cond hi_id
 742         ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
 743         }
 744         -- we test (e >= mid_tag) rather than (e < mid_tag), because
 745         -- the former works better when e is a comparison, and there
 746         -- are two tags 0 & 1 (mid_tag == 1).  In this case, the code
 747         -- generator can reduce the condition to e itself without
 748         -- having to reverse the sense of the comparison: comparisons
 749         -- can't always be easily reversed (eg. floating
 750         -- pt. comparisons).
 751   where
 752     use_switch   = {- pprTrace "mk_switch" (
 753                         ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
 754                         text "branches:" <+> ppr (map fst branches) <+>
 755                         text "n_branches:" <+> int n_branches <+>
 756                         text "lo_tag:" <+> int lo_tag <+>
 757                         text "hi_tag:" <+> int hi_tag <+>
 758                         text "real_lo_tag:" <+> int real_lo_tag <+>
 759                         text "real_hi_tag:" <+> int real_hi_tag) $ -}
 760                    ASSERT( n_branches > 1 && n_tags > 1 )
 761                    n_tags > 2 && (via_C || (dense && big_enough))
 762                  -- up to 4 branches we use a decision tree, otherwise
 763                  -- a switch (== jump table in the NCG).  This seems to be
 764                  -- optimal, and corresponds with what gcc does.
 765     big_enough   = n_branches > 4
 766     dense        = n_branches > (n_tags `div` 2)
 767     n_branches   = length branches
 768
 769     -- ignore default slots at each end of the range if there's
 770     -- no default branch defined.
 771     lowest_branch  = fst (head branches)
 772     highest_branch = fst (last branches)
 773
 774     real_lo_tag
 775         | isNothing mb_deflt = lowest_branch
 776         | otherwise          = lo_tag
 777
 778     real_hi_tag
 779         | isNothing mb_deflt = highest_branch
 780         | otherwise          = hi_tag
 781
 782     n_tags = real_hi_tag - real_lo_tag + 1
 783
 784         -- INVARIANT: Provided hi_tag > lo_tag (which is true)
 785         --      lo_tag <= mid_tag < hi_tag
 786         --      lo_branches have tags <  mid_tag
 787         --      hi_branches have tags >= mid_tag
 788
 789     (mid_tag,_) = branches !! (n_branches `div` 2)
 790         -- 2 branches => n_branches `div` 2 = 1
 791         --            => branches !! 1 give the *second* tag
 792         -- There are always at least 2 branches here
 793
 794     (lo_branches, hi_branches) = span is_lo branches
 795     is_lo (t,_) = t < mid_tag
 796
 797
 798 assignTemp' e
 799   | isTrivialCmmExpr e = return (CmmNop, e)
 800   | otherwise          = do { reg <- newTemp (cmmExprType e)
 801                             ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
 802
 803 emitLitSwitch :: CmmExpr                        -- Tag to switch on
 804               -> [(Literal, CgStmts)]           -- Tagged branches
 805               -> CgStmts                        -- Default branch (always)
 806               -> Code                           -- Emit the code
 807 -- Used for general literals, whose size might not be a word,
 808 -- where there is always a default case, and where we don't know
 809 -- the range of values for certain.  For simplicity we always generate a tree.
 810 --
 811 -- ToDo: for integers we could do better here, perhaps by generalising
 812 -- mk_switch and using that.  --SDM 15/09/2004
 813 emitLitSwitch scrut [] deflt
 814   = emitCgStmts deflt
 815 emitLitSwitch scrut branches deflt_blk
 816   = do  { scrut' <- assignTemp scrut
 817         ; deflt_blk_id <- forkCgStmts deflt_blk
 818         ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
 819         ; emitCgStmts blk }
 820   where
 821     le (t1,_) (t2,_) = t1 <= t2
 822
 823 mk_lit_switch :: CmmExpr -> BlockId
 824               -> [(Literal,CgStmts)]
 825               -> FCode CgStmts
 826 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
 827   = return (consCgStmt if_stmt blk)
 828   where
 829     cmm_lit = mkSimpleLit lit
 830     rep     = cmmLitType cmm_lit
 831     ne      = if isFloatType rep then MO_F_Ne else MO_Ne
 832     cond    = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit]
 833     if_stmt = CmmCondBranch cond deflt_blk_id
 834
 835 mk_lit_switch scrut deflt_blk_id branches
 836   = do  { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
 837         ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
 838         ; lo_blk_id <- forkCgStmts lo_blk
 839         ; let if_stmt = CmmCondBranch cond lo_blk_id
 840         ; return (if_stmt `consCgStmt` hi_blk) }
 841   where
 842     n_branches = length branches
 843     (mid_lit,_) = branches !! (n_branches `div` 2)
 844         -- See notes above re mid_tag
 845
 846     (lo_branches, hi_branches) = span is_lo branches
 847     is_lo (t,_) = t < mid_lit
 848
 849     cond    = CmmMachOp (mkLtOp mid_lit)
 850                         [scrut, CmmLit (mkSimpleLit mid_lit)]
 851
 852 -------------------------------------------------------------------------
 853 --
 854 --      Simultaneous assignment
 855 --
 856 -------------------------------------------------------------------------
 857
 858
 859 emitSimultaneously :: CmmStmts -> Code
 860 -- Emit code to perform the assignments in the
 861 -- input simultaneously, using temporary variables when necessary.
 862 --
 863 -- The Stmts must be:
 864 --      CmmNop, CmmComment, CmmAssign, CmmStore
 865 -- and nothing else
 866
 867
 868 -- We use the strongly-connected component algorithm, in which
 869 --      * the vertices are the statements
 870 --      * an edge goes from s1 to s2 iff
 871 --              s1 assigns to something s2 uses
 872 --        that is, if s1 should *follow* s2 in the final order
 873
 874 type CVertex = (Int, CmmStmt)   -- Give each vertex a unique number,
 875                                 -- for fast comparison
 876
 877 emitSimultaneously stmts
 878   = codeOnly $
 879     case filterOut isNopStmt (stmtList stmts) of
 880         -- Remove no-ops
 881       []        -> nopC
 882       [stmt]    -> stmtC stmt   -- It's often just one stmt
 883       stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
 884
 885 doSimultaneously1 :: [CVertex] -> Code
 886 doSimultaneously1 vertices
 887   = let
 888         edges = [ (vertex, key1, edges_from stmt1)
 889                 | vertex@(key1, stmt1) <- vertices
 890                 ]
 891         edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
 892                                     stmt1 `mustFollow` stmt2
 893                            ]
 894         components = stronglyConnCompFromEdgedVertices edges
 895
 896         -- do_components deal with one strongly-connected component
 897         -- Not cyclic, or singleton?  Just do it
 898         do_component (AcyclicSCC (n,stmt))  = stmtC stmt
 899         do_component (CyclicSCC [(n,stmt)]) = stmtC stmt
 900
 901                 -- Cyclic?  Then go via temporaries.  Pick one to
 902                 -- break the loop and try again with the rest.
 903         do_component (CyclicSCC ((n,first_stmt) : rest))
 904           = do  { from_temp <- go_via_temp first_stmt
 905                 ; doSimultaneously1 rest
 906                 ; stmtC from_temp }
 907
 908         go_via_temp (CmmAssign dest src)
 909           = do  { tmp <- newTemp (cmmRegType dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
 910                 ; stmtC (CmmAssign (CmmLocal tmp) src)
 911                 ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
 912         go_via_temp (CmmStore dest src)
 913           = do  { tmp <- newTemp (cmmExprType src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong
 914                 ; stmtC (CmmAssign (CmmLocal tmp) src)
 915                 ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
 916     in
 917     mapCs do_component components
 918
 919 mustFollow :: CmmStmt -> CmmStmt -> Bool
 920 CmmAssign reg _  `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
 921 CmmStore loc e   `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprType e)) stmt
 922 CmmNop           `mustFollow` stmt = False
 923 CmmComment _     `mustFollow` stmt = False
 924
 925
 926 anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
 927 -- True if the fn is true of any input of the stmt
 928 anySrc p (CmmAssign _ e)    = p e
 929 anySrc p (CmmStore e1 e2)   = p e1 || p e2      -- Might be used in either side
 930 anySrc p (CmmComment _)     = False
 931 anySrc p CmmNop             = False
 932 anySrc p other              = True              -- Conservative
 933
 934 regUsedIn :: CmmReg -> CmmExpr -> Bool
 935 reg `regUsedIn` CmmLit _         = False
 936 reg `regUsedIn` CmmLoad e  _     = reg `regUsedIn` e
 937 reg `regUsedIn` CmmReg reg'      = reg == reg'
 938 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
 939 reg `regUsedIn` CmmMachOp _ es   = any (reg `regUsedIn`) es
 940
 941 locUsedIn :: CmmExpr -> CmmType -> CmmExpr -> Bool
 942 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
 943 -- 'e'.  Returns True if it's not sure.
 944 locUsedIn loc rep (CmmLit _)         = False
 945 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
 946 locUsedIn loc rep (CmmReg reg')      = False
 947 locUsedIn loc rep (CmmRegOff reg' _) = False
 948 locUsedIn loc rep (CmmMachOp _ es)   = any (locUsedIn loc rep) es
 949
 950 possiblySameLoc :: CmmExpr -> CmmType -> CmmExpr -> CmmType -> Bool
 951 -- Assumes that distinct registers (eg Hp, Sp) do not
 952 -- point to the same location, nor any offset thereof.
 953 possiblySameLoc (CmmReg r1)       rep1 (CmmReg r2)      rep2  = r1==r2
 954 possiblySameLoc (CmmReg r1)       rep1 (CmmRegOff r2 0) rep2  = r1==r2
 955 possiblySameLoc (CmmRegOff r1 0)  rep1 (CmmReg r2)      rep2  = r1==r2
 956 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
 957   = r1==r2 && end1 > start2 && end2 > start1
 958   where
 959     end1 = start1 + widthInBytes (typeWidth rep1)
 960     end2 = start2 + widthInBytes (typeWidth rep2)
 961
 962 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
 963 possiblySameLoc l1 rep1 l2         rep2 = True  -- Conservative
 964
 965 -------------------------------------------------------------------------
 966 --
 967 --      Static Reference Tables
 968 --
 969 -------------------------------------------------------------------------
 970
 971 -- There is just one SRT for each top level binding; all the nested
 972 -- bindings use sub-sections of this SRT.  The label is passed down to
 973 -- the nested bindings via the monad.
 974
 975 getSRTInfo :: FCode C_SRT
 976 getSRTInfo = do
 977   srt_lbl <- getSRTLabel
 978   srt <- getSRT
 979   case srt of
 980     -- TODO: Should we panic in this case?
 981     -- Someone obviously thinks there should be an SRT
 982     NoSRT -> return NoC_SRT
 983     SRTEntries {} -> panic "getSRTInfo: SRTEntries.  Perhaps you forgot to run SimplStg?"
 984     SRT off len bmp
 985       | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
 986       -> do id <- newUnique
 987             let srt_desc_lbl = mkLargeSRTLabel id
 988             emitRODataLits "getSRTInfo" srt_desc_lbl
 989              ( cmmLabelOffW srt_lbl off
 990                : mkWordCLit (fromIntegral len)
 991                : map mkWordCLit bmp)
 992             return (C_SRT srt_desc_lbl 0 srt_escape)
 993
 994     SRT off len bmp
 995       | otherwise
 996       -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
 997                 -- The fromIntegral converts to StgHalfWord
 998
 999 srt_escape = (-1) :: StgHalfWord
1000
1001 clHasCafRefs :: ClosureInfo -> CafInfo
1002 clHasCafRefs (ClosureInfo {closureSRT = srt}) =
1003   case srt of NoC_SRT -> NoCafRefs
1004               _       -> MayHaveCafRefs
1005 clHasCafRefs (ConInfo {}) = NoCafRefs