Merge remote-tracking branch 'origin/master' into tc-untouchables
[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 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.List
75 import Data.Maybe
76 import Data.Ord
77
78 -------------------------------------------------------------------------
79 --
80 -- Random small functions
81 --
82 -------------------------------------------------------------------------
83
84 addIdReps :: [Id] -> [(CgRep, Id)]
85 addIdReps ids = [(idCgRep id, id) | id <- ids]
86
87 -------------------------------------------------------------------------
88 --
89 -- Literals
90 --
91 -------------------------------------------------------------------------
92
93 cgLit :: Literal -> FCode CmmLit
94 cgLit (MachStr s) = newByteStringCLit (bytesFB s)
95 cgLit other_lit = do dflags <- getDynFlags
96 return (mkSimpleLit dflags other_lit)
97
98 mkSimpleLit :: DynFlags -> Literal -> CmmLit
99 mkSimpleLit dflags (MachChar c) = CmmInt (fromIntegral (ord c)) (wordWidth dflags)
100 mkSimpleLit dflags MachNullAddr = zeroCLit dflags
101 mkSimpleLit dflags (MachInt i) = CmmInt i (wordWidth dflags)
102 mkSimpleLit _ (MachInt64 i) = CmmInt i W64
103 mkSimpleLit dflags (MachWord i) = CmmInt i (wordWidth dflags)
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 dflags (MachInt _) = MO_S_Lt (wordWidth dflags)
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 dflags 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 :: DynFlags -> Int -> Bool
145 isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags
146
147 tagForCon :: DynFlags -> DataCon -> ConTagZ
148 tagForCon dflags con = tag
149 where
150 con_tag = dataConTagZ con
151 fam_size = tyConFamilySize (dataConTyCon con)
152 tag | isSmallFamily dflags 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 dflags 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 dflags)
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 dflags] ]
302 -- The VNonGcPtr is a lie, but I don't think it matters
303 ++ [ FloatReg n | n <- [0 .. mAX_Float_REG dflags] ]
304 ++ [ DoubleReg n | n <- [0 .. mAX_Double_REG dflags] ]
305 ++ [ LongReg n | n <- [0 .. mAX_Long_REG dflags] ]
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 :: DynFlags -> GlobalReg -> Int
326
327 baseRegOffset dflags (VanillaReg 1 _) = oFFSET_StgRegTable_rR1 dflags
328 baseRegOffset dflags (VanillaReg 2 _) = oFFSET_StgRegTable_rR2 dflags
329 baseRegOffset dflags (VanillaReg 3 _) = oFFSET_StgRegTable_rR3 dflags
330 baseRegOffset dflags (VanillaReg 4 _) = oFFSET_StgRegTable_rR4 dflags
331 baseRegOffset dflags (VanillaReg 5 _) = oFFSET_StgRegTable_rR5 dflags
332 baseRegOffset dflags (VanillaReg 6 _) = oFFSET_StgRegTable_rR6 dflags
333 baseRegOffset dflags (VanillaReg 7 _) = oFFSET_StgRegTable_rR7 dflags
334 baseRegOffset dflags (VanillaReg 8 _) = oFFSET_StgRegTable_rR8 dflags
335 baseRegOffset dflags (VanillaReg 9 _) = oFFSET_StgRegTable_rR9 dflags
336 baseRegOffset dflags (VanillaReg 10 _) = oFFSET_StgRegTable_rR10 dflags
337 baseRegOffset _ (VanillaReg n _) = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")
338 baseRegOffset dflags (FloatReg 1) = oFFSET_StgRegTable_rF1 dflags
339 baseRegOffset dflags (FloatReg 2) = oFFSET_StgRegTable_rF2 dflags
340 baseRegOffset dflags (FloatReg 3) = oFFSET_StgRegTable_rF3 dflags
341 baseRegOffset dflags (FloatReg 4) = oFFSET_StgRegTable_rF4 dflags
342 baseRegOffset _ (FloatReg n) = panic ("Registers above F4 are not supported (tried to use F" ++ show n ++ ")")
343 baseRegOffset dflags (DoubleReg 1) = oFFSET_StgRegTable_rD1 dflags
344 baseRegOffset dflags (DoubleReg 2) = oFFSET_StgRegTable_rD2 dflags
345 baseRegOffset _ (DoubleReg n) = panic ("Registers above D2 are not supported (tried to use D" ++ show n ++ ")")
346 baseRegOffset dflags Sp = oFFSET_StgRegTable_rSp dflags
347 baseRegOffset dflags SpLim = oFFSET_StgRegTable_rSpLim dflags
348 baseRegOffset dflags (LongReg 1) = oFFSET_StgRegTable_rL1 dflags
349 baseRegOffset _ (LongReg n) = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")
350 baseRegOffset dflags Hp = oFFSET_StgRegTable_rHp dflags
351 baseRegOffset dflags HpLim = oFFSET_StgRegTable_rHpLim dflags
352 baseRegOffset dflags CCCS = oFFSET_StgRegTable_rCCCS dflags
353 baseRegOffset dflags CurrentTSO = oFFSET_StgRegTable_rCurrentTSO dflags
354 baseRegOffset dflags CurrentNursery = oFFSET_StgRegTable_rCurrentNursery dflags
355 baseRegOffset dflags HpAlloc = oFFSET_StgRegTable_rHpAlloc dflags
356 baseRegOffset dflags EagerBlackholeInfo = oFFSET_stgEagerBlackholeInfo dflags
357 baseRegOffset dflags GCEnter1 = oFFSET_stgGCEnter1 dflags
358 baseRegOffset dflags GCFun = oFFSET_stgGCFun dflags
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 = do
482 dflags <- getDynFlags
483 let
484 cond = cmmNeWord dflags tag_expr (CmmLit (mkIntCLit dflags tag))
485 -- We have lo_tag < hi_tag, but there's only one branch,
486 -- so there must be a default
487 return (CmmCondBranch cond deflt `consCgStmt` stmts)
488
489 -- ToDo: we might want to check for the two branch case, where one of
490 -- the branches is the tag 0, because comparing '== 0' is likely to be
491 -- more efficient than other kinds of comparison.
492
493 -- DENSE TAG RANGE: use a switch statment.
494 --
495 -- We also use a switch uncoditionally when compiling via C, because
496 -- this will get emitted as a C switch statement and the C compiler
497 -- should do a good job of optimising it. Also, older GCC versions
498 -- (2.95 in particular) have problems compiling the complicated
499 -- if-trees generated by this code, so compiling to a switch every
500 -- time works around that problem.
501 --
502 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
503 | use_switch -- Use a switch
504 = do { dflags <- getDynFlags
505 ; branch_ids <- mapM forkCgStmts (map snd branches)
506 ; let
507 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
508
509 find_branch :: ConTagZ -> Maybe BlockId
510 find_branch i = assocDefault mb_deflt tagged_blk_ids i
511
512 -- NB. we have eliminated impossible branches at
513 -- either end of the range (see below), so the first
514 -- tag of a real branch is real_lo_tag (not lo_tag).
515 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
516
517 switch_stmt = CmmSwitch (cmmOffset dflags tag_expr (- real_lo_tag)) arms
518
519 ; ASSERT(not (all isNothing arms))
520 return (oneCgStmt switch_stmt)
521 }
522
523 -- if we can knock off a bunch of default cases with one if, then do so
524 | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
525 = do { dflags <- getDynFlags
526 ; (assign_tag, tag_expr') <- assignTemp' tag_expr
527 ; let cond = cmmULtWord dflags tag_expr' (CmmLit (mkIntCLit dflags lowest_branch))
528 branch = CmmCondBranch cond deflt
529 ; stmts <- mk_switch tag_expr' branches mb_deflt
530 lowest_branch hi_tag via_C
531 ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
532 }
533
534 | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
535 = do { dflags <- getDynFlags
536 ; (assign_tag, tag_expr') <- assignTemp' tag_expr
537 ; let cond = cmmUGtWord dflags tag_expr' (CmmLit (mkIntCLit dflags highest_branch))
538 branch = CmmCondBranch cond deflt
539 ; stmts <- mk_switch tag_expr' branches mb_deflt
540 lo_tag highest_branch via_C
541 ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
542 }
543
544 | otherwise -- Use an if-tree
545 = do { dflags <- getDynFlags
546 ; (assign_tag, tag_expr') <- assignTemp' tag_expr
547 -- To avoid duplication
548 ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
549 lo_tag (mid_tag-1) via_C
550 ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
551 mid_tag hi_tag via_C
552 ; hi_id <- forkCgStmts hi_stmts
553 ; let cond = cmmUGeWord dflags tag_expr' (CmmLit (mkIntCLit dflags mid_tag))
554 branch_stmt = CmmCondBranch cond hi_id
555 ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
556 }
557 -- we test (e >= mid_tag) rather than (e < mid_tag), because
558 -- the former works better when e is a comparison, and there
559 -- are two tags 0 & 1 (mid_tag == 1). In this case, the code
560 -- generator can reduce the condition to e itself without
561 -- having to reverse the sense of the comparison: comparisons
562 -- can't always be easily reversed (eg. floating
563 -- pt. comparisons).
564 where
565 use_switch = {- pprTrace "mk_switch" (
566 ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
567 text "branches:" <+> ppr (map fst branches) <+>
568 text "n_branches:" <+> int n_branches <+>
569 text "lo_tag:" <+> int lo_tag <+>
570 text "hi_tag:" <+> int hi_tag <+>
571 text "real_lo_tag:" <+> int real_lo_tag <+>
572 text "real_hi_tag:" <+> int real_hi_tag) $ -}
573 ASSERT( n_branches > 1 && n_tags > 1 )
574 n_tags > 2 && (via_C || (dense && big_enough))
575 -- up to 4 branches we use a decision tree, otherwise
576 -- a switch (== jump table in the NCG). This seems to be
577 -- optimal, and corresponds with what gcc does.
578 big_enough = n_branches > 4
579 dense = n_branches > (n_tags `div` 2)
580 n_branches = length branches
581
582 -- ignore default slots at each end of the range if there's
583 -- no default branch defined.
584 lowest_branch = fst (head branches)
585 highest_branch = fst (last branches)
586
587 real_lo_tag
588 | isNothing mb_deflt = lowest_branch
589 | otherwise = lo_tag
590
591 real_hi_tag
592 | isNothing mb_deflt = highest_branch
593 | otherwise = hi_tag
594
595 n_tags = real_hi_tag - real_lo_tag + 1
596
597 -- INVARIANT: Provided hi_tag > lo_tag (which is true)
598 -- lo_tag <= mid_tag < hi_tag
599 -- lo_branches have tags < mid_tag
600 -- hi_branches have tags >= mid_tag
601
602 (mid_tag,_) = branches !! (n_branches `div` 2)
603 -- 2 branches => n_branches `div` 2 = 1
604 -- => branches !! 1 give the *second* tag
605 -- There are always at least 2 branches here
606
607 (lo_branches, hi_branches) = span is_lo branches
608 is_lo (t,_) = t < mid_tag
609
610 assignTemp' :: CmmExpr -> FCode (CmmStmt, CmmExpr)
611 assignTemp' e
612 | isTrivialCmmExpr e = return (CmmNop, e)
613 | otherwise = do dflags <- getDynFlags
614 reg <- newTemp (cmmExprType dflags e)
615 return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg))
616
617 emitLitSwitch :: CmmExpr -- Tag to switch on
618 -> [(Literal, CgStmts)] -- Tagged branches
619 -> CgStmts -- Default branch (always)
620 -> Code -- Emit the code
621 -- Used for general literals, whose size might not be a word,
622 -- where there is always a default case, and where we don't know
623 -- the range of values for certain. For simplicity we always generate a tree.
624 --
625 -- ToDo: for integers we could do better here, perhaps by generalising
626 -- mk_switch and using that. --SDM 15/09/2004
627 emitLitSwitch _ [] deflt = emitCgStmts deflt
628 emitLitSwitch scrut branches deflt_blk
629 = do { scrut' <- assignTemp scrut
630 ; deflt_blk_id <- forkCgStmts deflt_blk
631 ; blk <- mk_lit_switch scrut' deflt_blk_id (sortBy (comparing fst) branches)
632 ; emitCgStmts blk }
633
634 mk_lit_switch :: CmmExpr -> BlockId
635 -> [(Literal,CgStmts)]
636 -> FCode CgStmts
637 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
638 = do dflags <- getDynFlags
639 let cmm_lit = mkSimpleLit dflags lit
640 rep = cmmLitType dflags cmm_lit
641 ne = if isFloatType rep then MO_F_Ne else MO_Ne
642 cond = CmmMachOp (ne (typeWidth rep)) [scrut, CmmLit cmm_lit]
643 if_stmt = CmmCondBranch cond deflt_blk_id
644 return (consCgStmt if_stmt blk)
645
646 mk_lit_switch scrut deflt_blk_id branches
647 = do { dflags <- getDynFlags
648 ; hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
649 ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
650 ; lo_blk_id <- forkCgStmts lo_blk
651 ; let if_stmt = CmmCondBranch (cond dflags) lo_blk_id
652 ; return (if_stmt `consCgStmt` hi_blk) }
653 where
654 n_branches = length branches
655 (mid_lit,_) = branches !! (n_branches `div` 2)
656 -- See notes above re mid_tag
657
658 (lo_branches, hi_branches) = span is_lo branches
659 is_lo (t,_) = t < mid_lit
660
661 cond dflags = CmmMachOp (mkLtOp dflags mid_lit)
662 [scrut, CmmLit (mkSimpleLit dflags mid_lit)]
663
664 -------------------------------------------------------------------------
665 --
666 -- Simultaneous assignment
667 --
668 -------------------------------------------------------------------------
669
670
671 emitSimultaneously :: CmmStmts -> Code
672 -- Emit code to perform the assignments in the
673 -- input simultaneously, using temporary variables when necessary.
674 --
675 -- The Stmts must be:
676 -- CmmNop, CmmComment, CmmAssign, CmmStore
677 -- and nothing else
678
679
680 -- We use the strongly-connected component algorithm, in which
681 -- * the vertices are the statements
682 -- * an edge goes from s1 to s2 iff
683 -- s1 assigns to something s2 uses
684 -- that is, if s1 should *follow* s2 in the final order
685
686 type CVertex = (Int, CmmStmt) -- Give each vertex a unique number,
687 -- for fast comparison
688
689 emitSimultaneously stmts
690 = codeOnly $
691 case filterOut isNopStmt (stmtList stmts) of
692 -- Remove no-ops
693 [] -> nopC
694 [stmt] -> stmtC stmt -- It's often just one stmt
695 stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
696
697 doSimultaneously1 :: [CVertex] -> Code
698 doSimultaneously1 vertices = do
699 dflags <- getDynFlags
700 let
701 edges = [ (vertex, key1, edges_from stmt1)
702 | vertex@(key1, stmt1) <- vertices
703 ]
704 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
705 mustFollow dflags stmt1 stmt2
706 ]
707 components = stronglyConnCompFromEdgedVertices edges
708
709 -- do_components deal with one strongly-connected component
710 -- Not cyclic, or singleton? Just do it
711 do_component (AcyclicSCC (_n, stmt)) = stmtC stmt
712 do_component (CyclicSCC [])
713 = panic "doSimultaneously1: do_component (CyclicSCC [])"
714 do_component (CyclicSCC [(_n, stmt)]) = stmtC stmt
715
716 -- Cyclic? Then go via temporaries. Pick one to
717 -- break the loop and try again with the rest.
718 do_component (CyclicSCC ((_n, first_stmt) : rest))
719 = do { from_temp <- go_via_temp first_stmt
720 ; doSimultaneously1 rest
721 ; stmtC from_temp }
722
723 go_via_temp (CmmAssign dest src)
724 = do { dflags <- getDynFlags
725 ; tmp <- newTemp (cmmRegType dflags dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
726 ; stmtC (CmmAssign (CmmLocal tmp) src)
727 ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
728 go_via_temp (CmmStore dest src)
729 = do { tmp <- newTemp (cmmExprType dflags src) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
730 ; stmtC (CmmAssign (CmmLocal tmp) src)
731 ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
732 go_via_temp _ = panic "doSimultaneously1: go_via_temp"
733 mapCs do_component components
734
735 mustFollow :: DynFlags -> CmmStmt -> CmmStmt -> Bool
736 mustFollow dflags x y = x `mustFollow'` y
737 where CmmAssign reg _ `mustFollow'` stmt = anySrc (reg `regUsedIn`) stmt
738 CmmStore loc e `mustFollow'` stmt = anySrc (locUsedIn loc (cmmExprType dflags e)) stmt
739 CmmNop `mustFollow'` _ = False
740 CmmComment _ `mustFollow'` _ = False
741 _ `mustFollow'` _ = panic "mustFollow"
742
743
744 anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
745 -- True if the fn is true of any input of the stmt
746 anySrc p (CmmAssign _ e) = p e
747 anySrc p (CmmStore e1 e2) = p e1 || p e2 -- Might be used in either side
748 anySrc _ (CmmComment _) = False
749 anySrc _ CmmNop = False
750 anySrc _ _ = True -- Conservative
751
752 locUsedIn :: CmmExpr -> CmmType -> CmmExpr -> Bool
753 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
754 -- 'e'. Returns True if it's not sure.
755 locUsedIn _ _ (CmmLit _) = False
756 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
757 locUsedIn _ _ (CmmReg _) = False
758 locUsedIn _ _ (CmmRegOff _ _) = False
759 locUsedIn loc rep (CmmMachOp _ es) = any (locUsedIn loc rep) es
760 locUsedIn _ _ (CmmStackSlot _ _) = panic "locUsedIn: CmmStackSlot"
761
762 possiblySameLoc :: CmmExpr -> CmmType -> CmmExpr -> CmmType -> Bool
763 -- Assumes that distinct registers (eg Hp, Sp) do not
764 -- point to the same location, nor any offset thereof.
765 possiblySameLoc (CmmReg r1) _ (CmmReg r2) _ = r1 == r2
766 possiblySameLoc (CmmReg r1) _ (CmmRegOff r2 0) _ = r1 == r2
767 possiblySameLoc (CmmRegOff r1 0) _ (CmmReg r2) _ = r1 == r2
768 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
769 = r1==r2 && end1 > start2 && end2 > start1
770 where
771 end1 = start1 + widthInBytes (typeWidth rep1)
772 end2 = start2 + widthInBytes (typeWidth rep2)
773
774 possiblySameLoc _ _ (CmmLit _) _ = False
775 possiblySameLoc _ _ _ _ = True -- Conservative
776
777 -------------------------------------------------------------------------
778 --
779 -- Static Reference Tables
780 --
781 -------------------------------------------------------------------------
782
783 -- There is just one SRT for each top level binding; all the nested
784 -- bindings use sub-sections of this SRT. The label is passed down to
785 -- the nested bindings via the monad.
786
787 getSRTInfo :: FCode C_SRT
788 getSRTInfo = do
789 dflags <- getDynFlags
790 srt_lbl <- getSRTLabel
791 srt <- getSRT
792 case srt of
793 -- TODO: Should we panic in this case?
794 -- Someone obviously thinks there should be an SRT
795 NoSRT -> return NoC_SRT
796 SRTEntries {} -> panic "getSRTInfo: SRTEntries. Perhaps you forgot to run SimplStg?"
797 SRT off len bmp
798 | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
799 -> do id <- newUnique
800 let srt_desc_lbl = mkLargeSRTLabel id
801 emitRODataLits "getSRTInfo" srt_desc_lbl
802 ( cmmLabelOffW dflags srt_lbl off
803 : mkWordCLit dflags (fromIntegral len)
804 : map (mkWordCLit dflags) bmp)
805 return (C_SRT srt_desc_lbl 0 srt_escape)
806
807 | otherwise
808 -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
809 -- The fromIntegral converts to StgHalfWord
810
811 srt_escape :: StgHalfWord
812 srt_escape = -1
813
814 -- -----------------------------------------------------------------------------
815 --
816 -- STG/Cmm GlobalReg
817 --
818 -- -----------------------------------------------------------------------------
819
820 -- | We map STG registers onto appropriate CmmExprs. Either they map
821 -- to real machine registers or stored as offsets from BaseReg. Given
822 -- a GlobalReg, get_GlobalReg_addr always produces the
823 -- register table address for it.
824 get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr
825 get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0
826 get_GlobalReg_addr dflags mid
827 = get_Regtable_addr_from_offset dflags
828 (globalRegType dflags mid) (baseRegOffset dflags mid)
829
830 -- Calculate a literal representing an offset into the register table.
831 -- Used when we don't have an actual BaseReg to offset from.
832 regTableOffset :: DynFlags -> Int -> CmmExpr
833 regTableOffset dflags n =
834 CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))
835
836 get_Regtable_addr_from_offset :: DynFlags -> CmmType -> Int -> CmmExpr
837 get_Regtable_addr_from_offset dflags _ offset =
838 if haveRegBase (targetPlatform dflags)
839 then CmmRegOff (CmmGlobal BaseReg) offset
840 else regTableOffset dflags offset
841
842 -- | Fixup global registers so that they assign to locations within the
843 -- RegTable if they aren't pinned for the current target.
844 fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl
845 fixStgRegisters _ top@(CmmData _ _) = top
846
847 fixStgRegisters dflags (CmmProc info lbl (ListGraph blocks)) =
848 let blocks' = map (fixStgRegBlock dflags) blocks
849 in CmmProc info lbl $ ListGraph blocks'
850
851 fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock
852 fixStgRegBlock dflags (BasicBlock id stmts) =
853 let stmts' = map (fixStgRegStmt dflags) stmts
854 in BasicBlock id stmts'
855
856 fixStgRegStmt :: DynFlags -> CmmStmt -> CmmStmt
857 fixStgRegStmt dflags stmt
858 = case stmt of
859 CmmAssign (CmmGlobal reg) src ->
860 let src' = fixStgRegExpr dflags src
861 baseAddr = get_GlobalReg_addr dflags reg
862 in case reg `elem` activeStgRegs platform of
863 True -> CmmAssign (CmmGlobal reg) src'
864 False -> CmmStore baseAddr src'
865
866 CmmAssign reg src ->
867 let src' = fixStgRegExpr dflags src
868 in CmmAssign reg src'
869
870 CmmStore addr src -> CmmStore (fixStgRegExpr dflags addr) (fixStgRegExpr dflags src)
871
872 CmmCall target regs args returns ->
873 let target' = case target of
874 CmmCallee e conv -> CmmCallee (fixStgRegExpr dflags e) conv
875 CmmPrim op mStmts ->
876 CmmPrim op (fmap (map (fixStgRegStmt dflags)) mStmts)
877 args' = map (\(CmmHinted arg hint) ->
878 (CmmHinted (fixStgRegExpr dflags arg) hint)) args
879 in CmmCall target' regs args' returns
880
881 CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr dflags test) dest
882
883 CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr dflags expr) ids
884
885 CmmJump addr live -> CmmJump (fixStgRegExpr dflags addr) live
886
887 -- CmmNop, CmmComment, CmmBranch, CmmReturn
888 _other -> stmt
889 where platform = targetPlatform dflags
890
891
892 fixStgRegExpr :: DynFlags -> CmmExpr -> CmmExpr
893 fixStgRegExpr dflags expr
894 = case expr of
895 CmmLoad addr ty -> CmmLoad (fixStgRegExpr dflags addr) ty
896
897 CmmMachOp mop args -> CmmMachOp mop args'
898 where args' = map (fixStgRegExpr dflags) args
899
900 CmmReg (CmmGlobal reg) ->
901 -- Replace register leaves with appropriate StixTrees for
902 -- the given target. MagicIds which map to a reg on this
903 -- arch are left unchanged. For the rest, BaseReg is taken
904 -- to mean the address of the reg table in MainCapability,
905 -- and for all others we generate an indirection to its
906 -- location in the register table.
907 case reg `elem` activeStgRegs platform of
908 True -> expr
909 False ->
910 let baseAddr = get_GlobalReg_addr dflags reg
911 in case reg of
912 BaseReg -> fixStgRegExpr dflags baseAddr
913 _other -> fixStgRegExpr dflags
914 (CmmLoad baseAddr (globalRegType dflags reg))
915
916 CmmRegOff (CmmGlobal reg) offset ->
917 -- RegOf leaves are just a shorthand form. If the reg maps
918 -- to a real reg, we keep the shorthand, otherwise, we just
919 -- expand it and defer to the above code.
920 case reg `elem` activeStgRegs platform of
921 True -> expr
922 False -> fixStgRegExpr dflags (CmmMachOp (MO_Add (wordWidth dflags)) [
923 CmmReg (CmmGlobal reg),
924 CmmLit (CmmInt (fromIntegral offset)
925 (wordWidth dflags))])
926
927 -- CmmLit, CmmReg (CmmLocal), CmmStackSlot
928 _other -> expr
929 where platform = targetPlatform dflags
930