Add support for producing position-independent executables
[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 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' 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 "StgCmmUtils.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 (mkStringLitLabel 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 primRepForeignHint reps) }
366 where
367 reps = typePrimRep res_ty
368 choose_regs _ (AssignTo regs _) = return regs
369 choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps
370
371
372
373 -------------------------------------------------------------------------
374 -- emitMultiAssign
375 -------------------------------------------------------------------------
376
377 emitMultiAssign :: [LocalReg] -> [CmmExpr] -> 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, CmmExpr) -- 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 :: [ Node Key Vrtx ]
403 edges = [ DigraphNode 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, CmmReg (CmmLocal tmp)))
433 where
434 rep = cmmExprType 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 -------------------------------------------------------------------------
444 -- mkSwitch
445 -------------------------------------------------------------------------
446
447
448 emitSwitch :: CmmExpr -- Tag to switch on
449 -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches
450 -> Maybe CmmAGraphScoped -- Default branch (if any)
451 -> ConTagZ -> ConTagZ -- Min and Max possible values;
452 -- behaviour outside this range is
453 -- undefined
454 -> FCode ()
455
456 -- First, two rather common cases in which there is no work to do
457 emitSwitch _ [] (Just code) _ _ = emit (fst code)
458 emitSwitch _ [(_,code)] Nothing _ _ = emit (fst code)
459
460 -- Right, off we go
461 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do
462 join_lbl <- newBlockId
463 mb_deflt_lbl <- label_default join_lbl mb_deflt
464 branches_lbls <- label_branches join_lbl branches
465 tag_expr' <- assignTemp' tag_expr
466
467 -- Sort the branches before calling mk_discrete_switch
468 let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]
469 let range = (fromIntegral lo_tag, fromIntegral hi_tag)
470
471 emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range
472
473 emitLabel join_lbl
474
475 mk_discrete_switch :: Bool -- ^ Use signed comparisons
476 -> CmmExpr
477 -> [(Integer, BlockId)]
478 -> Maybe BlockId
479 -> (Integer, Integer)
480 -> CmmAGraph
481
482 -- SINGLETON TAG RANGE: no case analysis to do
483 mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)
484 | lo_tag == hi_tag
485 = ASSERT( tag == lo_tag )
486 mkBranch lbl
487
488 -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
489 mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _
490 = mkBranch lbl
491 -- The simplifier might have eliminated a case
492 -- so we may have e.g. case xs of
493 -- [] -> e
494 -- In that situation we can be sure the (:) case
495 -- can't happen, so no need to test
496
497 -- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans
498 -- See Note [Cmm Switches, the general plan] in CmmSwitch
499 mk_discrete_switch signed tag_expr branches mb_deflt range
500 = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)
501
502 divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])
503 divideBranches branches = (lo_branches, mid, hi_branches)
504 where
505 -- 2 branches => n_branches `div` 2 = 1
506 -- => branches !! 1 give the *second* tag
507 -- There are always at least 2 branches here
508 (mid,_) = branches !! (length branches `div` 2)
509 (lo_branches, hi_branches) = span is_lo branches
510 is_lo (t,_) = t < mid
511
512 --------------
513 emitCmmLitSwitch :: CmmExpr -- Tag to switch on
514 -> [(Literal, CmmAGraphScoped)] -- Tagged branches
515 -> CmmAGraphScoped -- Default branch (always)
516 -> FCode () -- Emit the code
517 emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt
518 emitCmmLitSwitch scrut branches deflt = do
519 scrut' <- assignTemp' scrut
520 join_lbl <- newBlockId
521 deflt_lbl <- label_code join_lbl deflt
522 branches_lbls <- label_branches join_lbl branches
523
524 dflags <- getDynFlags
525 let cmm_ty = cmmExprType dflags scrut
526 rep = typeWidth cmm_ty
527
528 -- We find the necessary type information in the literals in the branches
529 let signed = case head branches of
530 (MachInt _, _) -> True
531 (MachInt64 _, _) -> True
532 _ -> False
533
534 let range | signed = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)
535 | otherwise = (0, tARGET_MAX_WORD dflags)
536
537 if isFloatType cmm_ty
538 then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls
539 else emit $ mk_discrete_switch
540 signed
541 scrut'
542 [(litValue lit,l) | (lit,l) <- branches_lbls]
543 (Just deflt_lbl)
544 range
545 emitLabel join_lbl
546
547 -- | lower bound (inclusive), upper bound (exclusive)
548 type LitBound = (Maybe Literal, Maybe Literal)
549
550 noBound :: LitBound
551 noBound = (Nothing, Nothing)
552
553 mk_float_switch :: Width -> CmmExpr -> BlockId
554 -> LitBound
555 -> [(Literal,BlockId)]
556 -> FCode CmmAGraph
557 mk_float_switch rep scrut deflt _bounds [(lit,blk)]
558 = do dflags <- getDynFlags
559 return $ mkCbranch (cond dflags) deflt blk Nothing
560 where
561 cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]
562 where
563 cmm_lit = mkSimpleLit dflags lit
564 ne = MO_F_Ne rep
565
566 mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches
567 = do dflags <- getDynFlags
568 lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches
569 hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches
570 mkCmmIfThenElse (cond dflags) lo_blk hi_blk
571 where
572 (lo_branches, mid_lit, hi_branches) = divideBranches branches
573
574 bounds_lo = (lo_bound, Just mid_lit)
575 bounds_hi = (Just mid_lit, hi_bound)
576
577 cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]
578 where
579 cmm_lit = mkSimpleLit dflags mid_lit
580 lt = MO_F_Lt rep
581
582
583 --------------
584 label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
585 label_default _ Nothing
586 = return Nothing
587 label_default join_lbl (Just code)
588 = do lbl <- label_code join_lbl code
589 return (Just lbl)
590
591 --------------
592 label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
593 label_branches _join_lbl []
594 = return []
595 label_branches join_lbl ((tag,code):branches)
596 = do lbl <- label_code join_lbl code
597 branches' <- label_branches join_lbl branches
598 return ((tag,lbl):branches')
599
600 --------------
601 label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
602 -- label_code J code
603 -- generates
604 -- [L: code; goto J]
605 -- and returns L
606 label_code join_lbl (code,tsc) = do
607 lbl <- newBlockId
608 emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)
609 return lbl
610
611 --------------
612 assignTemp' :: CmmExpr -> FCode CmmExpr
613 assignTemp' e
614 | isTrivialCmmExpr e = return e
615 | otherwise = do
616 dflags <- getDynFlags
617 lreg <- newTemp (cmmExprType dflags e)
618 let reg = CmmLocal lreg
619 emitAssign reg e
620 return (CmmReg reg)