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