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