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