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