compiler/codeGen/StgCmmUtils.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Code generator utilities; mostly monadic
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module StgCmmUtils (
  10         cgLit, mkSimpleLit,
  11         emitDataLits, mkDataLits,
  12         emitRODataLits, mkRODataLits,
  13         emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
  14         assignTemp, newTemp, withTemp,
  15
  16         newUnboxedTupleRegs,
  17
  18         mkMultiAssign, mkCmmSwitch, mkCmmLitSwitch,
  19         emitSwitch,
  20
  21         tagToClosure, mkTaggedObjectLoad,
  22
  23         callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
  24
  25         cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
  26         cmmUGtWord,
  27         cmmOffsetExprW, cmmOffsetExprB,
  28         cmmRegOffW, cmmRegOffB,
  29         cmmLabelOffW, cmmLabelOffB,
  30         cmmOffsetW, cmmOffsetB,
  31         cmmOffsetLitW, cmmOffsetLitB,
  32         cmmLoadIndexW,
  33         cmmConstrTag, cmmConstrTag1,
  34
  35         cmmUntag, cmmIsTagged, cmmGetTag,
  36
  37         addToMem, addToMemE, addToMemLbl,
  38         mkWordCLit,
  39         mkStringCLit, mkByteStringCLit,
  40         packHalfWordsCLit,
  41         blankWord,
  42
  43         getSRTInfo, clHasCafRefs, srt_escape
  44   ) where
  45
  46 #include "HsVersions.h"
  47 #include "../includes/stg/MachRegs.h"
  48
  49 import StgCmmMonad
  50 import StgCmmClosure
  51 import BlockId
  52 import CmmDecl
  53 import CmmExpr hiding (regUsedIn)
  54 import MkGraph
  55 import CLabel
  56 import CmmUtils
  57
  58 import ForeignCall
  59 import IdInfo
  60 import Type
  61 import TyCon
  62 import Constants
  63 import SMRep
  64 import StgSyn   ( SRT(..) )
  65 import Module
  66 import Literal
  67 import Digraph
  68 import ListSetOps
  69 import Util
  70 import Unique
  71 import DynFlags
  72 import FastString
  73 import Outputable
  74
  75 import Data.Char
  76 import Data.Bits
  77 import Data.Word
  78 import Data.Maybe
  79
  80
  81 -------------------------------------------------------------------------
  82 --
  83 --      Literals
  84 --
  85 -------------------------------------------------------------------------
  86
  87 cgLit :: Literal -> FCode CmmLit
  88 cgLit (MachStr s) = mkByteStringCLit (bytesFS s)
  89  -- not unpackFS; we want the UTF-8 byte stream.
  90 cgLit other_lit   = return (mkSimpleLit other_lit)
  91
  92 mkSimpleLit :: Literal -> CmmLit
  93 mkSimpleLit (MachChar   c)    = CmmInt (fromIntegral (ord c)) wordWidth
  94 mkSimpleLit MachNullAddr      = zeroCLit
  95 mkSimpleLit (MachInt i)       = CmmInt i wordWidth
  96 mkSimpleLit (MachInt64 i)     = CmmInt i W64
  97 mkSimpleLit (MachWord i)      = CmmInt i wordWidth
  98 mkSimpleLit (MachWord64 i)    = CmmInt i W64
  99 mkSimpleLit (MachFloat r)     = CmmFloat r W32
 100 mkSimpleLit (MachDouble r)    = CmmFloat r W64
 101 mkSimpleLit (MachLabel fs ms fod)
 102         = CmmLabel (mkForeignLabel fs ms labelSrc fod)
 103         where
 104                 -- TODO: Literal labels might not actually be in the current package...
 105                 labelSrc = ForeignLabelInThisPackage
 106 mkSimpleLit other             = pprPanic "mkSimpleLit" (ppr other)
 107
 108 mkLtOp :: Literal -> MachOp
 109 -- On signed literals we must do a signed comparison
 110 mkLtOp (MachInt _)    = MO_S_Lt wordWidth
 111 mkLtOp (MachFloat _)  = MO_F_Lt W32
 112 mkLtOp (MachDouble _) = MO_F_Lt W64
 113 mkLtOp lit            = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit)))
 114                                 -- ToDo: seems terribly indirect!
 115
 116
 117 ---------------------------------------------------
 118 --
 119 --      Cmm data type functions
 120 --
 121 ---------------------------------------------------
 122
 123 -- The "B" variants take byte offsets
 124 cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
 125 cmmRegOffB = cmmRegOff
 126
 127 cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr
 128 cmmOffsetB = cmmOffset
 129
 130 cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr
 131 cmmOffsetExprB = cmmOffsetExpr
 132
 133 cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
 134 cmmLabelOffB = cmmLabelOff
 135
 136 cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
 137 cmmOffsetLitB = cmmOffsetLit
 138
 139 -----------------------
 140 -- The "W" variants take word offsets
 141 cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
 142 -- The second arg is a *word* offset; need to change it to bytes
 143 cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
 144 cmmOffsetExprW e wd_off = cmmIndexExpr wordWidth e wd_off
 145
 146 cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
 147 cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)
 148
 149 cmmRegOffW :: CmmReg -> WordOff -> CmmExpr
 150 cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE)
 151
 152 cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit
 153 cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off)
 154
 155 cmmLabelOffW :: CLabel -> WordOff -> CmmLit
 156 cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)
 157
 158 cmmLoadIndexW :: CmmExpr -> Int -> CmmType -> CmmExpr
 159 cmmLoadIndexW base off ty = CmmLoad (cmmOffsetW base off) ty
 160
 161 -----------------------
 162 cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord,
 163   cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord
 164   :: CmmExpr -> CmmExpr -> CmmExpr
 165 cmmOrWord  e1 e2 = CmmMachOp mo_wordOr  [e1, e2]
 166 cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
 167 cmmNeWord  e1 e2 = CmmMachOp mo_wordNe  [e1, e2]
 168 cmmEqWord  e1 e2 = CmmMachOp mo_wordEq  [e1, e2]
 169 cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
 170 cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
 171 cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
 172 --cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2]
 173 --cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2]
 174 cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2]
 175
 176 cmmNegate :: CmmExpr -> CmmExpr
 177 cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
 178 cmmNegate e                       = CmmMachOp (MO_S_Neg (cmmExprWidth e)) [e]
 179
 180 blankWord :: CmmStatic
 181 blankWord = CmmUninitialised wORD_SIZE
 182
 183 -- Tagging --
 184 -- Tag bits mask
 185 --cmmTagBits = CmmLit (mkIntCLit tAG_BITS)
 186 cmmTagMask, cmmPointerMask :: CmmExpr
 187 cmmTagMask = CmmLit (mkIntCLit tAG_MASK)
 188 cmmPointerMask = CmmLit (mkIntCLit (complement tAG_MASK))
 189
 190 -- Used to untag a possibly tagged pointer
 191 -- A static label need not be untagged
 192 cmmUntag, cmmGetTag :: CmmExpr -> CmmExpr
 193 cmmUntag e@(CmmLit (CmmLabel _)) = e
 194 -- Default case
 195 cmmUntag e = (e `cmmAndWord` cmmPointerMask)
 196
 197 cmmGetTag e = (e `cmmAndWord` cmmTagMask)
 198
 199 -- Test if a closure pointer is untagged
 200 cmmIsTagged :: CmmExpr -> CmmExpr
 201 cmmIsTagged e = (e `cmmAndWord` cmmTagMask)
 202                  `cmmNeWord` CmmLit zeroCLit
 203
 204 cmmConstrTag, cmmConstrTag1 :: CmmExpr -> CmmExpr
 205 cmmConstrTag e = (e `cmmAndWord` cmmTagMask) `cmmSubWord` (CmmLit (mkIntCLit 1))
 206 -- Get constructor tag, but one based.
 207 cmmConstrTag1 e = e `cmmAndWord` cmmTagMask
 208
 209 -----------------------
 210 --      Making literals
 211
 212 mkWordCLit :: StgWord -> CmmLit
 213 mkWordCLit wd = CmmInt (fromIntegral wd) wordWidth
 214
 215 packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
 216 -- Make a single word literal in which the lower_half_word is
 217 -- at the lower address, and the upper_half_word is at the
 218 -- higher address
 219 -- ToDo: consider using half-word lits instead
 220 --       but be careful: that's vulnerable when reversed
 221 packHalfWordsCLit lower_half_word upper_half_word
 222 #ifdef WORDS_BIGENDIAN
 223    = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
 224                  .|. fromIntegral upper_half_word)
 225 #else
 226    = mkWordCLit ((fromIntegral lower_half_word)
 227                  .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
 228 #endif
 229
 230 --------------------------------------------------------------------------
 231 --
 232 -- Incrementing a memory location
 233 --
 234 --------------------------------------------------------------------------
 235
 236 addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
 237 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
 238
 239 addToMem :: CmmType     -- rep of the counter
 240          -> CmmExpr     -- Address
 241          -> Int         -- What to add (a word)
 242          -> CmmAGraph
 243 addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))
 244
 245 addToMemE :: CmmType    -- rep of the counter
 246           -> CmmExpr    -- Address
 247           -> CmmExpr    -- What to add (a word-typed expression)
 248           -> CmmAGraph
 249 addToMemE rep ptr n
 250   = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])
 251
 252
 253 -------------------------------------------------------------------------
 254 --
 255 --      Loading a field from an object,
 256 --      where the object pointer is itself tagged
 257 --
 258 -------------------------------------------------------------------------
 259
 260 mkTaggedObjectLoad :: LocalReg -> LocalReg -> WordOff -> DynTag -> CmmAGraph
 261 -- (loadTaggedObjectField reg base off tag) generates assignment
 262 --      reg = bitsK[ base + off - tag ]
 263 -- where K is fixed by 'reg'
 264 mkTaggedObjectLoad reg base offset tag
 265   = mkAssign (CmmLocal reg)
 266              (CmmLoad (cmmOffsetB (CmmReg (CmmLocal base))
 267                                   (wORD_SIZE*offset - tag))
 268                       (localRegType reg))
 269
 270 -------------------------------------------------------------------------
 271 --
 272 --      Converting a closure tag to a closure for enumeration types
 273 --      (this is the implementation of tagToEnum#).
 274 --
 275 -------------------------------------------------------------------------
 276
 277 tagToClosure :: TyCon -> CmmExpr -> CmmExpr
 278 tagToClosure tycon tag
 279   = CmmLoad (cmmOffsetExprW closure_tbl tag) bWord
 280   where closure_tbl = CmmLit (CmmLabel lbl)
 281         lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
 282
 283 -------------------------------------------------------------------------
 284 --
 285 --      Conditionals and rts calls
 286 --
 287 -------------------------------------------------------------------------
 288
 289 emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
 290 emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe
 291    -- The 'Nothing' says "save all global registers"
 292
 293 emitRtsCallWithVols :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> [GlobalReg] -> Bool -> FCode ()
 294 emitRtsCallWithVols pkg fun args vols safe
 295    = emitRtsCall' [] pkg fun args (Just vols) safe
 296
 297 emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString
 298         -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
 299 emitRtsCallWithResult res hint pkg fun args safe
 300    = emitRtsCall' [(res,hint)] pkg fun args Nothing safe
 301
 302 -- Make a call to an RTS C procedure
 303 emitRtsCall'
 304    :: [(LocalReg,ForeignHint)]
 305    -> PackageId
 306    -> FastString
 307    -> [(CmmExpr,ForeignHint)]
 308    -> Maybe [GlobalReg]
 309    -> Bool -- True <=> CmmSafe call
 310    -> FCode ()
 311 emitRtsCall' res pkg fun args _vols safe
 312   = --error "emitRtsCall'"
 313     do { updfr_off <- getUpdFrameOff
 314        ; emit caller_save
 315        ; emit $ call updfr_off
 316        ; emit caller_load }
 317   where
 318     call updfr_off =
 319       if safe then
 320         mkCmmCall fun_expr res' args' updfr_off
 321       else
 322         mkUnsafeCall (ForeignTarget fun_expr
 323                          (ForeignConvention CCallConv arg_hints res_hints)) res' args'
 324     (args', arg_hints) = unzip args
 325     (res',  res_hints) = unzip res
 326     (caller_save, caller_load) = callerSaveVolatileRegs
 327     fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
 328
 329
 330 -----------------------------------------------------------------------------
 331 --
 332 --      Caller-Save Registers
 333 --
 334 -----------------------------------------------------------------------------
 335
 336 -- Here we generate the sequence of saves/restores required around a
 337 -- foreign call instruction.
 338
 339 -- TODO: reconcile with includes/Regs.h
 340 --  * Regs.h claims that BaseReg should be saved last and loaded first
 341 --    * This might not have been tickled before since BaseReg is callee save
 342 --  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
 343 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 --      mkSwitch
 601 -------------------------------------------------------------------------
 602
 603
 604 emitSwitch :: CmmExpr           -- Tag to switch on
 605            -> [(ConTagZ, CmmAGraph)]    -- Tagged branches
 606            -> Maybe CmmAGraph           -- Default branch (if any)
 607            -> ConTagZ -> ConTagZ        -- Min and Max possible values; behaviour
 608                                         --      outside this range is undefined
 609            -> FCode ()
 610 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
 611   = do  { dflags <- getDynFlags
 612         ; emit (mkCmmSwitch (via_C dflags) tag_expr branches mb_deflt lo_tag hi_tag) }
 613   where
 614     via_C dflags | HscC <- hscTarget dflags = True
 615                  | otherwise                = False
 616
 617
 618 mkCmmSwitch :: Bool                     -- True <=> never generate a conditional tree
 619             -> CmmExpr                  -- Tag to switch on
 620             -> [(ConTagZ, CmmAGraph)]   -- Tagged branches
 621             -> Maybe CmmAGraph          -- Default branch (if any)
 622             -> ConTagZ -> ConTagZ       -- Min and Max possible values; behaviour
 623                                         --      outside this range is undefined
 624             -> CmmAGraph
 625
 626 -- First, two rather common cases in which there is no work to do
 627 mkCmmSwitch _ _ []         (Just code) _ _ = code
 628 mkCmmSwitch _ _ [(_,code)] Nothing     _ _ = code
 629
 630 -- Right, off we go
 631 mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag
 632   = withFreshLabel "switch join"        $ \ join_lbl ->
 633     label_default join_lbl mb_deflt     $ \ mb_deflt ->
 634     label_branches join_lbl branches    $ \ branches ->
 635     assignTemp' tag_expr                $ \tag_expr' ->
 636
 637     mk_switch tag_expr' (sortLe le branches) mb_deflt
 638               lo_tag hi_tag via_C
 639           -- Sort the branches before calling mk_switch
 640     <*> mkLabel join_lbl
 641
 642   where
 643     (t1,_) `le` (t2,_) = t1 <= t2
 644
 645 mk_switch :: CmmExpr -> [(ConTagZ, BlockId)]
 646           -> Maybe BlockId
 647           -> ConTagZ -> ConTagZ -> Bool
 648           -> CmmAGraph
 649
 650 -- SINGLETON TAG RANGE: no case analysis to do
 651 mk_switch _tag_expr [(tag, lbl)] _ lo_tag hi_tag _via_C
 652   | lo_tag == hi_tag
 653   = ASSERT( tag == lo_tag )
 654     mkBranch lbl
 655
 656 -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
 657 mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _
 658   = mkBranch lbl
 659         -- The simplifier might have eliminated a case
 660         --       so we may have e.g. case xs of
 661         --                               [] -> e
 662         -- In that situation we can be sure the (:) case
 663         -- can't happen, so no need to test
 664
 665 -- SINGLETON BRANCH: one equality check to do
 666 mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _
 667   = mkCbranch cond deflt lbl
 668   where
 669     cond =  cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
 670         -- We have lo_tag < hi_tag, but there's only one branch,
 671         -- so there must be a default
 672
 673 -- ToDo: we might want to check for the two branch case, where one of
 674 -- the branches is the tag 0, because comparing '== 0' is likely to be
 675 -- more efficient than other kinds of comparison.
 676
 677 -- DENSE TAG RANGE: use a switch statment.
 678 --
 679 -- We also use a switch uncoditionally when compiling via C, because
 680 -- this will get emitted as a C switch statement and the C compiler
 681 -- should do a good job of optimising it.  Also, older GCC versions
 682 -- (2.95 in particular) have problems compiling the complicated
 683 -- if-trees generated by this code, so compiling to a switch every
 684 -- time works around that problem.
 685 --
 686 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
 687   | use_switch  -- Use a switch
 688   = let
 689         find_branch :: ConTagZ -> Maybe BlockId
 690         find_branch i = case (assocMaybe branches i) of
 691                           Just lbl -> Just lbl
 692                           Nothing  -> mb_deflt
 693
 694         -- NB. we have eliminated impossible branches at
 695         -- either end of the range (see below), so the first
 696         -- tag of a real branch is real_lo_tag (not lo_tag).
 697         arms :: [Maybe BlockId]
 698         arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
 699     in
 700     mkSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
 701
 702   -- if we can knock off a bunch of default cases with one if, then do so
 703   | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
 704   = mkCmmIfThenElse
 705         (cmmULtWord tag_expr (CmmLit (mkIntCLit lowest_branch)))
 706         (mkBranch deflt)
 707         (mk_switch tag_expr branches mb_deflt
 708                         lowest_branch hi_tag via_C)
 709
 710   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
 711   = mkCmmIfThenElse
 712         (cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch)))
 713         (mkBranch deflt)
 714         (mk_switch tag_expr branches mb_deflt
 715                         lo_tag highest_branch via_C)
 716
 717   | otherwise   -- Use an if-tree
 718   = mkCmmIfThenElse
 719         (cmmUGeWord tag_expr (CmmLit (mkIntCLit mid_tag)))
 720         (mk_switch tag_expr hi_branches mb_deflt
 721                              mid_tag hi_tag via_C)
 722         (mk_switch tag_expr lo_branches mb_deflt
 723                              lo_tag (mid_tag-1) via_C)
 724         -- we test (e >= mid_tag) rather than (e < mid_tag), because
 725         -- the former works better when e is a comparison, and there
 726         -- are two tags 0 & 1 (mid_tag == 1).  In this case, the code
 727         -- generator can reduce the condition to e itself without
 728         -- having to reverse the sense of the comparison: comparisons
 729         -- can't always be easily reversed (eg. floating
 730         -- pt. comparisons).
 731   where
 732     use_switch   = {- pprTrace "mk_switch" (
 733                         ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
 734                         text "branches:" <+> ppr (map fst branches) <+>
 735                         text "n_branches:" <+> int n_branches <+>
 736                         text "lo_tag:" <+> int lo_tag <+>
 737                         text "hi_tag:" <+> int hi_tag <+>
 738                         text "real_lo_tag:" <+> int real_lo_tag <+>
 739                         text "real_hi_tag:" <+> int real_hi_tag) $ -}
 740                    ASSERT( n_branches > 1 && n_tags > 1 )
 741                    n_tags > 2 && (via_C || (dense && big_enough))
 742                  -- up to 4 branches we use a decision tree, otherwise
 743                  -- a switch (== jump table in the NCG).  This seems to be
 744                  -- optimal, and corresponds with what gcc does.
 745     big_enough   = n_branches > 4
 746     dense        = n_branches > (n_tags `div` 2)
 747     n_branches   = length branches
 748
 749     -- ignore default slots at each end of the range if there's
 750     -- no default branch defined.
 751     lowest_branch  = fst (head branches)
 752     highest_branch = fst (last branches)
 753
 754     real_lo_tag
 755         | isNothing mb_deflt = lowest_branch
 756         | otherwise          = lo_tag
 757
 758     real_hi_tag
 759         | isNothing mb_deflt = highest_branch
 760         | otherwise          = hi_tag
 761
 762     n_tags = real_hi_tag - real_lo_tag + 1
 763
 764         -- INVARIANT: Provided hi_tag > lo_tag (which is true)
 765         --      lo_tag <= mid_tag < hi_tag
 766         --      lo_branches have tags <  mid_tag
 767         --      hi_branches have tags >= mid_tag
 768
 769     (mid_tag,_) = branches !! (n_branches `div` 2)
 770         -- 2 branches => n_branches `div` 2 = 1
 771         --            => branches !! 1 give the *second* tag
 772         -- There are always at least 2 branches here
 773
 774     (lo_branches, hi_branches) = span is_lo branches
 775     is_lo (t,_) = t < mid_tag
 776
 777 --------------
 778 mkCmmLitSwitch :: CmmExpr                 -- Tag to switch on
 779                -> [(Literal, CmmAGraph)]  -- Tagged branches
 780                -> CmmAGraph               -- Default branch (always)
 781                -> CmmAGraph               -- Emit the code
 782 -- Used for general literals, whose size might not be a word,
 783 -- where there is always a default case, and where we don't know
 784 -- the range of values for certain.  For simplicity we always generate a tree.
 785 --
 786 -- ToDo: for integers we could do better here, perhaps by generalising
 787 -- mk_switch and using that.  --SDM 15/09/2004
 788 mkCmmLitSwitch _scrut []       deflt = deflt
 789 mkCmmLitSwitch scrut  branches deflt
 790   = assignTemp' scrut           $ \ scrut' ->
 791     withFreshLabel "switch join"        $ \ join_lbl ->
 792     label_code join_lbl deflt           $ \ deflt ->
 793     label_branches join_lbl branches    $ \ branches ->
 794     mk_lit_switch scrut' deflt (sortLe le branches)
 795     <*> mkLabel join_lbl
 796   where
 797     le (t1,_) (t2,_) = t1 <= t2
 798
 799 mk_lit_switch :: CmmExpr -> BlockId
 800               -> [(Literal,BlockId)]
 801               -> CmmAGraph
 802 mk_lit_switch scrut deflt [(lit,blk)]
 803   = mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk
 804   where
 805     cmm_lit = mkSimpleLit lit
 806     cmm_ty  = cmmLitType cmm_lit
 807     rep     = typeWidth cmm_ty
 808     ne      = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep
 809
 810 mk_lit_switch scrut deflt_blk_id branches
 811   = mkCmmIfThenElse cond
 812         (mk_lit_switch scrut deflt_blk_id lo_branches)
 813         (mk_lit_switch scrut deflt_blk_id hi_branches)
 814   where
 815     n_branches = length branches
 816     (mid_lit,_) = branches !! (n_branches `div` 2)
 817         -- See notes above re mid_tag
 818
 819     (lo_branches, hi_branches) = span is_lo branches
 820     is_lo (t,_) = t < mid_lit
 821
 822     cond = CmmMachOp (mkLtOp mid_lit)
 823                         [scrut, CmmLit (mkSimpleLit mid_lit)]
 824
 825
 826 --------------
 827 label_default :: BlockId -> Maybe CmmAGraph
 828               -> (Maybe BlockId -> CmmAGraph)
 829               -> CmmAGraph
 830 label_default _ Nothing thing_inside
 831   = thing_inside Nothing
 832 label_default join_lbl (Just code) thing_inside
 833   = label_code join_lbl code    $ \ lbl ->
 834     thing_inside (Just lbl)
 835
 836 --------------
 837 label_branches :: BlockId -> [(a,CmmAGraph)]
 838                -> ([(a,BlockId)] -> CmmAGraph)
 839                -> CmmAGraph
 840 label_branches _join_lbl [] thing_inside
 841   = thing_inside []
 842 label_branches join_lbl ((tag,code):branches) thing_inside
 843   = label_code join_lbl code            $ \ lbl ->
 844     label_branches join_lbl branches    $ \ branches' ->
 845     thing_inside ((tag,lbl):branches')
 846
 847 --------------
 848 label_code :: BlockId -> CmmAGraph -> (BlockId -> CmmAGraph) -> CmmAGraph
 849 -- (label_code J code fun)
 850 --      generates
 851 --  [L: code; goto J] fun L
 852 label_code join_lbl code thing_inside
 853   = withFreshLabel "switch"     $ \lbl ->
 854     outOfLine (mkLabel lbl <*> code <*> mkBranch join_lbl)
 855     <*> thing_inside lbl
 856
 857
 858 --------------
 859 assignTemp' :: CmmExpr -> (CmmExpr -> CmmAGraph) -> CmmAGraph
 860 assignTemp' e thing_inside
 861   | isTrivialCmmExpr e = thing_inside e
 862   | otherwise          = withTemp (cmmExprType e)       $ \ lreg ->
 863                          let reg = CmmLocal lreg in
 864                          mkAssign reg e <*> thing_inside (CmmReg reg)
 865
 866 withTemp :: CmmType -> (LocalReg -> CmmAGraph) -> CmmAGraph
 867 withTemp rep thing_inside
 868   = withUnique $ \uniq -> thing_inside (LocalReg uniq rep)
 869
 870
 871 -------------------------------------------------------------------------
 872 --
 873 --      Static Reference Tables
 874 --
 875 -------------------------------------------------------------------------
 876
 877 -- There is just one SRT for each top level binding; all the nested
 878 -- bindings use sub-sections of this SRT.  The label is passed down to
 879 -- the nested bindings via the monad.
 880
 881 getSRTInfo :: SRT -> FCode C_SRT
 882 getSRTInfo (SRTEntries {}) = panic "getSRTInfo"
 883
 884 getSRTInfo (SRT off len bmp)
 885   | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
 886   = do  { id <- newUnique
 887         -- ; top_srt <- getSRTLabel
 888         ; let srt_desc_lbl = mkLargeSRTLabel id
 889         -- JD: We're not constructing and emitting SRTs in the back end,
 890         -- which renders this code wrong (it now names a now-non-existent label).
 891         -- ; emitRODataLits srt_desc_lbl
 892         --      ( cmmLabelOffW top_srt off
 893         --        : mkWordCLit (fromIntegral len)
 894         --        : map mkWordCLit bmp)
 895         ; return (C_SRT srt_desc_lbl 0 srt_escape) }
 896
 897   | otherwise
 898   = do  { top_srt <- getSRTLabel
 899         ; return (C_SRT top_srt off (fromIntegral (head bmp))) }
 900         -- The fromIntegral converts to StgHalfWord
 901
 902 getSRTInfo NoSRT
 903   = -- TODO: Should we panic in this case?
 904     -- Someone obviously thinks there should be an SRT
 905     return NoC_SRT
 906
 907
 908 srt_escape :: StgHalfWord
 909 srt_escape = -1