compiler/codeGen/StgCmmUtils.hs

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