64af5c579c3283ef8366b67d7873f9bee89e969f
[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 Data.ByteString (ByteString)
75 import qualified Data.ByteString.Char8 as BS8
76 import qualified Data.Map as M
77 import Data.Char
78 import Data.List
79 import Data.Ord
80
81
82 -------------------------------------------------------------------------
83 --
84 -- Literals
85 --
86 -------------------------------------------------------------------------
87
88 cgLit :: Literal -> FCode CmmLit
89 cgLit (LitString s) = newByteStringCLit 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 (LitChar c) = CmmInt (fromIntegral (ord c))
96 (wordWidth dflags)
97 mkSimpleLit dflags LitNullAddr = zeroCLit dflags
98 mkSimpleLit dflags (LitNumber LitNumInt i _) = CmmInt i (wordWidth dflags)
99 mkSimpleLit _ (LitNumber LitNumInt64 i _) = CmmInt i W64
100 mkSimpleLit dflags (LitNumber LitNumWord i _) = CmmInt i (wordWidth dflags)
101 mkSimpleLit _ (LitNumber LitNumWord64 i _) = CmmInt i W64
102 mkSimpleLit _ (LitFloat r) = CmmFloat r W32
103 mkSimpleLit _ (LitDouble r) = CmmFloat r W64
104 mkSimpleLit _ (LitLabel fs ms fod)
105 = let -- TODO: Literal labels might not actually be in the current package...
106 labelSrc = ForeignLabelInThisPackage
107 in CmmLabel (mkForeignLabel fs ms labelSrc fod)
108 -- NB: LitRubbish should have been lowered in "CoreToStg"
109 mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other)
110
111 --------------------------------------------------------------------------
112 --
113 -- Incrementing a memory location
114 --
115 --------------------------------------------------------------------------
116
117 addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
118 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
119
120 addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
121 addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))
122
123 addToMem :: CmmType -- rep of the counter
124 -> CmmExpr -- Address
125 -> Int -- What to add (a word)
126 -> CmmAGraph
127 addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))
128
129 addToMemE :: CmmType -- rep of the counter
130 -> CmmExpr -- Address
131 -> CmmExpr -- What to add (a word-typed expression)
132 -> CmmAGraph
133 addToMemE rep ptr n
134 = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])
135
136
137 -------------------------------------------------------------------------
138 --
139 -- Loading a field from an object,
140 -- where the object pointer is itself tagged
141 --
142 -------------------------------------------------------------------------
143
144 mkTaggedObjectLoad
145 :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
146 -- (loadTaggedObjectField reg base off tag) generates assignment
147 -- reg = bitsK[ base + off - tag ]
148 -- where K is fixed by 'reg'
149 mkTaggedObjectLoad dflags reg base offset tag
150 = mkAssign (CmmLocal reg)
151 (CmmLoad (cmmOffsetB dflags
152 (CmmReg (CmmLocal base))
153 (offset - tag))
154 (localRegType reg))
155
156 -------------------------------------------------------------------------
157 --
158 -- Converting a closure tag to a closure for enumeration types
159 -- (this is the implementation of tagToEnum#).
160 --
161 -------------------------------------------------------------------------
162
163 tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
164 tagToClosure dflags tycon tag
165 = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)
166 where closure_tbl = CmmLit (CmmLabel lbl)
167 lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
168
169 -------------------------------------------------------------------------
170 --
171 -- Conditionals and rts calls
172 --
173 -------------------------------------------------------------------------
174
175 emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
176 emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
177
178 emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString
179 -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
180 emitRtsCallWithResult res hint pkg fun args safe
181 = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe
182
183 -- Make a call to an RTS C procedure
184 emitRtsCallGen
185 :: [(LocalReg,ForeignHint)]
186 -> CLabel
187 -> [(CmmExpr,ForeignHint)]
188 -> Bool -- True <=> CmmSafe call
189 -> FCode ()
190 emitRtsCallGen res lbl args safe
191 = do { dflags <- getDynFlags
192 ; updfr_off <- getUpdFrameOff
193 ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags
194 ; emit caller_save
195 ; call updfr_off
196 ; emit caller_load }
197 where
198 call updfr_off =
199 if safe then
200 emit =<< mkCmmCall fun_expr res' args' updfr_off
201 else do
202 let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
203 emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
204 (args', arg_hints) = unzip args
205 (res', res_hints) = unzip res
206 fun_expr = mkLblExpr lbl
207
208
209 -----------------------------------------------------------------------------
210 --
211 -- Caller-Save Registers
212 --
213 -----------------------------------------------------------------------------
214
215 -- Here we generate the sequence of saves/restores required around a
216 -- foreign call instruction.
217
218 -- TODO: reconcile with includes/Regs.h
219 -- * Regs.h claims that BaseReg should be saved last and loaded first
220 -- * This might not have been tickled before since BaseReg is callee save
221 -- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
222 --
223 -- This code isn't actually used right now, because callerSaves
224 -- only ever returns true in the current universe for registers NOT in
225 -- system_regs (just do a grep for CALLER_SAVES in
226 -- includes/stg/MachRegs.h). It's all one giant no-op, and for
227 -- good reason: having to save system registers on every foreign call
228 -- would be very expensive, so we avoid assigning them to those
229 -- registers when we add support for an architecture.
230 --
231 -- Note that the old code generator actually does more work here: it
232 -- also saves other global registers. We can't (nor want) to do that
233 -- here, as we don't have liveness information. And really, we
234 -- shouldn't be doing the workaround at this point in the pipeline, see
235 -- Note [Register parameter passing] and the ToDo on CmmCall in
236 -- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across
237 -- unsafe foreign calls in rewriteAssignments, but this is strictly
238 -- temporary.
239 callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)
240 callerSaveVolatileRegs dflags = (caller_save, caller_load)
241 where
242 platform = targetPlatform dflags
243
244 caller_save = catAGraphs (map callerSaveGlobalReg regs_to_save)
245 caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
246
247 system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
248 {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
249 , BaseReg ]
250
251 regs_to_save = filter (callerSaves platform) system_regs
252
253 callerSaveGlobalReg reg
254 = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
255
256 callerRestoreGlobalReg reg
257 = mkAssign (CmmGlobal reg)
258 (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))
259
260 -- -----------------------------------------------------------------------------
261 -- Global registers
262
263 -- We map STG registers onto appropriate CmmExprs. Either they map
264 -- to real machine registers or stored as offsets from BaseReg. Given
265 -- a GlobalReg, get_GlobalReg_addr always produces the
266 -- register table address for it.
267 -- (See also get_GlobalReg_reg_or_addr in MachRegs)
268
269 get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr
270 get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0
271 get_GlobalReg_addr dflags mid
272 = get_Regtable_addr_from_offset dflags
273 (globalRegType dflags mid) (baseRegOffset dflags mid)
274
275 -- Calculate a literal representing an offset into the register table.
276 -- Used when we don't have an actual BaseReg to offset from.
277 regTableOffset :: DynFlags -> Int -> CmmExpr
278 regTableOffset dflags n =
279 CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))
280
281 get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
282 get_Regtable_addr_from_offset dflags _rep offset =
283 if haveRegBase (targetPlatform dflags)
284 then CmmRegOff baseReg offset
285 else regTableOffset dflags offset
286
287
288 -- -----------------------------------------------------------------------------
289 -- Information about global registers
290
291 baseRegOffset :: DynFlags -> GlobalReg -> Int
292
293 baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags
294 baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags
295 baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags
296 baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags
297 baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags
298 baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags
299 baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags
300 baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags
301 baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags
302 baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags
303 baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags
304 baseRegOffset _ reg = pprPanic "StgCmmUtils.baseRegOffset:" (ppr reg)
305
306 -------------------------------------------------------------------------
307 --
308 -- Strings generate a top-level data block
309 --
310 -------------------------------------------------------------------------
311
312 emitDataLits :: CLabel -> [CmmLit] -> FCode ()
313 -- Emit a data-segment data block
314 emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)
315
316 emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
317 -- Emit a read-only data block
318 emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
319
320 newStringCLit :: String -> FCode CmmLit
321 -- Make a global definition for the string,
322 -- and return its label
323 newStringCLit str = newByteStringCLit (BS8.pack str)
324
325 newByteStringCLit :: ByteString -> FCode CmmLit
326 newByteStringCLit bytes
327 = do { uniq <- newUnique
328 ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes
329 ; emitDecl decl
330 ; return lit }
331
332 -------------------------------------------------------------------------
333 --
334 -- Assigning expressions to temporaries
335 --
336 -------------------------------------------------------------------------
337
338 assignTemp :: CmmExpr -> FCode LocalReg
339 -- Make sure the argument is in a local register.
340 -- We don't bother being particularly aggressive with avoiding
341 -- unnecessary local registers, since we can rely on a later
342 -- optimization pass to inline as necessary (and skipping out
343 -- on things like global registers can be a little dangerous
344 -- due to them being trashed on foreign calls--though it means
345 -- the optimization pass doesn't have to do as much work)
346 assignTemp (CmmReg (CmmLocal reg)) = return reg
347 assignTemp e = do { dflags <- getDynFlags
348 ; uniq <- newUnique
349 ; let reg = LocalReg uniq (cmmExprType dflags e)
350 ; emitAssign (CmmLocal reg) e
351 ; return reg }
352
353 newTemp :: MonadUnique m => CmmType -> m LocalReg
354 newTemp rep = do { uniq <- getUniqueM
355 ; return (LocalReg uniq rep) }
356
357 newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
358 -- Choose suitable local regs to use for the components
359 -- of an unboxed tuple that we are about to return to
360 -- the Sequel. If the Sequel is a join point, using the
361 -- regs it wants will save later assignments.
362 newUnboxedTupleRegs res_ty
363 = ASSERT( isUnboxedTupleType res_ty )
364 do { dflags <- getDynFlags
365 ; sequel <- getSequel
366 ; regs <- choose_regs dflags sequel
367 ; ASSERT( regs `equalLength` reps )
368 return (regs, map primRepForeignHint reps) }
369 where
370 reps = typePrimRep res_ty
371 choose_regs _ (AssignTo regs _) = return regs
372 choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps
373
374
375
376 -------------------------------------------------------------------------
377 -- emitMultiAssign
378 -------------------------------------------------------------------------
379
380 emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
381 -- Emit code to perform the assignments in the
382 -- input simultaneously, using temporary variables when necessary.
383
384 type Key = Int
385 type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
386 -- for fast comparison
387 type Stmt = (LocalReg, CmmExpr) -- r := e
388
389 -- We use the strongly-connected component algorithm, in which
390 -- * the vertices are the statements
391 -- * an edge goes from s1 to s2 iff
392 -- s1 assigns to something s2 uses
393 -- that is, if s1 should *follow* s2 in the final order
394
395 emitMultiAssign [] [] = return ()
396 emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs
397 emitMultiAssign regs rhss = do
398 dflags <- getDynFlags
399 ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )
400 unscramble dflags ([1..] `zip` (regs `zip` rhss))
401
402 unscramble :: DynFlags -> [Vrtx] -> FCode ()
403 unscramble dflags vertices = mapM_ do_component components
404 where
405 edges :: [ Node Key Vrtx ]
406 edges = [ DigraphNode vertex key1 (edges_from stmt1)
407 | vertex@(key1, stmt1) <- vertices ]
408
409 edges_from :: Stmt -> [Key]
410 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
411 stmt1 `mustFollow` stmt2 ]
412
413 components :: [SCC Vrtx]
414 components = stronglyConnCompFromEdgedVerticesUniq edges
415
416 -- do_components deal with one strongly-connected component
417 -- Not cyclic, or singleton? Just do it
418 do_component :: SCC Vrtx -> FCode ()
419 do_component (AcyclicSCC (_,stmt)) = mk_graph stmt
420 do_component (CyclicSCC []) = panic "do_component"
421 do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt
422
423 -- Cyclic? Then go via temporaries. Pick one to
424 -- break the loop and try again with the rest.
425 do_component (CyclicSCC ((_,first_stmt) : rest)) = do
426 dflags <- getDynFlags
427 u <- newUnique
428 let (to_tmp, from_tmp) = split dflags u first_stmt
429 mk_graph to_tmp
430 unscramble dflags rest
431 mk_graph from_tmp
432
433 split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)
434 split dflags uniq (reg, rhs)
435 = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
436 where
437 rep = cmmExprType dflags rhs
438 tmp = LocalReg uniq rep
439
440 mk_graph :: Stmt -> FCode ()
441 mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs
442
443 mustFollow :: Stmt -> Stmt -> Bool
444 (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs
445
446 -------------------------------------------------------------------------
447 -- mkSwitch
448 -------------------------------------------------------------------------
449
450
451 emitSwitch :: CmmExpr -- Tag to switch on
452 -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches
453 -> Maybe CmmAGraphScoped -- Default branch (if any)
454 -> ConTagZ -> ConTagZ -- Min and Max possible values;
455 -- behaviour outside this range is
456 -- undefined
457 -> FCode ()
458
459 -- First, two rather common cases in which there is no work to do
460 emitSwitch _ [] (Just code) _ _ = emit (fst code)
461 emitSwitch _ [(_,code)] Nothing _ _ = emit (fst code)
462
463 -- Right, off we go
464 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do
465 join_lbl <- newBlockId
466 mb_deflt_lbl <- label_default join_lbl mb_deflt
467 branches_lbls <- label_branches join_lbl branches
468 tag_expr' <- assignTemp' tag_expr
469
470 -- Sort the branches before calling mk_discrete_switch
471 let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]
472 let range = (fromIntegral lo_tag, fromIntegral hi_tag)
473
474 emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range
475
476 emitLabel join_lbl
477
478 mk_discrete_switch :: Bool -- ^ Use signed comparisons
479 -> CmmExpr
480 -> [(Integer, BlockId)]
481 -> Maybe BlockId
482 -> (Integer, Integer)
483 -> CmmAGraph
484
485 -- SINGLETON TAG RANGE: no case analysis to do
486 mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)
487 | lo_tag == hi_tag
488 = ASSERT( tag == lo_tag )
489 mkBranch lbl
490
491 -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
492 mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _
493 = mkBranch lbl
494 -- The simplifier might have eliminated a case
495 -- so we may have e.g. case xs of
496 -- [] -> e
497 -- In that situation we can be sure the (:) case
498 -- can't happen, so no need to test
499
500 -- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans
501 -- See Note [Cmm Switches, the general plan] in CmmSwitch
502 mk_discrete_switch signed tag_expr branches mb_deflt range
503 = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)
504
505 divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])
506 divideBranches branches = (lo_branches, mid, hi_branches)
507 where
508 -- 2 branches => n_branches `div` 2 = 1
509 -- => branches !! 1 give the *second* tag
510 -- There are always at least 2 branches here
511 (mid,_) = branches !! (length branches `div` 2)
512 (lo_branches, hi_branches) = span is_lo branches
513 is_lo (t,_) = t < mid
514
515 --------------
516 emitCmmLitSwitch :: CmmExpr -- Tag to switch on
517 -> [(Literal, CmmAGraphScoped)] -- Tagged branches
518 -> CmmAGraphScoped -- Default branch (always)
519 -> FCode () -- Emit the code
520 emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt
521 emitCmmLitSwitch scrut branches deflt = do
522 scrut' <- assignTemp' scrut
523 join_lbl <- newBlockId
524 deflt_lbl <- label_code join_lbl deflt
525 branches_lbls <- label_branches join_lbl branches
526
527 dflags <- getDynFlags
528 let cmm_ty = cmmExprType dflags scrut
529 rep = typeWidth cmm_ty
530
531 -- We find the necessary type information in the literals in the branches
532 let signed = case head branches of
533 (LitNumber nt _ _, _) -> litNumIsSigned nt
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)