compiler/codeGen/CgUtils.hs

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