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