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,
  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 "n_branches:" <+> int n_branches <+>
 478                         text "lo_tag: " <+> int lo_tag <+>
 479                         text "hi_tag: " <+> int hi_tag <+>
 480                         text "real_lo_tag: " <+> int real_lo_tag <+>
 481                         text "real_hi_tag: " <+> int real_hi_tag) $ -}
 482                    ASSERT( n_branches > 1 && n_tags > 1 )
 483                    n_tags > 2 && (small || dense || via_C)
 484                  -- a 2-branch switch always turns into an if.
 485     small        = n_tags <= 4
 486     dense        = n_branches > (n_tags `div` 2)
 487     n_branches   = length branches
 488
 489     -- ignore default slots at each end of the range if there's
 490     -- no default branch defined.
 491     lowest_branch  = fst (head branches)
 492     highest_branch = fst (last branches)
 493
 494     real_lo_tag
 495         | isNothing mb_deflt = lowest_branch
 496         | otherwise          = lo_tag
 497
 498     real_hi_tag
 499         | isNothing mb_deflt = highest_branch
 500         | otherwise          = hi_tag
 501
 502     n_tags = real_hi_tag - real_lo_tag + 1
 503
 504         -- INVARIANT: Provided hi_tag > lo_tag (which is true)
 505         --      lo_tag <= mid_tag < hi_tag
 506         --      lo_branches have tags <  mid_tag
 507         --      hi_branches have tags >= mid_tag
 508
 509     (mid_tag,_) = branches !! (n_branches `div` 2)
 510         -- 2 branches => n_branches `div` 2 = 1
 511         --            => branches !! 1 give the *second* tag
 512         -- There are always at least 2 branches here
 513
 514     (lo_branches, hi_branches) = span is_lo branches
 515     is_lo (t,_) = t < mid_tag
 516
 517
 518 assignTemp' e
 519   | isTrivialCmmExpr e = return (CmmNop, e)
 520   | otherwise          = do { reg <- newTemp (cmmExprRep e)
 521                             ; return (CmmAssign reg e, CmmReg reg) }
 522
 523
 524 emitLitSwitch :: CmmExpr                        -- Tag to switch on
 525               -> [(Literal, CgStmts)]           -- Tagged branches
 526               -> CgStmts                        -- Default branch (always)
 527               -> Code                           -- Emit the code
 528 -- Used for general literals, whose size might not be a word,
 529 -- where there is always a default case, and where we don't know
 530 -- the range of values for certain.  For simplicity we always generate a tree.
 531 --
 532 -- ToDo: for integers we could do better here, perhaps by generalising
 533 -- mk_switch and using that.  --SDM 15/09/2004
 534 emitLitSwitch scrut [] deflt
 535   = emitCgStmts deflt
 536 emitLitSwitch scrut branches deflt_blk
 537   = do  { scrut' <- assignTemp scrut
 538         ; deflt_blk_id <- forkCgStmts deflt_blk
 539         ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
 540         ; emitCgStmts blk }
 541   where
 542     le (t1,_) (t2,_) = t1 <= t2
 543
 544 mk_lit_switch :: CmmExpr -> BlockId
 545               -> [(Literal,CgStmts)]
 546               -> FCode CgStmts
 547 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
 548   = return (consCgStmt if_stmt blk)
 549   where
 550     cmm_lit = mkSimpleLit lit
 551     rep     = cmmLitRep cmm_lit
 552     cond    = CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit]
 553     if_stmt = CmmCondBranch cond deflt_blk_id
 554
 555 mk_lit_switch scrut deflt_blk_id branches
 556   = do  { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
 557         ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
 558         ; lo_blk_id <- forkCgStmts lo_blk
 559         ; let if_stmt = CmmCondBranch cond lo_blk_id
 560         ; return (if_stmt `consCgStmt` hi_blk) }
 561   where
 562     n_branches = length branches
 563     (mid_lit,_) = branches !! (n_branches `div` 2)
 564         -- See notes above re mid_tag
 565
 566     (lo_branches, hi_branches) = span is_lo branches
 567     is_lo (t,_) = t < mid_lit
 568
 569     cond    = CmmMachOp (mkLtOp mid_lit)
 570                         [scrut, CmmLit (mkSimpleLit mid_lit)]
 571
 572 -------------------------------------------------------------------------
 573 --
 574 --      Simultaneous assignment
 575 --
 576 -------------------------------------------------------------------------
 577
 578
 579 emitSimultaneously :: CmmStmts -> Code
 580 -- Emit code to perform the assignments in the
 581 -- input simultaneously, using temporary variables when necessary.
 582 --
 583 -- The Stmts must be:
 584 --      CmmNop, CmmComment, CmmAssign, CmmStore
 585 -- and nothing else
 586
 587
 588 -- We use the strongly-connected component algorithm, in which
 589 --      * the vertices are the statements
 590 --      * an edge goes from s1 to s2 iff
 591 --              s1 assigns to something s2 uses
 592 --        that is, if s1 should *follow* s2 in the final order
 593
 594 type CVertex = (Int, CmmStmt)   -- Give each vertex a unique number,
 595                                 -- for fast comparison
 596
 597 emitSimultaneously stmts
 598   = codeOnly $
 599     case filterOut isNopStmt (stmtList stmts) of
 600         -- Remove no-ops
 601       []        -> nopC
 602       [stmt]    -> stmtC stmt   -- It's often just one stmt
 603       stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
 604
 605 doSimultaneously1 :: [CVertex] -> Code
 606 doSimultaneously1 vertices
 607   = let
 608         edges = [ (vertex, key1, edges_from stmt1)
 609                 | vertex@(key1, stmt1) <- vertices
 610                 ]
 611         edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
 612                                     stmt1 `mustFollow` stmt2
 613                            ]
 614         components = stronglyConnComp edges
 615
 616         -- do_components deal with one strongly-connected component
 617         -- Not cyclic, or singleton?  Just do it
 618         do_component (AcyclicSCC (n,stmt))  = stmtC stmt
 619         do_component (CyclicSCC [(n,stmt)]) = stmtC stmt
 620
 621                 -- Cyclic?  Then go via temporaries.  Pick one to
 622                 -- break the loop and try again with the rest.
 623         do_component (CyclicSCC ((n,first_stmt) : rest))
 624           = do  { from_temp <- go_via_temp first_stmt
 625                 ; doSimultaneously1 rest
 626                 ; stmtC from_temp }
 627
 628         go_via_temp (CmmAssign dest src)
 629           = do  { tmp <- newTemp (cmmRegRep dest)
 630                 ; stmtC (CmmAssign tmp src)
 631                 ; return (CmmAssign dest (CmmReg tmp)) }
 632         go_via_temp (CmmStore dest src)
 633           = do  { tmp <- newTemp (cmmExprRep src)
 634                 ; stmtC (CmmAssign tmp src)
 635                 ; return (CmmStore dest (CmmReg tmp)) }
 636     in
 637     mapCs do_component components
 638
 639 mustFollow :: CmmStmt -> CmmStmt -> Bool
 640 CmmAssign reg _  `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
 641 CmmStore loc e   `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprRep e)) stmt
 642 CmmNop           `mustFollow` stmt = False
 643 CmmComment _     `mustFollow` stmt = False
 644
 645
 646 anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
 647 -- True if the fn is true of any input of the stmt
 648 anySrc p (CmmAssign _ e)    = p e
 649 anySrc p (CmmStore e1 e2)   = p e1 || p e2      -- Might be used in either side
 650 anySrc p (CmmComment _)     = False
 651 anySrc p CmmNop             = False
 652 anySrc p other              = True              -- Conservative
 653
 654 regUsedIn :: CmmReg -> CmmExpr -> Bool
 655 reg `regUsedIn` CmmLit _         = False
 656 reg `regUsedIn` CmmLoad e  _     = reg `regUsedIn` e
 657 reg `regUsedIn` CmmReg reg'      = reg == reg'
 658 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
 659 reg `regUsedIn` CmmMachOp _ es   = any (reg `regUsedIn`) es
 660
 661 locUsedIn :: CmmExpr -> MachRep -> CmmExpr -> Bool
 662 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
 663 -- 'e'.  Returns True if it's not sure.
 664 locUsedIn loc rep (CmmLit _)         = False
 665 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
 666 locUsedIn loc rep (CmmReg reg')      = False
 667 locUsedIn loc rep (CmmRegOff reg' _) = False
 668 locUsedIn loc rep (CmmMachOp _ es)   = any (locUsedIn loc rep) es
 669
 670 possiblySameLoc :: CmmExpr -> MachRep -> CmmExpr -> MachRep -> Bool
 671 -- Assumes that distinct registers (eg Hp, Sp) do not
 672 -- point to the same location, nor any offset thereof.
 673 possiblySameLoc (CmmReg r1)       rep1 (CmmReg r2)      rep2  = r1==r2
 674 possiblySameLoc (CmmReg r1)       rep1 (CmmRegOff r2 0) rep2  = r1==r2
 675 possiblySameLoc (CmmRegOff r1 0)  rep1 (CmmReg r2)      rep2  = r1==r2
 676 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
 677   = r1==r2 && end1 > start2 && end2 > start1
 678   where
 679     end1 = start1 + machRepByteWidth rep1
 680     end2 = start2 + machRepByteWidth rep2
 681
 682 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
 683 possiblySameLoc l1 rep1 l2         rep2 = True  -- Conservative