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)
 115         = CmmLabel (mkForeignLabel fs ms labelSrc fod)
 116         where
 117                 -- TODO: Literal labels might not actually be in the current package...
 118                 labelSrc = ForeignLabelInThisPackage
 119
 120 mkLtOp :: Literal -> MachOp
 121 -- On signed literals we must do a signed comparison
 122 mkLtOp (MachInt _)    = MO_S_Lt wordWidth
 123 mkLtOp (MachFloat _)  = MO_F_Lt W32
 124 mkLtOp (MachDouble _) = MO_F_Lt W64
 125 mkLtOp lit            = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit)))
 126
 127
 128 ---------------------------------------------------
 129 --
 130 --      Cmm data type functions
 131 --
 132 ---------------------------------------------------
 133
 134 -----------------------
 135 -- The "B" variants take byte offsets
 136 cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
 137 cmmRegOffB = cmmRegOff
 138
 139 cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr
 140 cmmOffsetB = cmmOffset
 141
 142 cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr
 143 cmmOffsetExprB = cmmOffsetExpr
 144
 145 cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
 146 cmmLabelOffB = cmmLabelOff
 147
 148 cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
 149 cmmOffsetLitB = cmmOffsetLit
 150
 151 -----------------------
 152 -- The "W" variants take word offsets
 153 cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
 154 -- The second arg is a *word* offset; need to change it to bytes
 155 cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
 156 cmmOffsetExprW e wd_off = cmmIndexExpr wordWidth e wd_off
 157
 158 cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
 159 cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)
 160
 161 cmmRegOffW :: CmmReg -> WordOff -> CmmExpr
 162 cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE)
 163
 164 cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit
 165 cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off)
 166
 167 cmmLabelOffW :: CLabel -> WordOff -> CmmLit
 168 cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)
 169
 170 cmmLoadIndexW :: CmmExpr -> Int -> CmmType -> CmmExpr
 171 cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty
 172
 173 -----------------------
 174 cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord :: CmmExpr -> CmmExpr -> CmmExpr
 175 cmmOrWord  e1 e2 = CmmMachOp mo_wordOr  [e1, e2]
 176 cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
 177 cmmNeWord  e1 e2 = CmmMachOp mo_wordNe  [e1, e2]
 178 cmmEqWord  e1 e2 = CmmMachOp mo_wordEq  [e1, e2]
 179 cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
 180 cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
 181 cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
 182 --cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
 183 --cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
 184 cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
 185
 186 cmmNegate :: CmmExpr -> CmmExpr
 187 cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
 188 cmmNegate e                       = CmmMachOp (MO_S_Neg (cmmExprWidth e)) [e]
 189
 190 blankWord :: CmmStatic
 191 blankWord = CmmUninitialised wORD_SIZE
 192
 193 -- Tagging --
 194 -- Tag bits mask
 195 --cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
 196 cmmTagMask = CmmLit (mkIntCLit tAG_MASK)
 197 cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK))
 198
 199 -- Used to untag a possibly tagged pointer
 200 -- A static label need not be untagged
 201 cmmUntag e@(CmmLit (CmmLabel _)) = e
 202 -- Default case
 203 cmmUntag e = (e `cmmAndWord` cmmPointerMask)
 204
 205 cmmGetTag e = (e `cmmAndWord` cmmTagMask)
 206
 207 -- Test if a closure pointer is untagged
 208 cmmIsTagged e = (e `cmmAndWord` cmmTagMask)
 209                  `cmmNeWord` CmmLit zeroCLit
 210
 211 cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1))
 212 -- Get constructor tag, but one based.
 213 cmmConstrTag1 e = e `cmmAndWord` cmmTagMask
 214
 215 {-
 216    The family size of a data type (the number of constructors)
 217    can be either:
 218     * small, if the family size < 2**tag_bits
 219     * big, otherwise.
 220
 221    Small families can have the constructor tag in the tag
 222    bits.
 223    Big families only use the tag value 1 to represent
 224    evaluatedness.
 225 -}
 226 isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
 227
 228 tagForCon con = tag
 229     where
 230     con_tag           = dataConTagZ con
 231     fam_size   = tyConFamilySize (dataConTyCon con)
 232     tag | isSmallFamily fam_size = con_tag + 1
 233         | otherwise              = 1
 234
 235 --Tag an expression, to do: refactor, this appears in some other module.
 236 tagCons con expr = cmmOffsetB expr (tagForCon con)
 237
 238 -- Copied from CgInfoTbls.hs
 239 -- We keep the *zero-indexed* tag in the srt_len field of the info
 240 -- table of a data constructor.
 241 dataConTagZ :: DataCon -> ConTagZ
 242 dataConTagZ con = dataConTag con - fIRST_TAG
 243
 244 -----------------------
 245 --      Making literals
 246
 247 mkWordCLit :: StgWord -> CmmLit
 248 mkWordCLit wd = CmmInt (fromIntegral wd) wordWidth
 249
 250 packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
 251 -- Make a single word literal in which the lower_half_word is
 252 -- at the lower address, and the upper_half_word is at the
 253 -- higher address
 254 -- ToDo: consider using half-word lits instead
 255 --       but be careful: that's vulnerable when reversed
 256 packHalfWordsCLit lower_half_word upper_half_word
 257 #ifdef WORDS_BIGENDIAN
 258    = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
 259                  .|. fromIntegral upper_half_word)
 260 #else
 261    = mkWordCLit ((fromIntegral lower_half_word)
 262                  .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
 263 #endif
 264
 265 --------------------------------------------------------------------------
 266 --
 267 -- Incrementing a memory location
 268 --
 269 --------------------------------------------------------------------------
 270
 271 addToMem :: Width       -- rep of the counter
 272          -> CmmExpr     -- Address
 273          -> Int         -- What to add (a word)
 274          -> CmmStmt
 275 addToMem width ptr n = addToMemE width ptr (CmmLit (CmmInt (toInteger n) width))
 276
 277 addToMemE :: Width      -- rep of the counter
 278           -> CmmExpr    -- Address
 279           -> CmmExpr    -- What to add (a word-typed expression)
 280           -> CmmStmt
 281 addToMemE width ptr n
 282   = CmmStore ptr (CmmMachOp (MO_Add width) [CmmLoad ptr (cmmBits width), n])
 283
 284 -------------------------------------------------------------------------
 285 --
 286 --      Converting a closure tag to a closure for enumeration types
 287 --      (this is the implementation of tagToEnum#).
 288 --
 289 -------------------------------------------------------------------------
 290
 291 tagToClosure :: TyCon -> CmmExpr -> CmmExpr
 292 tagToClosure tycon tag
 293   = CmmLoad (cmmOffsetExprW closure_tbl tag) gcWord
 294   where closure_tbl = CmmLit (CmmLabel lbl)
 295         lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
 296
 297 -------------------------------------------------------------------------
 298 --
 299 --      Conditionals and rts calls
 300 --
 301 -------------------------------------------------------------------------
 302
 303 emitIf :: CmmExpr       -- Boolean
 304        -> Code          -- Then part
 305        -> Code
 306 -- Emit (if e then x)
 307 -- ToDo: reverse the condition to avoid the extra branch instruction if possible
 308 -- (some conditionals aren't reversible. eg. floating point comparisons cannot
 309 -- be inverted because there exist some values for which both comparisons
 310 -- return False, such as NaN.)
 311 emitIf cond then_part
 312   = do { then_id <- newLabelC
 313        ; join_id <- newLabelC
 314        ; stmtC (CmmCondBranch cond then_id)
 315        ; stmtC (CmmBranch join_id)
 316        ; labelC then_id
 317        ; then_part
 318        ; labelC join_id
 319        }
 320
 321 emitIfThenElse :: CmmExpr       -- Boolean
 322                 -> Code         -- Then part
 323                 -> Code         -- Else part
 324                 -> Code
 325 -- Emit (if e then x else y)
 326 emitIfThenElse cond then_part else_part
 327   = do { then_id <- newLabelC
 328        ; join_id <- newLabelC
 329        ; stmtC (CmmCondBranch cond then_id)
 330        ; else_part
 331        ; stmtC (CmmBranch join_id)
 332        ; labelC then_id
 333        ; then_part
 334        ; labelC join_id
 335        }
 336
 337
 338 -- | Emit code to call a Cmm function.
 339 emitRtsCall
 340    :: PackageId                 -- ^ package the function is in
 341    -> FastString                -- ^ name of function
 342    -> [CmmHinted CmmExpr]       -- ^ function args
 343    -> Bool                      -- ^ whether this is a safe call
 344    -> Code                      -- ^ cmm code
 345
 346 emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe
 347    -- The 'Nothing' says "save all global registers"
 348
 349 emitRtsCallWithVols :: PackageId -> FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code
 350 emitRtsCallWithVols pkg fun args vols safe
 351    = emitRtsCall' [] pkg fun args (Just vols) safe
 352
 353 emitRtsCallWithResult
 354    :: LocalReg -> ForeignHint
 355    -> PackageId -> FastString
 356    -> [CmmHinted CmmExpr] -> Bool -> Code
 357 emitRtsCallWithResult res hint pkg fun args safe
 358    = emitRtsCall' [CmmHinted res hint] pkg fun args Nothing safe
 359
 360 -- Make a call to an RTS C procedure
 361 emitRtsCall'
 362    :: [CmmHinted LocalReg]
 363    -> PackageId
 364    -> FastString
 365    -> [CmmHinted CmmExpr]
 366    -> Maybe [GlobalReg]
 367    -> Bool -- True <=> CmmSafe call
 368    -> Code
 369 emitRtsCall' res pkg fun args vols safe = do
 370   safety <- if safe
 371             then getSRTInfo >>= (return . CmmSafe)
 372             else return CmmUnsafe
 373   stmtsC caller_save
 374   stmtC (CmmCall target res args safety CmmMayReturn)
 375   stmtsC caller_load
 376   where
 377     (caller_save, caller_load) = callerSaveVolatileRegs vols
 378     target   = CmmCallee fun_expr CCallConv
 379     fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
 380
 381 -----------------------------------------------------------------------------
 382 --
 383 --      Caller-Save Registers
 384 --
 385 -----------------------------------------------------------------------------
 386
 387 -- Here we generate the sequence of saves/restores required around a
 388 -- foreign call instruction.
 389
 390 -- TODO: reconcile with includes/Regs.h
 391 --  * Regs.h claims that BaseReg should be saved last and loaded first
 392 --    * This might not have been tickled before since BaseReg is callee save
 393 --  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
 394 callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
 395 callerSaveVolatileRegs vols = (caller_save, caller_load)
 396   where
 397     caller_save = foldr ($!) [] (map callerSaveGlobalReg    regs_to_save)
 398     caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save)
 399
 400     system_regs = [Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery,
 401                    {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ]
 402
 403     regs_to_save = system_regs ++ vol_list
 404
 405     vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
 406
 407     all_of_em = [ VanillaReg n VNonGcPtr | n <- [0..mAX_Vanilla_REG] ]
 408                         -- The VNonGcPtr is a lie, but I don't think it matters
 409              ++ [ FloatReg   n | n <- [0..mAX_Float_REG] ]
 410              ++ [ DoubleReg  n | n <- [0..mAX_Double_REG] ]
 411              ++ [ LongReg    n | n <- [0..mAX_Long_REG] ]
 412
 413     callerSaveGlobalReg reg next
 414         | callerSaves reg =
 415                 CmmStore (get_GlobalReg_addr reg)
 416                          (CmmReg (CmmGlobal reg)) : next
 417         | otherwise = next
 418
 419     callerRestoreGlobalReg reg next
 420         | callerSaves reg =
 421                 CmmAssign (CmmGlobal reg)
 422                           (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
 423                         : next
 424         | otherwise = next
 425
 426 -- -----------------------------------------------------------------------------
 427 -- Global registers
 428
 429 -- We map STG registers onto appropriate CmmExprs.  Either they map
 430 -- to real machine registers or stored as offsets from BaseReg.  Given
 431 -- a GlobalReg, get_GlobalReg_addr always produces the
 432 -- register table address for it.
 433 -- (See also get_GlobalReg_reg_or_addr in MachRegs)
 434
 435 get_GlobalReg_addr              :: GlobalReg -> CmmExpr
 436 get_GlobalReg_addr BaseReg = regTableOffset 0
 437 get_GlobalReg_addr mid     = get_Regtable_addr_from_offset
 438                                 (globalRegType mid) (baseRegOffset mid)
 439
 440 -- Calculate a literal representing an offset into the register table.
 441 -- Used when we don't have an actual BaseReg to offset from.
 442 regTableOffset n =
 443   CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
 444
 445 get_Regtable_addr_from_offset   :: CmmType -> Int -> CmmExpr
 446 get_Regtable_addr_from_offset rep offset =
 447 #ifdef REG_Base
 448   CmmRegOff (CmmGlobal BaseReg) offset
 449 #else
 450   regTableOffset offset
 451 #endif
 452
 453
 454 -- | Returns @True@ if this global register is stored in a caller-saves
 455 -- machine register.
 456
 457 callerSaves :: GlobalReg -> Bool
 458
 459 #ifdef CALLER_SAVES_Base
 460 callerSaves BaseReg             = True
 461 #endif
 462 #ifdef CALLER_SAVES_R1
 463 callerSaves (VanillaReg 1 _)    = True
 464 #endif
 465 #ifdef CALLER_SAVES_R2
 466 callerSaves (VanillaReg 2 _)    = True
 467 #endif
 468 #ifdef CALLER_SAVES_R3
 469 callerSaves (VanillaReg 3 _)    = True
 470 #endif
 471 #ifdef CALLER_SAVES_R4
 472 callerSaves (VanillaReg 4 _)    = True
 473 #endif
 474 #ifdef CALLER_SAVES_R5
 475 callerSaves (VanillaReg 5 _)    = True
 476 #endif
 477 #ifdef CALLER_SAVES_R6
 478 callerSaves (VanillaReg 6 _)    = True
 479 #endif
 480 #ifdef CALLER_SAVES_R7
 481 callerSaves (VanillaReg 7 _)    = True
 482 #endif
 483 #ifdef CALLER_SAVES_R8
 484 callerSaves (VanillaReg 8 _)    = True
 485 #endif
 486 #ifdef CALLER_SAVES_F1
 487 callerSaves (FloatReg 1)        = True
 488 #endif
 489 #ifdef CALLER_SAVES_F2
 490 callerSaves (FloatReg 2)        = True
 491 #endif
 492 #ifdef CALLER_SAVES_F3
 493 callerSaves (FloatReg 3)        = True
 494 #endif
 495 #ifdef CALLER_SAVES_F4
 496 callerSaves (FloatReg 4)        = True
 497 #endif
 498 #ifdef CALLER_SAVES_D1
 499 callerSaves (DoubleReg 1)       = True
 500 #endif
 501 #ifdef CALLER_SAVES_D2
 502 callerSaves (DoubleReg 2)       = True
 503 #endif
 504 #ifdef CALLER_SAVES_L1
 505 callerSaves (LongReg 1)         = True
 506 #endif
 507 #ifdef CALLER_SAVES_Sp
 508 callerSaves Sp                  = True
 509 #endif
 510 #ifdef CALLER_SAVES_SpLim
 511 callerSaves SpLim               = True
 512 #endif
 513 #ifdef CALLER_SAVES_Hp
 514 callerSaves Hp                  = True
 515 #endif
 516 #ifdef CALLER_SAVES_HpLim
 517 callerSaves HpLim               = True
 518 #endif
 519 #ifdef CALLER_SAVES_CurrentTSO
 520 callerSaves CurrentTSO          = True
 521 #endif
 522 #ifdef CALLER_SAVES_CurrentNursery
 523 callerSaves CurrentNursery      = True
 524 #endif
 525 callerSaves _                   = False
 526
 527
 528 -- -----------------------------------------------------------------------------
 529 -- Information about global registers
 530
 531 baseRegOffset :: GlobalReg -> Int
 532
 533 baseRegOffset (VanillaReg 1 _)    = oFFSET_StgRegTable_rR1
 534 baseRegOffset (VanillaReg 2 _)    = oFFSET_StgRegTable_rR2
 535 baseRegOffset (VanillaReg 3 _)    = oFFSET_StgRegTable_rR3
 536 baseRegOffset (VanillaReg 4 _)    = oFFSET_StgRegTable_rR4
 537 baseRegOffset (VanillaReg 5 _)    = oFFSET_StgRegTable_rR5
 538 baseRegOffset (VanillaReg 6 _)    = oFFSET_StgRegTable_rR6
 539 baseRegOffset (VanillaReg 7 _)    = oFFSET_StgRegTable_rR7
 540 baseRegOffset (VanillaReg 8 _)    = oFFSET_StgRegTable_rR8
 541 baseRegOffset (VanillaReg 9 _)    = oFFSET_StgRegTable_rR9
 542 baseRegOffset (VanillaReg 10 _)   = oFFSET_StgRegTable_rR10
 543 baseRegOffset (FloatReg  1)       = oFFSET_StgRegTable_rF1
 544 baseRegOffset (FloatReg  2)       = oFFSET_StgRegTable_rF2
 545 baseRegOffset (FloatReg  3)       = oFFSET_StgRegTable_rF3
 546 baseRegOffset (FloatReg  4)       = oFFSET_StgRegTable_rF4
 547 baseRegOffset (DoubleReg 1)       = oFFSET_StgRegTable_rD1
 548 baseRegOffset (DoubleReg 2)       = oFFSET_StgRegTable_rD2
 549 baseRegOffset Sp                  = oFFSET_StgRegTable_rSp
 550 baseRegOffset SpLim               = oFFSET_StgRegTable_rSpLim
 551 baseRegOffset (LongReg 1)         = oFFSET_StgRegTable_rL1
 552 baseRegOffset Hp                  = oFFSET_StgRegTable_rHp
 553 baseRegOffset HpLim               = oFFSET_StgRegTable_rHpLim
 554 baseRegOffset CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO
 555 baseRegOffset CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery
 556 baseRegOffset HpAlloc             = oFFSET_StgRegTable_rHpAlloc
 557 baseRegOffset EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo
 558 baseRegOffset GCEnter1            = oFFSET_stgGCEnter1
 559 baseRegOffset GCFun               = oFFSET_stgGCFun
 560 baseRegOffset BaseReg             = panic "baseRegOffset:BaseReg"
 561 baseRegOffset _                   = panic "baseRegOffset:other"
 562
 563
 564 -------------------------------------------------------------------------
 565 --
 566 --      Strings generate a top-level data block
 567 --
 568 -------------------------------------------------------------------------
 569
 570 emitDataLits :: CLabel -> [CmmLit] -> Code
 571 -- Emit a data-segment data block
 572 emitDataLits lbl lits
 573   = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 574
 575 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
 576 -- Emit a data-segment data block
 577 mkDataLits lbl lits
 578   = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 579
 580 emitRODataLits :: String -> CLabel -> [CmmLit] -> Code
 581 -- Emit a read-only data block
 582 emitRODataLits caller lbl lits
 583   = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
 584     where section | any needsRelocation lits = RelocatableReadOnlyData
 585                   | otherwise                = ReadOnlyData
 586           needsRelocation (CmmLabel _)      = True
 587           needsRelocation (CmmLabelOff _ _) = True
 588           needsRelocation _                 = False
 589
 590 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph
 591 mkRODataLits lbl lits
 592   = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
 593   where section | any needsRelocation lits = RelocatableReadOnlyData
 594                 | otherwise                = ReadOnlyData
 595         needsRelocation (CmmLabel _)      = True
 596         needsRelocation (CmmLabelOff _ _) = True
 597         needsRelocation _                 = False
 598
 599 mkStringCLit :: String -> FCode CmmLit
 600 -- Make a global definition for the string,
 601 -- and return its label
 602 mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str)
 603
 604 mkByteStringCLit :: [Word8] -> FCode CmmLit
 605 mkByteStringCLit bytes
 606   = do  { uniq <- newUnique
 607         ; let lbl = mkStringLitLabel uniq
 608         ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
 609         ; return (CmmLabel lbl) }
 610
 611 -------------------------------------------------------------------------
 612 --
 613 --      Assigning expressions to temporaries
 614 --
 615 -------------------------------------------------------------------------
 616
 617 assignTemp :: CmmExpr -> FCode CmmExpr
 618 -- For a non-trivial expression, e, create a local
 619 -- variable and assign the expression to it
 620 assignTemp e
 621   | isTrivialCmmExpr e = return e
 622   | otherwise          = do { reg <- newTemp (cmmExprType e)
 623                             ; stmtC (CmmAssign (CmmLocal reg) e)
 624                             ; return (CmmReg (CmmLocal reg)) }
 625
 626 newTemp :: CmmType -> FCode LocalReg
 627 newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
 628
 629 -------------------------------------------------------------------------
 630 --
 631 --      Building case analysis
 632 --
 633 -------------------------------------------------------------------------
 634
 635 emitSwitch
 636         :: CmmExpr                -- Tag to switch on
 637         -> [(ConTagZ, CgStmts)]   -- Tagged branches
 638         -> Maybe CgStmts          -- Default branch (if any)
 639         -> ConTagZ -> ConTagZ     -- Min and Max possible values; behaviour
 640                                   --    outside this range is undefined
 641         -> Code
 642
 643 -- ONLY A DEFAULT BRANCH: no case analysis to do
 644 emitSwitch tag_expr [] (Just stmts) _ _
 645   = emitCgStmts stmts
 646
 647 -- Right, off we go
 648 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
 649   =     -- Just sort the branches before calling mk_sritch
 650     do  { mb_deflt_id <-
 651                 case mb_deflt of
 652                   Nothing    -> return Nothing
 653                   Just stmts -> do id <- forkCgStmts stmts; return (Just id)
 654
 655         ; dflags <- getDynFlags
 656         ; let via_C | HscC <- hscTarget dflags = True
 657                     | otherwise                = False
 658
 659         ; stmts <- mk_switch tag_expr (sortLe le branches)
 660                         mb_deflt_id lo_tag hi_tag via_C
 661         ; emitCgStmts stmts
 662         }
 663   where
 664     (t1,_) `le` (t2,_) = t1 <= t2
 665
 666
 667 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
 668           -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
 669           -> FCode CgStmts
 670
 671 -- SINGLETON TAG RANGE: no case analysis to do
 672 mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
 673   | lo_tag == hi_tag
 674   = ASSERT( tag == lo_tag )
 675     return stmts
 676
 677 -- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
 678 mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
 679   = return stmts
 680         -- The simplifier might have eliminated a case
 681         --       so we may have e.g. case xs of
 682         --                               [] -> e
 683         -- In that situation we can be sure the (:) case
 684         -- can't happen, so no need to test
 685
 686 -- SINGLETON BRANCH: one equality check to do
 687 mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
 688   = return (CmmCondBranch cond deflt `consCgStmt` stmts)
 689   where
 690     cond  =  cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
 691         -- We have lo_tag < hi_tag, but there's only one branch,
 692         -- so there must be a default
 693
 694 -- ToDo: we might want to check for the two branch case, where one of
 695 -- the branches is the tag 0, because comparing '== 0' is likely to be
 696 -- more efficient than other kinds of comparison.
 697
 698 -- DENSE TAG RANGE: use a switch statment.
 699 --
 700 -- We also use a switch uncoditionally when compiling via C, because
 701 -- this will get emitted as a C switch statement and the C compiler
 702 -- should do a good job of optimising it.  Also, older GCC versions
 703 -- (2.95 in particular) have problems compiling the complicated
 704 -- if-trees generated by this code, so compiling to a switch every
 705 -- time works around that problem.
 706 --
 707 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
 708   | use_switch  -- Use a switch
 709   = do  { branch_ids <- mapM forkCgStmts (map snd branches)
 710         ; let
 711                 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
 712
 713                 find_branch :: ConTagZ -> Maybe BlockId
 714                 find_branch i = assocDefault mb_deflt tagged_blk_ids i
 715
 716                 -- NB. we have eliminated impossible branches at
 717                 -- either end of the range (see below), so the first
 718                 -- tag of a real branch is real_lo_tag (not lo_tag).
 719                 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
 720
 721                 switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
 722
 723         ; ASSERT(not (all isNothing arms))
 724           return (oneCgStmt switch_stmt)
 725         }
 726
 727   -- if we can knock off a bunch of default cases with one if, then do so
 728   | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
 729   = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
 730        ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
 731              branch = CmmCondBranch cond deflt
 732        ; stmts <- mk_switch tag_expr' branches mb_deflt
 733                         lowest_branch hi_tag via_C
 734        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 735        }
 736
 737   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
 738   = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
 739        ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
 740              branch = CmmCondBranch cond deflt
 741        ; stmts <- mk_switch tag_expr' branches mb_deflt
 742                         lo_tag highest_branch via_C
 743        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 744        }
 745
 746   | otherwise   -- Use an if-tree
 747   = do  { (assign_tag, tag_expr') <- assignTemp' tag_expr
 748                 -- To avoid duplication
 749         ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
 750                                 lo_tag (mid_tag-1) via_C
 751         ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
 752                                 mid_tag hi_tag via_C
 753         ; hi_id <- forkCgStmts hi_stmts
 754         ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
 755               branch_stmt = CmmCondBranch cond hi_id
 756         ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
 757         }
 758         -- we test (e >= mid_tag) rather than (e < mid_tag), because
 759         -- the former works better when e is a comparison, and there
 760         -- are two tags 0 & 1 (mid_tag == 1).  In this case, the code
 761         -- generator can reduce the condition to e itself without
 762         -- having to reverse the sense of the comparison: comparisons
 763         -- can't always be easily reversed (eg. floating
 764         -- pt. comparisons).
 765   where
 766     use_switch   = {- pprTrace "mk_switch" (
 767                         ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
 768                         text "branches:" <+> ppr (map fst branches) <+>
 769                         text "n_branches:" <+> int n_branches <+>
 770                         text "lo_tag:" <+> int lo_tag <+>
 771                         text "hi_tag:" <+> int hi_tag <+>
 772                         text "real_lo_tag:" <+> int real_lo_tag <+>
 773                         text "real_hi_tag:" <+> int real_hi_tag) $ -}
 774                    ASSERT( n_branches > 1 && n_tags > 1 )
 775                    n_tags > 2 && (via_C || (dense && big_enough))
 776                  -- up to 4 branches we use a decision tree, otherwise
 777                  -- a switch (== jump table in the NCG).  This seems to be
 778                  -- optimal, and corresponds with what gcc does.
 779     big_enough   = n_branches > 4
 780     dense        = n_branches > (n_tags `div` 2)
 781     n_branches   = length branches
 782
 783     -- ignore default slots at each end of the range if there's
 784     -- no default branch defined.
 785     lowest_branch  = fst (head branches)
 786     highest_branch = fst (last branches)
 787
 788     real_lo_tag
 789         | isNothing mb_deflt = lowest_branch
 790         | otherwise          = lo_tag
 791
 792     real_hi_tag
 793         | isNothing mb_deflt = highest_branch
 794         | otherwise          = hi_tag
 795
 796     n_tags = real_hi_tag - real_lo_tag + 1
 797
 798         -- INVARIANT: Provided hi_tag > lo_tag (which is true)
 799         --      lo_tag <= mid_tag < hi_tag
 800         --      lo_branches have tags <  mid_tag
 801         --      hi_branches have tags >= mid_tag
 802
 803     (mid_tag,_) = branches !! (n_branches `div` 2)
 804         -- 2 branches => n_branches `div` 2 = 1
 805         --            => branches !! 1 give the *second* tag
 806         -- There are always at least 2 branches here
 807
 808     (lo_branches, hi_branches) = span is_lo branches
 809     is_lo (t,_) = t < mid_tag
 810
 811
 812 assignTemp' e
 813   | isTrivialCmmExpr e = return (CmmNop, e)
 814   | otherwise          = do { reg <- newTemp (cmmExprType e)
 815                             ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
 816
 817 emitLitSwitch :: CmmExpr                        -- Tag to switch on
 818               -> [(Literal, CgStmts)]           -- Tagged branches
 819               -> CgStmts                        -- Default branch (always)
 820               -> Code                           -- Emit the code
 821 -- Used for general literals, whose size might not be a word,
 822 -- where there is always a default case, and where we don't know
 823 -- the range of values for certain.  For simplicity we always generate a tree.
 824 --
 825 -- ToDo: for integers we could do better here, perhaps by generalising
 826 -- mk_switch and using that.  --SDM 15/09/2004
 827 emitLitSwitch scrut [] deflt
 828   = emitCgStmts deflt
 829 emitLitSwitch scrut branches deflt_blk
 830   = do  { scrut' <- assignTemp scrut
 831         ; deflt_blk_id <- forkCgStmts deflt_blk
 832         ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
 833         ; emitCgStmts blk }
 834   where
 835     le (t1,_) (t2,_) = t1 <= t2
 836
 837 mk_lit_switch :: CmmExpr -> BlockId
 838               -> [(Literal,CgStmts)]
 839               -> FCode CgStmts
 840 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
 841   = return (consCgStmt if_stmt blk)
 842   where
 843     cmm_lit = mkSimpleLit lit
 844     rep     = cmmLitType cmm_lit
 845     ne      = if isFloatType rep then MO_F_Ne else MO_Ne
 846     cond    = CmmMachOp (ne (typeWidth 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 = stronglyConnCompFromEdgedVertices 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 <- newTemp (cmmRegType 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 <- newTemp (cmmExprType 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 (cmmExprType 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 -> CmmType -> 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 -> CmmType -> CmmExpr -> CmmType -> 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 + widthInBytes (typeWidth rep1)
 974     end2 = start2 + widthInBytes (typeWidth 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     SRTEntries {} -> panic "getSRTInfo: SRTEntries.  Perhaps you forgot to run SimplStg?"
 998     SRT off len bmp
 999       | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
1000       -> do id <- newUnique
1001             let srt_desc_lbl = mkLargeSRTLabel id
1002             emitRODataLits "getSRTInfo" srt_desc_lbl
1003              ( cmmLabelOffW srt_lbl off
1004                : mkWordCLit (fromIntegral len)
1005                : map mkWordCLit bmp)
1006             return (C_SRT srt_desc_lbl 0 srt_escape)
1007
1008     SRT off len bmp
1009       | otherwise
1010       -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
1011                 -- The fromIntegral converts to StgHalfWord
1012
1013 srt_escape = (-1) :: StgHalfWord
1014
1015 clHasCafRefs :: ClosureInfo -> CafInfo
1016 clHasCafRefs (ClosureInfo {closureSRT = srt}) =
1017   case srt of NoC_SRT -> NoCafRefs
1018               _       -> MayHaveCafRefs
1019 clHasCafRefs (ConInfo {}) = NoCafRefs