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