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)] -> Bool -> Code
 273 emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
 274    -- The 'Nothing' says "save all global registers"
 275
 276 emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Bool -> Code
 277 emitRtsCallWithVols fun args vols safe
 278    = emitRtsCall' [] fun args (Just vols) safe
 279
 280 emitRtsCallWithResult :: LocalReg -> MachHint -> LitString
 281         -> [(CmmExpr,MachHint)] -> Bool -> Code
 282 emitRtsCallWithResult res hint fun args safe
 283    = emitRtsCall' [(res,hint)] fun args Nothing safe
 284
 285 -- Make a call to an RTS C procedure
 286 emitRtsCall'
 287    :: CmmHintFormals
 288    -> LitString
 289    -> [(CmmExpr,MachHint)]
 290    -> Maybe [GlobalReg]
 291    -> Bool -- True <=> CmmSafe call
 292    -> Code
 293 emitRtsCall' res fun args vols safe = do
 294   safety <- if safe
 295             then getSRTInfo >>= (return . CmmSafe)
 296             else return CmmUnsafe
 297   stmtsC caller_save
 298   stmtC (CmmCall target res args safety)
 299   stmtsC caller_load
 300   where
 301     (caller_save, caller_load) = callerSaveVolatileRegs vols
 302     target   = CmmForeignCall fun_expr CCallConv
 303     fun_expr = mkLblExpr (mkRtsCodeLabel fun)
 304
 305
 306 -------------------------------------------------------------------------
 307 --
 308 --      Strings gnerate a top-level data block
 309 --
 310 -------------------------------------------------------------------------
 311
 312 emitDataLits :: CLabel -> [CmmLit] -> Code
 313 -- Emit a data-segment data block
 314 emitDataLits lbl lits
 315   = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 316
 317 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
 318 -- Emit a data-segment data block
 319 mkDataLits lbl lits
 320   = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
 321
 322 emitRODataLits :: CLabel -> [CmmLit] -> Code
 323 -- Emit a read-only data block
 324 emitRODataLits lbl lits
 325   = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
 326   where section | any needsRelocation lits = RelocatableReadOnlyData
 327                 | otherwise                = ReadOnlyData
 328         needsRelocation (CmmLabel _)      = True
 329         needsRelocation (CmmLabelOff _ _) = True
 330         needsRelocation _                 = False
 331
 332 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
 333 mkRODataLits lbl lits
 334   = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
 335   where section | any needsRelocation lits = RelocatableReadOnlyData
 336                 | otherwise                = ReadOnlyData
 337         needsRelocation (CmmLabel _)      = True
 338         needsRelocation (CmmLabelOff _ _) = True
 339         needsRelocation _                 = False
 340
 341 mkStringCLit :: String -> FCode CmmLit
 342 -- Make a global definition for the string,
 343 -- and return its label
 344 mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str)
 345
 346 mkByteStringCLit :: [Word8] -> FCode CmmLit
 347 mkByteStringCLit bytes
 348   = do  { uniq <- newUnique
 349         ; let lbl = mkStringLitLabel uniq
 350         ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
 351         ; return (CmmLabel lbl) }
 352
 353 -------------------------------------------------------------------------
 354 --
 355 --      Assigning expressions to temporaries
 356 --
 357 -------------------------------------------------------------------------
 358
 359 assignNonPtrTemp :: CmmExpr -> FCode CmmExpr
 360 -- For a non-trivial expression, e, create a local
 361 -- variable and assign the expression to it
 362 assignNonPtrTemp e
 363   | isTrivialCmmExpr e = return e
 364   | otherwise          = do { reg <- newNonPtrTemp (cmmExprRep e)
 365                             ; stmtC (CmmAssign (CmmLocal reg) e)
 366                             ; return (CmmReg (CmmLocal reg)) }
 367
 368 assignPtrTemp :: CmmExpr -> FCode CmmExpr
 369 -- For a non-trivial expression, e, create a local
 370 -- variable and assign the expression to it
 371 assignPtrTemp e
 372   | isTrivialCmmExpr e = return e
 373   | otherwise          = do { reg <- newPtrTemp (cmmExprRep e)
 374                             ; stmtC (CmmAssign (CmmLocal reg) e)
 375                             ; return (CmmReg (CmmLocal reg)) }
 376
 377 newNonPtrTemp :: MachRep -> FCode LocalReg
 378 newNonPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindNonPtr) }
 379
 380 newPtrTemp :: MachRep -> FCode LocalReg
 381 newPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindPtr) }
 382
 383
 384 -------------------------------------------------------------------------
 385 --
 386 --      Building case analysis
 387 --
 388 -------------------------------------------------------------------------
 389
 390 emitSwitch
 391         :: CmmExpr                -- Tag to switch on
 392         -> [(ConTagZ, CgStmts)]   -- Tagged branches
 393         -> Maybe CgStmts          -- Default branch (if any)
 394         -> ConTagZ -> ConTagZ     -- Min and Max possible values; behaviour
 395                                   --    outside this range is undefined
 396         -> Code
 397
 398 -- ONLY A DEFAULT BRANCH: no case analysis to do
 399 emitSwitch tag_expr [] (Just stmts) _ _
 400   = emitCgStmts stmts
 401
 402 -- Right, off we go
 403 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
 404   =     -- Just sort the branches before calling mk_sritch
 405     do  { mb_deflt_id <-
 406                 case mb_deflt of
 407                   Nothing    -> return Nothing
 408                   Just stmts -> do id <- forkCgStmts stmts; return (Just id)
 409
 410         ; dflags <- getDynFlags
 411         ; let via_C | HscC <- hscTarget dflags = True
 412                     | otherwise                = False
 413
 414         ; stmts <- mk_switch tag_expr (sortLe le branches)
 415                         mb_deflt_id lo_tag hi_tag via_C
 416         ; emitCgStmts stmts
 417         }
 418   where
 419     (t1,_) `le` (t2,_) = t1 <= t2
 420
 421
 422 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
 423           -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
 424           -> FCode CgStmts
 425
 426 -- SINGLETON TAG RANGE: no case analysis to do
 427 mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
 428   | lo_tag == hi_tag
 429   = ASSERT( tag == lo_tag )
 430     return stmts
 431
 432 -- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
 433 mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
 434   = return stmts
 435         -- The simplifier might have eliminated a case
 436         --       so we may have e.g. case xs of
 437         --                               [] -> e
 438         -- In that situation we can be sure the (:) case
 439         -- can't happen, so no need to test
 440
 441 -- SINGLETON BRANCH: one equality check to do
 442 mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
 443   = return (CmmCondBranch cond deflt `consCgStmt` stmts)
 444   where
 445     cond  =  cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
 446         -- We have lo_tag < hi_tag, but there's only one branch,
 447         -- so there must be a default
 448
 449 -- ToDo: we might want to check for the two branch case, where one of
 450 -- the branches is the tag 0, because comparing '== 0' is likely to be
 451 -- more efficient than other kinds of comparison.
 452
 453 -- DENSE TAG RANGE: use a switch statment.
 454 --
 455 -- We also use a switch uncoditionally when compiling via C, because
 456 -- this will get emitted as a C switch statement and the C compiler
 457 -- should do a good job of optimising it.  Also, older GCC versions
 458 -- (2.95 in particular) have problems compiling the complicated
 459 -- if-trees generated by this code, so compiling to a switch every
 460 -- time works around that problem.
 461 --
 462 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
 463   | use_switch  -- Use a switch
 464   = do  { branch_ids <- mapM forkCgStmts (map snd branches)
 465         ; let
 466                 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
 467
 468                 find_branch :: ConTagZ -> Maybe BlockId
 469                 find_branch i = assocDefault mb_deflt tagged_blk_ids i
 470
 471                 -- NB. we have eliminated impossible branches at
 472                 -- either end of the range (see below), so the first
 473                 -- tag of a real branch is real_lo_tag (not lo_tag).
 474                 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
 475
 476                 switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
 477
 478         ; ASSERT(not (all isNothing arms))
 479           return (oneCgStmt switch_stmt)
 480         }
 481
 482   -- if we can knock off a bunch of default cases with one if, then do so
 483   | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
 484   = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
 485        ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
 486              branch = CmmCondBranch cond deflt
 487        ; stmts <- mk_switch tag_expr' branches mb_deflt
 488                         lowest_branch hi_tag via_C
 489        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 490        }
 491
 492   | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
 493   = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
 494        ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
 495              branch = CmmCondBranch cond deflt
 496        ; stmts <- mk_switch tag_expr' branches mb_deflt
 497                         lo_tag highest_branch via_C
 498        ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
 499        }
 500
 501   | otherwise   -- Use an if-tree
 502   = do  { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
 503                 -- To avoid duplication
 504         ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
 505                                 lo_tag (mid_tag-1) via_C
 506         ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
 507                                 mid_tag hi_tag via_C
 508         ; hi_id <- forkCgStmts hi_stmts
 509         ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
 510               branch_stmt = CmmCondBranch cond hi_id
 511         ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
 512         }
 513         -- we test (e >= mid_tag) rather than (e < mid_tag), because
 514         -- the former works better when e is a comparison, and there
 515         -- are two tags 0 & 1 (mid_tag == 1).  In this case, the code
 516         -- generator can reduce the condition to e itself without
 517         -- having to reverse the sense of the comparison: comparisons
 518         -- can't always be easily reversed (eg. floating
 519         -- pt. comparisons).
 520   where
 521     use_switch   = {- pprTrace "mk_switch" (
 522                         ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
 523                         text "branches:" <+> ppr (map fst branches) <+>
 524                         text "n_branches:" <+> int n_branches <+>
 525                         text "lo_tag:" <+> int lo_tag <+>
 526                         text "hi_tag:" <+> int hi_tag <+>
 527                         text "real_lo_tag:" <+> int real_lo_tag <+>
 528                         text "real_hi_tag:" <+> int real_hi_tag) $ -}
 529                    ASSERT( n_branches > 1 && n_tags > 1 )
 530                    n_tags > 2 && (via_C || (dense && big_enough))
 531                  -- up to 4 branches we use a decision tree, otherwise
 532                  -- a switch (== jump table in the NCG).  This seems to be
 533                  -- optimal, and corresponds with what gcc does.
 534     big_enough   = n_branches > 4
 535     dense        = n_branches > (n_tags `div` 2)
 536     n_branches   = length branches
 537
 538     -- ignore default slots at each end of the range if there's
 539     -- no default branch defined.
 540     lowest_branch  = fst (head branches)
 541     highest_branch = fst (last branches)
 542
 543     real_lo_tag
 544         | isNothing mb_deflt = lowest_branch
 545         | otherwise          = lo_tag
 546
 547     real_hi_tag
 548         | isNothing mb_deflt = highest_branch
 549         | otherwise          = hi_tag
 550
 551     n_tags = real_hi_tag - real_lo_tag + 1
 552
 553         -- INVARIANT: Provided hi_tag > lo_tag (which is true)
 554         --      lo_tag <= mid_tag < hi_tag
 555         --      lo_branches have tags <  mid_tag
 556         --      hi_branches have tags >= mid_tag
 557
 558     (mid_tag,_) = branches !! (n_branches `div` 2)
 559         -- 2 branches => n_branches `div` 2 = 1
 560         --            => branches !! 1 give the *second* tag
 561         -- There are always at least 2 branches here
 562
 563     (lo_branches, hi_branches) = span is_lo branches
 564     is_lo (t,_) = t < mid_tag
 565
 566
 567 assignNonPtrTemp' e
 568   | isTrivialCmmExpr e = return (CmmNop, e)
 569   | otherwise          = do { reg <- newNonPtrTemp (cmmExprRep e)
 570                             ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
 571
 572 emitLitSwitch :: CmmExpr                        -- Tag to switch on
 573               -> [(Literal, CgStmts)]           -- Tagged branches
 574               -> CgStmts                        -- Default branch (always)
 575               -> Code                           -- Emit the code
 576 -- Used for general literals, whose size might not be a word,
 577 -- where there is always a default case, and where we don't know
 578 -- the range of values for certain.  For simplicity we always generate a tree.
 579 --
 580 -- ToDo: for integers we could do better here, perhaps by generalising
 581 -- mk_switch and using that.  --SDM 15/09/2004
 582 emitLitSwitch scrut [] deflt
 583   = emitCgStmts deflt
 584 emitLitSwitch scrut branches deflt_blk
 585   = do  { scrut' <- assignNonPtrTemp scrut
 586         ; deflt_blk_id <- forkCgStmts deflt_blk
 587         ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
 588         ; emitCgStmts blk }
 589   where
 590     le (t1,_) (t2,_) = t1 <= t2
 591
 592 mk_lit_switch :: CmmExpr -> BlockId
 593               -> [(Literal,CgStmts)]
 594               -> FCode CgStmts
 595 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
 596   = return (consCgStmt if_stmt blk)
 597   where
 598     cmm_lit = mkSimpleLit lit
 599     rep     = cmmLitRep cmm_lit
 600     cond    = CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit]
 601     if_stmt = CmmCondBranch cond deflt_blk_id
 602
 603 mk_lit_switch scrut deflt_blk_id branches
 604   = do  { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
 605         ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
 606         ; lo_blk_id <- forkCgStmts lo_blk
 607         ; let if_stmt = CmmCondBranch cond lo_blk_id
 608         ; return (if_stmt `consCgStmt` hi_blk) }
 609   where
 610     n_branches = length branches
 611     (mid_lit,_) = branches !! (n_branches `div` 2)
 612         -- See notes above re mid_tag
 613
 614     (lo_branches, hi_branches) = span is_lo branches
 615     is_lo (t,_) = t < mid_lit
 616
 617     cond    = CmmMachOp (mkLtOp mid_lit)
 618                         [scrut, CmmLit (mkSimpleLit mid_lit)]
 619
 620 -------------------------------------------------------------------------
 621 --
 622 --      Simultaneous assignment
 623 --
 624 -------------------------------------------------------------------------
 625
 626
 627 emitSimultaneously :: CmmStmts -> Code
 628 -- Emit code to perform the assignments in the
 629 -- input simultaneously, using temporary variables when necessary.
 630 --
 631 -- The Stmts must be:
 632 --      CmmNop, CmmComment, CmmAssign, CmmStore
 633 -- and nothing else
 634
 635
 636 -- We use the strongly-connected component algorithm, in which
 637 --      * the vertices are the statements
 638 --      * an edge goes from s1 to s2 iff
 639 --              s1 assigns to something s2 uses
 640 --        that is, if s1 should *follow* s2 in the final order
 641
 642 type CVertex = (Int, CmmStmt)   -- Give each vertex a unique number,
 643                                 -- for fast comparison
 644
 645 emitSimultaneously stmts
 646   = codeOnly $
 647     case filterOut isNopStmt (stmtList stmts) of
 648         -- Remove no-ops
 649       []        -> nopC
 650       [stmt]    -> stmtC stmt   -- It's often just one stmt
 651       stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
 652
 653 doSimultaneously1 :: [CVertex] -> Code
 654 doSimultaneously1 vertices
 655   = let
 656         edges = [ (vertex, key1, edges_from stmt1)
 657                 | vertex@(key1, stmt1) <- vertices
 658                 ]
 659         edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
 660                                     stmt1 `mustFollow` stmt2
 661                            ]
 662         components = stronglyConnComp edges
 663
 664         -- do_components deal with one strongly-connected component
 665         -- Not cyclic, or singleton?  Just do it
 666         do_component (AcyclicSCC (n,stmt))  = stmtC stmt
 667         do_component (CyclicSCC [(n,stmt)]) = stmtC stmt
 668
 669                 -- Cyclic?  Then go via temporaries.  Pick one to
 670                 -- break the loop and try again with the rest.
 671         do_component (CyclicSCC ((n,first_stmt) : rest))
 672           = do  { from_temp <- go_via_temp first_stmt
 673                 ; doSimultaneously1 rest
 674                 ; stmtC from_temp }
 675
 676         go_via_temp (CmmAssign dest src)
 677           = do  { tmp <- newNonPtrTemp (cmmRegRep dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
 678                 ; stmtC (CmmAssign (CmmLocal tmp) src)
 679                 ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
 680         go_via_temp (CmmStore dest src)
 681           = do  { tmp <- newNonPtrTemp (cmmExprRep src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong
 682                 ; stmtC (CmmAssign (CmmLocal tmp) src)
 683                 ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
 684     in
 685     mapCs do_component components
 686
 687 mustFollow :: CmmStmt -> CmmStmt -> Bool
 688 CmmAssign reg _  `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
 689 CmmStore loc e   `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprRep e)) stmt
 690 CmmNop           `mustFollow` stmt = False
 691 CmmComment _     `mustFollow` stmt = False
 692
 693
 694 anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
 695 -- True if the fn is true of any input of the stmt
 696 anySrc p (CmmAssign _ e)    = p e
 697 anySrc p (CmmStore e1 e2)   = p e1 || p e2      -- Might be used in either side
 698 anySrc p (CmmComment _)     = False
 699 anySrc p CmmNop             = False
 700 anySrc p other              = True              -- Conservative
 701
 702 regUsedIn :: CmmReg -> CmmExpr -> Bool
 703 reg `regUsedIn` CmmLit _         = False
 704 reg `regUsedIn` CmmLoad e  _     = reg `regUsedIn` e
 705 reg `regUsedIn` CmmReg reg'      = reg == reg'
 706 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
 707 reg `regUsedIn` CmmMachOp _ es   = any (reg `regUsedIn`) es
 708
 709 locUsedIn :: CmmExpr -> MachRep -> CmmExpr -> Bool
 710 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
 711 -- 'e'.  Returns True if it's not sure.
 712 locUsedIn loc rep (CmmLit _)         = False
 713 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
 714 locUsedIn loc rep (CmmReg reg')      = False
 715 locUsedIn loc rep (CmmRegOff reg' _) = False
 716 locUsedIn loc rep (CmmMachOp _ es)   = any (locUsedIn loc rep) es
 717
 718 possiblySameLoc :: CmmExpr -> MachRep -> CmmExpr -> MachRep -> Bool
 719 -- Assumes that distinct registers (eg Hp, Sp) do not
 720 -- point to the same location, nor any offset thereof.
 721 possiblySameLoc (CmmReg r1)       rep1 (CmmReg r2)      rep2  = r1==r2
 722 possiblySameLoc (CmmReg r1)       rep1 (CmmRegOff r2 0) rep2  = r1==r2
 723 possiblySameLoc (CmmRegOff r1 0)  rep1 (CmmReg r2)      rep2  = r1==r2
 724 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
 725   = r1==r2 && end1 > start2 && end2 > start1
 726   where
 727     end1 = start1 + machRepByteWidth rep1
 728     end2 = start2 + machRepByteWidth rep2
 729
 730 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
 731 possiblySameLoc l1 rep1 l2         rep2 = True  -- Conservative
 732
 733 -------------------------------------------------------------------------
 734 --
 735 --      Static Reference Tables
 736 --
 737 -------------------------------------------------------------------------
 738
 739 -- There is just one SRT for each top level binding; all the nested
 740 -- bindings use sub-sections of this SRT.  The label is passed down to
 741 -- the nested bindings via the monad.
 742
 743 getSRTInfo :: FCode C_SRT
 744 getSRTInfo = do
 745   srt_lbl <- getSRTLabel
 746   srt <- getSRT
 747   case srt of
 748     -- TODO: Should we panic in this case?
 749     -- Someone obviously thinks there should be an SRT
 750     NoSRT -> return NoC_SRT
 751     SRT off len bmp
 752       | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
 753       -> do id <- newUnique
 754             let srt_desc_lbl = mkLargeSRTLabel id
 755             emitRODataLits srt_desc_lbl
 756              ( cmmLabelOffW srt_lbl off
 757                : mkWordCLit (fromIntegral len)
 758                : map mkWordCLit bmp)
 759             return (C_SRT srt_desc_lbl 0 srt_escape)
 760
 761     SRT off len bmp
 762       | otherwise
 763       -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
 764                 -- The fromIntegral converts to StgHalfWord
 765
 766 srt_escape = (-1) :: StgHalfWord