compiler/codeGen/CgUtils.hs

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