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