5d6710197bc71d64a19837c4efa4a2f63844cccf
[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 UniqSupply (MonadUnique(..))
67 import DynFlags
68 import FastString
69 import Outputable
70
71 import qualified Data.ByteString as BS
72 import qualified Data.Map as M
73 import Data.Char
74 import Data.List
75 import Data.Ord
76 import Data.Word
77
78
79 -------------------------------------------------------------------------
80 --
81 -- Literals
82 --
83 -------------------------------------------------------------------------
84
85 cgLit :: Literal -> FCode CmmLit
86 cgLit (MachStr s) = newByteStringCLit (BS.unpack s)
87 -- not unpackFS; we want the UTF-8 byte stream.
88 cgLit other_lit = do dflags <- getDynFlags
89 return (mkSimpleLit dflags other_lit)
90
91 mkSimpleLit :: DynFlags -> Literal -> CmmLit
92 mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags)
93 mkSimpleLit dflags MachNullAddr = zeroCLit dflags
94 mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags)
95 mkSimpleLit _ (MachInt64 i) = CmmInt i W64
96 mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags)
97 mkSimpleLit _ (MachWord64 i) = CmmInt i W64
98 mkSimpleLit _ (MachFloat r) = CmmFloat r W32
99 mkSimpleLit _ (MachDouble r) = CmmFloat r W64
100 mkSimpleLit _ (MachLabel fs ms fod)
101 = CmmLabel (mkForeignLabel fs ms labelSrc fod)
102 where
103 -- TODO: Literal labels might not actually be in the current package...
104 labelSrc = ForeignLabelInThisPackage
105 mkSimpleLit _ other = pprPanic "mkSimpleLit" (ppr other)
106
107 --------------------------------------------------------------------------
108 --
109 -- Incrementing a memory location
110 --
111 --------------------------------------------------------------------------
112
113 addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
114 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
115
116 addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
117 addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))
118
119 addToMem :: CmmType -- rep of the counter
120 -> CmmExpr -- Address
121 -> Int -- What to add (a word)
122 -> CmmAGraph
123 addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))
124
125 addToMemE :: CmmType -- rep of the counter
126 -> CmmExpr -- Address
127 -> CmmExpr -- What to add (a word-typed expression)
128 -> CmmAGraph
129 addToMemE rep ptr n
130 = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])
131
132
133 -------------------------------------------------------------------------
134 --
135 -- Loading a field from an object,
136 -- where the object pointer is itself tagged
137 --
138 -------------------------------------------------------------------------
139
140 mkTaggedObjectLoad
141 :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
142 -- (loadTaggedObjectField reg base off tag) generates assignment
143 -- reg = bitsK[ base + off - tag ]
144 -- where K is fixed by 'reg'
145 mkTaggedObjectLoad dflags reg base offset tag
146 = mkAssign (CmmLocal reg)
147 (CmmLoad (cmmOffsetB dflags
148 (CmmReg (CmmLocal base))
149 (offset - tag))
150 (localRegType reg))
151
152 -------------------------------------------------------------------------
153 --
154 -- Converting a closure tag to a closure for enumeration types
155 -- (this is the implementation of tagToEnum#).
156 --
157 -------------------------------------------------------------------------
158
159 tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr
160 tagToClosure dflags tycon tag
161 = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)
162 where closure_tbl = CmmLit (CmmLabel lbl)
163 lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
164
165 -------------------------------------------------------------------------
166 --
167 -- Conditionals and rts calls
168 --
169 -------------------------------------------------------------------------
170
171 emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
172 emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe
173
174 emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString
175 -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
176 emitRtsCallWithResult res hint pkg fun args safe
177 = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe
178
179 -- Make a call to an RTS C procedure
180 emitRtsCallGen
181 :: [(LocalReg,ForeignHint)]
182 -> CLabel
183 -> [(CmmExpr,ForeignHint)]
184 -> Bool -- True <=> CmmSafe call
185 -> FCode ()
186 emitRtsCallGen res lbl args safe
187 = do { dflags <- getDynFlags
188 ; updfr_off <- getUpdFrameOff
189 ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags
190 ; emit caller_save
191 ; call updfr_off
192 ; emit caller_load }
193 where
194 call updfr_off =
195 if safe then
196 emit =<< mkCmmCall fun_expr res' args' updfr_off
197 else do
198 let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
199 emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
200 (args', arg_hints) = unzip args
201 (res', res_hints) = unzip res
202 fun_expr = mkLblExpr lbl
203
204
205 -----------------------------------------------------------------------------
206 --
207 -- Caller-Save Registers
208 --
209 -----------------------------------------------------------------------------
210
211 -- Here we generate the sequence of saves/restores required around a
212 -- foreign call instruction.
213
214 -- TODO: reconcile with includes/Regs.h
215 -- * Regs.h claims that BaseReg should be saved last and loaded first
216 -- * This might not have been tickled before since BaseReg is callee save
217 -- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
218 --
219 -- This code isn't actually used right now, because callerSaves
220 -- only ever returns true in the current universe for registers NOT in
221 -- system_regs (just do a grep for CALLER_SAVES in
222 -- includes/stg/MachRegs.h). It's all one giant no-op, and for
223 -- good reason: having to save system registers on every foreign call
224 -- would be very expensive, so we avoid assigning them to those
225 -- registers when we add support for an architecture.
226 --
227 -- Note that the old code generator actually does more work here: it
228 -- also saves other global registers. We can't (nor want) to do that
229 -- here, as we don't have liveness information. And really, we
230 -- shouldn't be doing the workaround at this point in the pipeline, see
231 -- Note [Register parameter passing] and the ToDo on CmmCall in
232 -- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across
233 -- unsafe foreign calls in rewriteAssignments, but this is strictly
234 -- temporary.
235 callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)
236 callerSaveVolatileRegs dflags = (caller_save, caller_load)
237 where
238 platform = targetPlatform dflags
239
240 caller_save = catAGraphs (map callerSaveGlobalReg regs_to_save)
241 caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
242
243 system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
244 {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
245 , BaseReg ]
246
247 regs_to_save = filter (callerSaves platform) system_regs
248
249 callerSaveGlobalReg reg
250 = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))
251
252 callerRestoreGlobalReg reg
253 = mkAssign (CmmGlobal reg)
254 (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))
255
256 -- -----------------------------------------------------------------------------
257 -- Global registers
258
259 -- We map STG registers onto appropriate CmmExprs. Either they map
260 -- to real machine registers or stored as offsets from BaseReg. Given
261 -- a GlobalReg, get_GlobalReg_addr always produces the
262 -- register table address for it.
263 -- (See also get_GlobalReg_reg_or_addr in MachRegs)
264
265 get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr
266 get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0
267 get_GlobalReg_addr dflags mid
268 = get_Regtable_addr_from_offset dflags
269 (globalRegType dflags mid) (baseRegOffset dflags mid)
270
271 -- Calculate a literal representing an offset into the register table.
272 -- Used when we don't have an actual BaseReg to offset from.
273 regTableOffset :: DynFlags -> Int -> CmmExpr
274 regTableOffset dflags n =
275 CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))
276
277 get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
278 get_Regtable_addr_from_offset dflags _rep offset =
279 if haveRegBase (targetPlatform dflags)
280 then CmmRegOff (CmmGlobal BaseReg) offset
281 else regTableOffset dflags offset
282
283
284 -- -----------------------------------------------------------------------------
285 -- Information about global registers
286
287 baseRegOffset :: DynFlags -> GlobalReg -> Int
288
289 baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags
290 baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags
291 baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags
292 baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags
293 baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags
294 baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags
295 baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags
296 baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags
297 baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags
298 baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags
299 baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags
300 baseRegOffset _ reg = pprPanic "baseRegOffset:" (ppr reg)
301
302 -------------------------------------------------------------------------
303 --
304 -- Strings generate a top-level data block
305 --
306 -------------------------------------------------------------------------
307
308 emitDataLits :: CLabel -> [CmmLit] -> FCode ()
309 -- Emit a data-segment data block
310 emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)
311
312 emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
313 -- Emit a read-only data block
314 emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
315
316 newStringCLit :: String -> FCode CmmLit
317 -- Make a global definition for the string,
318 -- and return its label
319 newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str)
320
321 newByteStringCLit :: [Word8] -> FCode CmmLit
322 newByteStringCLit bytes
323 = do { uniq <- newUnique
324 ; let (lit, decl) = mkByteStringCLit uniq bytes
325 ; emitDecl decl
326 ; return lit }
327
328 -------------------------------------------------------------------------
329 --
330 -- Assigning expressions to temporaries
331 --
332 -------------------------------------------------------------------------
333
334 assignTemp :: CmmExpr -> FCode LocalReg
335 -- Make sure the argument is in a local register.
336 -- We don't bother being particularly aggressive with avoiding
337 -- unnecessary local registers, since we can rely on a later
338 -- optimization pass to inline as necessary (and skipping out
339 -- on things like global registers can be a little dangerous
340 -- due to them being trashed on foreign calls--though it means
341 -- the optimization pass doesn't have to do as much work)
342 assignTemp (CmmReg (CmmLocal reg)) = return reg
343 assignTemp e = do { dflags <- getDynFlags
344 ; uniq <- newUnique
345 ; let reg = LocalReg uniq (cmmExprType dflags e)
346 ; emitAssign (CmmLocal reg) e
347 ; return reg }
348
349 newTemp :: MonadUnique m => CmmType -> m LocalReg
350 newTemp rep = do { uniq <- getUniqueM
351 ; return (LocalReg uniq rep) }
352
353 newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
354 -- Choose suitable local regs to use for the components
355 -- of an unboxed tuple that we are about to return to
356 -- the Sequel. If the Sequel is a join point, using the
357 -- regs it wants will save later assignments.
358 newUnboxedTupleRegs res_ty
359 = ASSERT( isUnboxedTupleType res_ty )
360 do { dflags <- getDynFlags
361 ; sequel <- getSequel
362 ; regs <- choose_regs dflags sequel
363 ; ASSERT( regs `equalLength` reps )
364 return (regs, map primRepForeignHint reps) }
365 where
366 UbxTupleRep ty_args = repType res_ty
367 reps = [ rep
368 | ty <- ty_args
369 , let rep = typePrimRep ty
370 , not (isVoidRep rep) ]
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 :: [ (Vrtx, Key, [Key]) ]
406 edges = [ (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 <- newLabelC
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 <- newLabelC
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 (MachInt _, _) -> True
534 (MachInt64 _, _) -> True
535 _ -> False
536
537 let range | signed = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)
538 | otherwise = (0, tARGET_MAX_WORD dflags)
539
540 if isFloatType cmm_ty
541 then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls
542 else emit $ mk_discrete_switch
543 signed
544 scrut'
545 [(litValue lit,l) | (lit,l) <- branches_lbls]
546 (Just deflt_lbl)
547 range
548 emitLabel join_lbl
549
550 -- | lower bound (inclusive), upper bound (exclusive)
551 type LitBound = (Maybe Literal, Maybe Literal)
552
553 noBound :: LitBound
554 noBound = (Nothing, Nothing)
555
556 mk_float_switch :: Width -> CmmExpr -> BlockId
557 -> LitBound
558 -> [(Literal,BlockId)]
559 -> FCode CmmAGraph
560 mk_float_switch rep scrut deflt _bounds [(lit,blk)]
561 = do dflags <- getDynFlags
562 return $ mkCbranch (cond dflags) deflt blk Nothing
563 where
564 cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]
565 where
566 cmm_lit = mkSimpleLit dflags lit
567 ne = MO_F_Ne rep
568
569 mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches
570 = do dflags <- getDynFlags
571 lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches
572 hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches
573 mkCmmIfThenElse (cond dflags) lo_blk hi_blk
574 where
575 (lo_branches, mid_lit, hi_branches) = divideBranches branches
576
577 bounds_lo = (lo_bound, Just mid_lit)
578 bounds_hi = (Just mid_lit, hi_bound)
579
580 cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]
581 where
582 cmm_lit = mkSimpleLit dflags mid_lit
583 lt = MO_F_Lt rep
584
585
586 --------------
587 label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
588 label_default _ Nothing
589 = return Nothing
590 label_default join_lbl (Just code)
591 = do lbl <- label_code join_lbl code
592 return (Just lbl)
593
594 --------------
595 label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
596 label_branches _join_lbl []
597 = return []
598 label_branches join_lbl ((tag,code):branches)
599 = do lbl <- label_code join_lbl code
600 branches' <- label_branches join_lbl branches
601 return ((tag,lbl):branches')
602
603 --------------
604 label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
605 -- label_code J code
606 -- generates
607 -- [L: code; goto J]
608 -- and returns L
609 label_code join_lbl (code,tsc) = do
610 lbl <- newLabelC
611 emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)
612 return lbl
613
614 --------------
615 assignTemp' :: CmmExpr -> FCode CmmExpr
616 assignTemp' e
617 | isTrivialCmmExpr e = return e
618 | otherwise = do
619 dflags <- getDynFlags
620 lreg <- newTemp (cmmExprType dflags e)
621 let reg = CmmLocal lreg
622 emitAssign reg e
623 return (CmmReg reg)