ad435c740edf80ffaeb66b0f91b65cf0563a65c7
[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 {-# OPTIONS -fno-warn-tabs #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and
12 -- detab the module (please do the detabbing in a separate patch). See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
14 -- for details
15
16 module StgCmmUtils (
17 cgLit, mkSimpleLit,
18 emitDataLits, mkDataLits,
19 emitRODataLits, mkRODataLits,
20 emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
21 assignTemp, newTemp,
22
23 newUnboxedTupleRegs,
24
25 emitMultiAssign, emitCmmLitSwitch, emitSwitch,
26
27 tagToClosure, mkTaggedObjectLoad,
28
29 callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
30
31 cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
32 cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
33 cmmOffsetExprW, cmmOffsetExprB,
34 cmmRegOffW, cmmRegOffB,
35 cmmLabelOffW, cmmLabelOffB,
36 cmmOffsetW, cmmOffsetB,
37 cmmOffsetLitW, cmmOffsetLitB,
38 cmmLoadIndexW,
39 cmmConstrTag, cmmConstrTag1,
40
41 cmmUntag, cmmIsTagged, cmmGetTag,
42
43 addToMem, addToMemE, addToMemLbl,
44 mkWordCLit,
45 newStringCLit, newByteStringCLit,
46 packHalfWordsCLit,
47 blankWord,
48
49 srt_escape
50 ) where
51
52 #include "HsVersions.h"
53 #include "../includes/stg/HaskellMachRegs.h"
54
55 import StgCmmMonad
56 import StgCmmClosure
57 import Cmm
58 import BlockId
59 import MkGraph
60 import CodeGen.CallerSaves
61 import CLabel
62 import CmmUtils
63
64 import ForeignCall
65 import IdInfo
66 import Type
67 import TyCon
68 import Constants
69 import SMRep
70 import Module
71 import Literal
72 import Digraph
73 import ListSetOps
74 import Util
75 import Unique
76 import DynFlags
77 import FastString
78 import Outputable
79
80 import Data.Char
81 import Data.List
82 import Data.Ord
83 import Data.Word
84 import Data.Maybe
85
86
87 -------------------------------------------------------------------------
88 --
89 -- Literals
90 --
91 -------------------------------------------------------------------------
92
93 cgLit :: Literal -> FCode CmmLit
94 cgLit (MachStr s) = newByteStringCLit (bytesFB s)
95 -- not unpackFS; we want the UTF-8 byte stream.
96 cgLit other_lit = return (mkSimpleLit other_lit)
97
98 mkLtOp :: Literal -> MachOp
99 -- On signed literals we must do a signed comparison
100 mkLtOp (MachInt _) = MO_S_Lt wordWidth
101 mkLtOp (MachFloat _) = MO_F_Lt W32
102 mkLtOp (MachDouble _) = MO_F_Lt W64
103 mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit)))
104 -- ToDo: seems terribly indirect!
105
106 mkSimpleLit :: Literal -> CmmLit
107 mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth
108 mkSimpleLit MachNullAddr = zeroCLit
109 mkSimpleLit (MachInt i) = CmmInt i wordWidth
110 mkSimpleLit (MachInt64 i) = CmmInt i W64
111 mkSimpleLit (MachWord i) = CmmInt i wordWidth
112 mkSimpleLit (MachWord64 i) = CmmInt i W64
113 mkSimpleLit (MachFloat r) = CmmFloat r W32
114 mkSimpleLit (MachDouble r) = CmmFloat r W64
115 mkSimpleLit (MachLabel fs ms fod)
116 = CmmLabel (mkForeignLabel fs ms labelSrc fod)
117 where
118 -- TODO: Literal labels might not actually be in the current package...
119 labelSrc = ForeignLabelInThisPackage
120 mkSimpleLit other = pprPanic "mkSimpleLit" (ppr other)
121
122 --------------------------------------------------------------------------
123 --
124 -- Incrementing a memory location
125 --
126 --------------------------------------------------------------------------
127
128 addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
129 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
130
131 addToMem :: CmmType -- rep of the counter
132 -> CmmExpr -- Address
133 -> Int -- What to add (a word)
134 -> CmmAGraph
135 addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))
136
137 addToMemE :: CmmType -- rep of the counter
138 -> CmmExpr -- Address
139 -> CmmExpr -- What to add (a word-typed expression)
140 -> CmmAGraph
141 addToMemE rep ptr n
142 = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])
143
144
145 -------------------------------------------------------------------------
146 --
147 -- Loading a field from an object,
148 -- where the object pointer is itself tagged
149 --
150 -------------------------------------------------------------------------
151
152 mkTaggedObjectLoad :: LocalReg -> LocalReg -> WordOff -> DynTag -> CmmAGraph
153 -- (loadTaggedObjectField reg base off tag) generates assignment
154 -- reg = bitsK[ base + off - tag ]
155 -- where K is fixed by 'reg'
156 mkTaggedObjectLoad reg base offset tag
157 = mkAssign (CmmLocal reg)
158 (CmmLoad (cmmOffsetB (CmmReg (CmmLocal base))
159 (wORD_SIZE*offset - tag))
160 (localRegType reg))
161
162 -------------------------------------------------------------------------
163 --
164 -- Converting a closure tag to a closure for enumeration types
165 -- (this is the implementation of tagToEnum#).
166 --
167 -------------------------------------------------------------------------
168
169 tagToClosure :: TyCon -> CmmExpr -> CmmExpr
170 tagToClosure tycon tag
171 = CmmLoad (cmmOffsetExprW closure_tbl tag) bWord
172 where closure_tbl = CmmLit (CmmLabel lbl)
173 lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
174
175 -------------------------------------------------------------------------
176 --
177 -- Conditionals and rts calls
178 --
179 -------------------------------------------------------------------------
180
181 emitRtsCall :: PackageId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
182 emitRtsCall pkg fun args safe = emitRtsCallGen [] pkg fun args safe
183
184 emitRtsCallWithResult :: LocalReg -> ForeignHint -> PackageId -> FastString
185 -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
186 emitRtsCallWithResult res hint pkg fun args safe
187 = emitRtsCallGen [(res,hint)] pkg fun args safe
188
189 -- Make a call to an RTS C procedure
190 emitRtsCallGen
191 :: [(LocalReg,ForeignHint)]
192 -> PackageId
193 -> FastString
194 -> [(CmmExpr,ForeignHint)]
195 -> Bool -- True <=> CmmSafe call
196 -> FCode ()
197 emitRtsCallGen res pkg fun args safe
198 = do { dflags <- getDynFlags
199 ; updfr_off <- getUpdFrameOff
200 ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags
201 ; emit caller_save
202 ; call updfr_off
203 ; emit caller_load }
204 where
205 call updfr_off =
206 if safe then
207 emit =<< mkCmmCall fun_expr res' args' updfr_off
208 else
209 emit $ mkUnsafeCall (ForeignTarget fun_expr
210 (ForeignConvention CCallConv arg_hints res_hints)) res' args'
211 (args', arg_hints) = unzip args
212 (res', res_hints) = unzip res
213 fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
214
215
216 -----------------------------------------------------------------------------
217 --
218 -- Caller-Save Registers
219 --
220 -----------------------------------------------------------------------------
221
222 -- Here we generate the sequence of saves/restores required around a
223 -- foreign call instruction.
224
225 -- TODO: reconcile with includes/Regs.h
226 -- * Regs.h claims that BaseReg should be saved last and loaded first
227 -- * This might not have been tickled before since BaseReg is callee save
228 -- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
229 --
230 -- This code isn't actually used right now, because callerSaves
231 -- only ever returns true in the current universe for registers NOT in
232 -- system_regs (just do a grep for CALLER_SAVES in
233 -- includes/stg/MachRegs.h). It's all one giant no-op, and for
234 -- good reason: having to save system registers on every foreign call
235 -- would be very expensive, so we avoid assigning them to those
236 -- registers when we add support for an architecture.
237 --
238 -- Note that the old code generator actually does more work here: it
239 -- also saves other global registers. We can't (nor want) to do that
240 -- here, as we don't have liveness information. And really, we
241 -- shouldn't be doing the workaround at this point in the pipeline, see
242 -- Note [Register parameter passing] and the ToDo on CmmCall in
243 -- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across
244 -- unsafe foreign calls in rewriteAssignments, but this is strictly
245 -- temporary.
246 callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)
247 callerSaveVolatileRegs dflags = (caller_save, caller_load)
248 where
249 platform = targetPlatform dflags
250
251 caller_save = catAGraphs (map callerSaveGlobalReg regs_to_save)
252 caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)
253
254 system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery
255 {- ,SparkHd,SparkTl,SparkBase,SparkLim -}
256 , BaseReg ]
257
258 regs_to_save = filter (callerSaves platform) system_regs
259
260 callerSaveGlobalReg reg
261 = mkStore (get_GlobalReg_addr reg) (CmmReg (CmmGlobal reg))
262
263 callerRestoreGlobalReg reg
264 = mkAssign (CmmGlobal reg)
265 (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
266
267 -- -----------------------------------------------------------------------------
268 -- Global registers
269
270 -- We map STG registers onto appropriate CmmExprs. Either they map
271 -- to real machine registers or stored as offsets from BaseReg. Given
272 -- a GlobalReg, get_GlobalReg_addr always produces the
273 -- register table address for it.
274 -- (See also get_GlobalReg_reg_or_addr in MachRegs)
275
276 get_GlobalReg_addr :: GlobalReg -> CmmExpr
277 get_GlobalReg_addr BaseReg = regTableOffset 0
278 get_GlobalReg_addr mid = get_Regtable_addr_from_offset
279 (globalRegType mid) (baseRegOffset mid)
280
281 -- Calculate a literal representing an offset into the register table.
282 -- Used when we don't have an actual BaseReg to offset from.
283 regTableOffset :: Int -> CmmExpr
284 regTableOffset n =
285 CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
286
287 get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr
288 get_Regtable_addr_from_offset _rep offset =
289 #ifdef REG_Base
290 CmmRegOff (CmmGlobal BaseReg) offset
291 #else
292 regTableOffset offset
293 #endif
294
295
296 -- -----------------------------------------------------------------------------
297 -- Information about global registers
298
299 baseRegOffset :: GlobalReg -> Int
300
301 baseRegOffset Sp = oFFSET_StgRegTable_rSp
302 baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim
303 baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1
304 baseRegOffset Hp = oFFSET_StgRegTable_rHp
305 baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim
306 baseRegOffset CCCS = oFFSET_StgRegTable_rCCCS
307 baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO
308 baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery
309 baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc
310 baseRegOffset GCEnter1 = oFFSET_stgGCEnter1
311 baseRegOffset GCFun = oFFSET_stgGCFun
312 baseRegOffset reg = pprPanic "baseRegOffset:" (ppr reg)
313
314 -------------------------------------------------------------------------
315 --
316 -- Strings generate a top-level data block
317 --
318 -------------------------------------------------------------------------
319
320 emitDataLits :: CLabel -> [CmmLit] -> FCode ()
321 -- Emit a data-segment data block
322 emitDataLits lbl lits = emitDecl (mkDataLits Data lbl lits)
323
324 emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
325 -- Emit a read-only data block
326 emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)
327
328 newStringCLit :: String -> FCode CmmLit
329 -- Make a global definition for the string,
330 -- and return its label
331 newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str)
332
333 newByteStringCLit :: [Word8] -> FCode CmmLit
334 newByteStringCLit bytes
335 = do { uniq <- newUnique
336 ; let (lit, decl) = mkByteStringCLit uniq bytes
337 ; emitDecl decl
338 ; return lit }
339
340 -------------------------------------------------------------------------
341 --
342 -- Assigning expressions to temporaries
343 --
344 -------------------------------------------------------------------------
345
346 assignTemp :: CmmExpr -> FCode LocalReg
347 -- Make sure the argument is in a local register.
348 -- We don't bother being particularly aggressive with avoiding
349 -- unnecessary local registers, since we can rely on a later
350 -- optimization pass to inline as necessary (and skipping out
351 -- on things like global registers can be a little dangerous
352 -- due to them being trashed on foreign calls--though it means
353 -- the optimization pass doesn't have to do as much work)
354 assignTemp (CmmReg (CmmLocal reg)) = return reg
355 assignTemp e = do { uniq <- newUnique
356 ; let reg = LocalReg uniq (cmmExprType e)
357 ; emitAssign (CmmLocal reg) e
358 ; return reg }
359
360 newTemp :: CmmType -> FCode LocalReg
361 newTemp rep = do { uniq <- newUnique
362 ; return (LocalReg uniq rep) }
363
364 newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
365 -- Choose suitable local regs to use for the components
366 -- of an unboxed tuple that we are about to return to
367 -- the Sequel. If the Sequel is a join point, using the
368 -- regs it wants will save later assignments.
369 newUnboxedTupleRegs res_ty
370 = ASSERT( isUnboxedTupleType res_ty )
371 do { sequel <- getSequel
372 ; regs <- choose_regs sequel
373 ; ASSERT( regs `equalLength` reps )
374 return (regs, map primRepForeignHint reps) }
375 where
376 UbxTupleRep ty_args = repType res_ty
377 reps = [ rep
378 | ty <- ty_args
379 , let rep = typePrimRep ty
380 , not (isVoidRep rep) ]
381 choose_regs (AssignTo regs _) = return regs
382 choose_regs _other = mapM (newTemp . primRepCmmType) reps
383
384
385
386 -------------------------------------------------------------------------
387 -- emitMultiAssign
388 -------------------------------------------------------------------------
389
390 emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
391 -- Emit code to perform the assignments in the
392 -- input simultaneously, using temporary variables when necessary.
393
394 type Key = Int
395 type Vrtx = (Key, Stmt) -- Give each vertex a unique number,
396 -- for fast comparison
397 type Stmt = (LocalReg, CmmExpr) -- r := e
398
399 -- We use the strongly-connected component algorithm, in which
400 -- * the vertices are the statements
401 -- * an edge goes from s1 to s2 iff
402 -- s1 assigns to something s2 uses
403 -- that is, if s1 should *follow* s2 in the final order
404
405 emitMultiAssign [] [] = return ()
406 emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs
407 emitMultiAssign regs rhss = ASSERT( equalLength regs rhss )
408 unscramble ([1..] `zip` (regs `zip` rhss))
409
410 unscramble :: [Vrtx] -> FCode ()
411 unscramble vertices = mapM_ do_component components
412 where
413 edges :: [ (Vrtx, Key, [Key]) ]
414 edges = [ (vertex, key1, edges_from stmt1)
415 | vertex@(key1, stmt1) <- vertices ]
416
417 edges_from :: Stmt -> [Key]
418 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
419 stmt1 `mustFollow` stmt2 ]
420
421 components :: [SCC Vrtx]
422 components = stronglyConnCompFromEdgedVertices edges
423
424 -- do_components deal with one strongly-connected component
425 -- Not cyclic, or singleton? Just do it
426 do_component :: SCC Vrtx -> FCode ()
427 do_component (AcyclicSCC (_,stmt)) = mk_graph stmt
428 do_component (CyclicSCC []) = panic "do_component"
429 do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt
430
431 -- Cyclic? Then go via temporaries. Pick one to
432 -- break the loop and try again with the rest.
433 do_component (CyclicSCC ((_,first_stmt) : rest)) = do
434 u <- newUnique
435 let (to_tmp, from_tmp) = split u first_stmt
436 mk_graph to_tmp
437 unscramble rest
438 mk_graph from_tmp
439
440 split :: Unique -> Stmt -> (Stmt, Stmt)
441 split uniq (reg, rhs)
442 = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))
443 where
444 rep = cmmExprType rhs
445 tmp = LocalReg uniq rep
446
447 mk_graph :: Stmt -> FCode ()
448 mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs
449
450 mustFollow :: Stmt -> Stmt -> Bool
451 (reg, _) `mustFollow` (_, rhs) = CmmLocal reg `regUsedIn` rhs
452
453 -------------------------------------------------------------------------
454 -- mkSwitch
455 -------------------------------------------------------------------------
456
457
458 emitSwitch :: CmmExpr -- Tag to switch on
459 -> [(ConTagZ, CmmAGraph)] -- Tagged branches
460 -> Maybe CmmAGraph -- Default branch (if any)
461 -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
462 -- outside this range is undefined
463 -> FCode ()
464 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
465 = do { dflags <- getDynFlags
466 ; mkCmmSwitch (via_C dflags) tag_expr branches mb_deflt lo_tag hi_tag }
467 where
468 via_C dflags | HscC <- hscTarget dflags = True
469 | otherwise = False
470
471
472 mkCmmSwitch :: Bool -- True <=> never generate a conditional tree
473 -> CmmExpr -- Tag to switch on
474 -> [(ConTagZ, CmmAGraph)] -- Tagged branches
475 -> Maybe CmmAGraph -- Default branch (if any)
476 -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
477 -- outside this range is undefined
478 -> FCode ()
479
480 -- First, two rather common cases in which there is no work to do
481 mkCmmSwitch _ _ [] (Just code) _ _ = emit code
482 mkCmmSwitch _ _ [(_,code)] Nothing _ _ = emit code
483
484 -- Right, off we go
485 mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag = do
486 join_lbl <- newLabelC
487 mb_deflt_lbl <- label_default join_lbl mb_deflt
488 branches_lbls <- label_branches join_lbl branches
489 tag_expr' <- assignTemp' tag_expr
490
491 emit =<< mk_switch tag_expr' (sortBy (comparing fst) branches_lbls)
492 mb_deflt_lbl lo_tag hi_tag via_C
493
494 -- Sort the branches before calling mk_switch
495
496 emitLabel join_lbl
497
498 mk_switch :: CmmExpr -> [(ConTagZ, BlockId)]
499 -> Maybe BlockId
500 -> ConTagZ -> ConTagZ -> Bool
501 -> FCode CmmAGraph
502
503 -- SINGLETON TAG RANGE: no case analysis to do
504 mk_switch _tag_expr [(tag, lbl)] _ lo_tag hi_tag _via_C
505 | lo_tag == hi_tag
506 = ASSERT( tag == lo_tag )
507 return (mkBranch lbl)
508
509 -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
510 mk_switch _tag_expr [(_tag,lbl)] Nothing _ _ _
511 = return (mkBranch lbl)
512 -- The simplifier might have eliminated a case
513 -- so we may have e.g. case xs of
514 -- [] -> e
515 -- In that situation we can be sure the (:) case
516 -- can't happen, so no need to test
517
518 -- SINGLETON BRANCH: one equality check to do
519 mk_switch tag_expr [(tag,lbl)] (Just deflt) _ _ _
520 = return (mkCbranch cond deflt lbl)
521 where
522 cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
523 -- We have lo_tag < hi_tag, but there's only one branch,
524 -- so there must be a default
525
526 -- ToDo: we might want to check for the two branch case, where one of
527 -- the branches is the tag 0, because comparing '== 0' is likely to be
528 -- more efficient than other kinds of comparison.
529
530 -- DENSE TAG RANGE: use a switch statment.
531 --
532 -- We also use a switch uncoditionally when compiling via C, because
533 -- this will get emitted as a C switch statement and the C compiler
534 -- should do a good job of optimising it. Also, older GCC versions
535 -- (2.95 in particular) have problems compiling the complicated
536 -- if-trees generated by this code, so compiling to a switch every
537 -- time works around that problem.
538 --
539 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
540 | use_switch -- Use a switch
541 = let
542 find_branch :: ConTagZ -> Maybe BlockId
543 find_branch i = case (assocMaybe branches i) of
544 Just lbl -> Just lbl
545 Nothing -> mb_deflt
546
547 -- NB. we have eliminated impossible branches at
548 -- either end of the range (see below), so the first
549 -- tag of a real branch is real_lo_tag (not lo_tag).
550 arms :: [Maybe BlockId]
551 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
552 in
553 return (mkSwitch (cmmOffset tag_expr (- real_lo_tag)) arms)
554
555 -- if we can knock off a bunch of default cases with one if, then do so
556 | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
557 = do stmts <- mk_switch tag_expr branches mb_deflt
558 lowest_branch hi_tag via_C
559 mkCmmIfThenElse
560 (cmmULtWord tag_expr (CmmLit (mkIntCLit lowest_branch)))
561 (mkBranch deflt)
562 stmts
563
564 | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
565 = do stmts <- mk_switch tag_expr branches mb_deflt
566 lo_tag highest_branch via_C
567 mkCmmIfThenElse
568 (cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch)))
569 (mkBranch deflt)
570 stmts
571
572 | otherwise -- Use an if-tree
573 = do lo_stmts <- mk_switch tag_expr lo_branches mb_deflt
574 lo_tag (mid_tag-1) via_C
575 hi_stmts <- mk_switch tag_expr hi_branches mb_deflt
576 mid_tag hi_tag via_C
577 mkCmmIfThenElse
578 (cmmUGeWord tag_expr (CmmLit (mkIntCLit mid_tag)))
579 hi_stmts
580 lo_stmts
581 -- we test (e >= mid_tag) rather than (e < mid_tag), because
582 -- the former works better when e is a comparison, and there
583 -- are two tags 0 & 1 (mid_tag == 1). In this case, the code
584 -- generator can reduce the condition to e itself without
585 -- having to reverse the sense of the comparison: comparisons
586 -- can't always be easily reversed (eg. floating
587 -- pt. comparisons).
588 where
589 use_switch = {- pprTrace "mk_switch" (
590 ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
591 text "branches:" <+> ppr (map fst branches) <+>
592 text "n_branches:" <+> int n_branches <+>
593 text "lo_tag:" <+> int lo_tag <+>
594 text "hi_tag:" <+> int hi_tag <+>
595 text "real_lo_tag:" <+> int real_lo_tag <+>
596 text "real_hi_tag:" <+> int real_hi_tag) $ -}
597 ASSERT( n_branches > 1 && n_tags > 1 )
598 n_tags > 2 && (via_C || (dense && big_enough))
599 -- up to 4 branches we use a decision tree, otherwise
600 -- a switch (== jump table in the NCG). This seems to be
601 -- optimal, and corresponds with what gcc does.
602 big_enough = n_branches > 4
603 dense = n_branches > (n_tags `div` 2)
604 n_branches = length branches
605
606 -- ignore default slots at each end of the range if there's
607 -- no default branch defined.
608 lowest_branch = fst (head branches)
609 highest_branch = fst (last branches)
610
611 real_lo_tag
612 | isNothing mb_deflt = lowest_branch
613 | otherwise = lo_tag
614
615 real_hi_tag
616 | isNothing mb_deflt = highest_branch
617 | otherwise = hi_tag
618
619 n_tags = real_hi_tag - real_lo_tag + 1
620
621 -- INVARIANT: Provided hi_tag > lo_tag (which is true)
622 -- lo_tag <= mid_tag < hi_tag
623 -- lo_branches have tags < mid_tag
624 -- hi_branches have tags >= mid_tag
625
626 (mid_tag,_) = branches !! (n_branches `div` 2)
627 -- 2 branches => n_branches `div` 2 = 1
628 -- => branches !! 1 give the *second* tag
629 -- There are always at least 2 branches here
630
631 (lo_branches, hi_branches) = span is_lo branches
632 is_lo (t,_) = t < mid_tag
633
634 --------------
635 emitCmmLitSwitch :: CmmExpr -- Tag to switch on
636 -> [(Literal, CmmAGraph)] -- Tagged branches
637 -> CmmAGraph -- Default branch (always)
638 -> FCode () -- Emit the code
639 -- Used for general literals, whose size might not be a word,
640 -- where there is always a default case, and where we don't know
641 -- the range of values for certain. For simplicity we always generate a tree.
642 --
643 -- ToDo: for integers we could do better here, perhaps by generalising
644 -- mk_switch and using that. --SDM 15/09/2004
645 emitCmmLitSwitch _scrut [] deflt = emit deflt
646 emitCmmLitSwitch scrut branches deflt = do
647 scrut' <- assignTemp' scrut
648 join_lbl <- newLabelC
649 deflt_lbl <- label_code join_lbl deflt
650 branches_lbls <- label_branches join_lbl branches
651 emit =<< mk_lit_switch scrut' deflt_lbl
652 (sortBy (comparing fst) branches_lbls)
653 emitLabel join_lbl
654
655 mk_lit_switch :: CmmExpr -> BlockId
656 -> [(Literal,BlockId)]
657 -> FCode CmmAGraph
658 mk_lit_switch scrut deflt [(lit,blk)]
659 = return (mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk)
660 where
661 cmm_lit = mkSimpleLit lit
662 cmm_ty = cmmLitType cmm_lit
663 rep = typeWidth cmm_ty
664 ne = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep
665
666 mk_lit_switch scrut deflt_blk_id branches
667 = do lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
668 hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
669 mkCmmIfThenElse cond lo_blk hi_blk
670 where
671 n_branches = length branches
672 (mid_lit,_) = branches !! (n_branches `div` 2)
673 -- See notes above re mid_tag
674
675 (lo_branches, hi_branches) = span is_lo branches
676 is_lo (t,_) = t < mid_lit
677
678 cond = CmmMachOp (mkLtOp mid_lit)
679 [scrut, CmmLit (mkSimpleLit mid_lit)]
680
681
682 --------------
683 label_default :: BlockId -> Maybe CmmAGraph -> FCode (Maybe BlockId)
684 label_default _ Nothing
685 = return Nothing
686 label_default join_lbl (Just code)
687 = do lbl <- label_code join_lbl code
688 return (Just lbl)
689
690 --------------
691 label_branches :: BlockId -> [(a,CmmAGraph)] -> FCode [(a,BlockId)]
692 label_branches _join_lbl []
693 = return []
694 label_branches join_lbl ((tag,code):branches)
695 = do lbl <- label_code join_lbl code
696 branches' <- label_branches join_lbl branches
697 return ((tag,lbl):branches')
698
699 --------------
700 label_code :: BlockId -> CmmAGraph -> FCode BlockId
701 -- label_code J code
702 -- generates
703 -- [L: code; goto J]
704 -- and returns L
705 label_code join_lbl code = do
706 lbl <- newLabelC
707 emitOutOfLine lbl (code <*> mkBranch join_lbl)
708 return lbl
709
710 --------------
711 assignTemp' :: CmmExpr -> FCode CmmExpr
712 assignTemp' e
713 | isTrivialCmmExpr e = return e
714 | otherwise = do
715 lreg <- newTemp (cmmExprType e)
716 let reg = CmmLocal lreg
717 emitAssign reg e
718 return (CmmReg reg)
719
720 srt_escape :: StgHalfWord
721 srt_escape = -1