94013f5c6db2147d1c25fcca1905b38aec969f7d
[ghc.git] / compiler / codeGen / StgCmmUtils.hs
1 {-# LANGUAGE CPP #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Code generator utilities; mostly monadic
6 --
7 -- (c) The University of Glasgow 2004-2006
8 --
9 -----------------------------------------------------------------------------
10
11 module StgCmmUtils (
12 cgLit, mkSimpleLit,
13 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 cmmOffsetExprW, cmmOffsetExprB,
29 cmmRegOffW, cmmRegOffB,
30 cmmLabelOffW, cmmLabelOffB,
31 cmmOffsetW, cmmOffsetB,
32 cmmOffsetLitW, cmmOffsetLitB,
33 cmmLoadIndexW,
34 cmmConstrTag1,
35
36 cmmUntag, cmmIsTagged,
37
38 addToMem, addToMemE, addToMemLblE, addToMemLbl,
39 mkWordCLit,
40 newStringCLit, newByteStringCLit,
41 blankWord,
42 ) where
43
44 #include "HsVersions.h"
45
46 import GhcPrelude
47
48 import StgCmmMonad
49 import StgCmmClosure
50 import Cmm
51 import BlockId
52 import MkGraph
53 import CodeGen.Platform
54 import CLabel
55 import CmmUtils
56 import CmmSwitch
57
58 import ForeignCall
59 import IdInfo
60 import Type
61 import TyCon
62 import SMRep
63 import Module
64 import Literal
65 import Digraph
66 import Util
67 import Unique
68 import UniqSupply (MonadUnique(..))
69 import DynFlags
70 import FastString
71 import Outputable
72 import RepType
73
74 import qualified Data.ByteString as BS
75 import qualified Data.Map as M
76 import Data.Char
77 import Data.List
78 import Data.Ord
79 import Data.Word
80
81
82 -------------------------------------------------------------------------
83 --
84 -- Literals
85 --
86 -------------------------------------------------------------------------
87
88 cgLit :: Literal -> FCode CmmLit
89 cgLit (MachStr s) = newByteStringCLit (BS.unpack s)
90 -- not unpackFS; we want the UTF-8 byte stream.
91 cgLit other_lit = do dflags <- getDynFlags
92 return (mkSimpleLit dflags other_lit)
93
94 mkSimpleLit :: DynFlags -> Literal -> CmmLit
95 mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags)
96 mkSimpleLit dflags MachNullAddr = zeroCLit dflags
97 mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags)
98 mkSimpleLit _ (MachInt64 i) = CmmInt i W64
99 mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags)
100 mkSimpleLit _ (MachWord64 i) = CmmInt i W64
101 mkSimpleLit _ (MachFloat r) = CmmFloat r W32
102 mkSimpleLit _ (MachDouble r) = CmmFloat r W64
103 mkSimpleLit _ (MachLabel fs ms fod)
104 = CmmLabel (mkForeignLabel fs ms labelSrc fod)
105 where
106 -- TODO: Literal labels might not actually be in the current package...
107 labelSrc = ForeignLabelInThisPackage
108 mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other)
109
110 --------------------------------------------------------------------------
111 --
112 -- Incrementing a memory location
113 --
114 --------------------------------------------------------------------------
115
116 addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
117 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
118
119 addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
120 addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))
121
122 addToMem :: CmmType -- rep of the counter
123 -> CmmExpr -- Address
124 -> Int -- What to add (a word)
125 -> CmmAGraph
126 addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))
127
128 addToMemE :: CmmType -- rep of the counter
129 -> CmmExpr -- Address
130 -> CmmExpr -- What to add (a word-typed expression)
131 -> CmmAGraph
132 addToMemE rep ptr n
133 = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])
134
135
136 -------------------------------------------------------------------------
137 --
138 -- Loading a field from an object,
139 -- where the object pointer is itself tagged
140 --
141 -------------------------------------------------------------------------
142
143 mkTaggedObjectLoad
144 :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
145 -- (loadTaggedObjectField reg base off tag) generates assignment
146 -- reg = bitsK[ base + off - tag ]
147 -- where K is fixed by 'reg'
148 mkTaggedObjectLoad dflags reg base offset tag
149 = mkAssign (CmmLocal reg)
150 (CmmLoad (cmmOffsetB dflags
151 (CmmReg (CmmLocal base))
152 (offset - tag))
153 (localRegType reg))
154
155 -------------------------------------------------------------------------
156 --
157 -- Converting a closure tag to a closure for enumeration types
158 -- (this is the implementation of tagToEnum#).
159 --
160 -------------------------------------------------------------------------
161
162 tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
163 tagToClosure dflags tycon tag
164 = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)
165 where closure_tbl = CmmLit (CmmLabel lbl)
166 lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
167
168 -------------------------------------------------------------------------
169 --
170 -- Conditionals and rts calls
171 --
172 -------------------------------------------------------------------------
173
174 emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
175 emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
176
177 emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString
178 -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
179 emitRtsCallWithResult res hint pkg fun args safe
180 = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe
181
182 -- Make a call to an RTS C procedure
183 emitRtsCallGen
184 :: [(LocalReg,ForeignHint)]
185 -> CLabel
186 -> [(CmmExpr,ForeignHint)]
187 -> Bool -- True <=> CmmSafe call
188 -> FCode ()
189 emitRtsCallGen res lbl args safe
190 = do { dflags <- getDynFlags
191 ; updfr_off <- getUpdFrameOff
192 ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags
193 ; emit caller_save
194 ; call updfr_off
195 ; emit caller_load }
196 where
197 call updfr_off =
198 if safe then
199 emit =<< mkCmmCall fun_expr res' args' updfr_off
200 else do
201 let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
202 emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
203 (args', arg_hints) = unzip args
204 (res', res_hints) = unzip res
205 fun_expr = mkLblExpr lbl
206
207
208 -----------------------------------------------------------------------------
209 --
210 -- Caller-Save Registers
211 --
212 -----------------------------------------------------------------------------
213
214 -- Here we generate the sequence of saves/restores required around a
215 -- foreign call instruction.
216
217 -- TODO: reconcile with includes/Regs.h
218 -- * Regs.h claims that BaseReg should be saved last and loaded first
219 -- * This might not have been tickled before since BaseReg is callee save
220 -- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
221 --
222 -- This code isn't actually used right now, because callerSaves
223 -- only ever returns true in the current universe for registers NOT in
224 -- system_regs (just do a grep for CALLER_SAVES in
225 -- includes/stg/MachRegs.h). It's all one giant no-op, and for
226 -- good reason: having to save system registers on every foreign call
227 -- would be very expensive, so we avoid assigning them to those
228 -- registers when we add support for an architecture.
229 --
230 -- Note that the old code generator actually does more work here: it
231 -- also saves other global registers. We can't (nor want) to do that
232 -- here, as we don't have liveness information. And really, we
233 -- shouldn't be doing the workaround at this point in the pipeline, see
234 -- Note [Register parameter passing] and the ToDo on CmmCall in
235 -- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across
236 -- unsafe foreign calls in rewriteAssignments, but this is strictly
237 -- temporary.
238 callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)
239 callerSaveVolatileRegs dflags = (caller_save, caller_load)
240 where
241 platform = targetPlatform dflags
242
243 caller_save = catAGraphs (map callerSaveGlobalReg regs_to_save)
244 caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
245
246 system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
247 {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
248 , BaseReg ]
249
250 regs_to_save = filter (callerSaves platform) system_regs
251
252 callerSaveGlobalReg reg
253 = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
254
255 callerRestoreGlobalReg reg
256 = mkAssign (CmmGlobal reg)
257 (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))
258
259 -- -----------------------------------------------------------------------------
260 -- Global registers
261
262 -- We map STG registers onto appropriate CmmExprs. Either they map
263 -- to real machine registers or stored as offsets from BaseReg. Given
264 -- a GlobalReg, get_GlobalReg_addr always produces the
265 -- register table address for it.
266 -- (See also get_GlobalReg_reg_or_addr in MachRegs)
267
268 get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr
269 get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0
270 get_GlobalReg_addr dflags mid
271 = get_Regtable_addr_from_offset dflags
272 (globalRegType dflags mid) (baseRegOffset dflags mid)
273
274 -- Calculate a literal representing an offset into the register table.
275 -- Used when we don't have an actual BaseReg to offset from.
276 regTableOffset :: DynFlags -> Int -> CmmExpr
277 regTableOffset dflags n =
278 CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))
279
280 get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
281 get_Regtable_addr_from_offset dflags _rep offset =
282 if haveRegBase (targetPlatform dflags)
283 then CmmRegOff baseReg offset
284 else regTableOffset dflags offset
285
286
287 -- -----------------------------------------------------------------------------
288 -- Information about global registers
289
290 baseRegOffset :: DynFlags -> GlobalReg -> Int
291
292 baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags
293 baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags
294 baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags
295 baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags
296 baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags
297 baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags
298 baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags
299 baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags
300 baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags
301 baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags
302 baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags
303 baseRegOffset _ reg = pprPanic "StgCmmUtils.baseRegOffset:" (ppr reg)
304
305 -------------------------------------------------------------------------
306 --
307 -- Strings generate a top-level data block
308 --
309 -------------------------------------------------------------------------
310
311 emitDataLits :: CLabel -> [CmmLit] -> FCode ()
312 -- Emit a data-segment data block
313 emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)
314
315 emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
316 -- Emit a read-only data block
317 emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
318
319 newStringCLit :: String -> FCode CmmLit
320 -- Make a global definition for the string,
321 -- and return its label
322 newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str)
323
324 newByteStringCLit :: [Word8] -> FCode CmmLit
325 newByteStringCLit bytes
326 = do { uniq <- newUnique
327 ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes
328 ; emitDecl decl
329 ; return lit }
330
331 -------------------------------------------------------------------------
332 --
333 -- Assigning expressions to temporaries
334 --
335 -------------------------------------------------------------------------
336
337 assignTemp :: CmmExpr -> FCode LocalReg
338 -- Make sure the argument is in a local register.
339 -- We don't bother being particularly aggressive with avoiding
340 -- unnecessary local registers, since we can rely on a later
341 -- optimization pass to inline as necessary (and skipping out
342 -- on things like global registers can be a little dangerous
343 -- due to them being trashed on foreign calls--though it means
344 -- the optimization pass doesn't have to do as much work)
345 assignTemp (CmmReg (CmmLocal reg)) = return reg
346 assignTemp e = do { dflags <- getDynFlags
347 ; uniq <- newUnique
348 ; let reg = LocalReg uniq (cmmExprType dflags e)
349 ; emitAssign (CmmLocal reg) e
350 ; return reg }
351
352 newTemp :: MonadUnique m => CmmType -> m LocalReg
353 newTemp rep = do { uniq <- getUniqueM
354 ; return (LocalReg uniq rep) }
355
356 newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
357 -- Choose suitable local regs to use for the components
358 -- of an unboxed tuple that we are about to return to
359 -- the Sequel. If the Sequel is a join point, using the
360 -- regs it wants will save later assignments.
361 newUnboxedTupleRegs res_ty
362 = ASSERT( isUnboxedTupleType res_ty )
363 do { dflags <- getDynFlags
364 ; sequel <- getSequel
365 ; regs <- choose_regs dflags sequel
366 ; ASSERT( regs `equalLength` reps )
367 return (regs, map primRepForeignHint reps) }
368 where
369 reps = typePrimRep res_ty
370 choose_regs _ (AssignTo regs _) = return regs
371 choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps
372
373
374
375 -------------------------------------------------------------------------
376 -- emitMultiAssign
377 -------------------------------------------------------------------------
378
379 emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
380 -- Emit code to perform the assignments in the
381 -- input simultaneously, using temporary variables when necessary.
382
383 type Key = Int
384 type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
385 -- for fast comparison
386 type Stmt = (LocalReg, CmmExpr) -- r := e
387
388 -- We use the strongly-connected component algorithm, in which
389 -- * the vertices are the statements
390 -- * an edge goes from s1 to s2 iff
391 -- s1 assigns to something s2 uses
392 -- that is, if s1 should *follow* s2 in the final order
393
394 emitMultiAssign [] [] = return ()
395 emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs
396 emitMultiAssign regs rhss = do
397 dflags <- getDynFlags
398 ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )
399 unscramble dflags ([1..] `zip` (regs `zip` rhss))
400
401 unscramble :: DynFlags -> [Vrtx] -> FCode ()
402 unscramble dflags vertices = mapM_ do_component components
403 where
404 edges :: [ Node Key Vrtx ]
405 edges = [ DigraphNode vertex key1 (edges_from stmt1)
406 | vertex@(key1, stmt1) <- vertices ]
407
408 edges_from :: Stmt -> [Key]
409 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
410 stmt1 `mustFollow` stmt2 ]
411
412 components :: [SCC Vrtx]
413 components = stronglyConnCompFromEdgedVerticesUniq edges
414
415 -- do_components deal with one strongly-connected component
416 -- Not cyclic, or singleton? Just do it
417 do_component :: SCC Vrtx -> FCode ()
418 do_component (AcyclicSCC (_,stmt)) = mk_graph stmt
419 do_component (CyclicSCC []) = panic "do_component"
420 do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt
421
422 -- Cyclic? Then go via temporaries. Pick one to
423 -- 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 split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)
433 split dflags uniq (reg, rhs)
434 = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
435 where
436 rep = cmmExprType dflags rhs
437 tmp = LocalReg uniq rep
438
439 mk_graph :: Stmt -> FCode ()
440 mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs
441
442 mustFollow :: Stmt -> Stmt -> Bool
443 (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs
444
445 -------------------------------------------------------------------------
446 -- mkSwitch
447 -------------------------------------------------------------------------
448
449
450 emitSwitch :: CmmExpr -- Tag to switch on
451 -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches
452 -> Maybe CmmAGraphScoped -- Default branch (if any)
453 -> ConTagZ -> ConTagZ -- Min and Max possible values;
454 -- behaviour outside this range is
455 -- undefined
456 -> FCode ()
457
458 -- First, two rather common cases in which there is no work to do
459 emitSwitch _ [] (Just code) _ _ = emit (fst code)
460 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 join_lbl <- newBlockId
465 mb_deflt_lbl <- label_default join_lbl mb_deflt
466 branches_lbls <- label_branches join_lbl branches
467 tag_expr' <- assignTemp' tag_expr
468
469 -- Sort the branches before calling mk_discrete_switch
470 let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]
471 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 mk_discrete_switch :: Bool -- ^ Use signed comparisons
478 -> CmmExpr
479 -> [(Integer, BlockId)]
480 -> Maybe BlockId
481 -> (Integer, Integer)
482 -> CmmAGraph
483
484 -- SINGLETON TAG RANGE: no case analysis to do
485 mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)
486 | lo_tag == hi_tag
487 = ASSERT( tag == lo_tag )
488 mkBranch lbl
489
490 -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
491 mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _
492 = mkBranch lbl
493 -- The simplifier might have eliminated a case
494 -- so we may have e.g. case xs of
495 -- [] -> e
496 -- In that situation we can be sure the (:) case
497 -- can't happen, so no need to test
498
499 -- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans
500 -- See Note [Cmm Switches, the general plan] in CmmSwitch
501 mk_discrete_switch signed tag_expr branches mb_deflt range
502 = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)
503
504 divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])
505 divideBranches branches = (lo_branches, mid, hi_branches)
506 where
507 -- 2 branches => n_branches `div` 2 = 1
508 -- => branches !! 1 give the *second* tag
509 -- There are always at least 2 branches here
510 (mid,_) = branches !! (length branches `div` 2)
511 (lo_branches, hi_branches) = span is_lo branches
512 is_lo (t,_) = t < mid
513
514 --------------
515 emitCmmLitSwitch :: CmmExpr -- Tag to switch on
516 -> [(Literal, CmmAGraphScoped)] -- Tagged branches
517 -> CmmAGraphScoped -- Default branch (always)
518 -> FCode () -- Emit the code
519 emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt
520 emitCmmLitSwitch scrut branches deflt = do
521 scrut' <- assignTemp' scrut
522 join_lbl <- newBlockId
523 deflt_lbl <- label_code join_lbl deflt
524 branches_lbls <- label_branches join_lbl branches
525
526 dflags <- getDynFlags
527 let cmm_ty = cmmExprType dflags scrut
528 rep = typeWidth cmm_ty
529
530 -- We find the necessary type information in the literals in the branches
531 let signed = case head branches of
532 (MachInt _, _) -> True
533 (MachInt64 _, _) -> True
534 _ -> False
535
536 let range | signed = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)
537 | otherwise = (0, tARGET_MAX_WORD dflags)
538
539 if isFloatType cmm_ty
540 then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls
541 else emit $ mk_discrete_switch
542 signed
543 scrut'
544 [(litValue lit,l) | (lit,l) <- branches_lbls]
545 (Just deflt_lbl)
546 range
547 emitLabel join_lbl
548
549 -- | lower bound (inclusive), upper bound (exclusive)
550 type LitBound = (Maybe Literal, Maybe Literal)
551
552 noBound :: LitBound
553 noBound = (Nothing, Nothing)
554
555 mk_float_switch :: Width -> CmmExpr -> BlockId
556 -> LitBound
557 -> [(Literal,BlockId)]
558 -> FCode CmmAGraph
559 mk_float_switch rep scrut deflt _bounds [(lit,blk)]
560 = do dflags <- getDynFlags
561 return $ mkCbranch (cond dflags) deflt blk Nothing
562 where
563 cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]
564 where
565 cmm_lit = mkSimpleLit dflags lit
566 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 lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches
571 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 bounds_lo = (lo_bound, Just mid_lit)
577 bounds_hi = (Just mid_lit, hi_bound)
578
579 cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]
580 where
581 cmm_lit = mkSimpleLit dflags mid_lit
582 lt = MO_F_Lt rep
583
584
585 --------------
586 label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
587 label_default _ Nothing
588 = return Nothing
589 label_default join_lbl (Just code)
590 = do lbl <- label_code join_lbl code
591 return (Just lbl)
592
593 --------------
594 label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
595 label_branches _join_lbl []
596 = return []
597 label_branches join_lbl ((tag,code):branches)
598 = do lbl <- label_code join_lbl code
599 branches' <- label_branches join_lbl branches
600 return ((tag,lbl):branches')
601
602 --------------
603 label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
604 -- label_code J code
605 -- generates
606 -- [L: code; goto J]
607 -- and returns L
608 label_code join_lbl (code,tsc) = do
609 lbl <- newBlockId
610 emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)
611 return lbl
612
613 --------------
614 assignTemp' :: CmmExpr -> FCode CmmExpr
615 assignTemp' e
616 | isTrivialCmmExpr e = return e
617 | otherwise = do
618 dflags <- getDynFlags
619 lreg <- newTemp (cmmExprType dflags e)
620 let reg = CmmLocal lreg
621 emitAssign reg e
622 return (CmmReg reg)