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