compiler/codeGen/CgUtils.hs

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