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