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