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