StgCmmUtils.hs 22.5 KB
Newer Older
1 2
{-# LANGUAGE CPP #-}

3 4 5 6 7 8 9 10 11
-----------------------------------------------------------------------------
--
-- Code generator utilities; mostly monadic
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

module StgCmmUtils (
12 13
        cgLit, mkSimpleLit,
        emitDataLits, mkDataLits,
14
        emitRODataLits, mkRODataLits,
15
        emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
16
        assignTemp, newTemp,
17

18
        newUnboxedTupleRegs,
19

20
        emitMultiAssign, emitCmmLitSwitch, emitSwitch,
21

22
        tagToClosure, mkTaggedObjectLoad,
23

24
        callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
25

26
        cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
27
        cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
28 29 30 31 32 33
        cmmOffsetExprW, cmmOffsetExprB,
        cmmRegOffW, cmmRegOffB,
        cmmLabelOffW, cmmLabelOffB,
        cmmOffsetW, cmmOffsetB,
        cmmOffsetLitW, cmmOffsetLitB,
        cmmLoadIndexW,
34
        cmmConstrTag1,
35

36
        cmmUntag, cmmIsTagged,
37

nfrisby's avatar
nfrisby committed
38
        addToMem, addToMemE, addToMemLblE, addToMemLbl,
39 40
        mkWordCLit,
        newStringCLit, newByteStringCLit,
Simon Marlow's avatar
Simon Marlow committed
41
        blankWord
42 43 44 45 46 47
  ) where

#include "HsVersions.h"

import StgCmmMonad
import StgCmmClosure
48
import Cmm
49
import BlockId
50
import MkGraph
51
import CodeGen.Platform
52 53
import CLabel
import CmmUtils
54
import CmmSwitch
55 56 57 58 59 60

import ForeignCall
import IdInfo
import Type
import TyCon
import SMRep
61
import Module
62 63 64 65 66 67 68 69
import Literal
import Digraph
import Util
import Unique
import DynFlags
import FastString
import Outputable

70
import qualified Data.ByteString as BS
71
import qualified Data.Map as M
72
import Data.Char
73 74
import Data.List
import Data.Ord
75 76 77 78 79
import Data.Word


-------------------------------------------------------------------------
--
80
--      Literals
81 82 83 84
--
-------------------------------------------------------------------------

cgLit :: Literal -> FCode CmmLit
85
cgLit (MachStr s) = newByteStringCLit (BS.unpack s)
86
 -- not unpackFS; we want the UTF-8 byte stream.
87 88
cgLit other_lit   = do dflags <- getDynFlags
                       return (mkSimpleLit dflags other_lit)
89

90 91 92 93 94 95 96 97 98 99
mkSimpleLit :: DynFlags -> Literal -> CmmLit
mkSimpleLit dflags (MachChar   c)    = CmmInt (fromIntegral (ord c)) (wordWidth dflags)
mkSimpleLit dflags MachNullAddr      = zeroCLit dflags
mkSimpleLit dflags (MachInt i)       = CmmInt i (wordWidth dflags)
mkSimpleLit _      (MachInt64 i)     = CmmInt i W64
mkSimpleLit dflags (MachWord i)      = CmmInt i (wordWidth dflags)
mkSimpleLit _      (MachWord64 i)    = CmmInt i W64
mkSimpleLit _      (MachFloat r)     = CmmFloat r W32
mkSimpleLit _      (MachDouble r)    = CmmFloat r W64
mkSimpleLit _      (MachLabel fs ms fod)
100 101 102 103
        = CmmLabel (mkForeignLabel fs ms labelSrc fod)
        where
                -- TODO: Literal labels might not actually be in the current package...
                labelSrc = ForeignLabelInThisPackage
104
mkSimpleLit _ other             = pprPanic "mkSimpleLit" (ppr other)
105 106 107 108 109 110 111 112 113 114

--------------------------------------------------------------------------
--
-- Incrementing a memory location
--
--------------------------------------------------------------------------

addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n

nfrisby's avatar
nfrisby committed
115 116 117
addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))

118 119 120 121
addToMem :: CmmType     -- rep of the counter
         -> CmmExpr     -- Address
         -> Int         -- What to add (a word)
         -> CmmAGraph
122 123
addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))

124 125 126 127
addToMemE :: CmmType    -- rep of the counter
          -> CmmExpr    -- Address
          -> CmmExpr    -- What to add (a word-typed expression)
          -> CmmAGraph
128 129 130 131 132 133
addToMemE rep ptr n
  = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])


-------------------------------------------------------------------------
--
134 135
--      Loading a field from an object,
--      where the object pointer is itself tagged
136 137 138
--
-------------------------------------------------------------------------

139 140
mkTaggedObjectLoad
  :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
141
-- (loadTaggedObjectField reg base off tag) generates assignment
142
--      reg = bitsK[ base + off - tag ]
143
-- where K is fixed by 'reg'
144
mkTaggedObjectLoad dflags reg base offset tag
145
  = mkAssign (CmmLocal reg)
146 147
             (CmmLoad (cmmOffsetB dflags
                                  (CmmReg (CmmLocal base))
148
                                  (offset - tag))
149 150 151 152
                      (localRegType reg))

-------------------------------------------------------------------------
--
153
--      Converting a closure tag to a closure for enumeration types
154 155 156 157
--      (this is the implementation of tagToEnum#).
--
-------------------------------------------------------------------------

158 159 160
tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
tagToClosure dflags tycon tag
  = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)
161
  where closure_tbl = CmmLit (CmmLabel lbl)
162
        lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
163 164 165

-------------------------------------------------------------------------
--
166
--      Conditionals and rts calls
167 168 169
--
-------------------------------------------------------------------------

170
emitRtsCall :: PackageKey -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
171
emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
172

173
emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageKey -> FastString
174
        -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
175
emitRtsCallWithResult res hint pkg fun args safe
176
   = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe
177 178

-- Make a call to an RTS C procedure
179
emitRtsCallGen
180
   :: [(LocalReg,ForeignHint)]
181
   -> CLabel
182 183 184
   -> [(CmmExpr,ForeignHint)]
   -> Bool -- True <=> CmmSafe call
   -> FCode ()
185
emitRtsCallGen res lbl args safe
186 187 188
  = do { dflags <- getDynFlags
       ; updfr_off <- getUpdFrameOff
       ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags
189
       ; emit caller_save
190
       ; call updfr_off
191 192
       ; emit caller_load }
  where
193 194
    call updfr_off =
      if safe then
195
        emit =<< mkCmmCall fun_expr res' args' updfr_off
196 197 198
      else do
        let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
        emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
199 200
    (args', arg_hints) = unzip args
    (res',  res_hints) = unzip res
201
    fun_expr = mkLblExpr lbl
202 203 204 205


-----------------------------------------------------------------------------
--
206
--      Caller-Save Registers
207 208 209 210 211 212 213 214 215 216
--
-----------------------------------------------------------------------------

-- Here we generate the sequence of saves/restores required around a
-- foreign call instruction.

-- TODO: reconcile with includes/Regs.h
--  * Regs.h claims that BaseReg should be saved last and loaded first
--    * This might not have been tickled before since BaseReg is callee save
--  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
217 218 219
--
-- This code isn't actually used right now, because callerSaves
-- only ever returns true in the current universe for registers NOT in
220
-- system_regs (just do a grep for CALLER_SAVES in
221 222 223 224 225 226 227 228 229 230 231 232 233
-- includes/stg/MachRegs.h).  It's all one giant no-op, and for
-- good reason: having to save system registers on every foreign call
-- would be very expensive, so we avoid assigning them to those
-- registers when we add support for an architecture.
--
-- Note that the old code generator actually does more work here: it
-- also saves other global registers.  We can't (nor want) to do that
-- here, as we don't have liveness information.  And really, we
-- shouldn't be doing the workaround at this point in the pipeline, see
-- Note [Register parameter passing] and the ToDo on CmmCall in
-- cmm/CmmNode.hs.  Right now the workaround is to avoid inlining across
-- unsafe foreign calls in rewriteAssignments, but this is strictly
-- temporary.
234 235
callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs dflags = (caller_save, caller_load)
236
  where
237 238
    platform = targetPlatform dflags

239 240 241
    caller_save = catAGraphs (map callerSaveGlobalReg    regs_to_save)
    caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)

242
    system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
243 244
                    {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
                  , BaseReg ]
245

246
    regs_to_save = filter (callerSaves platform) system_regs
247 248

    callerSaveGlobalReg reg
249
        = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
250 251

    callerRestoreGlobalReg reg
252
        = mkAssign (CmmGlobal reg)
253
                    (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))
254 255 256 257 258 259

-- -----------------------------------------------------------------------------
-- Global registers

-- We map STG registers onto appropriate CmmExprs.  Either they map
-- to real machine registers or stored as offsets from BaseReg.  Given
260
-- a GlobalReg, get_GlobalReg_addr always produces the
261 262 263
-- register table address for it.
-- (See also get_GlobalReg_reg_or_addr in MachRegs)

264
get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr
265
get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0
266
get_GlobalReg_addr dflags mid
267 268
    = get_Regtable_addr_from_offset dflags
                                    (globalRegType dflags mid) (baseRegOffset dflags mid)
269 270 271

-- Calculate a literal representing an offset into the register table.
-- Used when we don't have an actual BaseReg to offset from.
272 273 274
regTableOffset :: DynFlags -> Int -> CmmExpr
regTableOffset dflags n =
  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))
275

276 277 278
get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
get_Regtable_addr_from_offset dflags _rep offset =
    if haveRegBase (targetPlatform dflags)
279
    then CmmRegOff (CmmGlobal BaseReg) offset
280
    else regTableOffset dflags offset
281 282 283 284 285


-- -----------------------------------------------------------------------------
-- Information about global registers

286 287 288 289 290 291 292 293 294 295 296 297 298 299
baseRegOffset :: DynFlags -> GlobalReg -> Int

baseRegOffset dflags Sp             = oFFSET_StgRegTable_rSp dflags
baseRegOffset dflags SpLim          = oFFSET_StgRegTable_rSpLim dflags
baseRegOffset dflags (LongReg 1)    = oFFSET_StgRegTable_rL1 dflags
baseRegOffset dflags Hp             = oFFSET_StgRegTable_rHp dflags
baseRegOffset dflags HpLim          = oFFSET_StgRegTable_rHpLim dflags
baseRegOffset dflags CCCS           = oFFSET_StgRegTable_rCCCS dflags
baseRegOffset dflags CurrentTSO     = oFFSET_StgRegTable_rCurrentTSO dflags
baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags
baseRegOffset dflags HpAlloc        = oFFSET_StgRegTable_rHpAlloc dflags
baseRegOffset dflags GCEnter1       = oFFSET_stgGCEnter1 dflags
baseRegOffset dflags GCFun          = oFFSET_stgGCFun dflags
baseRegOffset _      reg            = pprPanic "baseRegOffset:" (ppr reg)
300 301 302

-------------------------------------------------------------------------
--
303
--      Strings generate a top-level data block
304 305 306 307 308
--
-------------------------------------------------------------------------

emitDataLits :: CLabel -> [CmmLit] -> FCode ()
-- Emit a data-segment data block
309
emitDataLits lbl lits = emitDecl (mkDataLits Data lbl lits)
310 311 312

emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
-- Emit a read-only data block
313 314 315
emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)

newStringCLit :: String -> FCode CmmLit
316 317
-- Make a global definition for the string,
-- and return its label
318
newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str)
319

320 321
newByteStringCLit :: [Word8] -> FCode CmmLit
newByteStringCLit bytes
322 323 324 325
  = do  { uniq <- newUnique
        ; let (lit, decl) = mkByteStringCLit uniq bytes
        ; emitDecl decl
        ; return lit }
326 327 328

-------------------------------------------------------------------------
--
329
--      Assigning expressions to temporaries
330 331 332 333
--
-------------------------------------------------------------------------

assignTemp :: CmmExpr -> FCode LocalReg
334 335 336 337 338 339 340
-- Make sure the argument is in a local register.
-- We don't bother being particularly aggressive with avoiding
-- unnecessary local registers, since we can rely on a later
-- optimization pass to inline as necessary (and skipping out
-- on things like global registers can be a little dangerous
-- due to them being trashed on foreign calls--though it means
-- the optimization pass doesn't have to do as much work)
341
assignTemp (CmmReg (CmmLocal reg)) = return reg
342 343 344
assignTemp e = do { dflags <- getDynFlags
                  ; uniq <- newUnique
                  ; let reg = LocalReg uniq (cmmExprType dflags e)
345
                  ; emitAssign (CmmLocal reg) e
346
                  ; return reg }
347 348 349

newTemp :: CmmType -> FCode LocalReg
newTemp rep = do { uniq <- newUnique
350
                 ; return (LocalReg uniq rep) }
351 352 353

newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
-- Choose suitable local regs to use for the components
354
-- of an unboxed tuple that we are about to return to
355
-- the Sequel.  If the Sequel is a join point, using the
356
-- regs it wants will save later assignments.
357
newUnboxedTupleRegs res_ty
358
  = ASSERT( isUnboxedTupleType res_ty )
359 360 361
    do  { dflags <- getDynFlags
        ; sequel <- getSequel
        ; regs <- choose_regs dflags sequel
362 363
        ; ASSERT( regs `equalLength` reps )
          return (regs, map primRepForeignHint reps) }
364
  where
365
    UbxTupleRep ty_args = repType res_ty
366
    reps = [ rep
367 368 369
           | ty <- ty_args
           , let rep = typePrimRep ty
           , not (isVoidRep rep) ]
370 371
    choose_regs _ (AssignTo regs _) = return regs
    choose_regs dflags _            = mapM (newTemp . primRepCmmType dflags) reps
372 373 374 375



-------------------------------------------------------------------------
376
--      emitMultiAssign
377 378
-------------------------------------------------------------------------

379
emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
380 381 382 383
-- Emit code to perform the assignments in the
-- input simultaneously, using temporary variables when necessary.

type Key  = Int
384 385 386
type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
                        -- for fast comparison
type Stmt = (LocalReg, CmmExpr) -- r := e
387 388

-- We use the strongly-connected component algorithm, in which
389 390 391 392
--      * the vertices are the statements
--      * an edge goes from s1 to s2 iff
--              s1 assigns to something s2 uses
--        that is, if s1 should *follow* s2 in the final order
393

394 395
emitMultiAssign []    []    = return ()
emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs
396 397 398 399
emitMultiAssign regs rhss   = do
  dflags <- getDynFlags
  ASSERT( equalLength regs rhss )
    unscramble dflags ([1..] `zip` (regs `zip` rhss))
400

401 402
unscramble :: DynFlags -> [Vrtx] -> FCode ()
unscramble dflags vertices = mapM_ do_component components
403
  where
404 405 406
        edges :: [ (Vrtx, Key, [Key]) ]
        edges = [ (vertex, key1, edges_from stmt1)
                | vertex@(key1, stmt1) <- vertices ]
407

408 409 410
        edges_from :: Stmt -> [Key]
        edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
                                    stmt1 `mustFollow` stmt2 ]
411

412 413
        components :: [SCC Vrtx]
        components = stronglyConnCompFromEdgedVertices edges
414

415 416
        -- do_components deal with one strongly-connected component
        -- Not cyclic, or singleton?  Just do it
417 418
        do_component :: SCC Vrtx -> FCode ()
        do_component (AcyclicSCC (_,stmt))  = mk_graph stmt
419 420
        do_component (CyclicSCC [])         = panic "do_component"
        do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt
421

422 423
                -- Cyclic?  Then go via temporaries.  Pick one to
                -- break the loop and try again with the rest.
424
        do_component (CyclicSCC ((_,first_stmt) : rest)) = do
425
            dflags <- getDynFlags
426
            u <- newUnique
427
            let (to_tmp, from_tmp) = split dflags u first_stmt
428
            mk_graph to_tmp
429
            unscramble dflags rest
430
            mk_graph from_tmp
431

432 433
        split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)
        split dflags uniq (reg, rhs)
434 435
          = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
          where
436
            rep = cmmExprType dflags rhs
437
            tmp = LocalReg uniq rep
438

439 440
        mk_graph :: Stmt -> FCode ()
        mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs
441

442 443
        mustFollow :: Stmt -> Stmt -> Bool
        (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs
444 445

-------------------------------------------------------------------------
446
--      mkSwitch
447 448 449
-------------------------------------------------------------------------


Peter Wortmann's avatar
Peter Wortmann committed
450 451 452 453 454 455
emitSwitch :: CmmExpr                      -- Tag to switch on
           -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches
           -> Maybe CmmAGraphScoped        -- Default branch (if any)
           -> ConTagZ -> ConTagZ           -- Min and Max possible values;
                                           -- behaviour outside this range is
                                           -- undefined
456
           -> FCode ()
457 458

-- First, two rather common cases in which there is no work to do
459 460
emitSwitch _ []         (Just code) _ _ = emit (fst code)
emitSwitch _ [(_,code)] Nothing     _ _ = emit (fst code)
461 462

-- Right, off we go
463
emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do
464 465 466 467
    join_lbl      <- newLabelC
    mb_deflt_lbl  <- label_default join_lbl mb_deflt
    branches_lbls <- label_branches join_lbl branches
    tag_expr'     <- assignTemp' tag_expr
468

469 470 471
    -- Sort the branches before calling mk_discrete_switch
    let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]
    let range = (fromIntegral lo_tag, fromIntegral hi_tag)
472

473
    emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range
474 475

    emitLabel join_lbl
476

477 478 479
mk_discrete_switch :: Bool -- ^ Use signed comparisons
          -> CmmExpr
          -> [(Integer, BlockId)]
480
          -> Maybe BlockId
481 482
          -> (Integer, Integer)
          -> CmmAGraph
483 484

-- SINGLETON TAG RANGE: no case analysis to do
485
mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)
486 487
  | lo_tag == hi_tag
  = ASSERT( tag == lo_tag )
488
    mkBranch lbl
489 490

-- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
491 492
mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _
  = mkBranch lbl
493 494 495 496 497
        -- The simplifier might have eliminated a case
        --       so we may have e.g. case xs of
        --                               [] -> e
        -- In that situation we can be sure the (:) case
        -- can't happen, so no need to test
498

499 500 501 502
-- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans
-- See Note [Cmm Switches, the general plan] in CmmSwitch
mk_discrete_switch signed tag_expr branches mb_deflt range
  = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)
503

504 505 506 507 508 509 510
divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])
divideBranches branches = (lo_branches, mid, hi_branches)
  where
    -- 2 branches => n_branches `div` 2 = 1
    --            => branches !! 1 give the *second* tag
    -- There are always at least 2 branches here
    (mid,_) = branches !! (length branches `div` 2)
511
    (lo_branches, hi_branches) = span is_lo branches
512
    is_lo (t,_) = t < mid
513 514

--------------
Peter Wortmann's avatar
Peter Wortmann committed
515 516 517 518 519
emitCmmLitSwitch :: CmmExpr                    -- Tag to switch on
               -> [(Literal, CmmAGraphScoped)] -- Tagged branches
               -> CmmAGraphScoped              -- Default branch (always)
               -> FCode ()                     -- Emit the code
emitCmmLitSwitch _scrut []       deflt = emit $ fst deflt
520 521 522 523 524
emitCmmLitSwitch scrut  branches deflt = do
    scrut' <- assignTemp' scrut
    join_lbl <- newLabelC
    deflt_lbl <- label_code join_lbl deflt
    branches_lbls <- label_branches join_lbl branches
525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546

    dflags <- getDynFlags
    let cmm_ty = cmmExprType dflags scrut
        rep = typeWidth cmm_ty

    -- We find the necessary type information in the literals in the branches
    let signed = case head branches of
                    (MachInt _, _) ->   True
                    (MachInt64 _, _) -> True
                    _ -> False

    let range | signed    = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)
              | otherwise = (0, tARGET_MAX_WORD dflags)

    if isFloatType cmm_ty
    then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls
    else emit $ mk_discrete_switch
        signed
        scrut'
        [(litValue lit,l) | (lit,l) <- branches_lbls]
        (Just deflt_lbl)
        range
547
    emitLabel join_lbl
548

549 550 551 552 553 554
-- | lower bound (inclusive), upper bound (exclusive)
type LitBound = (Maybe Literal, Maybe Literal)

noBound :: LitBound
noBound = (Nothing, Nothing)

555
mk_float_switch :: Width -> CmmExpr -> BlockId
556
              -> LitBound
557
              -> [(Literal,BlockId)]
558
              -> FCode CmmAGraph
559 560
mk_float_switch rep scrut deflt _bounds [(lit,blk)]
  = do dflags <- getDynFlags
561
       return $ mkCbranch (cond dflags) deflt blk Nothing
562
  where
563 564 565 566
    cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]
      where
        cmm_lit = mkSimpleLit dflags lit
        ne      = MO_F_Ne rep
567

568
mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches
569
  = do dflags <- getDynFlags
570 571
       lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches
       hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches
572
       mkCmmIfThenElse (cond dflags) lo_blk hi_blk
573
  where
574
    (lo_branches, mid_lit, hi_branches) = divideBranches branches
575

576 577 578
    bounds_lo = (lo_bound, Just mid_lit)
    bounds_hi = (Just mid_lit, hi_bound)

579 580 581 582
    cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]
      where
        cmm_lit = mkSimpleLit dflags mid_lit
        lt      = MO_F_Lt rep
583 584 585


--------------
Peter Wortmann's avatar
Peter Wortmann committed
586
label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
587 588 589 590 591
label_default _ Nothing
  = return  Nothing
label_default join_lbl (Just code)
  = do lbl <- label_code join_lbl code
       return (Just lbl)
592 593

--------------
Peter Wortmann's avatar
Peter Wortmann committed
594
label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
595 596 597 598 599 600
label_branches _join_lbl []
  = return []
label_branches join_lbl ((tag,code):branches)
  = do lbl <- label_code join_lbl code
       branches' <- label_branches join_lbl branches
       return ((tag,lbl):branches')
601 602

--------------
Peter Wortmann's avatar
Peter Wortmann committed
603
label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
604
--  label_code J code
605
--      generates
606 607
--  [L: code; goto J]
-- and returns L
Peter Wortmann's avatar
Peter Wortmann committed
608
label_code join_lbl (code,tsc) = do
609
    lbl <- newLabelC
Peter Wortmann's avatar
Peter Wortmann committed
610
    emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)
611
    return lbl
612 613

--------------
614 615 616 617
assignTemp' :: CmmExpr -> FCode CmmExpr
assignTemp' e
  | isTrivialCmmExpr e = return e
  | otherwise = do
618 619
       dflags <- getDynFlags
       lreg <- newTemp (cmmExprType dflags e)
620 621 622
       let reg = CmmLocal lreg
       emitAssign reg e
       return (CmmReg reg)