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