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