Produce new-style Cmm from the Cmm parser
[ghc.git] / compiler / codeGen / StgCmmUtils.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generator utilities; mostly monadic
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module StgCmmUtils (
10 cgLit, mkSimpleLit,
11 emitDataLits, mkDataLits,
12 emitRODataLits, mkRODataLits,
13 emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
14 assignTemp, newTemp,
15
16 newUnboxedTupleRegs,
17
18 emitMultiAssign, emitCmmLitSwitch, emitSwitch,
19
20 tagToClosure, mkTaggedObjectLoad,
21
22 callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
23
24 cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
25 cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
26 cmmOffsetExprW, cmmOffsetExprB,
27 cmmRegOffW, cmmRegOffB,
28 cmmLabelOffW, cmmLabelOffB,
29 cmmOffsetW, cmmOffsetB,
30 cmmOffsetLitW, cmmOffsetLitB,
31 cmmLoadIndexW,
32 cmmConstrTag, cmmConstrTag1,
33
34 cmmUntag, cmmIsTagged, cmmGetTag,
35
36 addToMem, addToMemE, addToMemLbl,
37 mkWordCLit,
38 newStringCLit, newByteStringCLit,
39 blankWord
40 ) where
41
42 #include "HsVersions.h"
43
44 import StgCmmMonad
45 import StgCmmClosure
46 import Cmm
47 import BlockId
48 import MkGraph
49 import CodeGen.Platform
50 import CLabel
51 import CmmUtils
52
53 import ForeignCall
54 import IdInfo
55 import Type
56 import TyCon
57 import SMRep
58 import Module
59 import Literal
60 import Digraph
61 import ListSetOps
62 import Util
63 import Unique
64 import DynFlags
65 import FastString
66 import Outputable
67
68 import Data.Char
69 import Data.List
70 import Data.Ord
71 import Data.Word
72 import Data.Maybe
73
74
75 -------------------------------------------------------------------------
76 --
77 -- Literals
78 --
79 -------------------------------------------------------------------------
80
81 cgLit :: Literal -> FCode CmmLit
82 cgLit (MachStr s) = newByteStringCLit (bytesFB s)
83 -- not unpackFS; we want the UTF-8 byte stream.
84 cgLit other_lit = do dflags <- getDynFlags
85 return (mkSimpleLit dflags other_lit)
86
87 mkLtOp :: DynFlags -> Literal -> MachOp
88 -- On signed literals we must do a signed comparison
89 mkLtOp dflags (MachInt _) = MO_S_Lt (wordWidth dflags)
90 mkLtOp _ (MachFloat _) = MO_F_Lt W32
91 mkLtOp _ (MachDouble _) = MO_F_Lt W64
92 mkLtOp dflags lit = MO_U_Lt (typeWidth (cmmLitType dflags (mkSimpleLit dflags lit)))
93 -- ToDo: seems terribly indirect!
94
95 mkSimpleLit :: DynFlags -> Literal -> CmmLit
96 mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags)
97 mkSimpleLit dflags MachNullAddr = zeroCLit dflags
98 mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags)
99 mkSimpleLit _ (MachInt64 i) = CmmInt i W64
100 mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags)
101 mkSimpleLit _ (MachWord64 i) = CmmInt i W64
102 mkSimpleLit _ (MachFloat r) = CmmFloat r W32
103 mkSimpleLit _ (MachDouble r) = CmmFloat r W64
104 mkSimpleLit _ (MachLabel fs ms fod)
105 = CmmLabel (mkForeignLabel fs ms labelSrc fod)
106 where
107 -- TODO: Literal labels might not actually be in the current package...
108 labelSrc = ForeignLabelInThisPackage
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 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 :: DynFlags -> LocalReg -> LocalReg -> WordOff -> 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 (wORD_SIZE dflags * 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 :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
172 emitRtsCall pkg fun args safe = emitRtsCallGen [] pkg fun args safe
173
174 emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString
175 -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
176 emitRtsCallWithResult res hint pkg fun args safe
177 = emitRtsCallGen [(res,hint)] pkg fun args safe
178
179 -- Make a call to an RTS C procedure
180 emitRtsCallGen
181 :: [(LocalReg,ForeignHint)]
182 -> PackageId
183 -> FastString
184 -> [(CmmExpr,ForeignHint)]
185 -> Bool -- True <=> CmmSafe call
186 -> FCode ()
187 emitRtsCallGen res pkg fun 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 (mkCmmCodeLabel pkg fun)
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 Data 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 :: CmmType -> FCode LocalReg
351 newTemp rep = do { uniq <- newUnique
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 UbxTupleRep ty_args = repType res_ty
368 reps = [ rep
369 | ty <- ty_args
370 , let rep = typePrimRep ty
371 , not (isVoidRep rep) ]
372 choose_regs _ (AssignTo regs _) = return regs
373 choose_regs dflags _ = mapM (newTemp . primRepCmmType dflags) reps
374
375
376
377 -------------------------------------------------------------------------
378 -- emitMultiAssign
379 -------------------------------------------------------------------------
380
381 emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
382 -- Emit code to perform the assignments in the
383 -- input simultaneously, using temporary variables when necessary.
384
385 type Key = Int
386 type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
387 -- for fast comparison
388 type Stmt = (LocalReg, CmmExpr) -- r := e
389
390 -- We use the strongly-connected component algorithm, in which
391 -- * the vertices are the statements
392 -- * an edge goes from s1 to s2 iff
393 -- s1 assigns to something s2 uses
394 -- that is, if s1 should *follow* s2 in the final order
395
396 emitMultiAssign [] [] = return ()
397 emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs
398 emitMultiAssign regs rhss = ASSERT( equalLength regs rhss )
399 unscramble ([1..] `zip` (regs `zip` rhss))
400
401 unscramble :: [Vrtx] -> FCode ()
402 unscramble 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 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) = CmmLocal reg `regUsedIn` rhs
444
445 -------------------------------------------------------------------------
446 -- mkSwitch
447 -------------------------------------------------------------------------
448
449
450 emitSwitch :: CmmExpr -- Tag to switch on
451 -> [(ConTagZ, CmmAGraph)] -- Tagged branches
452 -> Maybe CmmAGraph -- Default branch (if any)
453 -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
454 -- outside this range is undefined
455 -> FCode ()
456 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
457 = do { dflags <- getDynFlags
458 ; mkCmmSwitch (via_C dflags) tag_expr branches mb_deflt lo_tag hi_tag }
459 where
460 via_C dflags | HscC <- hscTarget dflags = True
461 | otherwise = False
462
463
464 mkCmmSwitch :: Bool -- True <=> never generate a
465 -- conditional tree
466 -> CmmExpr -- Tag to switch on
467 -> [(ConTagZ, CmmAGraph)] -- Tagged branches
468 -> Maybe CmmAGraph -- Default branch (if any)
469 -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
470 -- outside this range is undefined
471 -> FCode ()
472
473 -- First, two rather common cases in which there is no work to do
474 mkCmmSwitch _ _ [] (Just code) _ _ = emit code
475 mkCmmSwitch _ _ [(_,code)] Nothing _ _ = emit code
476
477 -- Right, off we go
478 mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do
479 join_lbl <- newLabelC
480 mb_deflt_lbl <- label_default join_lbl mb_deflt
481 branches_lbls <- label_branches join_lbl branches
482 tag_expr' <- assignTemp' tag_expr
483
484 emit =<< mk_switch tag_expr' (sortBy (comparing fst) branches_lbls)
485 mb_deflt_lbl lo_tag hi_tag via_C
486
487 -- Sort the branches before calling mk_switch
488
489 emitLabel join_lbl
490
491 mk_switch :: CmmExpr -> [(ConTagZ, BlockId)]
492 -> Maybe BlockId
493 -> ConTagZ -> ConTagZ -> Bool
494 -> FCode CmmAGraph
495
496 -- SINGLETON TAG RANGE: no case analysis to do
497 mk_switch _tag_expr [(tag, lbl)] _ lo_tag hi_tag _via_C
498 | lo_tag == hi_tag
499 = ASSERT( tag == lo_tag )
500 return (mkBranch lbl)
501
502 -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
503 mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _
504 = return (mkBranch lbl)
505 -- The simplifier might have eliminated a case
506 -- so we may have e.g. case xs of
507 -- [] -> e
508 -- In that situation we can be sure the (:) case
509 -- can't happen, so no need to test
510
511 -- SINGLETON BRANCH: one equality check to do
512 mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _
513 = do dflags <- getDynFlags
514 let cond = cmmNeWord dflags tag_expr (mkIntExpr dflags tag)
515 -- We have lo_tag < hi_tag, but there's only one branch,
516 -- so there must be a default
517 return (mkCbranch cond deflt lbl)
518
519 -- ToDo: we might want to check for the two branch case, where one of
520 -- the branches is the tag 0, because comparing '== 0' is likely to be
521 -- more efficient than other kinds of comparison.
522
523 -- DENSE TAG RANGE: use a switch statment.
524 --
525 -- We also use a switch uncoditionally when compiling via C, because
526 -- this will get emitted as a C switch statement and the C compiler
527 -- should do a good job of optimising it. Also, older GCC versions
528 -- (2.95 in particular) have problems compiling the complicated
529 -- if-trees generated by this code, so compiling to a switch every
530 -- time works around that problem.
531 --
532 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
533 | use_switch -- Use a switch
534 = do let
535 find_branch :: ConTagZ -> Maybe BlockId
536 find_branch i = case (assocMaybe branches i) of
537 Just lbl -> Just lbl
538 Nothing -> mb_deflt
539
540 -- NB. we have eliminated impossible branches at
541 -- either end of the range (see below), so the first
542 -- tag of a real branch is real_lo_tag (not lo_tag).
543 arms :: [Maybe BlockId]
544 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
545 dflags <- getDynFlags
546 return (mkSwitch (cmmOffset dflags tag_expr (- real_lo_tag)) arms)
547
548 -- if we can knock off a bunch of default cases with one if, then do so
549 | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
550 = do dflags <- getDynFlags
551 stmts <- mk_switch tag_expr branches mb_deflt
552 lowest_branch hi_tag via_C
553 mkCmmIfThenElse
554 (cmmULtWord dflags tag_expr (mkIntExpr dflags lowest_branch))
555 (mkBranch deflt)
556 stmts
557
558 | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
559 = do dflags <- getDynFlags
560 stmts <- mk_switch tag_expr branches mb_deflt
561 lo_tag highest_branch via_C
562 mkCmmIfThenElse
563 (cmmUGtWord dflags tag_expr (mkIntExpr dflags highest_branch))
564 (mkBranch deflt)
565 stmts
566
567 | otherwise -- Use an if-tree
568 = do dflags <- getDynFlags
569 lo_stmts <- mk_switch tag_expr lo_branches mb_deflt
570 lo_tag (mid_tag-1) via_C
571 hi_stmts <- mk_switch tag_expr hi_branches mb_deflt
572 mid_tag hi_tag via_C
573 mkCmmIfThenElse
574 (cmmUGeWord dflags tag_expr (mkIntExpr dflags mid_tag))
575 hi_stmts
576 lo_stmts
577 -- we test (e >= mid_tag) rather than (e < mid_tag), because
578 -- the former works better when e is a comparison, and there
579 -- are two tags 0 & 1 (mid_tag == 1). In this case, the code
580 -- generator can reduce the condition to e itself without
581 -- having to reverse the sense of the comparison: comparisons
582 -- can't always be easily reversed (eg. floating
583 -- pt. comparisons).
584 where
585 use_switch = {- pprTrace "mk_switch" (
586 ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
587 text "branches:" <+> ppr (map fst branches) <+>
588 text "n_branches:" <+> int n_branches <+>
589 text "lo_tag:" <+> int lo_tag <+>
590 text "hi_tag:" <+> int hi_tag <+>
591 text "real_lo_tag:" <+> int real_lo_tag <+>
592 text "real_hi_tag:" <+> int real_hi_tag) $ -}
593 ASSERT( n_branches > 1 && n_tags > 1 )
594 n_tags > 2 && (via_C || (dense && big_enough))
595 -- up to 4 branches we use a decision tree, otherwise
596 -- a switch (== jump table in the NCG). This seems to be
597 -- optimal, and corresponds with what gcc does.
598 big_enough = n_branches > 4
599 dense = n_branches > (n_tags `div` 2)
600 n_branches = length branches
601
602 -- ignore default slots at each end of the range if there's
603 -- no default branch defined.
604 lowest_branch = fst (head branches)
605 highest_branch = fst (last branches)
606
607 real_lo_tag
608 | isNothing mb_deflt = lowest_branch
609 | otherwise = lo_tag
610
611 real_hi_tag
612 | isNothing mb_deflt = highest_branch
613 | otherwise = hi_tag
614
615 n_tags = real_hi_tag - real_lo_tag + 1
616
617 -- INVARIANT: Provided hi_tag > lo_tag (which is true)
618 -- lo_tag <= mid_tag < hi_tag
619 -- lo_branches have tags < mid_tag
620 -- hi_branches have tags >= mid_tag
621
622 (mid_tag,_) = branches !! (n_branches `div` 2)
623 -- 2 branches => n_branches `div` 2 = 1
624 -- => branches !! 1 give the *second* tag
625 -- There are always at least 2 branches here
626
627 (lo_branches, hi_branches) = span is_lo branches
628 is_lo (t,_) = t < mid_tag
629
630 --------------
631 emitCmmLitSwitch :: CmmExpr -- Tag to switch on
632 -> [(Literal, CmmAGraph)] -- Tagged branches
633 -> CmmAGraph -- Default branch (always)
634 -> FCode () -- Emit the code
635 -- Used for general literals, whose size might not be a word,
636 -- where there is always a default case, and where we don't know
637 -- the range of values for certain. For simplicity we always generate a tree.
638 --
639 -- ToDo: for integers we could do better here, perhaps by generalising
640 -- mk_switch and using that. --SDM 15/09/2004
641 emitCmmLitSwitch _scrut [] deflt = emit deflt
642 emitCmmLitSwitch scrut branches deflt = do
643 scrut' <- assignTemp' scrut
644 join_lbl <- newLabelC
645 deflt_lbl <- label_code join_lbl deflt
646 branches_lbls <- label_branches join_lbl branches
647 emit =<< mk_lit_switch scrut' deflt_lbl
648 (sortBy (comparing fst) branches_lbls)
649 emitLabel join_lbl
650
651 mk_lit_switch :: CmmExpr -> BlockId
652 -> [(Literal,BlockId)]
653 -> FCode CmmAGraph
654 mk_lit_switch scrut deflt [(lit,blk)]
655 = do
656 dflags <- getDynFlags
657 let
658 cmm_lit = mkSimpleLit dflags lit
659 cmm_ty = cmmLitType dflags cmm_lit
660 rep = typeWidth cmm_ty
661 ne = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep
662 return (mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk)
663
664 mk_lit_switch scrut deflt_blk_id branches
665 = do dflags <- getDynFlags
666 lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
667 hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
668 mkCmmIfThenElse (cond dflags) lo_blk hi_blk
669 where
670 n_branches = length branches
671 (mid_lit,_) = branches !! (n_branches `div` 2)
672 -- See notes above re mid_tag
673
674 (lo_branches, hi_branches) = span is_lo branches
675 is_lo (t,_) = t < mid_lit
676
677 cond dflags = CmmMachOp (mkLtOp dflags mid_lit)
678 [scrut, CmmLit (mkSimpleLit dflags mid_lit)]
679
680
681 --------------
682 label_default :: BlockId -> Maybe CmmAGraph -> FCode (Maybe BlockId)
683 label_default _ Nothing
684 = return Nothing
685 label_default join_lbl (Just code)
686 = do lbl <- label_code join_lbl code
687 return (Just lbl)
688
689 --------------
690 label_branches :: BlockId -> [(a,CmmAGraph)] -> FCode [(a,BlockId)]
691 label_branches _join_lbl []
692 = return []
693 label_branches join_lbl ((tag,code):branches)
694 = do lbl <- label_code join_lbl code
695 branches' <- label_branches join_lbl branches
696 return ((tag,lbl):branches')
697
698 --------------
699 label_code :: BlockId -> CmmAGraph -> FCode BlockId
700 -- label_code J code
701 -- generates
702 -- [L: code; goto J]
703 -- and returns L
704 label_code join_lbl code = do
705 lbl <- newLabelC
706 emitOutOfLine lbl (code <*> mkBranch join_lbl)
707 return lbl
708
709 --------------
710 assignTemp' :: CmmExpr -> FCode CmmExpr
711 assignTemp' e
712 | isTrivialCmmExpr e = return e
713 | otherwise = do
714 dflags <- getDynFlags
715 lreg <- newTemp (cmmExprType dflags e)
716 let reg = CmmLocal lreg
717 emitAssign reg e
718 return (CmmReg reg)