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