compiler/codeGen/CgUtils.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Code generator utilities; mostly monadic
   4 --
   5 -- (c) The University of Glasgow 2004-2006
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module CgUtils (
  10         addIdReps,
  11         cgLit,
  12         emitDataLits, mkDataLits,
  13         emitRODataLits, mkRODataLits,
  14         emitIf, emitIfThenElse,
  15         emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
  16         assignNonPtrTemp, newNonPtrTemp,
  17         assignPtrTemp, newPtrTemp,
  18         emitSimultaneously,
  19         emitSwitch, emitLitSwitch,
  20         tagToClosure,
  21
  22         cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
  23         cmmOffsetExprW, cmmOffsetExprB,
  24         cmmRegOffW, cmmRegOffB,
  25         cmmLabelOffW, cmmLabelOffB,
  26         cmmOffsetW, cmmOffsetB,
  27         cmmOffsetLitW, cmmOffsetLitB,
  28         cmmLoadIndexW,
  29
  30         addToMem, addToMemE,
  31         mkWordCLit,
  32         mkStringCLit, mkByteStringCLit,
  33         packHalfWordsCLit,
  34         blankWord,
  35
  36         getSRTInfo
  37   ) where
  38
  39 #include "HsVersions.h"
  40
  41 import CgMonad
  42 import TyCon
  43 import Id
  44 import Constants
  45 import SMRep
  46 import PprCmm           ( {- instances -} )
  47 import Cmm
  48 import CLabel
  49 import CmmUtils
  50 import MachOp
  51 import ForeignCall
  52 import ClosureInfo
  53 import StgSyn (SRT(..))
  54 import Literal
  55 import Digraph
  56 import ListSetOps
  57 import Util
  58 import DynFlags
  59 import FastString
  60 import PackageConfig
  61 import Outputable
  62
  63 import MachRegs (callerSaveVolatileRegs)
  64   -- HACK: this is part of the NCG so we shouldn't use this, but we need
  65   -- it for now to eliminate the need for saved regs to be in CmmCall.
  66   -- The long term solution is to factor callerSaveVolatileRegs
  67   -- from nativeGen into codeGen
  68
  69 import Data.Char
  70 import Data.Bits
  71 import Data.Word
  72 import Data.Maybe
  73
  74 -------------------------------------------------------------------------
  75 --
  76 --      Random small functions
  77 --
  78 -------------------------------------------------------------------------
  79
  80 addIdReps :: [Id] -> [(CgRep, Id)]
  81 addIdReps ids = [(idCgRep id, id) | id <- ids]
  82
  83 -------------------------------------------------------------------------
  84 --
  85 --      Literals
  86 --
  87 -------------------------------------------------------------------------
  88
  89 cgLit :: Literal -> FCode CmmLit
  90 cgLit (MachStr s) = mkByteStringCLit (bytesFS s)
  91  -- not unpackFS; we want the UTF-8 byte stream.
  92 cgLit other_lit   = return (mkSimpleLit other_lit)
  93
  94 mkSimpleLit :: Literal -> CmmLit
  95 mkSimpleLit (MachChar   c)    = CmmInt (fromIntegral (ord c)) wordRep
  96 mkSimpleLit MachNullAddr      = zeroCLit
  97 mkSimpleLit (MachInt i)       = CmmInt i wordRep
  98 mkSimpleLit (MachInt64 i)     = CmmInt i I64
  99 mkSimpleLit (MachWord i)      = CmmInt i wordRep
 100 mkSimpleLit (MachWord64 i)    = CmmInt i I64
 101 mkSimpleLit (MachFloat r)     = CmmFloat r F32
 102 mkSimpleLit (MachDouble r)    = CmmFloat r F64
 103 mkSimpleLit (MachLabel fs ms) = CmmLabel (mkForeignLabel fs ms is_dyn)
 104                               where
 105                                 is_dyn = False  -- ToDo: fix me
 106
 107 mkLtOp :: Literal -> MachOp
 108 -- On signed literals we must do a signed comparison
 109 mkLtOp (MachInt _)    = MO_S_Lt wordRep
 110 mkLtOp (MachFloat _)  = MO_S_Lt F32
 111 mkLtOp (MachDouble _) = MO_S_Lt F64
 112 mkLtOp lit            = MO_U_Lt (cmmLitRep (mkSimpleLit lit))
 113
 114
 115 ---------------------------------------------------
 116 --
 117 --      Cmm data type functions
 118 --
 119 ---------------------------------------------------
 120
 121 -----------------------
 122 -- The "B" variants take byte offsets
 123 cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
 124 cmmRegOffB = cmmRegOff
 125
 126 cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr
 127 cmmOffsetB = cmmOffset
 128
 129 cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr
 130 cmmOffsetExprB = cmmOffsetExpr
 131
 132 cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
 133 cmmLabelOffB = cmmLabelOff
 134
 135 cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
 136 cmmOffsetLitB = cmmOffsetLit
 137
 138 -----------------------
 139 -- The "W" variants take word offsets
 140 cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
 141 -- The second arg is a *word* offset; need to change it to bytes
 142 cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
 143 cmmOffsetExprW e wd_off = cmmIndexExpr wordRep e wd_off
 144
 145 cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
 146 cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)
 147
 148 cmmRegOffW :: CmmReg -> WordOff -> CmmExpr
 149 cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE)
 150
 151 cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit
 152 cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off)
 153
 154 cmmLabelOffW :: CLabel -> WordOff -> CmmLit
 155 cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)
 156
 157 cmmLoadIndexW :: CmmExpr -> Int -> CmmExpr
 158 cmmLoadIndexW base off
 159   = CmmLoad (cmmOffsetW base off) wordRep
 160
 161 -----------------------
 162 cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord :: 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
 171 cmmNegate :: CmmExpr -> CmmExpr
 172 cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
 173 cmmNegate e                       = CmmMachOp (MO_S_Neg (cmmExprRep e)) [e]
 174
 175 blankWord :: CmmStatic
 176 blankWord = CmmUninitialised wORD_SIZE
 177
 178 -----------------------
 179 --      Making literals
 180
 181 mkWordCLit :: StgWord -> CmmLit
 182 mkWordCLit wd = CmmInt (fromIntegral wd) wordRep
 183
 184 packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
 185 -- Make a single word literal in which the lower_half_word is
 186 -- at the lower address, and the upper_half_word is at the
 187 -- higher address
 188 -- ToDo: consider using half-word lits instead
 189 --       but be careful: that's vulnerable when reversed
 190 packHalfWordsCLit lower_half_word upper_half_word
 191 #ifdef WORDS_BIGENDIAN
 192    = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
 193                  .|. fromIntegral upper_half_word)
 194 #else
 195    = mkWordCLit ((fromIntegral lower_half_word)
 196                  .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
 197 #endif
 198
 199 --------------------------------------------------------------------------
 200 --
 201 -- Incrementing a memory location
 202 --
 203 --------------------------------------------------------------------------
 204
 205 addToMem :: MachRep     -- rep of the counter
 206          -> CmmExpr     -- Address
 207          -> Int         -- What to add (a word)
 208          -> CmmStmt
 209 addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) rep))
 210
 211 addToMemE :: MachRep    -- rep of the counter
 212           -> CmmExpr    -- Address
 213           -> CmmExpr    -- What to add (a word-typed expression)
 214           -> CmmStmt
 215 addToMemE rep ptr n
 216   = CmmStore ptr (CmmMachOp (MO_Add rep) [CmmLoad ptr rep, n])
 217
 218 -------------------------------------------------------------------------
 219 --
 220 --      Converting a closure tag to a closure for enumeration types
 221 --      (this is the implementation of tagToEnum#).
 222 --
 223 -------------------------------------------------------------------------
 224
 225 tagToClosure :: PackageId -> TyCon -> CmmExpr -> CmmExpr
 226 tagToClosure this_pkg tycon tag
 227   = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep
 228   where closure_tbl = CmmLit (CmmLabel lbl)
 229         lbl = mkClosureTableLabel this_pkg (tyConName tycon)
 230
 231 -------------------------------------------------------------------------
 232 --
 233 --      Conditionals and rts calls
 234 --
 235 -------------------------------------------------------------------------
 236
 237 emitIf :: CmmExpr       -- Boolean
 238        -> Code          -- Then part
 239        -> Code
 240 -- Emit (if e then x)
 241 -- ToDo: reverse the condition to avoid the extra branch instruction if possible
 242 -- (some conditionals aren't reversible. eg. floating point comparisons cannot
 243 -- be inverted because there exist some values for which both comparisons
 244 -- return False, such as NaN.)
 245 emitIf cond then_part
 246   = do { then_id <- newLabelC
 247        ; join_id <- newLabelC
 248        ; stmtC (CmmCondBranch cond then_id)
 249        ; stmtC (CmmBranch join_id)
 250        ; labelC then_id
 251        ; then_part
 252        ; labelC join_id
 253        }
 254
 255 emitIfThenElse :: CmmExpr       -- Boolean
 256                 -> Code         -- Then part
 257                 -> Code         -- Else part
 258                 -> Code
 259 -- Emit (if e then x else y)
 260 emitIfThenElse cond then_part else_part
 261   = do { then_id <- newLabelC
 262        ; else_id <- newLabelC
 263        ; join_id <- newLabelC
 264        ; stmtC (CmmCondBranch cond then_id)
 265        ; else_part
 266        ; stmtC (CmmBranch join_id)
 267        ; labelC then_id
 268        ; then_part
 269        ; labelC join_id
 270        }
 271
 272 emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Code
 273 emitRtsCall fun args = emitRtsCall' [] fun args Nothing
 274    -- The 'Nothing' says "save all global registers"
 275
 276 emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Code
 277 emitRtsCallWithVols fun args vols
 278    = emitRtsCall' [] fun args (Just vols)
 279
 280 emitRtsCallWithResult :: LocalReg -> MachHint -> LitString
 281         -> [(CmmExpr,MachHint)] -> Code
 282 emitRtsCallWithResult res hint fun args
 283    = emitRtsCall' [(res,hint)] fun args Nothing
 284
 285 -- Make a call to an RTS C procedure
 286 emitRtsCall'
 287    :: CmmHintFormals
 288    -> LitString
 289    -> [(CmmExpr,MachHint)]
 290    -> Maybe [GlobalReg]
 291    -> Code
 292 emitRtsCall' res fun args vols = do
 293     srt <- getSRTInfo
 294     stmtsC caller_save
 295     stmtC (CmmCall target res args srt)
 296     stmtsC caller_load
 297   where
 298     (caller_save, caller_load) = callerSaveVolatileRegs vols
 299     target   = CmmForeignCall fun_expr CCallConv
 300     fun_expr = mkLblExpr (mkRtsCodeLabel fun)
 301
 302
 303 -------------------------------------------------------------------------
 304 --
 305 --      Strings gnerate a top-level data block
 306 --
 307 -------------------------------------------------------------------------
 308
 309 emitDataLits :: CLabel -> [CmmLit] -> Code
 310 -- Emit a data-segment data block
 311 emitDataLits lbl lits
 312   = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 313
 314 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
 315 -- Emit a data-segment data block
 316 mkDataLits lbl lits
 317   = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 318
 319 emitRODataLits :: CLabel -> [CmmLit] -> Code
 320 -- Emit a read-only data block
 321 emitRODataLits lbl lits
 322   = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
 323   where section | any needsRelocation lits = RelocatableReadOnlyData
 324                 | otherwise                = ReadOnlyData
 325         needsRelocation (CmmLabel _)      = True
 326         needsRelocation (CmmLabelOff _ _) = True
 327         needsRelocation _                 = False
 328
 329 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
 330 mkRODataLits lbl lits
 331   = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
 332   where section | any needsRelocation lits = RelocatableReadOnlyData
 333                 | otherwise                = ReadOnlyData
 334         needsRelocation (CmmLabel _)      = True
 335         needsRelocation (CmmLabelOff _ _) = True
 336         needsRelocation _                 = False
 337
 338 mkStringCLit :: String -> FCode CmmLit
 339 -- Make a global definition for the string,
 340 -- and return its label
 341 mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str)
 342
 343 mkByteStringCLit :: [Word8] -> FCode CmmLit
 344 mkByteStringCLit bytes
 345   = do  { uniq <- newUnique
 346         ; let lbl = mkStringLitLabel uniq
 347         ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
 348         ; return (CmmLabel lbl) }
 349
 350 -------------------------------------------------------------------------
 351 --
 352 --      Assigning expressions to temporaries
 353 --
 354 -------------------------------------------------------------------------
 355
 356 assignNonPtrTemp :: CmmExpr -> FCode CmmExpr
 357 -- For a non-trivial expression, e, create a local
 358 -- variable and assign the expression to it
 359 assignNonPtrTemp e
 360   | isTrivialCmmExpr e = return e
 361   | otherwise          = do { reg <- newNonPtrTemp (cmmExprRep e)
 362                             ; stmtC (CmmAssign (CmmLocal reg) e)
 363                             ; return (CmmReg (CmmLocal reg)) }
 364
 365 assignPtrTemp :: CmmExpr -> FCode CmmExpr
 366 -- For a non-trivial expression, e, create a local
 367 -- variable and assign the expression to it
 368 assignPtrTemp e
 369   | isTrivialCmmExpr e = return e
 370   | otherwise          = do { reg <- newPtrTemp (cmmExprRep e)
 371                             ; stmtC (CmmAssign (CmmLocal reg) e)
 372                             ; return (CmmReg (CmmLocal reg)) }
 373
 374 newNonPtrTemp :: MachRep -> FCode LocalReg
 375 newNonPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindNonPtr) }
 376
 377 newPtrTemp :: MachRep -> FCode LocalReg
 378 newPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindPtr) }
 379
 380
 381 -------------------------------------------------------------------------
 382 --
 383 --      Building case analysis
 384 --
 385 -------------------------------------------------------------------------
 386
 387 emitSwitch
 388         :: CmmExpr                -- Tag to switch on
 389         -> [(ConTagZ, CgStmts)]   -- Tagged branches
 390         -> Maybe CgStmts          -- Default branch (if any)
 391         -> ConTagZ -> ConTagZ     -- Min and Max possible values; behaviour
 392                                   --    outside this range is undefined
 393         -> Code
 394
 395 -- ONLY A DEFAULT BRANCH: no case analysis to do
 396 emitSwitch tag_expr [] (Just stmts) _ _
 397   = emitCgStmts stmts
 398
 399 -- Right, off we go
 400 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
 401   =     -- Just sort the branches before calling mk_sritch
 402     do  { mb_deflt_id <-
 403                 case mb_deflt of
 404                   Nothing    -> return Nothing
 405                   Just stmts -> do id <- forkCgStmts stmts; return (Just id)
 406
 407         ; dflags <- getDynFlags
 408         ; let via_C | HscC <- hscTarget dflags = True
 409                     | otherwise                = False
 410
 411         ; stmts <- mk_switch tag_expr (sortLe le branches)
 412                         mb_deflt_id lo_tag hi_tag via_C
 413         ; emitCgStmts stmts
 414         }
 415   where
 416     (t1,_) `le` (t2,_) = t1 <= t2
 417
 418
 419 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
 420           -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
 421           -> FCode CgStmts
 422
 423 -- SINGLETON TAG RANGE: no case analysis to do
 424 mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
 425   | lo_tag == hi_tag
 426   = ASSERT( tag == lo_tag )
 427     return stmts
 428
 429 -- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
 430 mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
 431   = return stmts
 432         -- The simplifier might have eliminated a case
 433         --       so we may have e.g. case xs of
 434         --                               [] -> e
 435         -- In that situation we can be sure the (:) case
 436         -- can't happen, so no need to test
 437
 438 -- SINGLETON BRANCH: one equality check to do
 439 mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
 440   = return (CmmCondBranch cond deflt `consCgStmt` stmts)
 441   where
 442     cond  =  cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
 443         -- We have lo_tag < hi_tag, but there's only one branch,
 444         -- so there must be a default
 445
 446 -- ToDo: we might want to check for the two branch case, where one of
 447 -- the branches is the tag 0, because comparing '== 0' is likely to be
 448 -- more efficient than other kinds of comparison.
 449
 450 -- DENSE TAG RANGE: use a switch statment.
 451 --
 452 -- We also use a switch uncoditionally when compiling via C, because
 453 -- this will get emitted as a C switch statement and the C compiler
 454 -- should do a good job of optimising it.  Also, older GCC versions
 455 -- (2.95 in particular) have problems compiling the complicated
 456 -- if-trees generated by this code, so compiling to a switch every
 457 -- time works around that problem.
 458 --
 459 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
 460   | use_switch  -- Use a switch
 461   = do  { branch_ids <- mapM forkCgStmts (map snd branches)
 462         ; let
 463                 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
 464
 465                 find_branch :: ConTagZ -> Maybe BlockId
 466                 find_branch i = assocDefault mb_deflt tagged_blk_ids i
 467
 468                 -- NB. we have eliminated impossible branches at
 469                 -- either end of the range (see below), so the first
 470                 -- tag of a real branch is real_lo_tag (not lo_tag).
 471                 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
 472
 473                 switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
 474
 475         ; ASSERT(not (all isNothing arms))
 476           return (oneCgStmt switch_stmt)
 477         }
 478
 479   -- if we can knock off a bunch of default cases with one if, then do so
 480   | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
 481   = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
 482        ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
 483              branch = CmmCondBranch cond deflt
 484        ; stmts <- mk_switch tag_expr' branches mb_deflt
 485                         lowest_branch hi_tag via_C
 486        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 487        }
 488
 489   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
 490   = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
 491        ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
 492              branch = CmmCondBranch cond deflt
 493        ; stmts <- mk_switch tag_expr' branches mb_deflt
 494                         lo_tag highest_branch via_C
 495        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 496        }
 497
 498   | otherwise   -- Use an if-tree
 499   = do  { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
 500                 -- To avoid duplication
 501         ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
 502                                 lo_tag (mid_tag-1) via_C
 503         ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
 504                                 mid_tag hi_tag via_C
 505         ; hi_id <- forkCgStmts hi_stmts
 506         ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
 507               branch_stmt = CmmCondBranch cond hi_id
 508         ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
 509         }
 510         -- we test (e >= mid_tag) rather than (e < mid_tag), because
 511         -- the former works better when e is a comparison, and there
 512         -- are two tags 0 & 1 (mid_tag == 1).  In this case, the code
 513         -- generator can reduce the condition to e itself without
 514         -- having to reverse the sense of the comparison: comparisons
 515         -- can't always be easily reversed (eg. floating
 516         -- pt. comparisons).
 517   where
 518     use_switch   = {- pprTrace "mk_switch" (
 519                         ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
 520                         text "branches:" <+> ppr (map fst branches) <+>
 521                         text "n_branches:" <+> int n_branches <+>
 522                         text "lo_tag:" <+> int lo_tag <+>
 523                         text "hi_tag:" <+> int hi_tag <+>
 524                         text "real_lo_tag:" <+> int real_lo_tag <+>
 525                         text "real_hi_tag:" <+> int real_hi_tag) $ -}
 526                    ASSERT( n_branches > 1 && n_tags > 1 )
 527                    n_tags > 2 && (via_C || (dense && big_enough))
 528                  -- up to 4 branches we use a decision tree, otherwise
 529                  -- a switch (== jump table in the NCG).  This seems to be
 530                  -- optimal, and corresponds with what gcc does.
 531     big_enough   = n_branches > 4
 532     dense        = n_branches > (n_tags `div` 2)
 533     n_branches   = length branches
 534
 535     -- ignore default slots at each end of the range if there's
 536     -- no default branch defined.
 537     lowest_branch  = fst (head branches)
 538     highest_branch = fst (last branches)
 539
 540     real_lo_tag
 541         | isNothing mb_deflt = lowest_branch
 542         | otherwise          = lo_tag
 543
 544     real_hi_tag
 545         | isNothing mb_deflt = highest_branch
 546         | otherwise          = hi_tag
 547
 548     n_tags = real_hi_tag - real_lo_tag + 1
 549
 550         -- INVARIANT: Provided hi_tag > lo_tag (which is true)
 551         --      lo_tag <= mid_tag < hi_tag
 552         --      lo_branches have tags <  mid_tag
 553         --      hi_branches have tags >= mid_tag
 554
 555     (mid_tag,_) = branches !! (n_branches `div` 2)
 556         -- 2 branches => n_branches `div` 2 = 1
 557         --            => branches !! 1 give the *second* tag
 558         -- There are always at least 2 branches here
 559
 560     (lo_branches, hi_branches) = span is_lo branches
 561     is_lo (t,_) = t < mid_tag
 562
 563
 564 assignNonPtrTemp' e
 565   | isTrivialCmmExpr e = return (CmmNop, e)
 566   | otherwise          = do { reg <- newNonPtrTemp (cmmExprRep e)
 567                             ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
 568
 569 emitLitSwitch :: CmmExpr                        -- Tag to switch on
 570               -> [(Literal, CgStmts)]           -- Tagged branches
 571               -> CgStmts                        -- Default branch (always)
 572               -> Code                           -- Emit the code
 573 -- Used for general literals, whose size might not be a word,
 574 -- where there is always a default case, and where we don't know
 575 -- the range of values for certain.  For simplicity we always generate a tree.
 576 --
 577 -- ToDo: for integers we could do better here, perhaps by generalising
 578 -- mk_switch and using that.  --SDM 15/09/2004
 579 emitLitSwitch scrut [] deflt
 580   = emitCgStmts deflt
 581 emitLitSwitch scrut branches deflt_blk
 582   = do  { scrut' <- assignNonPtrTemp scrut
 583         ; deflt_blk_id <- forkCgStmts deflt_blk
 584         ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
 585         ; emitCgStmts blk }
 586   where
 587     le (t1,_) (t2,_) = t1 <= t2
 588
 589 mk_lit_switch :: CmmExpr -> BlockId
 590               -> [(Literal,CgStmts)]
 591               -> FCode CgStmts
 592 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
 593   = return (consCgStmt if_stmt blk)
 594   where
 595     cmm_lit = mkSimpleLit lit
 596     rep     = cmmLitRep cmm_lit
 597     cond    = CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit]
 598     if_stmt = CmmCondBranch cond deflt_blk_id
 599
 600 mk_lit_switch scrut deflt_blk_id branches
 601   = do  { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
 602         ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
 603         ; lo_blk_id <- forkCgStmts lo_blk
 604         ; let if_stmt = CmmCondBranch cond lo_blk_id
 605         ; return (if_stmt `consCgStmt` hi_blk) }
 606   where
 607     n_branches = length branches
 608     (mid_lit,_) = branches !! (n_branches `div` 2)
 609         -- See notes above re mid_tag
 610
 611     (lo_branches, hi_branches) = span is_lo branches
 612     is_lo (t,_) = t < mid_lit
 613
 614     cond    = CmmMachOp (mkLtOp mid_lit)
 615                         [scrut, CmmLit (mkSimpleLit mid_lit)]
 616
 617 -------------------------------------------------------------------------
 618 --
 619 --      Simultaneous assignment
 620 --
 621 -------------------------------------------------------------------------
 622
 623
 624 emitSimultaneously :: CmmStmts -> Code
 625 -- Emit code to perform the assignments in the
 626 -- input simultaneously, using temporary variables when necessary.
 627 --
 628 -- The Stmts must be:
 629 --      CmmNop, CmmComment, CmmAssign, CmmStore
 630 -- and nothing else
 631
 632
 633 -- We use the strongly-connected component algorithm, in which
 634 --      * the vertices are the statements
 635 --      * an edge goes from s1 to s2 iff
 636 --              s1 assigns to something s2 uses
 637 --        that is, if s1 should *follow* s2 in the final order
 638
 639 type CVertex = (Int, CmmStmt)   -- Give each vertex a unique number,
 640                                 -- for fast comparison
 641
 642 emitSimultaneously stmts
 643   = codeOnly $
 644     case filterOut isNopStmt (stmtList stmts) of
 645         -- Remove no-ops
 646       []        -> nopC
 647       [stmt]    -> stmtC stmt   -- It's often just one stmt
 648       stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
 649
 650 doSimultaneously1 :: [CVertex] -> Code
 651 doSimultaneously1 vertices
 652   = let
 653         edges = [ (vertex, key1, edges_from stmt1)
 654                 | vertex@(key1, stmt1) <- vertices
 655                 ]
 656         edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
 657                                     stmt1 `mustFollow` stmt2
 658                            ]
 659         components = stronglyConnComp edges
 660
 661         -- do_components deal with one strongly-connected component
 662         -- Not cyclic, or singleton?  Just do it
 663         do_component (AcyclicSCC (n,stmt))  = stmtC stmt
 664         do_component (CyclicSCC [(n,stmt)]) = stmtC stmt
 665
 666                 -- Cyclic?  Then go via temporaries.  Pick one to
 667                 -- break the loop and try again with the rest.
 668         do_component (CyclicSCC ((n,first_stmt) : rest))
 669           = do  { from_temp <- go_via_temp first_stmt
 670                 ; doSimultaneously1 rest
 671                 ; stmtC from_temp }
 672
 673         go_via_temp (CmmAssign dest src)
 674           = do  { tmp <- newNonPtrTemp (cmmRegRep dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
 675                 ; stmtC (CmmAssign (CmmLocal tmp) src)
 676                 ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
 677         go_via_temp (CmmStore dest src)
 678           = do  { tmp <- newNonPtrTemp (cmmExprRep src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong
 679                 ; stmtC (CmmAssign (CmmLocal tmp) src)
 680                 ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
 681     in
 682     mapCs do_component components
 683
 684 mustFollow :: CmmStmt -> CmmStmt -> Bool
 685 CmmAssign reg _  `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
 686 CmmStore loc e   `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprRep e)) stmt
 687 CmmNop           `mustFollow` stmt = False
 688 CmmComment _     `mustFollow` stmt = False
 689
 690
 691 anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
 692 -- True if the fn is true of any input of the stmt
 693 anySrc p (CmmAssign _ e)    = p e
 694 anySrc p (CmmStore e1 e2)   = p e1 || p e2      -- Might be used in either side
 695 anySrc p (CmmComment _)     = False
 696 anySrc p CmmNop             = False
 697 anySrc p other              = True              -- Conservative
 698
 699 regUsedIn :: CmmReg -> CmmExpr -> Bool
 700 reg `regUsedIn` CmmLit _         = False
 701 reg `regUsedIn` CmmLoad e  _     = reg `regUsedIn` e
 702 reg `regUsedIn` CmmReg reg'      = reg == reg'
 703 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
 704 reg `regUsedIn` CmmMachOp _ es   = any (reg `regUsedIn`) es
 705
 706 locUsedIn :: CmmExpr -> MachRep -> CmmExpr -> Bool
 707 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
 708 -- 'e'.  Returns True if it's not sure.
 709 locUsedIn loc rep (CmmLit _)         = False
 710 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
 711 locUsedIn loc rep (CmmReg reg')      = False
 712 locUsedIn loc rep (CmmRegOff reg' _) = False
 713 locUsedIn loc rep (CmmMachOp _ es)   = any (locUsedIn loc rep) es
 714
 715 possiblySameLoc :: CmmExpr -> MachRep -> CmmExpr -> MachRep -> Bool
 716 -- Assumes that distinct registers (eg Hp, Sp) do not
 717 -- point to the same location, nor any offset thereof.
 718 possiblySameLoc (CmmReg r1)       rep1 (CmmReg r2)      rep2  = r1==r2
 719 possiblySameLoc (CmmReg r1)       rep1 (CmmRegOff r2 0) rep2  = r1==r2
 720 possiblySameLoc (CmmRegOff r1 0)  rep1 (CmmReg r2)      rep2  = r1==r2
 721 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
 722   = r1==r2 && end1 > start2 && end2 > start1
 723   where
 724     end1 = start1 + machRepByteWidth rep1
 725     end2 = start2 + machRepByteWidth rep2
 726
 727 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
 728 possiblySameLoc l1 rep1 l2         rep2 = True  -- Conservative
 729
 730 -------------------------------------------------------------------------
 731 --
 732 --      Static Reference Tables
 733 --
 734 -------------------------------------------------------------------------
 735
 736 -- There is just one SRT for each top level binding; all the nested
 737 -- bindings use sub-sections of this SRT.  The label is passed down to
 738 -- the nested bindings via the monad.
 739
 740 getSRTInfo :: FCode C_SRT
 741 getSRTInfo = do
 742   srt_lbl <- getSRTLabel
 743   srt <- getSRT
 744   case srt of
 745     -- TODO: Should we panic in this case?
 746     -- Someone obviously thinks there should be an SRT
 747     NoSRT -> return NoC_SRT
 748     SRT off len bmp
 749       | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
 750       -> do id <- newUnique
 751             let srt_desc_lbl = mkLargeSRTLabel id
 752             emitRODataLits srt_desc_lbl
 753              ( cmmLabelOffW srt_lbl off
 754                : mkWordCLit (fromIntegral len)
 755                : map mkWordCLit bmp)
 756             return (C_SRT srt_desc_lbl 0 srt_escape)
 757
 758     SRT off len bmp
 759       | otherwise
 760       -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
 761                 -- The fromIntegral converts to StgHalfWord
 762
 763 srt_escape = (-1) :: StgHalfWord