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         assignTemp, newTemp,
  24         emitSimultaneously,
  25         emitSwitch, emitLitSwitch,
  26         tagToClosure,
  27
  28         callerSaveVolatileRegs, get_GlobalReg_addr,
  29
  30         cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
  31         cmmUGtWord,
  32         cmmOffsetExprW, cmmOffsetExprB,
  33         cmmRegOffW, cmmRegOffB,
  34         cmmLabelOffW, cmmLabelOffB,
  35         cmmOffsetW, cmmOffsetB,
  36         cmmOffsetLitW, cmmOffsetLitB,
  37         cmmLoadIndexW,
  38         cmmConstrTag, cmmConstrTag1,
  39
  40         tagForCon, tagCons, isSmallFamily,
  41         cmmUntag, cmmIsTagged, cmmGetTag,
  42
  43         addToMem, addToMemE,
  44         mkWordCLit,
  45         mkStringCLit, mkByteStringCLit,
  46         packHalfWordsCLit,
  47         blankWord,
  48
  49         getSRTInfo, clHasCafRefs
  50   ) where
  51
  52 #include "HsVersions.h"
  53 #include "../includes/stg/MachRegs.h"
  54
  55 import BlockId
  56 import CgMonad
  57 import TyCon
  58 import DataCon
  59 import Id
  60 import IdInfo
  61 import Constants
  62 import SMRep
  63 import PprCmm           ( {- instances -} )
  64 import Cmm
  65 import CLabel
  66 import CmmUtils
  67 import ForeignCall
  68 import ClosureInfo
  69 import StgSyn (SRT(..))
  70 import Module
  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)) wordWidth
 107 mkSimpleLit MachNullAddr      = zeroCLit
 108 mkSimpleLit (MachInt i)       = CmmInt i wordWidth
 109 mkSimpleLit (MachInt64 i)     = CmmInt i W64
 110 mkSimpleLit (MachWord i)      = CmmInt i wordWidth
 111 mkSimpleLit (MachWord64 i)    = CmmInt i W64
 112 mkSimpleLit (MachFloat r)     = CmmFloat r W32
 113 mkSimpleLit (MachDouble r)    = CmmFloat r W64
 114 mkSimpleLit (MachLabel fs ms fod) = CmmLabel (mkForeignLabel fs ms is_dyn fod)
 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 wordWidth
 121 mkLtOp (MachFloat _)  = MO_F_Lt W32
 122 mkLtOp (MachDouble _) = MO_F_Lt W64
 123 mkLtOp lit            = MO_U_Lt (typeWidth (cmmLitType (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 wordWidth 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 -> CmmType -> CmmExpr
 169 cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty
 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 (cmmExprWidth 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) wordWidth
 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 :: Width       -- rep of the counter
 270          -> CmmExpr     -- Address
 271          -> Int         -- What to add (a word)
 272          -> CmmStmt
 273 addToMem width ptr n = addToMemE width ptr (CmmLit (CmmInt (toInteger n) width))
 274
 275 addToMemE :: Width      -- rep of the counter
 276           -> CmmExpr    -- Address
 277           -> CmmExpr    -- What to add (a word-typed expression)
 278           -> CmmStmt
 279 addToMemE width ptr n
 280   = CmmStore ptr (CmmMachOp (MO_Add width) [CmmLoad ptr (cmmBits width), 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) gcWord
 292   where closure_tbl = CmmLit (CmmLabel lbl)
 293         lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
 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        ; join_id <- newLabelC
 327        ; stmtC (CmmCondBranch cond then_id)
 328        ; else_part
 329        ; stmtC (CmmBranch join_id)
 330        ; labelC then_id
 331        ; then_part
 332        ; labelC join_id
 333        }
 334
 335
 336 -- | Emit code to call a Cmm function.
 337 emitRtsCall
 338    :: PackageId                 -- ^ package the function is in
 339    -> FastString                -- ^ name of function
 340    -> [CmmHinted CmmExpr]       -- ^ function args
 341    -> Bool                      -- ^ whether this is a safe call
 342    -> Code                      -- ^ cmm code
 343
 344 emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe
 345    -- The 'Nothing' says "save all global registers"
 346
 347 emitRtsCallWithVols :: PackageId -> FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code
 348 emitRtsCallWithVols pkg fun args vols safe
 349    = emitRtsCall' [] pkg fun args (Just vols) safe
 350
 351 emitRtsCallWithResult
 352    :: LocalReg -> ForeignHint
 353    -> PackageId -> FastString
 354    -> [CmmHinted CmmExpr] -> Bool -> Code
 355 emitRtsCallWithResult res hint pkg fun args safe
 356    = emitRtsCall' [CmmHinted res hint] pkg fun args Nothing safe
 357
 358 -- Make a call to an RTS C procedure
 359 emitRtsCall'
 360    :: [CmmHinted LocalReg]
 361    -> PackageId
 362    -> FastString
 363    -> [CmmHinted CmmExpr]
 364    -> Maybe [GlobalReg]
 365    -> Bool -- True <=> CmmSafe call
 366    -> Code
 367 emitRtsCall' res pkg fun args vols safe = do
 368   safety <- if safe
 369             then getSRTInfo >>= (return . CmmSafe)
 370             else return CmmUnsafe
 371   stmtsC caller_save
 372   stmtC (CmmCall target res args safety CmmMayReturn)
 373   stmtsC caller_load
 374   where
 375     (caller_save, caller_load) = callerSaveVolatileRegs vols
 376     target   = CmmCallee fun_expr CCallConv
 377     fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
 378
 379 -----------------------------------------------------------------------------
 380 --
 381 --      Caller-Save Registers
 382 --
 383 -----------------------------------------------------------------------------
 384
 385 -- Here we generate the sequence of saves/restores required around a
 386 -- foreign call instruction.
 387
 388 -- TODO: reconcile with includes/Regs.h
 389 --  * Regs.h claims that BaseReg should be saved last and loaded first
 390 --    * This might not have been tickled before since BaseReg is callee save
 391 --  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
 392 callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
 393 callerSaveVolatileRegs vols = (caller_save, caller_load)
 394   where
 395     caller_save = foldr ($!) [] (map callerSaveGlobalReg    regs_to_save)
 396     caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save)
 397
 398     system_regs = [Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery,
 399                    {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ]
 400
 401     regs_to_save = system_regs ++ vol_list
 402
 403     vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
 404
 405     all_of_em = [ VanillaReg n VNonGcPtr | n <- [0..mAX_Vanilla_REG] ]
 406                         -- The VNonGcPtr is a lie, but I don't think it matters
 407              ++ [ FloatReg   n | n <- [0..mAX_Float_REG] ]
 408              ++ [ DoubleReg  n | n <- [0..mAX_Double_REG] ]
 409              ++ [ LongReg    n | n <- [0..mAX_Long_REG] ]
 410
 411     callerSaveGlobalReg reg next
 412         | callerSaves reg =
 413                 CmmStore (get_GlobalReg_addr reg)
 414                          (CmmReg (CmmGlobal reg)) : next
 415         | otherwise = next
 416
 417     callerRestoreGlobalReg reg next
 418         | callerSaves reg =
 419                 CmmAssign (CmmGlobal reg)
 420                           (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
 421                         : next
 422         | otherwise = next
 423
 424 -- -----------------------------------------------------------------------------
 425 -- Global registers
 426
 427 -- We map STG registers onto appropriate CmmExprs.  Either they map
 428 -- to real machine registers or stored as offsets from BaseReg.  Given
 429 -- a GlobalReg, get_GlobalReg_addr always produces the
 430 -- register table address for it.
 431 -- (See also get_GlobalReg_reg_or_addr in MachRegs)
 432
 433 get_GlobalReg_addr              :: GlobalReg -> CmmExpr
 434 get_GlobalReg_addr BaseReg = regTableOffset 0
 435 get_GlobalReg_addr mid     = get_Regtable_addr_from_offset
 436                                 (globalRegType mid) (baseRegOffset mid)
 437
 438 -- Calculate a literal representing an offset into the register table.
 439 -- Used when we don't have an actual BaseReg to offset from.
 440 regTableOffset n =
 441   CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
 442
 443 get_Regtable_addr_from_offset   :: CmmType -> Int -> CmmExpr
 444 get_Regtable_addr_from_offset rep offset =
 445 #ifdef REG_Base
 446   CmmRegOff (CmmGlobal BaseReg) offset
 447 #else
 448   regTableOffset offset
 449 #endif
 450
 451
 452 -- | Returns @True@ if this global register is stored in a caller-saves
 453 -- machine register.
 454
 455 callerSaves :: GlobalReg -> Bool
 456
 457 #ifdef CALLER_SAVES_Base
 458 callerSaves BaseReg             = True
 459 #endif
 460 #ifdef CALLER_SAVES_R1
 461 callerSaves (VanillaReg 1 _)    = True
 462 #endif
 463 #ifdef CALLER_SAVES_R2
 464 callerSaves (VanillaReg 2 _)    = True
 465 #endif
 466 #ifdef CALLER_SAVES_R3
 467 callerSaves (VanillaReg 3 _)    = True
 468 #endif
 469 #ifdef CALLER_SAVES_R4
 470 callerSaves (VanillaReg 4 _)    = True
 471 #endif
 472 #ifdef CALLER_SAVES_R5
 473 callerSaves (VanillaReg 5 _)    = True
 474 #endif
 475 #ifdef CALLER_SAVES_R6
 476 callerSaves (VanillaReg 6 _)    = True
 477 #endif
 478 #ifdef CALLER_SAVES_R7
 479 callerSaves (VanillaReg 7 _)    = True
 480 #endif
 481 #ifdef CALLER_SAVES_R8
 482 callerSaves (VanillaReg 8 _)    = True
 483 #endif
 484 #ifdef CALLER_SAVES_F1
 485 callerSaves (FloatReg 1)        = True
 486 #endif
 487 #ifdef CALLER_SAVES_F2
 488 callerSaves (FloatReg 2)        = True
 489 #endif
 490 #ifdef CALLER_SAVES_F3
 491 callerSaves (FloatReg 3)        = True
 492 #endif
 493 #ifdef CALLER_SAVES_F4
 494 callerSaves (FloatReg 4)        = True
 495 #endif
 496 #ifdef CALLER_SAVES_D1
 497 callerSaves (DoubleReg 1)       = True
 498 #endif
 499 #ifdef CALLER_SAVES_D2
 500 callerSaves (DoubleReg 2)       = True
 501 #endif
 502 #ifdef CALLER_SAVES_L1
 503 callerSaves (LongReg 1)         = True
 504 #endif
 505 #ifdef CALLER_SAVES_Sp
 506 callerSaves Sp                  = True
 507 #endif
 508 #ifdef CALLER_SAVES_SpLim
 509 callerSaves SpLim               = True
 510 #endif
 511 #ifdef CALLER_SAVES_Hp
 512 callerSaves Hp                  = True
 513 #endif
 514 #ifdef CALLER_SAVES_HpLim
 515 callerSaves HpLim               = True
 516 #endif
 517 #ifdef CALLER_SAVES_CurrentTSO
 518 callerSaves CurrentTSO          = True
 519 #endif
 520 #ifdef CALLER_SAVES_CurrentNursery
 521 callerSaves CurrentNursery      = True
 522 #endif
 523 callerSaves _                   = False
 524
 525
 526 -- -----------------------------------------------------------------------------
 527 -- Information about global registers
 528
 529 baseRegOffset :: GlobalReg -> Int
 530
 531 baseRegOffset (VanillaReg 1 _)    = oFFSET_StgRegTable_rR1
 532 baseRegOffset (VanillaReg 2 _)    = oFFSET_StgRegTable_rR2
 533 baseRegOffset (VanillaReg 3 _)    = oFFSET_StgRegTable_rR3
 534 baseRegOffset (VanillaReg 4 _)    = oFFSET_StgRegTable_rR4
 535 baseRegOffset (VanillaReg 5 _)    = oFFSET_StgRegTable_rR5
 536 baseRegOffset (VanillaReg 6 _)    = oFFSET_StgRegTable_rR6
 537 baseRegOffset (VanillaReg 7 _)    = oFFSET_StgRegTable_rR7
 538 baseRegOffset (VanillaReg 8 _)    = oFFSET_StgRegTable_rR8
 539 baseRegOffset (VanillaReg 9 _)    = oFFSET_StgRegTable_rR9
 540 baseRegOffset (VanillaReg 10 _)   = oFFSET_StgRegTable_rR10
 541 baseRegOffset (FloatReg  1)       = oFFSET_StgRegTable_rF1
 542 baseRegOffset (FloatReg  2)       = oFFSET_StgRegTable_rF2
 543 baseRegOffset (FloatReg  3)       = oFFSET_StgRegTable_rF3
 544 baseRegOffset (FloatReg  4)       = oFFSET_StgRegTable_rF4
 545 baseRegOffset (DoubleReg 1)       = oFFSET_StgRegTable_rD1
 546 baseRegOffset (DoubleReg 2)       = oFFSET_StgRegTable_rD2
 547 baseRegOffset Sp                  = oFFSET_StgRegTable_rSp
 548 baseRegOffset SpLim               = oFFSET_StgRegTable_rSpLim
 549 baseRegOffset (LongReg 1)         = oFFSET_StgRegTable_rL1
 550 baseRegOffset Hp                  = oFFSET_StgRegTable_rHp
 551 baseRegOffset HpLim               = oFFSET_StgRegTable_rHpLim
 552 baseRegOffset CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO
 553 baseRegOffset CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery
 554 baseRegOffset HpAlloc             = oFFSET_StgRegTable_rHpAlloc
 555 baseRegOffset EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo
 556 baseRegOffset GCEnter1            = oFFSET_stgGCEnter1
 557 baseRegOffset GCFun               = oFFSET_stgGCFun
 558 baseRegOffset BaseReg             = panic "baseRegOffset:BaseReg"
 559 baseRegOffset _                   = panic "baseRegOffset:other"
 560
 561
 562 -------------------------------------------------------------------------
 563 --
 564 --      Strings generate a top-level data block
 565 --
 566 -------------------------------------------------------------------------
 567
 568 emitDataLits :: CLabel -> [CmmLit] -> Code
 569 -- Emit a data-segment data block
 570 emitDataLits lbl lits
 571   = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 572
 573 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
 574 -- Emit a data-segment data block
 575 mkDataLits lbl lits
 576   = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 577
 578 emitRODataLits :: String -> CLabel -> [CmmLit] -> Code
 579 -- Emit a read-only data block
 580 emitRODataLits caller lbl lits
 581   = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
 582     where section | any needsRelocation lits = RelocatableReadOnlyData
 583                   | otherwise                = ReadOnlyData
 584           needsRelocation (CmmLabel _)      = True
 585           needsRelocation (CmmLabelOff _ _) = True
 586           needsRelocation _                 = False
 587
 588 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
 589 mkRODataLits lbl lits
 590   = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
 591   where section | any needsRelocation lits = RelocatableReadOnlyData
 592                 | otherwise                = ReadOnlyData
 593         needsRelocation (CmmLabel _)      = True
 594         needsRelocation (CmmLabelOff _ _) = True
 595         needsRelocation _                 = False
 596
 597 mkStringCLit :: String -> FCode CmmLit
 598 -- Make a global definition for the string,
 599 -- and return its label
 600 mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str)
 601
 602 mkByteStringCLit :: [Word8] -> FCode CmmLit
 603 mkByteStringCLit bytes
 604   = do  { uniq <- newUnique
 605         ; let lbl = mkStringLitLabel uniq
 606         ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
 607         ; return (CmmLabel lbl) }
 608
 609 -------------------------------------------------------------------------
 610 --
 611 --      Assigning expressions to temporaries
 612 --
 613 -------------------------------------------------------------------------
 614
 615 assignTemp :: CmmExpr -> FCode CmmExpr
 616 -- For a non-trivial expression, e, create a local
 617 -- variable and assign the expression to it
 618 assignTemp e
 619   | isTrivialCmmExpr e = return e
 620   | otherwise          = do { reg <- newTemp (cmmExprType e)
 621                             ; stmtC (CmmAssign (CmmLocal reg) e)
 622                             ; return (CmmReg (CmmLocal reg)) }
 623
 624 newTemp :: CmmType -> FCode LocalReg
 625 newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
 626
 627 -------------------------------------------------------------------------
 628 --
 629 --      Building case analysis
 630 --
 631 -------------------------------------------------------------------------
 632
 633 emitSwitch
 634         :: CmmExpr                -- Tag to switch on
 635         -> [(ConTagZ, CgStmts)]   -- Tagged branches
 636         -> Maybe CgStmts          -- Default branch (if any)
 637         -> ConTagZ -> ConTagZ     -- Min and Max possible values; behaviour
 638                                   --    outside this range is undefined
 639         -> Code
 640
 641 -- ONLY A DEFAULT BRANCH: no case analysis to do
 642 emitSwitch tag_expr [] (Just stmts) _ _
 643   = emitCgStmts stmts
 644
 645 -- Right, off we go
 646 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
 647   =     -- Just sort the branches before calling mk_sritch
 648     do  { mb_deflt_id <-
 649                 case mb_deflt of
 650                   Nothing    -> return Nothing
 651                   Just stmts -> do id <- forkCgStmts stmts; return (Just id)
 652
 653         ; dflags <- getDynFlags
 654         ; let via_C | HscC <- hscTarget dflags = True
 655                     | otherwise                = False
 656
 657         ; stmts <- mk_switch tag_expr (sortLe le branches)
 658                         mb_deflt_id lo_tag hi_tag via_C
 659         ; emitCgStmts stmts
 660         }
 661   where
 662     (t1,_) `le` (t2,_) = t1 <= t2
 663
 664
 665 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
 666           -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
 667           -> FCode CgStmts
 668
 669 -- SINGLETON TAG RANGE: no case analysis to do
 670 mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
 671   | lo_tag == hi_tag
 672   = ASSERT( tag == lo_tag )
 673     return stmts
 674
 675 -- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
 676 mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
 677   = return stmts
 678         -- The simplifier might have eliminated a case
 679         --       so we may have e.g. case xs of
 680         --                               [] -> e
 681         -- In that situation we can be sure the (:) case
 682         -- can't happen, so no need to test
 683
 684 -- SINGLETON BRANCH: one equality check to do
 685 mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
 686   = return (CmmCondBranch cond deflt `consCgStmt` stmts)
 687   where
 688     cond  =  cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
 689         -- We have lo_tag < hi_tag, but there's only one branch,
 690         -- so there must be a default
 691
 692 -- ToDo: we might want to check for the two branch case, where one of
 693 -- the branches is the tag 0, because comparing '== 0' is likely to be
 694 -- more efficient than other kinds of comparison.
 695
 696 -- DENSE TAG RANGE: use a switch statment.
 697 --
 698 -- We also use a switch uncoditionally when compiling via C, because
 699 -- this will get emitted as a C switch statement and the C compiler
 700 -- should do a good job of optimising it.  Also, older GCC versions
 701 -- (2.95 in particular) have problems compiling the complicated
 702 -- if-trees generated by this code, so compiling to a switch every
 703 -- time works around that problem.
 704 --
 705 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
 706   | use_switch  -- Use a switch
 707   = do  { branch_ids <- mapM forkCgStmts (map snd branches)
 708         ; let
 709                 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
 710
 711                 find_branch :: ConTagZ -> Maybe BlockId
 712                 find_branch i = assocDefault mb_deflt tagged_blk_ids i
 713
 714                 -- NB. we have eliminated impossible branches at
 715                 -- either end of the range (see below), so the first
 716                 -- tag of a real branch is real_lo_tag (not lo_tag).
 717                 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
 718
 719                 switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
 720
 721         ; ASSERT(not (all isNothing arms))
 722           return (oneCgStmt switch_stmt)
 723         }
 724
 725   -- if we can knock off a bunch of default cases with one if, then do so
 726   | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
 727   = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
 728        ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
 729              branch = CmmCondBranch cond deflt
 730        ; stmts <- mk_switch tag_expr' branches mb_deflt
 731                         lowest_branch hi_tag via_C
 732        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 733        }
 734
 735   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
 736   = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
 737        ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
 738              branch = CmmCondBranch cond deflt
 739        ; stmts <- mk_switch tag_expr' branches mb_deflt
 740                         lo_tag highest_branch via_C
 741        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 742        }
 743
 744   | otherwise   -- Use an if-tree
 745   = do  { (assign_tag, tag_expr') <- assignTemp' tag_expr
 746                 -- To avoid duplication
 747         ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
 748                                 lo_tag (mid_tag-1) via_C
 749         ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
 750                                 mid_tag hi_tag via_C
 751         ; hi_id <- forkCgStmts hi_stmts
 752         ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
 753               branch_stmt = CmmCondBranch cond hi_id
 754         ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
 755         }
 756         -- we test (e >= mid_tag) rather than (e < mid_tag), because
 757         -- the former works better when e is a comparison, and there
 758         -- are two tags 0 & 1 (mid_tag == 1).  In this case, the code
 759         -- generator can reduce the condition to e itself without
 760         -- having to reverse the sense of the comparison: comparisons
 761         -- can't always be easily reversed (eg. floating
 762         -- pt. comparisons).
 763   where
 764     use_switch   = {- pprTrace "mk_switch" (
 765                         ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
 766                         text "branches:" <+> ppr (map fst branches) <+>
 767                         text "n_branches:" <+> int n_branches <+>
 768                         text "lo_tag:" <+> int lo_tag <+>
 769                         text "hi_tag:" <+> int hi_tag <+>
 770                         text "real_lo_tag:" <+> int real_lo_tag <+>
 771                         text "real_hi_tag:" <+> int real_hi_tag) $ -}
 772                    ASSERT( n_branches > 1 && n_tags > 1 )
 773                    n_tags > 2 && (via_C || (dense && big_enough))
 774                  -- up to 4 branches we use a decision tree, otherwise
 775                  -- a switch (== jump table in the NCG).  This seems to be
 776                  -- optimal, and corresponds with what gcc does.
 777     big_enough   = n_branches > 4
 778     dense        = n_branches > (n_tags `div` 2)
 779     n_branches   = length branches
 780
 781     -- ignore default slots at each end of the range if there's
 782     -- no default branch defined.
 783     lowest_branch  = fst (head branches)
 784     highest_branch = fst (last branches)
 785
 786     real_lo_tag
 787         | isNothing mb_deflt = lowest_branch
 788         | otherwise          = lo_tag
 789
 790     real_hi_tag
 791         | isNothing mb_deflt = highest_branch
 792         | otherwise          = hi_tag
 793
 794     n_tags = real_hi_tag - real_lo_tag + 1
 795
 796         -- INVARIANT: Provided hi_tag > lo_tag (which is true)
 797         --      lo_tag <= mid_tag < hi_tag
 798         --      lo_branches have tags <  mid_tag
 799         --      hi_branches have tags >= mid_tag
 800
 801     (mid_tag,_) = branches !! (n_branches `div` 2)
 802         -- 2 branches => n_branches `div` 2 = 1
 803         --            => branches !! 1 give the *second* tag
 804         -- There are always at least 2 branches here
 805
 806     (lo_branches, hi_branches) = span is_lo branches
 807     is_lo (t,_) = t < mid_tag
 808
 809
 810 assignTemp' e
 811   | isTrivialCmmExpr e = return (CmmNop, e)
 812   | otherwise          = do { reg <- newTemp (cmmExprType e)
 813                             ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
 814
 815 emitLitSwitch :: CmmExpr                        -- Tag to switch on
 816               -> [(Literal, CgStmts)]           -- Tagged branches
 817               -> CgStmts                        -- Default branch (always)
 818               -> Code                           -- Emit the code
 819 -- Used for general literals, whose size might not be a word,
 820 -- where there is always a default case, and where we don't know
 821 -- the range of values for certain.  For simplicity we always generate a tree.
 822 --
 823 -- ToDo: for integers we could do better here, perhaps by generalising
 824 -- mk_switch and using that.  --SDM 15/09/2004
 825 emitLitSwitch scrut [] deflt
 826   = emitCgStmts deflt
 827 emitLitSwitch scrut branches deflt_blk
 828   = do  { scrut' <- assignTemp scrut
 829         ; deflt_blk_id <- forkCgStmts deflt_blk
 830         ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
 831         ; emitCgStmts blk }
 832   where
 833     le (t1,_) (t2,_) = t1 <= t2
 834
 835 mk_lit_switch :: CmmExpr -> BlockId
 836               -> [(Literal,CgStmts)]
 837               -> FCode CgStmts
 838 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
 839   = return (consCgStmt if_stmt blk)
 840   where
 841     cmm_lit = mkSimpleLit lit
 842     rep     = cmmLitType cmm_lit
 843     ne      = if isFloatType rep then MO_F_Ne else MO_Ne
 844     cond    = CmmMachOp (ne (typeWidth 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 = stronglyConnCompFromEdgedVertices 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 <- newTemp (cmmRegType 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 <- newTemp (cmmExprType 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 (cmmExprType 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 -> CmmType -> 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 -> CmmType -> CmmExpr -> CmmType -> 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 + widthInBytes (typeWidth rep1)
 972     end2 = start2 + widthInBytes (typeWidth 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 "getSRTInfo" 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
1012
1013 clHasCafRefs :: ClosureInfo -> CafInfo
1014 clHasCafRefs (ClosureInfo {closureSRT = srt}) =
1015   case srt of NoC_SRT -> NoCafRefs
1016               _       -> MayHaveCafRefs
1017 clHasCafRefs (ConInfo {}) = NoCafRefs