compiler/codeGen/StgCmmUtils.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Code generator utilities; mostly monadic
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module StgCmmUtils (
  10         cgLit, mkSimpleLit,
  11         emitDataLits, mkDataLits,
  12         emitRODataLits, mkRODataLits,
  13         emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
  14         assignTemp, newTemp, withTemp,
  15
  16         newUnboxedTupleRegs,
  17
  18         mkMultiAssign, mkCmmSwitch, mkCmmLitSwitch,
  19         emitSwitch,
  20
  21         tagToClosure, mkTaggedObjectLoad,
  22
  23         callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
  24
  25         cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
  26         cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
  27         cmmOffsetExprW, cmmOffsetExprB,
  28         cmmRegOffW, cmmRegOffB,
  29         cmmLabelOffW, cmmLabelOffB,
  30         cmmOffsetW, cmmOffsetB,
  31         cmmOffsetLitW, cmmOffsetLitB,
  32         cmmLoadIndexW,
  33         cmmConstrTag, cmmConstrTag1,
  34
  35         cmmUntag, cmmIsTagged, cmmGetTag,
  36
  37         addToMem, addToMemE, addToMemLbl,
  38         mkWordCLit,
  39         mkStringCLit, mkByteStringCLit,
  40         packHalfWordsCLit,
  41         blankWord,
  42
  43         getSRTInfo, clHasCafRefs, srt_escape
  44   ) where
  45
  46 #include "HsVersions.h"
  47 #include "../includes/stg/MachRegs.h"
  48
  49 import StgCmmMonad
  50 import StgCmmClosure
  51 import BlockId
  52 import CmmDecl
  53 import CmmExpr hiding (regUsedIn)
  54 import MkGraph
  55 import CLabel
  56 import CmmUtils
  57
  58 import ForeignCall
  59 import IdInfo
  60 import Type
  61 import TyCon
  62 import Constants
  63 import SMRep
  64 import StgSyn   ( SRT(..) )
  65 import Module
  66 import Literal
  67 import Digraph
  68 import ListSetOps
  69 import Util
  70 import Unique
  71 import DynFlags
  72 import FastString
  73 import Outputable
  74
  75 import Data.Char
  76 import Data.Bits
  77 import Data.Word
  78 import Data.Maybe
  79
  80
  81 -------------------------------------------------------------------------
  82 --
  83 --      Literals
  84 --
  85 -------------------------------------------------------------------------
  86
  87 cgLit :: Literal -> FCode CmmLit
  88 cgLit (MachStr s) = mkByteStringCLit (bytesFS s)
  89  -- not unpackFS; we want the UTF-8 byte stream.
  90 cgLit other_lit   = return (mkSimpleLit other_lit)
  91
  92 mkSimpleLit :: Literal -> CmmLit
  93 mkSimpleLit (MachChar   c)    = CmmInt (fromIntegral (ord c)) wordWidth
  94 mkSimpleLit MachNullAddr      = zeroCLit
  95 mkSimpleLit (MachInt i)       = CmmInt i wordWidth
  96 mkSimpleLit (MachInt64 i)     = CmmInt i W64
  97 mkSimpleLit (MachWord i)      = CmmInt i wordWidth
  98 mkSimpleLit (MachWord64 i)    = CmmInt i W64
  99 mkSimpleLit (MachFloat r)     = CmmFloat r W32
 100 mkSimpleLit (MachDouble r)    = CmmFloat r W64
 101 mkSimpleLit (MachLabel fs ms fod)
 102         = CmmLabel (mkForeignLabel fs ms labelSrc fod)
 103         where
 104                 -- TODO: Literal labels might not actually be in the current package...
 105                 labelSrc = ForeignLabelInThisPackage
 106 mkSimpleLit other             = pprPanic "mkSimpleLit" (ppr other)
 107
 108 mkLtOp :: Literal -> MachOp
 109 -- On signed literals we must do a signed comparison
 110 mkLtOp (MachInt _)    = MO_S_Lt wordWidth
 111 mkLtOp (MachFloat _)  = MO_F_Lt W32
 112 mkLtOp (MachDouble _) = MO_F_Lt W64
 113 mkLtOp lit            = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit)))
 114                                 -- ToDo: seems terribly indirect!
 115
 116
 117 ---------------------------------------------------
 118 --
 119 --      Cmm data type functions
 120 --
 121 ---------------------------------------------------
 122
 123 -- The "B" variants take byte offsets
 124 cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
 125 cmmRegOffB = cmmRegOff
 126
 127 cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr
 128 cmmOffsetB = cmmOffset
 129
 130 cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr
 131 cmmOffsetExprB = cmmOffsetExpr
 132
 133 cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
 134 cmmLabelOffB = cmmLabelOff
 135
 136 cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
 137 cmmOffsetLitB = cmmOffsetLit
 138
 139 -----------------------
 140 -- The "W" variants take word offsets
 141 cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
 142 -- The second arg is a *word* offset; need to change it to bytes
 143 cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
 144 cmmOffsetExprW e wd_off = cmmIndexExpr wordWidth e wd_off
 145
 146 cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
 147 cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)
 148
 149 cmmRegOffW :: CmmReg -> WordOff -> CmmExpr
 150 cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE)
 151
 152 cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit
 153 cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off)
 154
 155 cmmLabelOffW :: CLabel -> WordOff -> CmmLit
 156 cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)
 157
 158 cmmLoadIndexW :: CmmExpr -> Int -> CmmType -> CmmExpr
 159 cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty
 160
 161 -----------------------
 162 cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
 163   cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord,
 164   cmmUShrWord, cmmAddWord, cmmMulWord
 165   :: CmmExpr -> CmmExpr -> CmmExpr
 166 cmmOrWord  e1 e2 = CmmMachOp mo_wordOr  [e1, e2]
 167 cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
 168 cmmNeWord  e1 e2 = CmmMachOp mo_wordNe  [e1, e2]
 169 cmmEqWord  e1 e2 = CmmMachOp mo_wordEq  [e1, e2]
 170 cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
 171 cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
 172 cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
 173 --cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
 174 cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
 175 cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2]
 176 cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
 177 cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2]
 178
 179 cmmNegate :: CmmExpr -> CmmExpr
 180 cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
 181 cmmNegate e                       = CmmMachOp (MO_S_Neg (cmmExprWidth e)) [e]
 182
 183 blankWord :: CmmStatic
 184 blankWord = CmmUninitialised wORD_SIZE
 185
 186 -- Tagging --
 187 -- Tag bits mask
 188 --cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
 189 cmmTagMask, cmmPointerMask :: CmmExpr
 190 cmmTagMask = CmmLit (mkIntCLit tAG_MASK)
 191 cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK))
 192
 193 -- Used to untag a possibly tagged pointer
 194 -- A static label need not be untagged
 195 cmmUntag, cmmGetTag :: CmmExpr -> CmmExpr
 196 cmmUntag e@(CmmLit (CmmLabel _)) = e
 197 -- Default case
 198 cmmUntag e = (e `cmmAndWord` cmmPointerMask)
 199
 200 cmmGetTag e = (e `cmmAndWord` cmmTagMask)
 201
 202 -- Test if a closure pointer is untagged
 203 cmmIsTagged :: CmmExpr -> CmmExpr
 204 cmmIsTagged e = (e `cmmAndWord` cmmTagMask)
 205                  `cmmNeWord` CmmLit zeroCLit
 206
 207 cmmConstrTag, cmmConstrTag1 :: CmmExpr -> CmmExpr
 208 cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1))
 209 -- Get constructor tag, but one based.
 210 cmmConstrTag1 e = e `cmmAndWord` cmmTagMask
 211
 212 -----------------------
 213 --      Making literals
 214
 215 mkWordCLit :: StgWord -> CmmLit
 216 mkWordCLit wd = CmmInt (fromIntegral wd) wordWidth
 217
 218 packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
 219 -- Make a single word literal in which the lower_half_word is
 220 -- at the lower address, and the upper_half_word is at the
 221 -- higher address
 222 -- ToDo: consider using half-word lits instead
 223 --       but be careful: that's vulnerable when reversed
 224 packHalfWordsCLit lower_half_word upper_half_word
 225 #ifdef WORDS_BIGENDIAN
 226    = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
 227                  .|. fromIntegral upper_half_word)
 228 #else
 229    = mkWordCLit ((fromIntegral lower_half_word)
 230                  .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
 231 #endif
 232
 233 --------------------------------------------------------------------------
 234 --
 235 -- Incrementing a memory location
 236 --
 237 --------------------------------------------------------------------------
 238
 239 addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
 240 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
 241
 242 addToMem :: CmmType     -- rep of the counter
 243          -> CmmExpr     -- Address
 244          -> Int         -- What to add (a word)
 245          -> CmmAGraph
 246 addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))
 247
 248 addToMemE :: CmmType    -- rep of the counter
 249           -> CmmExpr    -- Address
 250           -> CmmExpr    -- What to add (a word-typed expression)
 251           -> CmmAGraph
 252 addToMemE rep ptr n
 253   = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])
 254
 255
 256 -------------------------------------------------------------------------
 257 --
 258 --      Loading a field from an object,
 259 --      where the object pointer is itself tagged
 260 --
 261 -------------------------------------------------------------------------
 262
 263 mkTaggedObjectLoad :: LocalReg -> LocalReg -> WordOff -> DynTag -> CmmAGraph
 264 -- (loadTaggedObjectField reg base off tag) generates assignment
 265 --      reg = bitsK[ base + off - tag ]
 266 -- where K is fixed by 'reg'
 267 mkTaggedObjectLoad reg base offset tag
 268   = mkAssign (CmmLocal reg)
 269              (CmmLoad (cmmOffsetB (CmmReg (CmmLocal base))
 270                                   (wORD_SIZE*offset - tag))
 271                       (localRegType reg))
 272
 273 -------------------------------------------------------------------------
 274 --
 275 --      Converting a closure tag to a closure for enumeration types
 276 --      (this is the implementation of tagToEnum#).
 277 --
 278 -------------------------------------------------------------------------
 279
 280 tagToClosure :: TyCon -> CmmExpr -> CmmExpr
 281 tagToClosure tycon tag
 282   = CmmLoad (cmmOffsetExprW closure_tbl tag) bWord
 283   where closure_tbl = CmmLit (CmmLabel lbl)
 284         lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
 285
 286 -------------------------------------------------------------------------
 287 --
 288 --      Conditionals and rts calls
 289 --
 290 -------------------------------------------------------------------------
 291
 292 emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
 293 emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe
 294    -- The 'Nothing' says "save all global registers"
 295
 296 emitRtsCallWithVols :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
 297 emitRtsCallWithVols pkg fun args vols safe
 298    = emitRtsCall' [] pkg fun args (Just vols) safe
 299
 300 emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString
 301         -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
 302 emitRtsCallWithResult res hint pkg fun args safe
 303    = emitRtsCall' [(res,hint)] pkg fun args Nothing safe
 304
 305 -- Make a call to an RTS C procedure
 306 emitRtsCall'
 307    :: [(LocalReg,ForeignHint)]
 308    -> PackageId
 309    -> FastString
 310    -> [(CmmExpr,ForeignHint)]
 311    -> Maybe [GlobalReg]
 312    -> Bool -- True <=> CmmSafe call
 313    -> FCode ()
 314 emitRtsCall' res pkg fun args _vols safe
 315   = --error "emitRtsCall'"
 316     do { updfr_off <- getUpdFrameOff
 317        ; emit caller_save
 318        ; emit $ call updfr_off
 319        ; emit caller_load }
 320   where
 321     call updfr_off =
 322       if safe then
 323         mkCmmCall fun_expr res' args' updfr_off
 324       else
 325         mkUnsafeCall (ForeignTarget fun_expr
 326                          (ForeignConvention CCallConv arg_hints res_hints)) res' args'
 327     (args', arg_hints) = unzip args
 328     (res',  res_hints) = unzip res
 329     (caller_save, caller_load) = callerSaveVolatileRegs
 330     fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
 331
 332
 333 -----------------------------------------------------------------------------
 334 --
 335 --      Caller-Save Registers
 336 --
 337 -----------------------------------------------------------------------------
 338
 339 -- Here we generate the sequence of saves/restores required around a
 340 -- foreign call instruction.
 341
 342 -- TODO: reconcile with includes/Regs.h
 343 --  * Regs.h claims that BaseReg should be saved last and loaded first
 344 --    * This might not have been tickled before since BaseReg is callee save
 345 --  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
 346 --
 347 -- This code isn't actually used right now, because callerSaves
 348 -- only ever returns true in the current universe for registers NOT in
 349 -- system_regs (just do a grep for CALLER_SAVES in
 350 -- includes/stg/MachRegs.h).  It's all one giant no-op, and for
 351 -- good reason: having to save system registers on every foreign call
 352 -- would be very expensive, so we avoid assigning them to those
 353 -- registers when we add support for an architecture.
 354 --
 355 -- Note that the old code generator actually does more work here: it
 356 -- also saves other global registers.  We can't (nor want) to do that
 357 -- here, as we don't have liveness information.  And really, we
 358 -- shouldn't be doing the workaround at this point in the pipeline, see
 359 -- Note [Register parameter passing] and the ToDo on CmmCall in
 360 -- cmm/CmmNode.hs.  Right now the workaround is to avoid inlining across
 361 -- unsafe foreign calls in rewriteAssignments, but this is strictly
 362 -- temporary.
 363 callerSaveVolatileRegs :: (CmmAGraph, CmmAGraph)
 364 callerSaveVolatileRegs = (caller_save, caller_load)
 365   where
 366     caller_save = catAGraphs (map callerSaveGlobalReg    regs_to_save)
 367     caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
 368
 369     system_regs = [ Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery
 370                     {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
 371                   , BaseReg ]
 372
 373     regs_to_save = filter callerSaves system_regs
 374
 375     callerSaveGlobalReg reg
 376         = mkStore (get_GlobalReg_addr reg) (CmmReg (CmmGlobal reg))
 377
 378     callerRestoreGlobalReg reg
 379         = mkAssign (CmmGlobal reg)
 380                     (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
 381
 382 -- -----------------------------------------------------------------------------
 383 -- Global registers
 384
 385 -- We map STG registers onto appropriate CmmExprs.  Either they map
 386 -- to real machine registers or stored as offsets from BaseReg.  Given
 387 -- a GlobalReg, get_GlobalReg_addr always produces the
 388 -- register table address for it.
 389 -- (See also get_GlobalReg_reg_or_addr in MachRegs)
 390
 391 get_GlobalReg_addr              :: GlobalReg -> CmmExpr
 392 get_GlobalReg_addr BaseReg = regTableOffset 0
 393 get_GlobalReg_addr mid     = get_Regtable_addr_from_offset
 394                                 (globalRegType mid) (baseRegOffset mid)
 395
 396 -- Calculate a literal representing an offset into the register table.
 397 -- Used when we don't have an actual BaseReg to offset from.
 398 regTableOffset :: Int -> CmmExpr
 399 regTableOffset n =
 400   CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
 401
 402 get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr
 403 get_Regtable_addr_from_offset _rep offset =
 404 #ifdef REG_Base
 405   CmmRegOff (CmmGlobal BaseReg) offset
 406 #else
 407   regTableOffset offset
 408 #endif
 409
 410
 411 -- | Returns 'True' if this global register is stored in a caller-saves
 412 -- machine register.
 413
 414 callerSaves :: GlobalReg -> Bool
 415
 416 #ifdef CALLER_SAVES_Base
 417 callerSaves BaseReg             = True
 418 #endif
 419 #ifdef CALLER_SAVES_R1
 420 callerSaves (VanillaReg 1 _)    = True
 421 #endif
 422 #ifdef CALLER_SAVES_R2
 423 callerSaves (VanillaReg 2 _)    = True
 424 #endif
 425 #ifdef CALLER_SAVES_R3
 426 callerSaves (VanillaReg 3 _)    = True
 427 #endif
 428 #ifdef CALLER_SAVES_R4
 429 callerSaves (VanillaReg 4 _)    = True
 430 #endif
 431 #ifdef CALLER_SAVES_R5
 432 callerSaves (VanillaReg 5 _)    = True
 433 #endif
 434 #ifdef CALLER_SAVES_R6
 435 callerSaves (VanillaReg 6 _)    = True
 436 #endif
 437 #ifdef CALLER_SAVES_R7
 438 callerSaves (VanillaReg 7 _)    = True
 439 #endif
 440 #ifdef CALLER_SAVES_R8
 441 callerSaves (VanillaReg 8 _)    = True
 442 #endif
 443 #ifdef CALLER_SAVES_F1
 444 callerSaves (FloatReg 1)        = True
 445 #endif
 446 #ifdef CALLER_SAVES_F2
 447 callerSaves (FloatReg 2)        = True
 448 #endif
 449 #ifdef CALLER_SAVES_F3
 450 callerSaves (FloatReg 3)        = True
 451 #endif
 452 #ifdef CALLER_SAVES_F4
 453 callerSaves (FloatReg 4)        = True
 454 #endif
 455 #ifdef CALLER_SAVES_D1
 456 callerSaves (DoubleReg 1)       = True
 457 #endif
 458 #ifdef CALLER_SAVES_D2
 459 callerSaves (DoubleReg 2)       = True
 460 #endif
 461 #ifdef CALLER_SAVES_L1
 462 callerSaves (LongReg 1)         = True
 463 #endif
 464 #ifdef CALLER_SAVES_Sp
 465 callerSaves Sp                  = True
 466 #endif
 467 #ifdef CALLER_SAVES_SpLim
 468 callerSaves SpLim               = True
 469 #endif
 470 #ifdef CALLER_SAVES_Hp
 471 callerSaves Hp                  = True
 472 #endif
 473 #ifdef CALLER_SAVES_HpLim
 474 callerSaves HpLim               = True
 475 #endif
 476 #ifdef CALLER_SAVES_CurrentTSO
 477 callerSaves CurrentTSO          = True
 478 #endif
 479 #ifdef CALLER_SAVES_CurrentNursery
 480 callerSaves CurrentNursery      = True
 481 #endif
 482 callerSaves _                   = False
 483
 484
 485 -- -----------------------------------------------------------------------------
 486 -- Information about global registers
 487
 488 baseRegOffset :: GlobalReg -> Int
 489
 490 baseRegOffset Sp                  = oFFSET_StgRegTable_rSp
 491 baseRegOffset SpLim               = oFFSET_StgRegTable_rSpLim
 492 baseRegOffset (LongReg 1)         = oFFSET_StgRegTable_rL1
 493 baseRegOffset Hp                  = oFFSET_StgRegTable_rHp
 494 baseRegOffset HpLim               = oFFSET_StgRegTable_rHpLim
 495 baseRegOffset CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO
 496 baseRegOffset CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery
 497 baseRegOffset HpAlloc             = oFFSET_StgRegTable_rHpAlloc
 498 baseRegOffset GCEnter1            = oFFSET_stgGCEnter1
 499 baseRegOffset GCFun               = oFFSET_stgGCFun
 500 baseRegOffset reg                 = pprPanic "baseRegOffset:" (ppr reg)
 501
 502 -------------------------------------------------------------------------
 503 --
 504 --      Strings generate a top-level data block
 505 --
 506 -------------------------------------------------------------------------
 507
 508 emitDataLits :: CLabel -> [CmmLit] -> FCode ()
 509 -- Emit a data-segment data block
 510 emitDataLits lbl lits
 511   = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 512
 513 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
 514 -- Emit a data-segment data block
 515 mkDataLits lbl lits
 516   = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 517
 518 emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
 519 -- Emit a read-only data block
 520 emitRODataLits lbl lits
 521   = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
 522   where section | any needsRelocation lits = RelocatableReadOnlyData
 523                 | otherwise                = ReadOnlyData
 524         needsRelocation (CmmLabel _)      = True
 525         needsRelocation (CmmLabelOff _ _) = True
 526         needsRelocation _                 = False
 527
 528 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
 529 mkRODataLits lbl lits
 530   = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
 531   where section | any needsRelocation lits = RelocatableReadOnlyData
 532                 | otherwise                = ReadOnlyData
 533         needsRelocation (CmmLabel _)      = True
 534         needsRelocation (CmmLabelOff _ _) = True
 535         needsRelocation _                 = False
 536
 537 mkStringCLit :: String -> FCode CmmLit
 538 -- Make a global definition for the string,
 539 -- and return its label
 540 mkStringCLit str = mkByteStringCLit (map (fromIntegral . ord) str)
 541
 542 mkByteStringCLit :: [Word8] -> FCode CmmLit
 543 mkByteStringCLit bytes
 544   = do  { uniq <- newUnique
 545         ; let lbl = mkStringLitLabel uniq
 546         ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
 547         ; return (CmmLabel lbl) }
 548
 549 -------------------------------------------------------------------------
 550 --
 551 --      Assigning expressions to temporaries
 552 --
 553 -------------------------------------------------------------------------
 554
 555 assignTemp :: CmmExpr -> FCode LocalReg
 556 -- Make sure the argument is in a local register.
 557 -- We don't bother being particularly aggressive with avoiding
 558 -- unnecessary local registers, since we can rely on a later
 559 -- optimization pass to inline as necessary (and skipping out
 560 -- on things like global registers can be a little dangerous
 561 -- due to them being trashed on foreign calls--though it means
 562 -- the optimization pass doesn't have to do as much work)
 563 assignTemp (CmmReg (CmmLocal reg)) = return reg
 564 assignTemp e = do { uniq <- newUnique
 565                   ; let reg = LocalReg uniq (cmmExprType e)
 566                   ; emit (mkAssign (CmmLocal reg) e)
 567                   ; return reg }
 568
 569 newTemp :: CmmType -> FCode LocalReg
 570 newTemp rep = do { uniq <- newUnique
 571                  ; return (LocalReg uniq rep) }
 572
 573 newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
 574 -- Choose suitable local regs to use for the components
 575 -- of an unboxed tuple that we are about to return to
 576 -- the Sequel.  If the Sequel is a join point, using the
 577 -- regs it wants will save later assignments.
 578 newUnboxedTupleRegs res_ty
 579   = ASSERT( isUnboxedTupleType res_ty )
 580     do  { sequel <- getSequel
 581         ; regs <- choose_regs sequel
 582         ; ASSERT( regs `equalLength` reps )
 583           return (regs, map primRepForeignHint reps) }
 584   where
 585     ty_args = tyConAppArgs (repType res_ty)
 586     reps = [ rep
 587            | ty <- ty_args
 588            , let rep = typePrimRep ty
 589            , not (isVoidRep rep) ]
 590     choose_regs (AssignTo regs _) = return regs
 591     choose_regs _other            = mapM (newTemp . primRepCmmType) reps
 592
 593
 594
 595 -------------------------------------------------------------------------
 596 --      mkMultiAssign
 597 -------------------------------------------------------------------------
 598
 599 mkMultiAssign :: [LocalReg] -> [CmmExpr] -> CmmAGraph
 600 -- Emit code to perform the assignments in the
 601 -- input simultaneously, using temporary variables when necessary.
 602
 603 type Key  = Int
 604 type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
 605                         -- for fast comparison
 606 type Stmt = (LocalReg, CmmExpr) -- r := e
 607
 608 -- We use the strongly-connected component algorithm, in which
 609 --      * the vertices are the statements
 610 --      * an edge goes from s1 to s2 iff
 611 --              s1 assigns to something s2 uses
 612 --        that is, if s1 should *follow* s2 in the final order
 613
 614 mkMultiAssign []    []    = mkNop
 615 mkMultiAssign [reg] [rhs] = mkAssign (CmmLocal reg) rhs
 616 mkMultiAssign regs  rhss  = ASSERT( equalLength regs rhss )
 617                             unscramble ([1..] `zip` (regs `zip` rhss))
 618
 619 unscramble :: [Vrtx] -> CmmAGraph
 620 unscramble vertices
 621   = catAGraphs (map do_component components)
 622   where
 623         edges :: [ (Vrtx, Key, [Key]) ]
 624         edges = [ (vertex, key1, edges_from stmt1)
 625                 | vertex@(key1, stmt1) <- vertices ]
 626
 627         edges_from :: Stmt -> [Key]
 628         edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
 629                                     stmt1 `mustFollow` stmt2 ]
 630
 631         components :: [SCC Vrtx]
 632         components = stronglyConnCompFromEdgedVertices edges
 633
 634         -- do_components deal with one strongly-connected component
 635         -- Not cyclic, or singleton?  Just do it
 636         do_component :: SCC Vrtx -> CmmAGraph
 637         do_component (AcyclicSCC (_,stmt))  = mk_graph stmt
 638         do_component (CyclicSCC [])         = panic "do_component"
 639         do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt
 640
 641                 -- Cyclic?  Then go via temporaries.  Pick one to
 642                 -- break the loop and try again with the rest.
 643         do_component (CyclicSCC ((_,first_stmt) : rest))
 644           = withUnique          $ \u ->
 645             let (to_tmp, from_tmp) = split u first_stmt
 646             in mk_graph to_tmp
 647                <*> unscramble rest
 648                <*> mk_graph from_tmp
 649
 650         split :: Unique -> Stmt -> (Stmt, Stmt)
 651         split uniq (reg, rhs)
 652           = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
 653           where
 654             rep = cmmExprType rhs
 655             tmp = LocalReg uniq rep
 656
 657         mk_graph :: Stmt -> CmmAGraph
 658         mk_graph (reg, rhs) = mkAssign (CmmLocal reg) rhs
 659
 660 mustFollow :: Stmt -> Stmt -> Bool
 661 (reg, _) `mustFollow` (_, rhs) = reg `regUsedIn` rhs
 662
 663 regUsedIn :: LocalReg -> CmmExpr -> Bool
 664 reg  `regUsedIn` CmmLoad e  _                = reg `regUsedIn` e
 665 reg  `regUsedIn` CmmReg (CmmLocal reg')      = reg == reg'
 666 reg  `regUsedIn` CmmRegOff (CmmLocal reg') _ = reg == reg'
 667 reg  `regUsedIn` CmmMachOp _ es              = any (reg `regUsedIn`) es
 668 _reg `regUsedIn` _other                      = False            -- The CmmGlobal cases
 669
 670 -------------------------------------------------------------------------
 671 --      mkSwitch
 672 -------------------------------------------------------------------------
 673
 674
 675 emitSwitch :: CmmExpr           -- Tag to switch on
 676            -> [(ConTagZ, CmmAGraph)]    -- Tagged branches
 677            -> Maybe CmmAGraph           -- Default branch (if any)
 678            -> ConTagZ -> ConTagZ        -- Min and Max possible values; behaviour
 679                                         --      outside this range is undefined
 680            -> FCode ()
 681 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
 682   = do  { dflags <- getDynFlags
 683         ; emit (mkCmmSwitch (via_C dflags) tag_expr branches mb_deflt lo_tag hi_tag) }
 684   where
 685     via_C dflags | HscC <- hscTarget dflags = True
 686                  | otherwise                = False
 687
 688
 689 mkCmmSwitch :: Bool                     -- True <=> never generate a conditional tree
 690             -> CmmExpr                  -- Tag to switch on
 691             -> [(ConTagZ, CmmAGraph)]   -- Tagged branches
 692             -> Maybe CmmAGraph          -- Default branch (if any)
 693             -> ConTagZ -> ConTagZ       -- Min and Max possible values; behaviour
 694                                         --      outside this range is undefined
 695             -> CmmAGraph
 696
 697 -- First, two rather common cases in which there is no work to do
 698 mkCmmSwitch _ _ []         (Just code) _ _ = code
 699 mkCmmSwitch _ _ [(_,code)] Nothing     _ _ = code
 700
 701 -- Right, off we go
 702 mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag
 703   = withFreshLabel "switch join"        $ \ join_lbl ->
 704     label_default join_lbl mb_deflt     $ \ mb_deflt ->
 705     label_branches join_lbl branches    $ \ branches ->
 706     assignTemp' tag_expr                $ \tag_expr' ->
 707
 708     mk_switch tag_expr' (sortLe le branches) mb_deflt
 709               lo_tag hi_tag via_C
 710           -- Sort the branches before calling mk_switch
 711     <*> mkLabel join_lbl
 712
 713   where
 714     (t1,_) `le` (t2,_) = t1 <= t2
 715
 716 mk_switch :: CmmExpr -> [(ConTagZ, BlockId)]
 717           -> Maybe BlockId
 718           -> ConTagZ -> ConTagZ -> Bool
 719           -> CmmAGraph
 720
 721 -- SINGLETON TAG RANGE: no case analysis to do
 722 mk_switch _tag_expr [(tag, lbl)] _ lo_tag hi_tag _via_C
 723   | lo_tag == hi_tag
 724   = ASSERT( tag == lo_tag )
 725     mkBranch lbl
 726
 727 -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
 728 mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _
 729   = mkBranch lbl
 730         -- The simplifier might have eliminated a case
 731         --       so we may have e.g. case xs of
 732         --                               [] -> e
 733         -- In that situation we can be sure the (:) case
 734         -- can't happen, so no need to test
 735
 736 -- SINGLETON BRANCH: one equality check to do
 737 mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _
 738   = mkCbranch cond deflt lbl
 739   where
 740     cond =  cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
 741         -- We have lo_tag < hi_tag, but there's only one branch,
 742         -- so there must be a default
 743
 744 -- ToDo: we might want to check for the two branch case, where one of
 745 -- the branches is the tag 0, because comparing '== 0' is likely to be
 746 -- more efficient than other kinds of comparison.
 747
 748 -- DENSE TAG RANGE: use a switch statment.
 749 --
 750 -- We also use a switch uncoditionally when compiling via C, because
 751 -- this will get emitted as a C switch statement and the C compiler
 752 -- should do a good job of optimising it.  Also, older GCC versions
 753 -- (2.95 in particular) have problems compiling the complicated
 754 -- if-trees generated by this code, so compiling to a switch every
 755 -- time works around that problem.
 756 --
 757 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
 758   | use_switch  -- Use a switch
 759   = let
 760         find_branch :: ConTagZ -> Maybe BlockId
 761         find_branch i = case (assocMaybe branches i) of
 762                           Just lbl -> Just lbl
 763                           Nothing  -> mb_deflt
 764
 765         -- NB. we have eliminated impossible branches at
 766         -- either end of the range (see below), so the first
 767         -- tag of a real branch is real_lo_tag (not lo_tag).
 768         arms :: [Maybe BlockId]
 769         arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
 770     in
 771     mkSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
 772
 773   -- if we can knock off a bunch of default cases with one if, then do so
 774   | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
 775   = mkCmmIfThenElse
 776         (cmmULtWord tag_expr (CmmLit (mkIntCLit lowest_branch)))
 777         (mkBranch deflt)
 778         (mk_switch tag_expr branches mb_deflt
 779                         lowest_branch hi_tag via_C)
 780
 781   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
 782   = mkCmmIfThenElse
 783         (cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch)))
 784         (mkBranch deflt)
 785         (mk_switch tag_expr branches mb_deflt
 786                         lo_tag highest_branch via_C)
 787
 788   | otherwise   -- Use an if-tree
 789   = mkCmmIfThenElse
 790         (cmmUGeWord tag_expr (CmmLit (mkIntCLit mid_tag)))
 791         (mk_switch tag_expr hi_branches mb_deflt
 792                              mid_tag hi_tag via_C)
 793         (mk_switch tag_expr lo_branches mb_deflt
 794                              lo_tag (mid_tag-1) via_C)
 795         -- we test (e >= mid_tag) rather than (e < mid_tag), because
 796         -- the former works better when e is a comparison, and there
 797         -- are two tags 0 & 1 (mid_tag == 1).  In this case, the code
 798         -- generator can reduce the condition to e itself without
 799         -- having to reverse the sense of the comparison: comparisons
 800         -- can't always be easily reversed (eg. floating
 801         -- pt. comparisons).
 802   where
 803     use_switch   = {- pprTrace "mk_switch" (
 804                         ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
 805                         text "branches:" <+> ppr (map fst branches) <+>
 806                         text "n_branches:" <+> int n_branches <+>
 807                         text "lo_tag:" <+> int lo_tag <+>
 808                         text "hi_tag:" <+> int hi_tag <+>
 809                         text "real_lo_tag:" <+> int real_lo_tag <+>
 810                         text "real_hi_tag:" <+> int real_hi_tag) $ -}
 811                    ASSERT( n_branches > 1 && n_tags > 1 )
 812                    n_tags > 2 && (via_C || (dense && big_enough))
 813                  -- up to 4 branches we use a decision tree, otherwise
 814                  -- a switch (== jump table in the NCG).  This seems to be
 815                  -- optimal, and corresponds with what gcc does.
 816     big_enough   = n_branches > 4
 817     dense        = n_branches > (n_tags `div` 2)
 818     n_branches   = length branches
 819
 820     -- ignore default slots at each end of the range if there's
 821     -- no default branch defined.
 822     lowest_branch  = fst (head branches)
 823     highest_branch = fst (last branches)
 824
 825     real_lo_tag
 826         | isNothing mb_deflt = lowest_branch
 827         | otherwise          = lo_tag
 828
 829     real_hi_tag
 830         | isNothing mb_deflt = highest_branch
 831         | otherwise          = hi_tag
 832
 833     n_tags = real_hi_tag - real_lo_tag + 1
 834
 835         -- INVARIANT: Provided hi_tag > lo_tag (which is true)
 836         --      lo_tag <= mid_tag < hi_tag
 837         --      lo_branches have tags <  mid_tag
 838         --      hi_branches have tags >= mid_tag
 839
 840     (mid_tag,_) = branches !! (n_branches `div` 2)
 841         -- 2 branches => n_branches `div` 2 = 1
 842         --            => branches !! 1 give the *second* tag
 843         -- There are always at least 2 branches here
 844
 845     (lo_branches, hi_branches) = span is_lo branches
 846     is_lo (t,_) = t < mid_tag
 847
 848 --------------
 849 mkCmmLitSwitch :: CmmExpr                 -- Tag to switch on
 850                -> [(Literal, CmmAGraph)]  -- Tagged branches
 851                -> CmmAGraph               -- Default branch (always)
 852                -> CmmAGraph               -- Emit the code
 853 -- Used for general literals, whose size might not be a word,
 854 -- where there is always a default case, and where we don't know
 855 -- the range of values for certain.  For simplicity we always generate a tree.
 856 --
 857 -- ToDo: for integers we could do better here, perhaps by generalising
 858 -- mk_switch and using that.  --SDM 15/09/2004
 859 mkCmmLitSwitch _scrut []       deflt = deflt
 860 mkCmmLitSwitch scrut  branches deflt
 861   = assignTemp' scrut           $ \ scrut' ->
 862     withFreshLabel "switch join"        $ \ join_lbl ->
 863     label_code join_lbl deflt           $ \ deflt ->
 864     label_branches join_lbl branches    $ \ branches ->
 865     mk_lit_switch scrut' deflt (sortLe le branches)
 866     <*> mkLabel join_lbl
 867   where
 868     le (t1,_) (t2,_) = t1 <= t2
 869
 870 mk_lit_switch :: CmmExpr -> BlockId
 871               -> [(Literal,BlockId)]
 872               -> CmmAGraph
 873 mk_lit_switch scrut deflt [(lit,blk)]
 874   = mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk
 875   where
 876     cmm_lit = mkSimpleLit lit
 877     cmm_ty  = cmmLitType cmm_lit
 878     rep     = typeWidth cmm_ty
 879     ne      = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep
 880
 881 mk_lit_switch scrut deflt_blk_id branches
 882   = mkCmmIfThenElse cond
 883         (mk_lit_switch scrut deflt_blk_id lo_branches)
 884         (mk_lit_switch scrut deflt_blk_id hi_branches)
 885   where
 886     n_branches = length branches
 887     (mid_lit,_) = branches !! (n_branches `div` 2)
 888         -- See notes above re mid_tag
 889
 890     (lo_branches, hi_branches) = span is_lo branches
 891     is_lo (t,_) = t < mid_lit
 892
 893     cond = CmmMachOp (mkLtOp mid_lit)
 894                         [scrut, CmmLit (mkSimpleLit mid_lit)]
 895
 896
 897 --------------
 898 label_default :: BlockId -> Maybe CmmAGraph
 899               -> (Maybe BlockId -> CmmAGraph)
 900               -> CmmAGraph
 901 label_default _ Nothing thing_inside
 902   = thing_inside Nothing
 903 label_default join_lbl (Just code) thing_inside
 904   = label_code join_lbl code    $ \ lbl ->
 905     thing_inside (Just lbl)
 906
 907 --------------
 908 label_branches :: BlockId -> [(a,CmmAGraph)]
 909                -> ([(a,BlockId)] -> CmmAGraph)
 910                -> CmmAGraph
 911 label_branches _join_lbl [] thing_inside
 912   = thing_inside []
 913 label_branches join_lbl ((tag,code):branches) thing_inside
 914   = label_code join_lbl code            $ \ lbl ->
 915     label_branches join_lbl branches    $ \ branches' ->
 916     thing_inside ((tag,lbl):branches')
 917
 918 --------------
 919 label_code :: BlockId -> CmmAGraph -> (BlockId -> CmmAGraph) -> CmmAGraph
 920 -- (label_code J code fun)
 921 --      generates
 922 --  [L: code; goto J] fun L
 923 label_code join_lbl code thing_inside
 924   = withFreshLabel "switch"     $ \lbl ->
 925     outOfLine (mkLabel lbl <*> code <*> mkBranch join_lbl)
 926     <*> thing_inside lbl
 927
 928
 929 --------------
 930 assignTemp' :: CmmExpr -> (CmmExpr -> CmmAGraph) -> CmmAGraph
 931 assignTemp' e thing_inside
 932   | isTrivialCmmExpr e = thing_inside e
 933   | otherwise          = withTemp (cmmExprType e)       $ \ lreg ->
 934                          let reg = CmmLocal lreg in
 935                          mkAssign reg e <*> thing_inside (CmmReg reg)
 936
 937 withTemp :: CmmType -> (LocalReg -> CmmAGraph) -> CmmAGraph
 938 withTemp rep thing_inside
 939   = withUnique $ \uniq -> thing_inside (LocalReg uniq rep)
 940
 941
 942 -------------------------------------------------------------------------
 943 --
 944 --      Static Reference Tables
 945 --
 946 -------------------------------------------------------------------------
 947
 948 -- There is just one SRT for each top level binding; all the nested
 949 -- bindings use sub-sections of this SRT.  The label is passed down to
 950 -- the nested bindings via the monad.
 951
 952 getSRTInfo :: SRT -> FCode C_SRT
 953 getSRTInfo (SRTEntries {}) = panic "getSRTInfo"
 954
 955 getSRTInfo (SRT off len bmp)
 956   | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
 957   = do  { id <- newUnique
 958         -- ; top_srt <- getSRTLabel
 959         ; let srt_desc_lbl = mkLargeSRTLabel id
 960         -- JD: We're not constructing and emitting SRTs in the back end,
 961         -- which renders this code wrong (it now names a now-non-existent label).
 962         -- ; emitRODataLits srt_desc_lbl
 963         --      ( cmmLabelOffW top_srt off
 964         --        : mkWordCLit (fromIntegral len)
 965         --        : map mkWordCLit bmp)
 966         ; return (C_SRT srt_desc_lbl 0 srt_escape) }
 967
 968   | otherwise
 969   = do  { top_srt <- getSRTLabel
 970         ; return (C_SRT top_srt off (fromIntegral (head bmp))) }
 971         -- The fromIntegral converts to StgHalfWord
 972
 973 getSRTInfo NoSRT
 974   = -- TODO: Should we panic in this case?
 975     -- Someone obviously thinks there should be an SRT
 976     return NoC_SRT
 977
 978
 979 srt_escape :: StgHalfWord
 980 srt_escape = -1