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