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 GCEnter1            = oFFSET_stgGCEnter1
 546 baseRegOffset GCFun               = oFFSET_stgGCFun
 547 baseRegOffset BaseReg             = panic "baseRegOffset:BaseReg"
 548 baseRegOffset _                   = panic "baseRegOffset:other"
 549
 550
 551 -------------------------------------------------------------------------
 552 --
 553 --      Strings generate a top-level data block
 554 --
 555 -------------------------------------------------------------------------
 556
 557 emitDataLits :: CLabel -> [CmmLit] -> Code
 558 -- Emit a data-segment data block
 559 emitDataLits lbl lits
 560   = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 561
 562 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
 563 -- Emit a data-segment data block
 564 mkDataLits lbl lits
 565   = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 566
 567 emitRODataLits :: CLabel -> [CmmLit] -> Code
 568 -- Emit a read-only data block
 569 emitRODataLits lbl lits
 570   = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
 571   where section | any needsRelocation lits = RelocatableReadOnlyData
 572                 | otherwise                = ReadOnlyData
 573         needsRelocation (CmmLabel _)      = True
 574         needsRelocation (CmmLabelOff _ _) = True
 575         needsRelocation _                 = False
 576
 577 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
 578 mkRODataLits lbl lits
 579   = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
 580   where section | any needsRelocation lits = RelocatableReadOnlyData
 581                 | otherwise                = ReadOnlyData
 582         needsRelocation (CmmLabel _)      = True
 583         needsRelocation (CmmLabelOff _ _) = True
 584         needsRelocation _                 = False
 585
 586 mkStringCLit :: String -> FCode CmmLit
 587 -- Make a global definition for the string,
 588 -- and return its label
 589 mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str)
 590
 591 mkByteStringCLit :: [Word8] -> FCode CmmLit
 592 mkByteStringCLit bytes
 593   = do  { uniq <- newUnique
 594         ; let lbl = mkStringLitLabel uniq
 595         ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
 596         ; return (CmmLabel lbl) }
 597
 598 -------------------------------------------------------------------------
 599 --
 600 --      Assigning expressions to temporaries
 601 --
 602 -------------------------------------------------------------------------
 603
 604 assignNonPtrTemp :: CmmExpr -> FCode CmmExpr
 605 -- For a non-trivial expression, e, create a local
 606 -- variable and assign the expression to it
 607 assignNonPtrTemp e
 608   | isTrivialCmmExpr e = return e
 609   | otherwise          = do { reg <- newNonPtrTemp (cmmExprRep e)
 610                             ; stmtC (CmmAssign (CmmLocal reg) e)
 611                             ; return (CmmReg (CmmLocal reg)) }
 612
 613 assignPtrTemp :: CmmExpr -> FCode CmmExpr
 614 -- For a non-trivial expression, e, create a local
 615 -- variable and assign the expression to it
 616 assignPtrTemp e
 617   | isTrivialCmmExpr e = return e
 618   | otherwise          = do { reg <- newPtrTemp (cmmExprRep e)
 619                             ; stmtC (CmmAssign (CmmLocal reg) e)
 620                             ; return (CmmReg (CmmLocal reg)) }
 621
 622 newNonPtrTemp :: MachRep -> FCode LocalReg
 623 newNonPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep GCKindNonPtr) }
 624
 625 newPtrTemp :: MachRep -> FCode LocalReg
 626 newPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep GCKindPtr) }
 627
 628
 629 -------------------------------------------------------------------------
 630 --
 631 --      Building case analysis
 632 --
 633 -------------------------------------------------------------------------
 634
 635 emitSwitch
 636         :: CmmExpr                -- Tag to switch on
 637         -> [(ConTagZ, CgStmts)]   -- Tagged branches
 638         -> Maybe CgStmts          -- Default branch (if any)
 639         -> ConTagZ -> ConTagZ     -- Min and Max possible values; behaviour
 640                                   --    outside this range is undefined
 641         -> Code
 642
 643 -- ONLY A DEFAULT BRANCH: no case analysis to do
 644 emitSwitch tag_expr [] (Just stmts) _ _
 645   = emitCgStmts stmts
 646
 647 -- Right, off we go
 648 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
 649   =     -- Just sort the branches before calling mk_sritch
 650     do  { mb_deflt_id <-
 651                 case mb_deflt of
 652                   Nothing    -> return Nothing
 653                   Just stmts -> do id <- forkCgStmts stmts; return (Just id)
 654
 655         ; dflags <- getDynFlags
 656         ; let via_C | HscC <- hscTarget dflags = True
 657                     | otherwise                = False
 658
 659         ; stmts <- mk_switch tag_expr (sortLe le branches)
 660                         mb_deflt_id lo_tag hi_tag via_C
 661         ; emitCgStmts stmts
 662         }
 663   where
 664     (t1,_) `le` (t2,_) = t1 <= t2
 665
 666
 667 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
 668           -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
 669           -> FCode CgStmts
 670
 671 -- SINGLETON TAG RANGE: no case analysis to do
 672 mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
 673   | lo_tag == hi_tag
 674   = ASSERT( tag == lo_tag )
 675     return stmts
 676
 677 -- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
 678 mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
 679   = return stmts
 680         -- The simplifier might have eliminated a case
 681         --       so we may have e.g. case xs of
 682         --                               [] -> e
 683         -- In that situation we can be sure the (:) case
 684         -- can't happen, so no need to test
 685
 686 -- SINGLETON BRANCH: one equality check to do
 687 mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
 688   = return (CmmCondBranch cond deflt `consCgStmt` stmts)
 689   where
 690     cond  =  cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
 691         -- We have lo_tag < hi_tag, but there's only one branch,
 692         -- so there must be a default
 693
 694 -- ToDo: we might want to check for the two branch case, where one of
 695 -- the branches is the tag 0, because comparing '== 0' is likely to be
 696 -- more efficient than other kinds of comparison.
 697
 698 -- DENSE TAG RANGE: use a switch statment.
 699 --
 700 -- We also use a switch uncoditionally when compiling via C, because
 701 -- this will get emitted as a C switch statement and the C compiler
 702 -- should do a good job of optimising it.  Also, older GCC versions
 703 -- (2.95 in particular) have problems compiling the complicated
 704 -- if-trees generated by this code, so compiling to a switch every
 705 -- time works around that problem.
 706 --
 707 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
 708   | use_switch  -- Use a switch
 709   = do  { branch_ids <- mapM forkCgStmts (map snd branches)
 710         ; let
 711                 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
 712
 713                 find_branch :: ConTagZ -> Maybe BlockId
 714                 find_branch i = assocDefault mb_deflt tagged_blk_ids i
 715
 716                 -- NB. we have eliminated impossible branches at
 717                 -- either end of the range (see below), so the first
 718                 -- tag of a real branch is real_lo_tag (not lo_tag).
 719                 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
 720
 721                 switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
 722
 723         ; ASSERT(not (all isNothing arms))
 724           return (oneCgStmt switch_stmt)
 725         }
 726
 727   -- if we can knock off a bunch of default cases with one if, then do so
 728   | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
 729   = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
 730        ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
 731              branch = CmmCondBranch cond deflt
 732        ; stmts <- mk_switch tag_expr' branches mb_deflt
 733                         lowest_branch hi_tag via_C
 734        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 735        }
 736
 737   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
 738   = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
 739        ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
 740              branch = CmmCondBranch cond deflt
 741        ; stmts <- mk_switch tag_expr' branches mb_deflt
 742                         lo_tag highest_branch via_C
 743        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 744        }
 745
 746   | otherwise   -- Use an if-tree
 747   = do  { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
 748                 -- To avoid duplication
 749         ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
 750                                 lo_tag (mid_tag-1) via_C
 751         ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
 752                                 mid_tag hi_tag via_C
 753         ; hi_id <- forkCgStmts hi_stmts
 754         ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
 755               branch_stmt = CmmCondBranch cond hi_id
 756         ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
 757         }
 758         -- we test (e >= mid_tag) rather than (e < mid_tag), because
 759         -- the former works better when e is a comparison, and there
 760         -- are two tags 0 & 1 (mid_tag == 1).  In this case, the code
 761         -- generator can reduce the condition to e itself without
 762         -- having to reverse the sense of the comparison: comparisons
 763         -- can't always be easily reversed (eg. floating
 764         -- pt. comparisons).
 765   where
 766     use_switch   = {- pprTrace "mk_switch" (
 767                         ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
 768                         text "branches:" <+> ppr (map fst branches) <+>
 769                         text "n_branches:" <+> int n_branches <+>
 770                         text "lo_tag:" <+> int lo_tag <+>
 771                         text "hi_tag:" <+> int hi_tag <+>
 772                         text "real_lo_tag:" <+> int real_lo_tag <+>
 773                         text "real_hi_tag:" <+> int real_hi_tag) $ -}
 774                    ASSERT( n_branches > 1 && n_tags > 1 )
 775                    n_tags > 2 && (via_C || (dense && big_enough))
 776                  -- up to 4 branches we use a decision tree, otherwise
 777                  -- a switch (== jump table in the NCG).  This seems to be
 778                  -- optimal, and corresponds with what gcc does.
 779     big_enough   = n_branches > 4
 780     dense        = n_branches > (n_tags `div` 2)
 781     n_branches   = length branches
 782
 783     -- ignore default slots at each end of the range if there's
 784     -- no default branch defined.
 785     lowest_branch  = fst (head branches)
 786     highest_branch = fst (last branches)
 787
 788     real_lo_tag
 789         | isNothing mb_deflt = lowest_branch
 790         | otherwise          = lo_tag
 791
 792     real_hi_tag
 793         | isNothing mb_deflt = highest_branch
 794         | otherwise          = hi_tag
 795
 796     n_tags = real_hi_tag - real_lo_tag + 1
 797
 798         -- INVARIANT: Provided hi_tag > lo_tag (which is true)
 799         --      lo_tag <= mid_tag < hi_tag
 800         --      lo_branches have tags <  mid_tag
 801         --      hi_branches have tags >= mid_tag
 802
 803     (mid_tag,_) = branches !! (n_branches `div` 2)
 804         -- 2 branches => n_branches `div` 2 = 1
 805         --            => branches !! 1 give the *second* tag
 806         -- There are always at least 2 branches here
 807
 808     (lo_branches, hi_branches) = span is_lo branches
 809     is_lo (t,_) = t < mid_tag
 810
 811
 812 assignNonPtrTemp' e
 813   | isTrivialCmmExpr e = return (CmmNop, e)
 814   | otherwise          = do { reg <- newNonPtrTemp (cmmExprRep e)
 815                             ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
 816
 817 emitLitSwitch :: CmmExpr                        -- Tag to switch on
 818               -> [(Literal, CgStmts)]           -- Tagged branches
 819               -> CgStmts                        -- Default branch (always)
 820               -> Code                           -- Emit the code
 821 -- Used for general literals, whose size might not be a word,
 822 -- where there is always a default case, and where we don't know
 823 -- the range of values for certain.  For simplicity we always generate a tree.
 824 --
 825 -- ToDo: for integers we could do better here, perhaps by generalising
 826 -- mk_switch and using that.  --SDM 15/09/2004
 827 emitLitSwitch scrut [] deflt
 828   = emitCgStmts deflt
 829 emitLitSwitch scrut branches deflt_blk
 830   = do  { scrut' <- assignNonPtrTemp scrut
 831         ; deflt_blk_id <- forkCgStmts deflt_blk
 832         ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
 833         ; emitCgStmts blk }
 834   where
 835     le (t1,_) (t2,_) = t1 <= t2
 836
 837 mk_lit_switch :: CmmExpr -> BlockId
 838               -> [(Literal,CgStmts)]
 839               -> FCode CgStmts
 840 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
 841   = return (consCgStmt if_stmt blk)
 842   where
 843     cmm_lit = mkSimpleLit lit
 844     rep     = cmmLitRep cmm_lit
 845     cond    = CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit]
 846     if_stmt = CmmCondBranch cond deflt_blk_id
 847
 848 mk_lit_switch scrut deflt_blk_id branches
 849   = do  { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
 850         ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
 851         ; lo_blk_id <- forkCgStmts lo_blk
 852         ; let if_stmt = CmmCondBranch cond lo_blk_id
 853         ; return (if_stmt `consCgStmt` hi_blk) }
 854   where
 855     n_branches = length branches
 856     (mid_lit,_) = branches !! (n_branches `div` 2)
 857         -- See notes above re mid_tag
 858
 859     (lo_branches, hi_branches) = span is_lo branches
 860     is_lo (t,_) = t < mid_lit
 861
 862     cond    = CmmMachOp (mkLtOp mid_lit)
 863                         [scrut, CmmLit (mkSimpleLit mid_lit)]
 864
 865 -------------------------------------------------------------------------
 866 --
 867 --      Simultaneous assignment
 868 --
 869 -------------------------------------------------------------------------
 870
 871
 872 emitSimultaneously :: CmmStmts -> Code
 873 -- Emit code to perform the assignments in the
 874 -- input simultaneously, using temporary variables when necessary.
 875 --
 876 -- The Stmts must be:
 877 --      CmmNop, CmmComment, CmmAssign, CmmStore
 878 -- and nothing else
 879
 880
 881 -- We use the strongly-connected component algorithm, in which
 882 --      * the vertices are the statements
 883 --      * an edge goes from s1 to s2 iff
 884 --              s1 assigns to something s2 uses
 885 --        that is, if s1 should *follow* s2 in the final order
 886
 887 type CVertex = (Int, CmmStmt)   -- Give each vertex a unique number,
 888                                 -- for fast comparison
 889
 890 emitSimultaneously stmts
 891   = codeOnly $
 892     case filterOut isNopStmt (stmtList stmts) of
 893         -- Remove no-ops
 894       []        -> nopC
 895       [stmt]    -> stmtC stmt   -- It's often just one stmt
 896       stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
 897
 898 doSimultaneously1 :: [CVertex] -> Code
 899 doSimultaneously1 vertices
 900   = let
 901         edges = [ (vertex, key1, edges_from stmt1)
 902                 | vertex@(key1, stmt1) <- vertices
 903                 ]
 904         edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
 905                                     stmt1 `mustFollow` stmt2
 906                            ]
 907         components = stronglyConnCompFromEdgedVertices edges
 908
 909         -- do_components deal with one strongly-connected component
 910         -- Not cyclic, or singleton?  Just do it
 911         do_component (AcyclicSCC (n,stmt))  = stmtC stmt
 912         do_component (CyclicSCC [(n,stmt)]) = stmtC stmt
 913
 914                 -- Cyclic?  Then go via temporaries.  Pick one to
 915                 -- break the loop and try again with the rest.
 916         do_component (CyclicSCC ((n,first_stmt) : rest))
 917           = do  { from_temp <- go_via_temp first_stmt
 918                 ; doSimultaneously1 rest
 919                 ; stmtC from_temp }
 920
 921         go_via_temp (CmmAssign dest src)
 922           = do  { tmp <- newNonPtrTemp (cmmRegRep dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
 923                 ; stmtC (CmmAssign (CmmLocal tmp) src)
 924                 ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
 925         go_via_temp (CmmStore dest src)
 926           = do  { tmp <- newNonPtrTemp (cmmExprRep src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong
 927                 ; stmtC (CmmAssign (CmmLocal tmp) src)
 928                 ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
 929     in
 930     mapCs do_component components
 931
 932 mustFollow :: CmmStmt -> CmmStmt -> Bool
 933 CmmAssign reg _  `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
 934 CmmStore loc e   `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprRep e)) stmt
 935 CmmNop           `mustFollow` stmt = False
 936 CmmComment _     `mustFollow` stmt = False
 937
 938
 939 anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
 940 -- True if the fn is true of any input of the stmt
 941 anySrc p (CmmAssign _ e)    = p e
 942 anySrc p (CmmStore e1 e2)   = p e1 || p e2      -- Might be used in either side
 943 anySrc p (CmmComment _)     = False
 944 anySrc p CmmNop             = False
 945 anySrc p other              = True              -- Conservative
 946
 947 regUsedIn :: CmmReg -> CmmExpr -> Bool
 948 reg `regUsedIn` CmmLit _         = False
 949 reg `regUsedIn` CmmLoad e  _     = reg `regUsedIn` e
 950 reg `regUsedIn` CmmReg reg'      = reg == reg'
 951 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
 952 reg `regUsedIn` CmmMachOp _ es   = any (reg `regUsedIn`) es
 953
 954 locUsedIn :: CmmExpr -> MachRep -> CmmExpr -> Bool
 955 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
 956 -- 'e'.  Returns True if it's not sure.
 957 locUsedIn loc rep (CmmLit _)         = False
 958 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
 959 locUsedIn loc rep (CmmReg reg')      = False
 960 locUsedIn loc rep (CmmRegOff reg' _) = False
 961 locUsedIn loc rep (CmmMachOp _ es)   = any (locUsedIn loc rep) es
 962
 963 possiblySameLoc :: CmmExpr -> MachRep -> CmmExpr -> MachRep -> Bool
 964 -- Assumes that distinct registers (eg Hp, Sp) do not
 965 -- point to the same location, nor any offset thereof.
 966 possiblySameLoc (CmmReg r1)       rep1 (CmmReg r2)      rep2  = r1==r2
 967 possiblySameLoc (CmmReg r1)       rep1 (CmmRegOff r2 0) rep2  = r1==r2
 968 possiblySameLoc (CmmRegOff r1 0)  rep1 (CmmReg r2)      rep2  = r1==r2
 969 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
 970   = r1==r2 && end1 > start2 && end2 > start1
 971   where
 972     end1 = start1 + machRepByteWidth rep1
 973     end2 = start2 + machRepByteWidth rep2
 974
 975 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
 976 possiblySameLoc l1 rep1 l2         rep2 = True  -- Conservative
 977
 978 -------------------------------------------------------------------------
 979 --
 980 --      Static Reference Tables
 981 --
 982 -------------------------------------------------------------------------
 983
 984 -- There is just one SRT for each top level binding; all the nested
 985 -- bindings use sub-sections of this SRT.  The label is passed down to
 986 -- the nested bindings via the monad.
 987
 988 getSRTInfo :: FCode C_SRT
 989 getSRTInfo = do
 990   srt_lbl <- getSRTLabel
 991   srt <- getSRT
 992   case srt of
 993     -- TODO: Should we panic in this case?
 994     -- Someone obviously thinks there should be an SRT
 995     NoSRT -> return NoC_SRT
 996     SRTEntries {} -> panic "getSRTInfo: SRTEntries.  Perhaps you forgot to run SimplStg?"
 997     SRT off len bmp
 998       | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
 999       -> do id <- newUnique
1000             let srt_desc_lbl = mkLargeSRTLabel id
1001             emitRODataLits srt_desc_lbl
1002              ( cmmLabelOffW srt_lbl off
1003                : mkWordCLit (fromIntegral len)
1004                : map mkWordCLit bmp)
1005             return (C_SRT srt_desc_lbl 0 srt_escape)
1006
1007     SRT off len bmp
1008       | otherwise
1009       -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
1010                 -- The fromIntegral converts to StgHalfWord
1011
1012 srt_escape = (-1) :: StgHalfWord