Fix warnings in codeGen/CgUtils.hs
[ghc.git] / compiler / codeGen / CgUtils.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generator utilities; mostly monadic
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module CgUtils (
10 addIdReps,
11 cgLit,
12 emitDataLits, mkDataLits,
13 emitRODataLits, mkRODataLits,
14 emitIf, emitIfThenElse,
15 emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
16 assignTemp, assignTemp_, newTemp,
17 emitSimultaneously,
18 emitSwitch, emitLitSwitch,
19 tagToClosure,
20
21 callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
22 activeStgRegs, fixStgRegisters,
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 tagForCon, tagCons, isSmallFamily,
35 cmmUntag, cmmIsTagged, cmmGetTag,
36
37 addToMem, addToMemE,
38 mkWordCLit,
39 newStringCLit, newByteStringCLit,
40 packHalfWordsCLit,
41 blankWord,
42
43 getSRTInfo
44 ) where
45
46 #include "HsVersions.h"
47 #include "../includes/stg/MachRegs.h"
48
49 import BlockId
50 import CgMonad
51 import TyCon
52 import DataCon
53 import Id
54 import IdInfo
55 import Constants
56 import SMRep
57 import OldCmm
58 import OldCmmUtils
59 import CLabel
60 import ForeignCall
61 import ClosureInfo
62 import StgSyn (SRT(..))
63 import Module
64 import Literal
65 import Digraph
66 import ListSetOps
67 import Util
68 import DynFlags
69 import FastString
70 import Outputable
71
72 import Data.Char
73 import Data.Word
74 import Data.Maybe
75
76 -------------------------------------------------------------------------
77 --
78 -- Random small functions
79 --
80 -------------------------------------------------------------------------
81
82 addIdReps :: [Id] -> [(CgRep, Id)]
83 addIdReps ids = [(idCgRep id, id) | id <- ids]
84
85 -------------------------------------------------------------------------
86 --
87 -- Literals
88 --
89 -------------------------------------------------------------------------
90
91 cgLit :: Literal -> FCode CmmLit
92 cgLit (MachStr s) = newByteStringCLit (bytesFS s)
93 -- not unpackFS; we want the UTF-8 byte stream.
94 cgLit other_lit = return (mkSimpleLit other_lit)
95
96 mkSimpleLit :: Literal -> CmmLit
97 mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordWidth
98 mkSimpleLit MachNullAddr = zeroCLit
99 mkSimpleLit (MachInt i) = CmmInt i wordWidth
100 mkSimpleLit (MachInt64 i) = CmmInt i W64
101 mkSimpleLit (MachWord i) = CmmInt i wordWidth
102 mkSimpleLit (MachWord64 i) = CmmInt i W64
103 mkSimpleLit (MachFloat r) = CmmFloat r W32
104 mkSimpleLit (MachDouble r) = CmmFloat r W64
105 mkSimpleLit (MachLabel fs ms fod)
106 = CmmLabel (mkForeignLabel fs ms labelSrc fod)
107 where
108 -- TODO: Literal labels might not actually be in the current package...
109 labelSrc = ForeignLabelInThisPackage
110 mkSimpleLit (MachStr _) = panic "mkSimpleLit: MachStr"
111
112 mkLtOp :: Literal -> MachOp
113 -- On signed literals we must do a signed comparison
114 mkLtOp (MachInt _) = MO_S_Lt wordWidth
115 mkLtOp (MachFloat _) = MO_F_Lt W32
116 mkLtOp (MachDouble _) = MO_F_Lt W64
117 mkLtOp lit = MO_U_Lt (typeWidth (cmmLitType (mkSimpleLit lit)))
118
119
120 ---------------------------------------------------
121 --
122 -- Cmm data type functions
123 --
124 ---------------------------------------------------
125
126
127
128 {-
129 The family size of a data type (the number of constructors)
130 can be either:
131 * small, if the family size < 2**tag_bits
132 * big, otherwise.
133
134 Small families can have the constructor tag in the tag
135 bits.
136 Big families only use the tag value 1 to represent
137 evaluatedness.
138 -}
139 isSmallFamily :: Int -> Bool
140 isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
141
142 tagForCon :: DataCon -> ConTagZ
143 tagForCon con = tag
144 where
145 con_tag = dataConTagZ con
146 fam_size = tyConFamilySize (dataConTyCon con)
147 tag | isSmallFamily fam_size = con_tag + 1
148 | otherwise = 1
149
150 --Tag an expression, to do: refactor, this appears in some other module.
151 tagCons :: DataCon -> CmmExpr -> CmmExpr
152 tagCons con expr = cmmOffsetB expr (tagForCon con)
153
154 --------------------------------------------------------------------------
155 --
156 -- Incrementing a memory location
157 --
158 --------------------------------------------------------------------------
159
160 addToMem :: Width -- rep of the counter
161 -> CmmExpr -- Address
162 -> Int -- What to add (a word)
163 -> CmmStmt
164 addToMem width ptr n = addToMemE width ptr (CmmLit (CmmInt (toInteger n) width))
165
166 addToMemE :: Width -- rep of the counter
167 -> CmmExpr -- Address
168 -> CmmExpr -- What to add (a word-typed expression)
169 -> CmmStmt
170 addToMemE width ptr n
171 = CmmStore ptr (CmmMachOp (MO_Add width) [CmmLoad ptr (cmmBits width), n])
172
173 -------------------------------------------------------------------------
174 --
175 -- Converting a closure tag to a closure for enumeration types
176 -- (this is the implementation of tagToEnum#).
177 --
178 -------------------------------------------------------------------------
179
180 tagToClosure :: TyCon -> CmmExpr -> CmmExpr
181 tagToClosure tycon tag
182 = CmmLoad (cmmOffsetExprW closure_tbl tag) gcWord
183 where closure_tbl = CmmLit (CmmLabel lbl)
184 lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs
185
186 -------------------------------------------------------------------------
187 --
188 -- Conditionals and rts calls
189 --
190 -------------------------------------------------------------------------
191
192 emitIf :: CmmExpr -- Boolean
193 -> Code -- Then part
194 -> Code
195 -- Emit (if e then x)
196 -- ToDo: reverse the condition to avoid the extra branch instruction if possible
197 -- (some conditionals aren't reversible. eg. floating point comparisons cannot
198 -- be inverted because there exist some values for which both comparisons
199 -- return False, such as NaN.)
200 emitIf cond then_part
201 = do { then_id <- newLabelC
202 ; join_id <- newLabelC
203 ; stmtC (CmmCondBranch cond then_id)
204 ; stmtC (CmmBranch join_id)
205 ; labelC then_id
206 ; then_part
207 ; labelC join_id
208 }
209
210 emitIfThenElse :: CmmExpr -- Boolean
211 -> Code -- Then part
212 -> Code -- Else part
213 -> Code
214 -- Emit (if e then x else y)
215 emitIfThenElse cond then_part else_part
216 = do { then_id <- newLabelC
217 ; join_id <- newLabelC
218 ; stmtC (CmmCondBranch cond then_id)
219 ; else_part
220 ; stmtC (CmmBranch join_id)
221 ; labelC then_id
222 ; then_part
223 ; labelC join_id
224 }
225
226
227 -- | Emit code to call a Cmm function.
228 emitRtsCall
229 :: PackageId -- ^ package the function is in
230 -> FastString -- ^ name of function
231 -> [CmmHinted CmmExpr] -- ^ function args
232 -> Bool -- ^ whether this is a safe call
233 -> Code -- ^ cmm code
234
235 emitRtsCall pkg fun args safe = emitRtsCall' [] pkg fun args Nothing safe
236 -- The 'Nothing' says "save all global registers"
237
238 emitRtsCallWithVols :: PackageId -> FastString -> [CmmHinted CmmExpr] -> [GlobalReg] -> Bool -> Code
239 emitRtsCallWithVols pkg fun args vols safe
240 = emitRtsCall' [] pkg fun args (Just vols) safe
241
242 emitRtsCallWithResult
243 :: LocalReg -> ForeignHint
244 -> PackageId -> FastString
245 -> [CmmHinted CmmExpr] -> Bool -> Code
246 emitRtsCallWithResult res hint pkg fun args safe
247 = emitRtsCall' [CmmHinted res hint] pkg fun args Nothing safe
248
249 -- Make a call to an RTS C procedure
250 emitRtsCall'
251 :: [CmmHinted LocalReg]
252 -> PackageId
253 -> FastString
254 -> [CmmHinted CmmExpr]
255 -> Maybe [GlobalReg]
256 -> Bool -- True <=> CmmSafe call
257 -> Code
258 emitRtsCall' res pkg fun args vols safe = do
259 safety <- if safe
260 then getSRTInfo >>= (return . CmmSafe)
261 else return CmmUnsafe
262 stmtsC caller_save
263 stmtC (CmmCall target res args safety CmmMayReturn)
264 stmtsC caller_load
265 where
266 (caller_save, caller_load) = callerSaveVolatileRegs vols
267 target = CmmCallee fun_expr CCallConv
268 fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
269
270 -----------------------------------------------------------------------------
271 --
272 -- Caller-Save Registers
273 --
274 -----------------------------------------------------------------------------
275
276 -- Here we generate the sequence of saves/restores required around a
277 -- foreign call instruction.
278
279 -- TODO: reconcile with includes/Regs.h
280 -- * Regs.h claims that BaseReg should be saved last and loaded first
281 -- * This might not have been tickled before since BaseReg is callee save
282 -- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim
283 callerSaveVolatileRegs :: Maybe [GlobalReg] -> ([CmmStmt], [CmmStmt])
284 callerSaveVolatileRegs vols = (caller_save, caller_load)
285 where
286 caller_save = foldr ($!) [] (map callerSaveGlobalReg regs_to_save)
287 caller_load = foldr ($!) [] (map callerRestoreGlobalReg regs_to_save)
288
289 system_regs = [Sp,SpLim,Hp,HpLim,CurrentTSO,CurrentNursery,
290 {-SparkHd,SparkTl,SparkBase,SparkLim,-}BaseReg ]
291
292 regs_to_save = system_regs ++ vol_list
293
294 vol_list = case vols of Nothing -> all_of_em; Just regs -> regs
295
296 all_of_em = [ VanillaReg n VNonGcPtr | n <- [0..mAX_Vanilla_REG] ]
297 -- The VNonGcPtr is a lie, but I don't think it matters
298 ++ [ FloatReg n | n <- [0..mAX_Float_REG] ]
299 ++ [ DoubleReg n | n <- [0..mAX_Double_REG] ]
300 ++ [ LongReg n | n <- [0..mAX_Long_REG] ]
301
302 callerSaveGlobalReg reg next
303 | callerSaves reg =
304 CmmStore (get_GlobalReg_addr reg)
305 (CmmReg (CmmGlobal reg)) : next
306 | otherwise = next
307
308 callerRestoreGlobalReg reg next
309 | callerSaves reg =
310 CmmAssign (CmmGlobal reg)
311 (CmmLoad (get_GlobalReg_addr reg) (globalRegType reg))
312 : next
313 | otherwise = next
314
315
316 -- | Returns @True@ if this global register is stored in a caller-saves
317 -- machine register.
318
319 callerSaves :: GlobalReg -> Bool
320
321 #ifdef CALLER_SAVES_Base
322 callerSaves BaseReg = True
323 #endif
324 #ifdef CALLER_SAVES_R1
325 callerSaves (VanillaReg 1 _) = True
326 #endif
327 #ifdef CALLER_SAVES_R2
328 callerSaves (VanillaReg 2 _) = True
329 #endif
330 #ifdef CALLER_SAVES_R3
331 callerSaves (VanillaReg 3 _) = True
332 #endif
333 #ifdef CALLER_SAVES_R4
334 callerSaves (VanillaReg 4 _) = True
335 #endif
336 #ifdef CALLER_SAVES_R5
337 callerSaves (VanillaReg 5 _) = True
338 #endif
339 #ifdef CALLER_SAVES_R6
340 callerSaves (VanillaReg 6 _) = True
341 #endif
342 #ifdef CALLER_SAVES_R7
343 callerSaves (VanillaReg 7 _) = True
344 #endif
345 #ifdef CALLER_SAVES_R8
346 callerSaves (VanillaReg 8 _) = True
347 #endif
348 #ifdef CALLER_SAVES_F1
349 callerSaves (FloatReg 1) = True
350 #endif
351 #ifdef CALLER_SAVES_F2
352 callerSaves (FloatReg 2) = True
353 #endif
354 #ifdef CALLER_SAVES_F3
355 callerSaves (FloatReg 3) = True
356 #endif
357 #ifdef CALLER_SAVES_F4
358 callerSaves (FloatReg 4) = True
359 #endif
360 #ifdef CALLER_SAVES_D1
361 callerSaves (DoubleReg 1) = True
362 #endif
363 #ifdef CALLER_SAVES_D2
364 callerSaves (DoubleReg 2) = True
365 #endif
366 #ifdef CALLER_SAVES_L1
367 callerSaves (LongReg 1) = True
368 #endif
369 #ifdef CALLER_SAVES_Sp
370 callerSaves Sp = True
371 #endif
372 #ifdef CALLER_SAVES_SpLim
373 callerSaves SpLim = True
374 #endif
375 #ifdef CALLER_SAVES_Hp
376 callerSaves Hp = True
377 #endif
378 #ifdef CALLER_SAVES_HpLim
379 callerSaves HpLim = True
380 #endif
381 #ifdef CALLER_SAVES_CurrentTSO
382 callerSaves CurrentTSO = True
383 #endif
384 #ifdef CALLER_SAVES_CurrentNursery
385 callerSaves CurrentNursery = True
386 #endif
387 callerSaves _ = False
388
389
390 -- -----------------------------------------------------------------------------
391 -- Information about global registers
392
393 baseRegOffset :: GlobalReg -> Int
394
395 baseRegOffset (VanillaReg 1 _) = oFFSET_StgRegTable_rR1
396 baseRegOffset (VanillaReg 2 _) = oFFSET_StgRegTable_rR2
397 baseRegOffset (VanillaReg 3 _) = oFFSET_StgRegTable_rR3
398 baseRegOffset (VanillaReg 4 _) = oFFSET_StgRegTable_rR4
399 baseRegOffset (VanillaReg 5 _) = oFFSET_StgRegTable_rR5
400 baseRegOffset (VanillaReg 6 _) = oFFSET_StgRegTable_rR6
401 baseRegOffset (VanillaReg 7 _) = oFFSET_StgRegTable_rR7
402 baseRegOffset (VanillaReg 8 _) = oFFSET_StgRegTable_rR8
403 baseRegOffset (VanillaReg 9 _) = oFFSET_StgRegTable_rR9
404 baseRegOffset (VanillaReg 10 _) = oFFSET_StgRegTable_rR10
405 baseRegOffset (FloatReg 1) = oFFSET_StgRegTable_rF1
406 baseRegOffset (FloatReg 2) = oFFSET_StgRegTable_rF2
407 baseRegOffset (FloatReg 3) = oFFSET_StgRegTable_rF3
408 baseRegOffset (FloatReg 4) = oFFSET_StgRegTable_rF4
409 baseRegOffset (DoubleReg 1) = oFFSET_StgRegTable_rD1
410 baseRegOffset (DoubleReg 2) = oFFSET_StgRegTable_rD2
411 baseRegOffset Sp = oFFSET_StgRegTable_rSp
412 baseRegOffset SpLim = oFFSET_StgRegTable_rSpLim
413 baseRegOffset (LongReg 1) = oFFSET_StgRegTable_rL1
414 baseRegOffset Hp = oFFSET_StgRegTable_rHp
415 baseRegOffset HpLim = oFFSET_StgRegTable_rHpLim
416 baseRegOffset CurrentTSO = oFFSET_StgRegTable_rCurrentTSO
417 baseRegOffset CurrentNursery = oFFSET_StgRegTable_rCurrentNursery
418 baseRegOffset HpAlloc = oFFSET_StgRegTable_rHpAlloc
419 baseRegOffset EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo
420 baseRegOffset GCEnter1 = oFFSET_stgGCEnter1
421 baseRegOffset GCFun = oFFSET_stgGCFun
422 baseRegOffset BaseReg = panic "baseRegOffset:BaseReg"
423 baseRegOffset _ = panic "baseRegOffset:other"
424
425
426 -------------------------------------------------------------------------
427 --
428 -- Strings generate a top-level data block
429 --
430 -------------------------------------------------------------------------
431
432 emitDataLits :: CLabel -> [CmmLit] -> Code
433 -- Emit a data-segment data block
434 emitDataLits lbl lits = emitDecl (mkDataLits Data lbl lits)
435
436 emitRODataLits :: String -> CLabel -> [CmmLit] -> Code
437 -- Emit a read-only data block
438 emitRODataLits _caller lbl lits
439 = emitDecl (mkRODataLits lbl lits)
440
441 newStringCLit :: String -> FCode CmmLit
442 -- Make a global definition for the string,
443 -- and return its label
444 newStringCLit str = newByteStringCLit (map (fromIntegral.ord) str)
445
446 newByteStringCLit :: [Word8] -> FCode CmmLit
447 newByteStringCLit bytes
448 = do { uniq <- newUnique
449 ; let (lit, decl) = mkByteStringCLit uniq bytes
450 ; emitDecl decl
451 ; return lit }
452
453 -------------------------------------------------------------------------
454 --
455 -- Assigning expressions to temporaries
456 --
457 -------------------------------------------------------------------------
458
459 -- | If the expression is trivial, return it. Otherwise, assign the
460 -- expression to a temporary register and return an expression
461 -- referring to this register.
462 assignTemp :: CmmExpr -> FCode CmmExpr
463 -- For a non-trivial expression, e, create a local
464 -- variable and assign the expression to it
465 assignTemp e
466 | isTrivialCmmExpr e = return e
467 | otherwise = do { reg <- newTemp (cmmExprType e)
468 ; stmtC (CmmAssign (CmmLocal reg) e)
469 ; return (CmmReg (CmmLocal reg)) }
470
471 -- | If the expression is trivial and doesn't refer to a global
472 -- register, return it. Otherwise, assign the expression to a
473 -- temporary register and return an expression referring to this
474 -- register.
475 assignTemp_ :: CmmExpr -> FCode CmmExpr
476 assignTemp_ e
477 | isTrivialCmmExpr e && hasNoGlobalRegs e = return e
478 | otherwise = do
479 reg <- newTemp (cmmExprType e)
480 stmtC (CmmAssign (CmmLocal reg) e)
481 return (CmmReg (CmmLocal reg))
482
483 newTemp :: CmmType -> FCode LocalReg
484 newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) }
485
486 -------------------------------------------------------------------------
487 --
488 -- Building case analysis
489 --
490 -------------------------------------------------------------------------
491
492 emitSwitch
493 :: CmmExpr -- Tag to switch on
494 -> [(ConTagZ, CgStmts)] -- Tagged branches
495 -> Maybe CgStmts -- Default branch (if any)
496 -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
497 -- outside this range is undefined
498 -> Code
499
500 -- ONLY A DEFAULT BRANCH: no case analysis to do
501 emitSwitch _ [] (Just stmts) _ _
502 = emitCgStmts stmts
503
504 -- Right, off we go
505 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
506 = -- Just sort the branches before calling mk_sritch
507 do { mb_deflt_id <-
508 case mb_deflt of
509 Nothing -> return Nothing
510 Just stmts -> do id <- forkCgStmts stmts; return (Just id)
511
512 ; dflags <- getDynFlags
513 ; let via_C | HscC <- hscTarget dflags = True
514 | otherwise = False
515
516 ; stmts <- mk_switch tag_expr (sortLe le branches)
517 mb_deflt_id lo_tag hi_tag via_C
518 ; emitCgStmts stmts
519 }
520 where
521 (t1,_) `le` (t2,_) = t1 <= t2
522
523
524 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
525 -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
526 -> FCode CgStmts
527
528 -- SINGLETON TAG RANGE: no case analysis to do
529 mk_switch _tag_expr [(tag,stmts)] _ lo_tag hi_tag _via_C
530 | lo_tag == hi_tag
531 = ASSERT( tag == lo_tag )
532 return stmts
533
534 -- SINGLETON BRANCH, NO DEFAULT: no case analysis to do
535 mk_switch _tag_expr [(_tag,stmts)] Nothing _lo_tag _hi_tag _via_C
536 = return stmts
537 -- The simplifier might have eliminated a case
538 -- so we may have e.g. case xs of
539 -- [] -> e
540 -- In that situation we can be sure the (:) case
541 -- can't happen, so no need to test
542
543 -- SINGLETON BRANCH: one equality check to do
544 mk_switch tag_expr [(tag,stmts)] (Just deflt) _lo_tag _hi_tag _via_C
545 = return (CmmCondBranch cond deflt `consCgStmt` stmts)
546 where
547 cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
548 -- We have lo_tag < hi_tag, but there's only one branch,
549 -- so there must be a default
550
551 -- ToDo: we might want to check for the two branch case, where one of
552 -- the branches is the tag 0, because comparing '== 0' is likely to be
553 -- more efficient than other kinds of comparison.
554
555 -- DENSE TAG RANGE: use a switch statment.
556 --
557 -- We also use a switch uncoditionally when compiling via C, because
558 -- this will get emitted as a C switch statement and the C compiler
559 -- should do a good job of optimising it. Also, older GCC versions
560 -- (2.95 in particular) have problems compiling the complicated
561 -- if-trees generated by this code, so compiling to a switch every
562 -- time works around that problem.
563 --
564 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
565 | use_switch -- Use a switch
566 = do { branch_ids <- mapM forkCgStmts (map snd branches)
567 ; let
568 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
569
570 find_branch :: ConTagZ -> Maybe BlockId
571 find_branch i = assocDefault mb_deflt tagged_blk_ids i
572
573 -- NB. we have eliminated impossible branches at
574 -- either end of the range (see below), so the first
575 -- tag of a real branch is real_lo_tag (not lo_tag).
576 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
577
578 switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
579
580 ; ASSERT(not (all isNothing arms))
581 return (oneCgStmt switch_stmt)
582 }
583
584 -- if we can knock off a bunch of default cases with one if, then do so
585 | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
586 = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
587 ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
588 branch = CmmCondBranch cond deflt
589 ; stmts <- mk_switch tag_expr' branches mb_deflt
590 lowest_branch hi_tag via_C
591 ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
592 }
593
594 | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
595 = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
596 ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
597 branch = CmmCondBranch cond deflt
598 ; stmts <- mk_switch tag_expr' branches mb_deflt
599 lo_tag highest_branch via_C
600 ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
601 }
602
603 | otherwise -- Use an if-tree
604 = do { (assign_tag, tag_expr') <- assignTemp' tag_expr
605 -- To avoid duplication
606 ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
607 lo_tag (mid_tag-1) via_C
608 ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
609 mid_tag hi_tag via_C
610 ; hi_id <- forkCgStmts hi_stmts
611 ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
612 branch_stmt = CmmCondBranch cond hi_id
613 ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
614 }
615 -- we test (e >= mid_tag) rather than (e < mid_tag), because
616 -- the former works better when e is a comparison, and there
617 -- are two tags 0 & 1 (mid_tag == 1). In this case, the code
618 -- generator can reduce the condition to e itself without
619 -- having to reverse the sense of the comparison: comparisons
620 -- can't always be easily reversed (eg. floating
621 -- pt. comparisons).
622 where
623 use_switch = {- pprTrace "mk_switch" (
624 ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
625 text "branches:" <+> ppr (map fst branches) <+>
626 text "n_branches:" <+> int n_branches <+>
627 text "lo_tag:" <+> int lo_tag <+>
628 text "hi_tag:" <+> int hi_tag <+>
629 text "real_lo_tag:" <+> int real_lo_tag <+>
630 text "real_hi_tag:" <+> int real_hi_tag) $ -}
631 ASSERT( n_branches > 1 && n_tags > 1 )
632 n_tags > 2 && (via_C || (dense && big_enough))
633 -- up to 4 branches we use a decision tree, otherwise
634 -- a switch (== jump table in the NCG). This seems to be
635 -- optimal, and corresponds with what gcc does.
636 big_enough = n_branches > 4
637 dense = n_branches > (n_tags `div` 2)
638 n_branches = length branches
639
640 -- ignore default slots at each end of the range if there's
641 -- no default branch defined.
642 lowest_branch = fst (head branches)
643 highest_branch = fst (last branches)
644
645 real_lo_tag
646 | isNothing mb_deflt = lowest_branch
647 | otherwise = lo_tag
648
649 real_hi_tag
650 | isNothing mb_deflt = highest_branch
651 | otherwise = hi_tag
652
653 n_tags = real_hi_tag - real_lo_tag + 1
654
655 -- INVARIANT: Provided hi_tag > lo_tag (which is true)
656 -- lo_tag <= mid_tag < hi_tag
657 -- lo_branches have tags < mid_tag
658 -- hi_branches have tags >= mid_tag
659
660 (mid_tag,_) = branches !! (n_branches `div` 2)
661 -- 2 branches => n_branches `div` 2 = 1
662 -- => branches !! 1 give the *second* tag
663 -- There are always at least 2 branches here
664
665 (lo_branches, hi_branches) = span is_lo branches
666 is_lo (t,_) = t < mid_tag
667
668 assignTemp' :: CmmExpr -> FCode (CmmStmt, CmmExpr)
669 assignTemp' e
670 | isTrivialCmmExpr e = return (CmmNop, e)
671 | otherwise = do { reg <- newTemp (cmmExprType e)
672 ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
673
674 emitLitSwitch :: CmmExpr -- Tag to switch on
675 -> [(Literal, CgStmts)] -- Tagged branches
676 -> CgStmts -- Default branch (always)
677 -> Code -- Emit the code
678 -- Used for general literals, whose size might not be a word,
679 -- where there is always a default case, and where we don't know
680 -- the range of values for certain. For simplicity we always generate a tree.
681 --
682 -- ToDo: for integers we could do better here, perhaps by generalising
683 -- mk_switch and using that. --SDM 15/09/2004
684 emitLitSwitch _ [] deflt = emitCgStmts deflt
685 emitLitSwitch scrut branches deflt_blk
686 = do { scrut' <- assignTemp scrut
687 ; deflt_blk_id <- forkCgStmts deflt_blk
688 ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
689 ; emitCgStmts blk }
690 where
691 le (t1,_) (t2,_) = t1 <= t2
692
693 mk_lit_switch :: CmmExpr -> BlockId
694 -> [(Literal,CgStmts)]
695 -> FCode CgStmts
696 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
697 = return (consCgStmt if_stmt blk)
698 where
699 cmm_lit = mkSimpleLit lit
700 rep = cmmLitType cmm_lit
701 ne = if isFloatType rep then MO_F_Ne else MO_Ne
702 cond = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit]
703 if_stmt = CmmCondBranch cond deflt_blk_id
704
705 mk_lit_switch scrut deflt_blk_id branches
706 = do { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
707 ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
708 ; lo_blk_id <- forkCgStmts lo_blk
709 ; let if_stmt = CmmCondBranch cond lo_blk_id
710 ; return (if_stmt `consCgStmt` hi_blk) }
711 where
712 n_branches = length branches
713 (mid_lit,_) = branches !! (n_branches `div` 2)
714 -- See notes above re mid_tag
715
716 (lo_branches, hi_branches) = span is_lo branches
717 is_lo (t,_) = t < mid_lit
718
719 cond = CmmMachOp (mkLtOp mid_lit)
720 [scrut, CmmLit (mkSimpleLit mid_lit)]
721
722 -------------------------------------------------------------------------
723 --
724 -- Simultaneous assignment
725 --
726 -------------------------------------------------------------------------
727
728
729 emitSimultaneously :: CmmStmts -> Code
730 -- Emit code to perform the assignments in the
731 -- input simultaneously, using temporary variables when necessary.
732 --
733 -- The Stmts must be:
734 -- CmmNop, CmmComment, CmmAssign, CmmStore
735 -- and nothing else
736
737
738 -- We use the strongly-connected component algorithm, in which
739 -- * the vertices are the statements
740 -- * an edge goes from s1 to s2 iff
741 -- s1 assigns to something s2 uses
742 -- that is, if s1 should *follow* s2 in the final order
743
744 type CVertex = (Int, CmmStmt) -- Give each vertex a unique number,
745 -- for fast comparison
746
747 emitSimultaneously stmts
748 = codeOnly $
749 case filterOut isNopStmt (stmtList stmts) of
750 -- Remove no-ops
751 [] -> nopC
752 [stmt] -> stmtC stmt -- It's often just one stmt
753 stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
754
755 doSimultaneously1 :: [CVertex] -> Code
756 doSimultaneously1 vertices
757 = let
758 edges = [ (vertex, key1, edges_from stmt1)
759 | vertex@(key1, stmt1) <- vertices
760 ]
761 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
762 stmt1 `mustFollow` stmt2
763 ]
764 components = stronglyConnCompFromEdgedVertices edges
765
766 -- do_components deal with one strongly-connected component
767 -- Not cyclic, or singleton? Just do it
768 do_component (AcyclicSCC (_n, stmt)) = stmtC stmt
769 do_component (CyclicSCC [])
770 = panic "doSimultaneously1: do_component (CyclicSCC [])"
771 do_component (CyclicSCC [(_n, stmt)]) = stmtC stmt
772
773 -- Cyclic? Then go via temporaries. Pick one to
774 -- break the loop and try again with the rest.
775 do_component (CyclicSCC ((_n, first_stmt) : rest))
776 = do { from_temp <- go_via_temp first_stmt
777 ; doSimultaneously1 rest
778 ; stmtC from_temp }
779
780 go_via_temp (CmmAssign dest src)
781 = do { tmp <- newTemp (cmmRegType dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
782 ; stmtC (CmmAssign (CmmLocal tmp) src)
783 ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
784 go_via_temp (CmmStore dest src)
785 = do { tmp <- newTemp (cmmExprType src) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
786 ; stmtC (CmmAssign (CmmLocal tmp) src)
787 ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
788 go_via_temp _ = panic "doSimultaneously1: go_via_temp"
789 in
790 mapCs do_component components
791
792 mustFollow :: CmmStmt -> CmmStmt -> Bool
793 CmmAssign reg _ `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
794 CmmStore loc e `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprType e)) stmt
795 CmmNop `mustFollow` _ = False
796 CmmComment _ `mustFollow` _ = False
797 _ `mustFollow` _ = panic "mustFollow"
798
799
800 anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
801 -- True if the fn is true of any input of the stmt
802 anySrc p (CmmAssign _ e) = p e
803 anySrc p (CmmStore e1 e2) = p e1 || p e2 -- Might be used in either side
804 anySrc _ (CmmComment _) = False
805 anySrc _ CmmNop = False
806 anySrc _ _ = True -- Conservative
807
808 locUsedIn :: CmmExpr -> CmmType -> CmmExpr -> Bool
809 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
810 -- 'e'. Returns True if it's not sure.
811 locUsedIn _ _ (CmmLit _) = False
812 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
813 locUsedIn _ _ (CmmReg _) = False
814 locUsedIn _ _ (CmmRegOff _ _) = False
815 locUsedIn loc rep (CmmMachOp _ es) = any (locUsedIn loc rep) es
816 locUsedIn _ _ (CmmStackSlot _ _) = panic "locUsedIn: CmmStackSlot"
817
818 possiblySameLoc :: CmmExpr -> CmmType -> CmmExpr -> CmmType -> Bool
819 -- Assumes that distinct registers (eg Hp, Sp) do not
820 -- point to the same location, nor any offset thereof.
821 possiblySameLoc (CmmReg r1) _ (CmmReg r2) _ = r1 == r2
822 possiblySameLoc (CmmReg r1) _ (CmmRegOff r2 0) _ = r1 == r2
823 possiblySameLoc (CmmRegOff r1 0) _ (CmmReg r2) _ = r1 == r2
824 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
825 = r1==r2 && end1 > start2 && end2 > start1
826 where
827 end1 = start1 + widthInBytes (typeWidth rep1)
828 end2 = start2 + widthInBytes (typeWidth rep2)
829
830 possiblySameLoc _ _ (CmmLit _) _ = False
831 possiblySameLoc _ _ _ _ = True -- Conservative
832
833 -------------------------------------------------------------------------
834 --
835 -- Static Reference Tables
836 --
837 -------------------------------------------------------------------------
838
839 -- There is just one SRT for each top level binding; all the nested
840 -- bindings use sub-sections of this SRT. The label is passed down to
841 -- the nested bindings via the monad.
842
843 getSRTInfo :: FCode C_SRT
844 getSRTInfo = do
845 srt_lbl <- getSRTLabel
846 srt <- getSRT
847 case srt of
848 -- TODO: Should we panic in this case?
849 -- Someone obviously thinks there should be an SRT
850 NoSRT -> return NoC_SRT
851 SRTEntries {} -> panic "getSRTInfo: SRTEntries. Perhaps you forgot to run SimplStg?"
852 SRT off len bmp
853 | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
854 -> do id <- newUnique
855 let srt_desc_lbl = mkLargeSRTLabel id
856 emitRODataLits "getSRTInfo" srt_desc_lbl
857 ( cmmLabelOffW srt_lbl off
858 : mkWordCLit (fromIntegral len)
859 : map mkWordCLit bmp)
860 return (C_SRT srt_desc_lbl 0 srt_escape)
861
862 | otherwise
863 -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
864 -- The fromIntegral converts to StgHalfWord
865
866 srt_escape :: StgHalfWord
867 srt_escape = -1
868
869 -- -----------------------------------------------------------------------------
870 --
871 -- STG/Cmm GlobalReg
872 --
873 -- -----------------------------------------------------------------------------
874
875 -- | Here is where the STG register map is defined for each target arch.
876 -- The order matters (for the llvm backend anyway)! We must make sure to
877 -- maintain the order here with the order used in the LLVM calling conventions.
878 -- Note that also, this isn't all registers, just the ones that are currently
879 -- possbily mapped to real registers.
880 activeStgRegs :: [GlobalReg]
881 activeStgRegs = [
882 #ifdef REG_Base
883 BaseReg
884 #endif
885 #ifdef REG_Sp
886 ,Sp
887 #endif
888 #ifdef REG_Hp
889 ,Hp
890 #endif
891 #ifdef REG_R1
892 ,VanillaReg 1 VGcPtr
893 #endif
894 #ifdef REG_R2
895 ,VanillaReg 2 VGcPtr
896 #endif
897 #ifdef REG_R3
898 ,VanillaReg 3 VGcPtr
899 #endif
900 #ifdef REG_R4
901 ,VanillaReg 4 VGcPtr
902 #endif
903 #ifdef REG_R5
904 ,VanillaReg 5 VGcPtr
905 #endif
906 #ifdef REG_R6
907 ,VanillaReg 6 VGcPtr
908 #endif
909 #ifdef REG_R7
910 ,VanillaReg 7 VGcPtr
911 #endif
912 #ifdef REG_R8
913 ,VanillaReg 8 VGcPtr
914 #endif
915 #ifdef REG_SpLim
916 ,SpLim
917 #endif
918 #ifdef REG_F1
919 ,FloatReg 1
920 #endif
921 #ifdef REG_F2
922 ,FloatReg 2
923 #endif
924 #ifdef REG_F3
925 ,FloatReg 3
926 #endif
927 #ifdef REG_F4
928 ,FloatReg 4
929 #endif
930 #ifdef REG_D1
931 ,DoubleReg 1
932 #endif
933 #ifdef REG_D2
934 ,DoubleReg 2
935 #endif
936 ]
937
938 -- | We map STG registers onto appropriate CmmExprs. Either they map
939 -- to real machine registers or stored as offsets from BaseReg. Given
940 -- a GlobalReg, get_GlobalReg_addr always produces the
941 -- register table address for it.
942 get_GlobalReg_addr :: GlobalReg -> CmmExpr
943 get_GlobalReg_addr BaseReg = regTableOffset 0
944 get_GlobalReg_addr mid = get_Regtable_addr_from_offset
945 (globalRegType mid) (baseRegOffset mid)
946
947 -- Calculate a literal representing an offset into the register table.
948 -- Used when we don't have an actual BaseReg to offset from.
949 regTableOffset :: Int -> CmmExpr
950 regTableOffset n =
951 CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r + n))
952
953 get_Regtable_addr_from_offset :: CmmType -> Int -> CmmExpr
954 get_Regtable_addr_from_offset _ offset =
955 #ifdef REG_Base
956 CmmRegOff (CmmGlobal BaseReg) offset
957 #else
958 regTableOffset offset
959 #endif
960
961 -- | Fixup global registers so that they assign to locations within the
962 -- RegTable if they aren't pinned for the current target.
963 fixStgRegisters :: RawCmmDecl -> RawCmmDecl
964 fixStgRegisters top@(CmmData _ _) = top
965
966 fixStgRegisters (CmmProc info lbl (ListGraph blocks)) =
967 let blocks' = map fixStgRegBlock blocks
968 in CmmProc info lbl $ ListGraph blocks'
969
970 fixStgRegBlock :: CmmBasicBlock -> CmmBasicBlock
971 fixStgRegBlock (BasicBlock id stmts) =
972 let stmts' = map fixStgRegStmt stmts
973 in BasicBlock id stmts'
974
975 fixStgRegStmt :: CmmStmt -> CmmStmt
976 fixStgRegStmt stmt
977 = case stmt of
978 CmmAssign (CmmGlobal reg) src ->
979 let src' = fixStgRegExpr src
980 baseAddr = get_GlobalReg_addr reg
981 in case reg `elem` activeStgRegs of
982 True -> CmmAssign (CmmGlobal reg) src'
983 False -> CmmStore baseAddr src'
984
985 CmmAssign reg src ->
986 let src' = fixStgRegExpr src
987 in CmmAssign reg src'
988
989 CmmStore addr src -> CmmStore (fixStgRegExpr addr) (fixStgRegExpr src)
990
991 CmmCall target regs args srt returns ->
992 let target' = case target of
993 CmmCallee e conv -> CmmCallee (fixStgRegExpr e) conv
994 other -> other
995 args' = map (\(CmmHinted arg hint) ->
996 (CmmHinted (fixStgRegExpr arg) hint)) args
997 in CmmCall target' regs args' srt returns
998
999 CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr test) dest
1000
1001 CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr expr) ids
1002
1003 CmmJump addr regs -> CmmJump (fixStgRegExpr addr) regs
1004
1005 -- CmmNop, CmmComment, CmmBranch, CmmReturn
1006 _other -> stmt
1007
1008
1009 fixStgRegExpr :: CmmExpr -> CmmExpr
1010 fixStgRegExpr expr
1011 = case expr of
1012 CmmLoad addr ty -> CmmLoad (fixStgRegExpr addr) ty
1013
1014 CmmMachOp mop args -> CmmMachOp mop args'
1015 where args' = map fixStgRegExpr args
1016
1017 CmmReg (CmmGlobal reg) ->
1018 -- Replace register leaves with appropriate StixTrees for
1019 -- the given target. MagicIds which map to a reg on this
1020 -- arch are left unchanged. For the rest, BaseReg is taken
1021 -- to mean the address of the reg table in MainCapability,
1022 -- and for all others we generate an indirection to its
1023 -- location in the register table.
1024 case reg `elem` activeStgRegs of
1025 True -> expr
1026 False ->
1027 let baseAddr = get_GlobalReg_addr reg
1028 in case reg of
1029 BaseReg -> fixStgRegExpr baseAddr
1030 _other -> fixStgRegExpr
1031 (CmmLoad baseAddr (globalRegType reg))
1032
1033 CmmRegOff (CmmGlobal reg) offset ->
1034 -- RegOf leaves are just a shorthand form. If the reg maps
1035 -- to a real reg, we keep the shorthand, otherwise, we just
1036 -- expand it and defer to the above code.
1037 case reg `elem` activeStgRegs of
1038 True -> expr
1039 False -> fixStgRegExpr (CmmMachOp (MO_Add wordWidth) [
1040 CmmReg (CmmGlobal reg),
1041 CmmLit (CmmInt (fromIntegral offset)
1042 wordWidth)])
1043
1044 -- CmmLit, CmmReg (CmmLocal), CmmStackSlot
1045 _other -> expr
1046