Implement function-sections for Haskell code, #8405
[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 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 DynFlags
67 import FastString
68 import Outputable
69
70 import qualified Data.ByteString as BS
71 import qualified Data.Map as M
72 import Data.Char
73 import Data.List
74 import Data.Ord
75 import Data.Word
76
77
78 -------------------------------------------------------------------------
79 --
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 cgLit other_lit = do dflags <- getDynFlags
88 return (mkSimpleLit dflags other_lit)
89
90 mkSimpleLit :: DynFlags -> Literal -> CmmLit
91 mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags)
92 mkSimpleLit dflags MachNullAddr = zeroCLit dflags
93 mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags)
94 mkSimpleLit _ (MachInt64 i) = CmmInt i W64
95 mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags)
96 mkSimpleLit _ (MachWord64 i) = CmmInt i W64
97 mkSimpleLit _ (MachFloat r) = CmmFloat r W32
98 mkSimpleLit _ (MachDouble r) = CmmFloat r W64
99 mkSimpleLit _ (MachLabel fs ms fod)
100 = CmmLabel (mkForeignLabel fs ms labelSrc fod)
101 where
102 -- TODO: Literal labels might not actually be in the current package...
103 labelSrc = ForeignLabelInThisPackage
104 mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other)
105
106 --------------------------------------------------------------------------
107 --
108 -- Incrementing a memory location
109 --
110 --------------------------------------------------------------------------
111
112 addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
113 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
114
115 addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
116 addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))
117
118 addToMem :: CmmType -- rep of the counter
119 -> CmmExpr -- Address
120 -> Int -- What to add (a word)
121 -> CmmAGraph
122 addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))
123
124 addToMemE :: CmmType -- rep of the counter
125 -> CmmExpr -- Address
126 -> CmmExpr -- What to add (a word-typed expression)
127 -> CmmAGraph
128 addToMemE rep ptr n
129 = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])
130
131
132 -------------------------------------------------------------------------
133 --
134 -- Loading a field from an object,
135 -- where the object pointer is itself tagged
136 --
137 -------------------------------------------------------------------------
138
139 mkTaggedObjectLoad
140 :: 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 (CmmLoad (cmmOffsetB dflags
147 (CmmReg (CmmLocal base))
148 (offset - tag))
149 (localRegType reg))
150
151 -------------------------------------------------------------------------
152 --
153 -- Converting a closure tag to a closure for enumeration types
154 -- (this is the implementation of tagToEnum#).
155 --
156 -------------------------------------------------------------------------
157
158 tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
159 tagToClosure dflags tycon tag
160 = 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 :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
171 emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
172
173 emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> 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 -> [(CmmExpr,ForeignHint)]
183 -> Bool -- True <=> CmmSafe call
184 -> FCode ()
185 emitRtsCallGen res lbl args safe
186 = do { dflags <- getDynFlags
187 ; updfr_off <- getUpdFrameOff
188 ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags
189 ; emit caller_save
190 ; call updfr_off
191 ; emit caller_load }
192 where
193 call updfr_off =
194 if safe then
195 emit =<< mkCmmCall fun_expr res' args' updfr_off
196 else do
197 let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
198 emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
199 (args', arg_hints) = unzip args
200 (res', res_hints) = unzip res
201 fun_expr = mkLblExpr lbl
202
203
204 -----------------------------------------------------------------------------
205 --
206 -- Caller-Save Registers
207 --
208 -----------------------------------------------------------------------------
209
210 -- Here we generate the sequence of saves/restores required around a
211 -- foreign call instruction.
212
213 -- TODO: reconcile with includes/Regs.h
214 -- * Regs.h claims that BaseReg should be saved last and loaded first
215 -- * This might not have been tickled before since BaseReg is callee save
216 -- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
217 --
218 -- This code isn't actually used right now, because callerSaves
219 -- only ever returns true in the current universe for registers NOT in
220 -- system_regs (just do a grep for CALLER_SAVES in
221 -- includes/stg/MachRegs.h). It's all one giant no-op, and for
222 -- good reason: having to save system registers on every foreign call
223 -- would be very expensive, so we avoid assigning them to those
224 -- registers when we add support for an architecture.
225 --
226 -- Note that the old code generator actually does more work here: it
227 -- also saves other global registers. We can't (nor want) to do that
228 -- here, as we don't have liveness information. And really, we
229 -- shouldn't be doing the workaround at this point in the pipeline, see
230 -- Note [Register parameter passing] and the ToDo on CmmCall in
231 -- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across
232 -- unsafe foreign calls in rewriteAssignments, but this is strictly
233 -- temporary.
234 callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)
235 callerSaveVolatileRegs dflags = (caller_save, caller_load)
236 where
237 platform = targetPlatform dflags
238
239 caller_save = catAGraphs (map callerSaveGlobalReg regs_to_save)
240 caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
241
242 system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
243 {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
244 , 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 -- Global registers
257
258 -- We map STG registers onto appropriate CmmExprs. Either they map
259 -- to real machine registers or stored as offsets from BaseReg. Given
260 -- a GlobalReg, get_GlobalReg_addr always produces the
261 -- register table address for it.
262 -- (See also get_GlobalReg_reg_or_addr in MachRegs)
263
264 get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr
265 get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0
266 get_GlobalReg_addr dflags mid
267 = get_Regtable_addr_from_offset dflags
268 (globalRegType dflags mid) (baseRegOffset dflags mid)
269
270 -- Calculate a literal representing an offset into the register table.
271 -- Used when we don't have an actual BaseReg to offset from.
272 regTableOffset :: DynFlags -> Int -> CmmExpr
273 regTableOffset dflags n =
274 CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))
275
276 get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
277 get_Regtable_addr_from_offset dflags _rep offset =
278 if haveRegBase (targetPlatform dflags)
279 then CmmRegOff (CmmGlobal BaseReg) offset
280 else regTableOffset dflags offset
281
282
283 -- -----------------------------------------------------------------------------
284 -- Information about global registers
285
286 baseRegOffset :: DynFlags -> GlobalReg -> Int
287
288 baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags
289 baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags
290 baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags
291 baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags
292 baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags
293 baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags
294 baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags
295 baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags
296 baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags
297 baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags
298 baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags
299 baseRegOffset _ reg = pprPanic "baseRegOffset:" (ppr reg)
300
301 -------------------------------------------------------------------------
302 --
303 -- Strings generate a top-level data block
304 --
305 -------------------------------------------------------------------------
306
307 emitDataLits :: CLabel -> [CmmLit] -> FCode ()
308 -- Emit a data-segment data block
309 emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)
310
311 emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
312 -- Emit a read-only data block
313 emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
314
315 newStringCLit :: String -> FCode CmmLit
316 -- Make a global definition for the string,
317 -- and return its label
318 newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str)
319
320 newByteStringCLit :: [Word8] -> FCode CmmLit
321 newByteStringCLit bytes
322 = do { uniq <- newUnique
323 ; let (lit, decl) = mkByteStringCLit uniq bytes
324 ; emitDecl decl
325 ; return lit }
326
327 -------------------------------------------------------------------------
328 --
329 -- Assigning expressions to temporaries
330 --
331 -------------------------------------------------------------------------
332
333 assignTemp :: CmmExpr -> FCode LocalReg
334 -- Make sure the argument is in a local register.
335 -- We don't bother being particularly aggressive with avoiding
336 -- unnecessary local registers, since we can rely on a later
337 -- optimization pass to inline as necessary (and skipping out
338 -- on things like global registers can be a little dangerous
339 -- due to them being trashed on foreign calls--though it means
340 -- the optimization pass doesn't have to do as much work)
341 assignTemp (CmmReg (CmmLocal reg)) = return reg
342 assignTemp e = do { dflags <- getDynFlags
343 ; uniq <- newUnique
344 ; let reg = LocalReg uniq (cmmExprType dflags e)
345 ; emitAssign (CmmLocal reg) e
346 ; return reg }
347
348 newTemp :: CmmType -> FCode LocalReg
349 newTemp rep = do { uniq <- newUnique
350 ; return (LocalReg uniq rep) }
351
352 newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
353 -- 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 do { dflags <- getDynFlags
360 ; sequel <- getSequel
361 ; regs <- choose_regs dflags sequel
362 ; ASSERT( regs `equalLength` reps )
363 return (regs, map primRepForeignHint reps) }
364 where
365 UbxTupleRep ty_args = repType res_ty
366 reps = [ rep
367 | ty <- ty_args
368 , let rep = typePrimRep ty
369 , not (isVoidRep rep) ]
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 ASSERT( equalLength regs 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 :: [ (Vrtx, Key, [Key]) ]
405 edges = [ (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 = stronglyConnCompFromEdgedVertices 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 <- newLabelC
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 <- newLabelC
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 <- newLabelC
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)