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