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