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