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