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 -- EZY: This code is very dodgy, because callerSaves only ever
 344 -- returns true in the current universe for registers NOT in
 345 -- system_regs (just do a grep for CALLER_SAVES in
 346 -- includes/stg/MachRegs.h).  Thus, this is all one giant no-op.  What we are
 347 -- actually interested in is saving are the non-system registers, which
 348 -- we is what the old code generator actually does at this point.
 349 -- Unfortunately, we can't do that here either, because we don't
 350 -- liveness information, and thus there's not an easy way to tell which
 351 -- specific global registers need to be saved (the 'vols' argument in
 352 -- the old code generator.)  One possible hack is to save all of them
 353 -- unconditionally, but unless we have very clever dead /memory/
 354 -- elimination (unlikely), this will still leave a dead, unnecessary
 355 -- memory assignment.  And really, we shouldn't be doing the workaround
 356 -- at this point in the pipeline, see Note [Register parameter passing].
 357 -- Right now the workaround is to avoid inlining across unsafe foreign
 358 -- calls in rewriteAssignments.
 359 callerSaveVolatileRegs :: (CmmAGraph, CmmAGraph)
 360 callerSaveVolatileRegs = (caller_save, caller_load)
 361   where
 362     caller_save = catAGraphs (map callerSaveGlobalReg    regs_to_save)
 363     caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
 364
 365     system_regs = [ Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery
 366                     {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
 367                   , BaseReg ]
 368
 369     regs_to_save = filter callerSaves system_regs
 370
 371     callerSaveGlobalReg reg
 372         = mkStore (get_GlobalReg_addr reg) (CmmReg (CmmGlobal reg))
 373
 374     callerRestoreGlobalReg reg
 375         = mkAssign (CmmGlobal reg)
 376                     (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
 377
 378 -- -----------------------------------------------------------------------------
 379 -- Global registers
 380
 381 -- We map STG registers onto appropriate CmmExprs.  Either they map
 382 -- to real machine registers or stored as offsets from BaseReg.  Given
 383 -- a GlobalReg, get_GlobalReg_addr always produces the
 384 -- register table address for it.
 385 -- (See also get_GlobalReg_reg_or_addr in MachRegs)
 386
 387 get_GlobalReg_addr              :: GlobalReg -> CmmExpr
 388 get_GlobalReg_addr BaseReg = regTableOffset 0
 389 get_GlobalReg_addr mid     = get_Regtable_addr_from_offset
 390                                 (globalRegType mid) (baseRegOffset mid)
 391
 392 -- Calculate a literal representing an offset into the register table.
 393 -- Used when we don't have an actual BaseReg to offset from.
 394 regTableOffset :: Int -> CmmExpr
 395 regTableOffset n =
 396   CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
 397
 398 get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr
 399 get_Regtable_addr_from_offset _rep offset =
 400 #ifdef REG_Base
 401   CmmRegOff (CmmGlobal BaseReg) offset
 402 #else
 403   regTableOffset offset
 404 #endif
 405
 406
 407 -- | Returns 'True' if this global register is stored in a caller-saves
 408 -- machine register.
 409
 410 callerSaves :: GlobalReg -> Bool
 411
 412 #ifdef CALLER_SAVES_Base
 413 callerSaves BaseReg             = True
 414 #endif
 415 #ifdef CALLER_SAVES_R1
 416 callerSaves (VanillaReg 1 _)    = True
 417 #endif
 418 #ifdef CALLER_SAVES_R2
 419 callerSaves (VanillaReg 2 _)    = True
 420 #endif
 421 #ifdef CALLER_SAVES_R3
 422 callerSaves (VanillaReg 3 _)    = True
 423 #endif
 424 #ifdef CALLER_SAVES_R4
 425 callerSaves (VanillaReg 4 _)    = True
 426 #endif
 427 #ifdef CALLER_SAVES_R5
 428 callerSaves (VanillaReg 5 _)    = True
 429 #endif
 430 #ifdef CALLER_SAVES_R6
 431 callerSaves (VanillaReg 6 _)    = True
 432 #endif
 433 #ifdef CALLER_SAVES_R7
 434 callerSaves (VanillaReg 7 _)    = True
 435 #endif
 436 #ifdef CALLER_SAVES_R8
 437 callerSaves (VanillaReg 8 _)    = True
 438 #endif
 439 #ifdef CALLER_SAVES_F1
 440 callerSaves (FloatReg 1)        = True
 441 #endif
 442 #ifdef CALLER_SAVES_F2
 443 callerSaves (FloatReg 2)        = True
 444 #endif
 445 #ifdef CALLER_SAVES_F3
 446 callerSaves (FloatReg 3)        = True
 447 #endif
 448 #ifdef CALLER_SAVES_F4
 449 callerSaves (FloatReg 4)        = True
 450 #endif
 451 #ifdef CALLER_SAVES_D1
 452 callerSaves (DoubleReg 1)       = True
 453 #endif
 454 #ifdef CALLER_SAVES_D2
 455 callerSaves (DoubleReg 2)       = True
 456 #endif
 457 #ifdef CALLER_SAVES_L1
 458 callerSaves (LongReg 1)         = True
 459 #endif
 460 #ifdef CALLER_SAVES_Sp
 461 callerSaves Sp                  = True
 462 #endif
 463 #ifdef CALLER_SAVES_SpLim
 464 callerSaves SpLim               = True
 465 #endif
 466 #ifdef CALLER_SAVES_Hp
 467 callerSaves Hp                  = True
 468 #endif
 469 #ifdef CALLER_SAVES_HpLim
 470 callerSaves HpLim               = True
 471 #endif
 472 #ifdef CALLER_SAVES_CurrentTSO
 473 callerSaves CurrentTSO          = True
 474 #endif
 475 #ifdef CALLER_SAVES_CurrentNursery
 476 callerSaves CurrentNursery      = True
 477 #endif
 478 callerSaves _                   = False
 479
 480
 481 -- -----------------------------------------------------------------------------
 482 -- Information about global registers
 483
 484 baseRegOffset :: GlobalReg -> Int
 485
 486 baseRegOffset Sp                  = oFFSET_StgRegTable_rSp
 487 baseRegOffset SpLim               = oFFSET_StgRegTable_rSpLim
 488 baseRegOffset (LongReg 1)         = oFFSET_StgRegTable_rL1
 489 baseRegOffset Hp                  = oFFSET_StgRegTable_rHp
 490 baseRegOffset HpLim               = oFFSET_StgRegTable_rHpLim
 491 baseRegOffset CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO
 492 baseRegOffset CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery
 493 baseRegOffset HpAlloc             = oFFSET_StgRegTable_rHpAlloc
 494 baseRegOffset GCEnter1            = oFFSET_stgGCEnter1
 495 baseRegOffset GCFun               = oFFSET_stgGCFun
 496 baseRegOffset reg                 = pprPanic "baseRegOffset:" (ppr reg)
 497
 498 -------------------------------------------------------------------------
 499 --
 500 --      Strings generate a top-level data block
 501 --
 502 -------------------------------------------------------------------------
 503
 504 emitDataLits :: CLabel -> [CmmLit] -> FCode ()
 505 -- Emit a data-segment data block
 506 emitDataLits lbl lits
 507   = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 508
 509 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
 510 -- Emit a data-segment data block
 511 mkDataLits lbl lits
 512   = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 513
 514 emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
 515 -- Emit a read-only data block
 516 emitRODataLits lbl lits
 517   = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
 518   where section | any needsRelocation lits = RelocatableReadOnlyData
 519                 | otherwise                = ReadOnlyData
 520         needsRelocation (CmmLabel _)      = True
 521         needsRelocation (CmmLabelOff _ _) = True
 522         needsRelocation _                 = False
 523
 524 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
 525 mkRODataLits lbl lits
 526   = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
 527   where section | any needsRelocation lits = RelocatableReadOnlyData
 528                 | otherwise                = ReadOnlyData
 529         needsRelocation (CmmLabel _)      = True
 530         needsRelocation (CmmLabelOff _ _) = True
 531         needsRelocation _                 = False
 532
 533 mkStringCLit :: String -> FCode CmmLit
 534 -- Make a global definition for the string,
 535 -- and return its label
 536 mkStringCLit str = mkByteStringCLit (map (fromIntegral . ord) str)
 537
 538 mkByteStringCLit :: [Word8] -> FCode CmmLit
 539 mkByteStringCLit bytes
 540   = do  { uniq <- newUnique
 541         ; let lbl = mkStringLitLabel uniq
 542         ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
 543         ; return (CmmLabel lbl) }
 544
 545 -------------------------------------------------------------------------
 546 --
 547 --      Assigning expressions to temporaries
 548 --
 549 -------------------------------------------------------------------------
 550
 551 assignTemp :: CmmExpr -> FCode LocalReg
 552 -- Make sure the argument is in a local register
 553 assignTemp (CmmReg (CmmLocal reg)) = return reg
 554 assignTemp e = do { uniq <- newUnique
 555                   ; let reg = LocalReg uniq (cmmExprType e)
 556                   ; emit (mkAssign (CmmLocal reg) e)
 557                   ; return reg }
 558
 559 newTemp :: CmmType -> FCode LocalReg
 560 newTemp rep = do { uniq <- newUnique
 561                  ; return (LocalReg uniq rep) }
 562
 563 newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
 564 -- Choose suitable local regs to use for the components
 565 -- of an unboxed tuple that we are about to return to
 566 -- the Sequel.  If the Sequel is a join point, using the
 567 -- regs it wants will save later assignments.
 568 newUnboxedTupleRegs res_ty
 569   = ASSERT( isUnboxedTupleType res_ty )
 570     do  { sequel <- getSequel
 571         ; regs <- choose_regs sequel
 572         ; ASSERT( regs `equalLength` reps )
 573           return (regs, map primRepForeignHint reps) }
 574   where
 575     ty_args = tyConAppArgs (repType res_ty)
 576     reps = [ rep
 577            | ty <- ty_args
 578            , let rep = typePrimRep ty
 579            , not (isVoidRep rep) ]
 580     choose_regs (AssignTo regs _) = return regs
 581     choose_regs _other            = mapM (newTemp . primRepCmmType) reps
 582
 583
 584
 585 -------------------------------------------------------------------------
 586 --      mkMultiAssign
 587 -------------------------------------------------------------------------
 588
 589 mkMultiAssign :: [LocalReg] -> [CmmExpr] -> CmmAGraph
 590 -- Emit code to perform the assignments in the
 591 -- input simultaneously, using temporary variables when necessary.
 592
 593 type Key  = Int
 594 type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
 595                         -- for fast comparison
 596 type Stmt = (LocalReg, CmmExpr) -- r := e
 597
 598 -- We use the strongly-connected component algorithm, in which
 599 --      * the vertices are the statements
 600 --      * an edge goes from s1 to s2 iff
 601 --              s1 assigns to something s2 uses
 602 --        that is, if s1 should *follow* s2 in the final order
 603
 604 mkMultiAssign []    []    = mkNop
 605 mkMultiAssign [reg] [rhs] = mkAssign (CmmLocal reg) rhs
 606 mkMultiAssign regs  rhss  = ASSERT( equalLength regs rhss )
 607                             unscramble ([1..] `zip` (regs `zip` rhss))
 608
 609 unscramble :: [Vrtx] -> CmmAGraph
 610 unscramble vertices
 611   = catAGraphs (map do_component components)
 612   where
 613         edges :: [ (Vrtx, Key, [Key]) ]
 614         edges = [ (vertex, key1, edges_from stmt1)
 615                 | vertex@(key1, stmt1) <- vertices ]
 616
 617         edges_from :: Stmt -> [Key]
 618         edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
 619                                     stmt1 `mustFollow` stmt2 ]
 620
 621         components :: [SCC Vrtx]
 622         components = stronglyConnCompFromEdgedVertices edges
 623
 624         -- do_components deal with one strongly-connected component
 625         -- Not cyclic, or singleton?  Just do it
 626         do_component :: SCC Vrtx -> CmmAGraph
 627         do_component (AcyclicSCC (_,stmt))  = mk_graph stmt
 628         do_component (CyclicSCC [])         = panic "do_component"
 629         do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt
 630
 631                 -- Cyclic?  Then go via temporaries.  Pick one to
 632                 -- break the loop and try again with the rest.
 633         do_component (CyclicSCC ((_,first_stmt) : rest))
 634           = withUnique          $ \u ->
 635             let (to_tmp, from_tmp) = split u first_stmt
 636             in mk_graph to_tmp
 637                <*> unscramble rest
 638                <*> mk_graph from_tmp
 639
 640         split :: Unique -> Stmt -> (Stmt, Stmt)
 641         split uniq (reg, rhs)
 642           = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
 643           where
 644             rep = cmmExprType rhs
 645             tmp = LocalReg uniq rep
 646
 647         mk_graph :: Stmt -> CmmAGraph
 648         mk_graph (reg, rhs) = mkAssign (CmmLocal reg) rhs
 649
 650 mustFollow :: Stmt -> Stmt -> Bool
 651 (reg, _) `mustFollow` (_, rhs) = reg `regUsedIn` rhs
 652
 653 regUsedIn :: LocalReg -> CmmExpr -> Bool
 654 reg  `regUsedIn` CmmLoad e  _                = reg `regUsedIn` e
 655 reg  `regUsedIn` CmmReg (CmmLocal reg')      = reg == reg'
 656 reg  `regUsedIn` CmmRegOff (CmmLocal reg') _ = reg == reg'
 657 reg  `regUsedIn` CmmMachOp _ es              = any (reg `regUsedIn`) es
 658 _reg `regUsedIn` _other                      = False            -- The CmmGlobal cases
 659
 660 -------------------------------------------------------------------------
 661 --      mkSwitch
 662 -------------------------------------------------------------------------
 663
 664
 665 emitSwitch :: CmmExpr           -- Tag to switch on
 666            -> [(ConTagZ, CmmAGraph)]    -- Tagged branches
 667            -> Maybe CmmAGraph           -- Default branch (if any)
 668            -> ConTagZ -> ConTagZ        -- Min and Max possible values; behaviour
 669                                         --      outside this range is undefined
 670            -> FCode ()
 671 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
 672   = do  { dflags <- getDynFlags
 673         ; emit (mkCmmSwitch (via_C dflags) tag_expr branches mb_deflt lo_tag hi_tag) }
 674   where
 675     via_C dflags | HscC <- hscTarget dflags = True
 676                  | otherwise                = False
 677
 678
 679 mkCmmSwitch :: Bool                     -- True <=> never generate a conditional tree
 680             -> CmmExpr                  -- Tag to switch on
 681             -> [(ConTagZ, CmmAGraph)]   -- Tagged branches
 682             -> Maybe CmmAGraph          -- Default branch (if any)
 683             -> ConTagZ -> ConTagZ       -- Min and Max possible values; behaviour
 684                                         --      outside this range is undefined
 685             -> CmmAGraph
 686
 687 -- First, two rather common cases in which there is no work to do
 688 mkCmmSwitch _ _ []         (Just code) _ _ = code
 689 mkCmmSwitch _ _ [(_,code)] Nothing     _ _ = code
 690
 691 -- Right, off we go
 692 mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag
 693   = withFreshLabel "switch join"        $ \ join_lbl ->
 694     label_default join_lbl mb_deflt     $ \ mb_deflt ->
 695     label_branches join_lbl branches    $ \ branches ->
 696     assignTemp' tag_expr                $ \tag_expr' ->
 697
 698     mk_switch tag_expr' (sortLe le branches) mb_deflt
 699               lo_tag hi_tag via_C
 700           -- Sort the branches before calling mk_switch
 701     <*> mkLabel join_lbl
 702
 703   where
 704     (t1,_) `le` (t2,_) = t1 <= t2
 705
 706 mk_switch :: CmmExpr -> [(ConTagZ, BlockId)]
 707           -> Maybe BlockId
 708           -> ConTagZ -> ConTagZ -> Bool
 709           -> CmmAGraph
 710
 711 -- SINGLETON TAG RANGE: no case analysis to do
 712 mk_switch _tag_expr [(tag, lbl)] _ lo_tag hi_tag _via_C
 713   | lo_tag == hi_tag
 714   = ASSERT( tag == lo_tag )
 715     mkBranch lbl
 716
 717 -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
 718 mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _
 719   = mkBranch lbl
 720         -- The simplifier might have eliminated a case
 721         --       so we may have e.g. case xs of
 722         --                               [] -> e
 723         -- In that situation we can be sure the (:) case
 724         -- can't happen, so no need to test
 725
 726 -- SINGLETON BRANCH: one equality check to do
 727 mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _
 728   = mkCbranch cond deflt lbl
 729   where
 730     cond =  cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
 731         -- We have lo_tag < hi_tag, but there's only one branch,
 732         -- so there must be a default
 733
 734 -- ToDo: we might want to check for the two branch case, where one of
 735 -- the branches is the tag 0, because comparing '== 0' is likely to be
 736 -- more efficient than other kinds of comparison.
 737
 738 -- DENSE TAG RANGE: use a switch statment.
 739 --
 740 -- We also use a switch uncoditionally when compiling via C, because
 741 -- this will get emitted as a C switch statement and the C compiler
 742 -- should do a good job of optimising it.  Also, older GCC versions
 743 -- (2.95 in particular) have problems compiling the complicated
 744 -- if-trees generated by this code, so compiling to a switch every
 745 -- time works around that problem.
 746 --
 747 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
 748   | use_switch  -- Use a switch
 749   = let
 750         find_branch :: ConTagZ -> Maybe BlockId
 751         find_branch i = case (assocMaybe branches i) of
 752                           Just lbl -> Just lbl
 753                           Nothing  -> mb_deflt
 754
 755         -- NB. we have eliminated impossible branches at
 756         -- either end of the range (see below), so the first
 757         -- tag of a real branch is real_lo_tag (not lo_tag).
 758         arms :: [Maybe BlockId]
 759         arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
 760     in
 761     mkSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
 762
 763   -- if we can knock off a bunch of default cases with one if, then do so
 764   | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
 765   = mkCmmIfThenElse
 766         (cmmULtWord tag_expr (CmmLit (mkIntCLit lowest_branch)))
 767         (mkBranch deflt)
 768         (mk_switch tag_expr branches mb_deflt
 769                         lowest_branch hi_tag via_C)
 770
 771   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
 772   = mkCmmIfThenElse
 773         (cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch)))
 774         (mkBranch deflt)
 775         (mk_switch tag_expr branches mb_deflt
 776                         lo_tag highest_branch via_C)
 777
 778   | otherwise   -- Use an if-tree
 779   = mkCmmIfThenElse
 780         (cmmUGeWord tag_expr (CmmLit (mkIntCLit mid_tag)))
 781         (mk_switch tag_expr hi_branches mb_deflt
 782                              mid_tag hi_tag via_C)
 783         (mk_switch tag_expr lo_branches mb_deflt
 784                              lo_tag (mid_tag-1) via_C)
 785         -- we test (e >= mid_tag) rather than (e < mid_tag), because
 786         -- the former works better when e is a comparison, and there
 787         -- are two tags 0 & 1 (mid_tag == 1).  In this case, the code
 788         -- generator can reduce the condition to e itself without
 789         -- having to reverse the sense of the comparison: comparisons
 790         -- can't always be easily reversed (eg. floating
 791         -- pt. comparisons).
 792   where
 793     use_switch   = {- pprTrace "mk_switch" (
 794                         ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
 795                         text "branches:" <+> ppr (map fst branches) <+>
 796                         text "n_branches:" <+> int n_branches <+>
 797                         text "lo_tag:" <+> int lo_tag <+>
 798                         text "hi_tag:" <+> int hi_tag <+>
 799                         text "real_lo_tag:" <+> int real_lo_tag <+>
 800                         text "real_hi_tag:" <+> int real_hi_tag) $ -}
 801                    ASSERT( n_branches > 1 && n_tags > 1 )
 802                    n_tags > 2 && (via_C || (dense && big_enough))
 803                  -- up to 4 branches we use a decision tree, otherwise
 804                  -- a switch (== jump table in the NCG).  This seems to be
 805                  -- optimal, and corresponds with what gcc does.
 806     big_enough   = n_branches > 4
 807     dense        = n_branches > (n_tags `div` 2)
 808     n_branches   = length branches
 809
 810     -- ignore default slots at each end of the range if there's
 811     -- no default branch defined.
 812     lowest_branch  = fst (head branches)
 813     highest_branch = fst (last branches)
 814
 815     real_lo_tag
 816         | isNothing mb_deflt = lowest_branch
 817         | otherwise          = lo_tag
 818
 819     real_hi_tag
 820         | isNothing mb_deflt = highest_branch
 821         | otherwise          = hi_tag
 822
 823     n_tags = real_hi_tag - real_lo_tag + 1
 824
 825         -- INVARIANT: Provided hi_tag > lo_tag (which is true)
 826         --      lo_tag <= mid_tag < hi_tag
 827         --      lo_branches have tags <  mid_tag
 828         --      hi_branches have tags >= mid_tag
 829
 830     (mid_tag,_) = branches !! (n_branches `div` 2)
 831         -- 2 branches => n_branches `div` 2 = 1
 832         --            => branches !! 1 give the *second* tag
 833         -- There are always at least 2 branches here
 834
 835     (lo_branches, hi_branches) = span is_lo branches
 836     is_lo (t,_) = t < mid_tag
 837
 838 --------------
 839 mkCmmLitSwitch :: CmmExpr                 -- Tag to switch on
 840                -> [(Literal, CmmAGraph)]  -- Tagged branches
 841                -> CmmAGraph               -- Default branch (always)
 842                -> CmmAGraph               -- Emit the code
 843 -- Used for general literals, whose size might not be a word,
 844 -- where there is always a default case, and where we don't know
 845 -- the range of values for certain.  For simplicity we always generate a tree.
 846 --
 847 -- ToDo: for integers we could do better here, perhaps by generalising
 848 -- mk_switch and using that.  --SDM 15/09/2004
 849 mkCmmLitSwitch _scrut []       deflt = deflt
 850 mkCmmLitSwitch scrut  branches deflt
 851   = assignTemp' scrut           $ \ scrut' ->
 852     withFreshLabel "switch join"        $ \ join_lbl ->
 853     label_code join_lbl deflt           $ \ deflt ->
 854     label_branches join_lbl branches    $ \ branches ->
 855     mk_lit_switch scrut' deflt (sortLe le branches)
 856     <*> mkLabel join_lbl
 857   where
 858     le (t1,_) (t2,_) = t1 <= t2
 859
 860 mk_lit_switch :: CmmExpr -> BlockId
 861               -> [(Literal,BlockId)]
 862               -> CmmAGraph
 863 mk_lit_switch scrut deflt [(lit,blk)]
 864   = mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk
 865   where
 866     cmm_lit = mkSimpleLit lit
 867     cmm_ty  = cmmLitType cmm_lit
 868     rep     = typeWidth cmm_ty
 869     ne      = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep
 870
 871 mk_lit_switch scrut deflt_blk_id branches
 872   = mkCmmIfThenElse cond
 873         (mk_lit_switch scrut deflt_blk_id lo_branches)
 874         (mk_lit_switch scrut deflt_blk_id hi_branches)
 875   where
 876     n_branches = length branches
 877     (mid_lit,_) = branches !! (n_branches `div` 2)
 878         -- See notes above re mid_tag
 879
 880     (lo_branches, hi_branches) = span is_lo branches
 881     is_lo (t,_) = t < mid_lit
 882
 883     cond = CmmMachOp (mkLtOp mid_lit)
 884                         [scrut, CmmLit (mkSimpleLit mid_lit)]
 885
 886
 887 --------------
 888 label_default :: BlockId -> Maybe CmmAGraph
 889               -> (Maybe BlockId -> CmmAGraph)
 890               -> CmmAGraph
 891 label_default _ Nothing thing_inside
 892   = thing_inside Nothing
 893 label_default join_lbl (Just code) thing_inside
 894   = label_code join_lbl code    $ \ lbl ->
 895     thing_inside (Just lbl)
 896
 897 --------------
 898 label_branches :: BlockId -> [(a,CmmAGraph)]
 899                -> ([(a,BlockId)] -> CmmAGraph)
 900                -> CmmAGraph
 901 label_branches _join_lbl [] thing_inside
 902   = thing_inside []
 903 label_branches join_lbl ((tag,code):branches) thing_inside
 904   = label_code join_lbl code            $ \ lbl ->
 905     label_branches join_lbl branches    $ \ branches' ->
 906     thing_inside ((tag,lbl):branches')
 907
 908 --------------
 909 label_code :: BlockId -> CmmAGraph -> (BlockId -> CmmAGraph) -> CmmAGraph
 910 -- (label_code J code fun)
 911 --      generates
 912 --  [L: code; goto J] fun L
 913 label_code join_lbl code thing_inside
 914   = withFreshLabel "switch"     $ \lbl ->
 915     outOfLine (mkLabel lbl <*> code <*> mkBranch join_lbl)
 916     <*> thing_inside lbl
 917
 918
 919 --------------
 920 assignTemp' :: CmmExpr -> (CmmExpr -> CmmAGraph) -> CmmAGraph
 921 assignTemp' e thing_inside
 922   | isTrivialCmmExpr e = thing_inside e
 923   | otherwise          = withTemp (cmmExprType e)       $ \ lreg ->
 924                          let reg = CmmLocal lreg in
 925                          mkAssign reg e <*> thing_inside (CmmReg reg)
 926
 927 withTemp :: CmmType -> (LocalReg -> CmmAGraph) -> CmmAGraph
 928 withTemp rep thing_inside
 929   = withUnique $ \uniq -> thing_inside (LocalReg uniq rep)
 930
 931
 932 -------------------------------------------------------------------------
 933 --
 934 --      Static Reference Tables
 935 --
 936 -------------------------------------------------------------------------
 937
 938 -- There is just one SRT for each top level binding; all the nested
 939 -- bindings use sub-sections of this SRT.  The label is passed down to
 940 -- the nested bindings via the monad.
 941
 942 getSRTInfo :: SRT -> FCode C_SRT
 943 getSRTInfo (SRTEntries {}) = panic "getSRTInfo"
 944
 945 getSRTInfo (SRT off len bmp)
 946   | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
 947   = do  { id <- newUnique
 948         -- ; top_srt <- getSRTLabel
 949         ; let srt_desc_lbl = mkLargeSRTLabel id
 950         -- JD: We're not constructing and emitting SRTs in the back end,
 951         -- which renders this code wrong (it now names a now-non-existent label).
 952         -- ; emitRODataLits srt_desc_lbl
 953         --      ( cmmLabelOffW top_srt off
 954         --        : mkWordCLit (fromIntegral len)
 955         --        : map mkWordCLit bmp)
 956         ; return (C_SRT srt_desc_lbl 0 srt_escape) }
 957
 958   | otherwise
 959   = do  { top_srt <- getSRTLabel
 960         ; return (C_SRT top_srt off (fromIntegral (head bmp))) }
 961         -- The fromIntegral converts to StgHalfWord
 962
 963 getSRTInfo NoSRT
 964   = -- TODO: Should we panic in this case?
 965     -- Someone obviously thinks there should be an SRT
 966     return NoC_SRT
 967
 968
 969 srt_escape :: StgHalfWord
 970 srt_escape = -1