13de2136f59cb6c5afb37b282482e6a3db9bf6e0
[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 assignNonPtrTemp, newNonPtrTemp,
17 assignPtrTemp, newPtrTemp,
18 emitSimultaneously,
19 emitSwitch, emitLitSwitch,
20 tagToClosure,
21
22 cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
23 cmmOffsetExprW, cmmOffsetExprB,
24 cmmRegOffW, cmmRegOffB,
25 cmmLabelOffW, cmmLabelOffB,
26 cmmOffsetW, cmmOffsetB,
27 cmmOffsetLitW, cmmOffsetLitB,
28 cmmLoadIndexW,
29
30 addToMem, addToMemE,
31 mkWordCLit,
32 mkStringCLit, mkByteStringCLit,
33 packHalfWordsCLit,
34 blankWord,
35
36 getSRTInfo
37 ) where
38
39 #include "HsVersions.h"
40
41 import CgMonad
42 import TyCon
43 import Id
44 import Constants
45 import SMRep
46 import PprCmm ( {- instances -} )
47 import Cmm
48 import CLabel
49 import CmmUtils
50 import MachOp
51 import ForeignCall
52 import ClosureInfo
53 import StgSyn (SRT(..))
54 import Literal
55 import Digraph
56 import ListSetOps
57 import Util
58 import DynFlags
59 import FastString
60 import PackageConfig
61 import Outputable
62
63 import MachRegs (callerSaveVolatileRegs)
64 -- HACK: this is part of the NCG so we shouldn't use this, but we need
65 -- it for now to eliminate the need for saved regs to be in CmmCall.
66 -- The long term solution is to factor callerSaveVolatileRegs
67 -- from nativeGen into codeGen
68
69 import Data.Char
70 import Data.Bits
71 import Data.Word
72 import Data.Maybe
73
74 -------------------------------------------------------------------------
75 --
76 -- Random small functions
77 --
78 -------------------------------------------------------------------------
79
80 addIdReps :: [Id] -> [(CgRep, Id)]
81 addIdReps ids = [(idCgRep id, id) | id <- ids]
82
83 -------------------------------------------------------------------------
84 --
85 -- Literals
86 --
87 -------------------------------------------------------------------------
88
89 cgLit :: Literal -> FCode CmmLit
90 cgLit (MachStr s) = mkByteStringCLit (bytesFS s)
91 -- not unpackFS; we want the UTF-8 byte stream.
92 cgLit other_lit = return (mkSimpleLit other_lit)
93
94 mkSimpleLit :: Literal -> CmmLit
95 mkSimpleLit (MachChar c) = CmmInt (fromIntegral (ord c)) wordRep
96 mkSimpleLit MachNullAddr = zeroCLit
97 mkSimpleLit (MachInt i) = CmmInt i wordRep
98 mkSimpleLit (MachInt64 i) = CmmInt i I64
99 mkSimpleLit (MachWord i) = CmmInt i wordRep
100 mkSimpleLit (MachWord64 i) = CmmInt i I64
101 mkSimpleLit (MachFloat r) = CmmFloat r F32
102 mkSimpleLit (MachDouble r) = CmmFloat r F64
103 mkSimpleLit (MachLabel fs ms) = CmmLabel (mkForeignLabel fs ms is_dyn)
104 where
105 is_dyn = False -- ToDo: fix me
106
107 mkLtOp :: Literal -> MachOp
108 -- On signed literals we must do a signed comparison
109 mkLtOp (MachInt _) = MO_S_Lt wordRep
110 mkLtOp (MachFloat _) = MO_S_Lt F32
111 mkLtOp (MachDouble _) = MO_S_Lt F64
112 mkLtOp lit = MO_U_Lt (cmmLitRep (mkSimpleLit lit))
113
114
115 ---------------------------------------------------
116 --
117 -- Cmm data type functions
118 --
119 ---------------------------------------------------
120
121 -----------------------
122 -- The "B" variants take byte offsets
123 cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
124 cmmRegOffB = cmmRegOff
125
126 cmmOffsetB :: CmmExpr -> ByteOff -> CmmExpr
127 cmmOffsetB = cmmOffset
128
129 cmmOffsetExprB :: CmmExpr -> CmmExpr -> CmmExpr
130 cmmOffsetExprB = cmmOffsetExpr
131
132 cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
133 cmmLabelOffB = cmmLabelOff
134
135 cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit
136 cmmOffsetLitB = cmmOffsetLit
137
138 -----------------------
139 -- The "W" variants take word offsets
140 cmmOffsetExprW :: CmmExpr -> CmmExpr -> CmmExpr
141 -- The second arg is a *word* offset; need to change it to bytes
142 cmmOffsetExprW e (CmmLit (CmmInt n _)) = cmmOffsetW e (fromInteger n)
143 cmmOffsetExprW e wd_off = cmmIndexExpr wordRep e wd_off
144
145 cmmOffsetW :: CmmExpr -> WordOff -> CmmExpr
146 cmmOffsetW e n = cmmOffsetB e (wORD_SIZE * n)
147
148 cmmRegOffW :: CmmReg -> WordOff -> CmmExpr
149 cmmRegOffW reg wd_off = cmmRegOffB reg (wd_off * wORD_SIZE)
150
151 cmmOffsetLitW :: CmmLit -> WordOff -> CmmLit
152 cmmOffsetLitW lit wd_off = cmmOffsetLitB lit (wORD_SIZE * wd_off)
153
154 cmmLabelOffW :: CLabel -> WordOff -> CmmLit
155 cmmLabelOffW lbl wd_off = cmmLabelOffB lbl (wORD_SIZE * wd_off)
156
157 cmmLoadIndexW :: CmmExpr -> Int -> CmmExpr
158 cmmLoadIndexW base off
159 = CmmLoad (cmmOffsetW base off) wordRep
160
161 -----------------------
162 cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord :: CmmExpr -> CmmExpr -> CmmExpr
163 cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2]
164 cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2]
165 cmmNeWord e1 e2 = CmmMachOp mo_wordNe [e1, e2]
166 cmmEqWord e1 e2 = CmmMachOp mo_wordEq [e1, e2]
167 cmmULtWord e1 e2 = CmmMachOp mo_wordULt [e1, e2]
168 cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2]
169 cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2]
170
171 cmmNegate :: CmmExpr -> CmmExpr
172 cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
173 cmmNegate e = CmmMachOp (MO_S_Neg (cmmExprRep e)) [e]
174
175 blankWord :: CmmStatic
176 blankWord = CmmUninitialised wORD_SIZE
177
178 -----------------------
179 -- Making literals
180
181 mkWordCLit :: StgWord -> CmmLit
182 mkWordCLit wd = CmmInt (fromIntegral wd) wordRep
183
184 packHalfWordsCLit :: (Integral a, Integral b) => a -> b -> CmmLit
185 -- Make a single word literal in which the lower_half_word is
186 -- at the lower address, and the upper_half_word is at the
187 -- higher address
188 -- ToDo: consider using half-word lits instead
189 -- but be careful: that's vulnerable when reversed
190 packHalfWordsCLit lower_half_word upper_half_word
191 #ifdef WORDS_BIGENDIAN
192 = mkWordCLit ((fromIntegral lower_half_word `shiftL` hALF_WORD_SIZE_IN_BITS)
193 .|. fromIntegral upper_half_word)
194 #else
195 = mkWordCLit ((fromIntegral lower_half_word)
196 .|. (fromIntegral upper_half_word `shiftL` hALF_WORD_SIZE_IN_BITS))
197 #endif
198
199 --------------------------------------------------------------------------
200 --
201 -- Incrementing a memory location
202 --
203 --------------------------------------------------------------------------
204
205 addToMem :: MachRep -- rep of the counter
206 -> CmmExpr -- Address
207 -> Int -- What to add (a word)
208 -> CmmStmt
209 addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) rep))
210
211 addToMemE :: MachRep -- rep of the counter
212 -> CmmExpr -- Address
213 -> CmmExpr -- What to add (a word-typed expression)
214 -> CmmStmt
215 addToMemE rep ptr n
216 = CmmStore ptr (CmmMachOp (MO_Add rep) [CmmLoad ptr rep, n])
217
218 -------------------------------------------------------------------------
219 --
220 -- Converting a closure tag to a closure for enumeration types
221 -- (this is the implementation of tagToEnum#).
222 --
223 -------------------------------------------------------------------------
224
225 tagToClosure :: PackageId -> TyCon -> CmmExpr -> CmmExpr
226 tagToClosure this_pkg tycon tag
227 = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep
228 where closure_tbl = CmmLit (CmmLabel lbl)
229 lbl = mkClosureTableLabel this_pkg (tyConName tycon)
230
231 -------------------------------------------------------------------------
232 --
233 -- Conditionals and rts calls
234 --
235 -------------------------------------------------------------------------
236
237 emitIf :: CmmExpr -- Boolean
238 -> Code -- Then part
239 -> Code
240 -- Emit (if e then x)
241 -- ToDo: reverse the condition to avoid the extra branch instruction if possible
242 -- (some conditionals aren't reversible. eg. floating point comparisons cannot
243 -- be inverted because there exist some values for which both comparisons
244 -- return False, such as NaN.)
245 emitIf cond then_part
246 = do { then_id <- newLabelC
247 ; join_id <- newLabelC
248 ; stmtC (CmmCondBranch cond then_id)
249 ; stmtC (CmmBranch join_id)
250 ; labelC then_id
251 ; then_part
252 ; labelC join_id
253 }
254
255 emitIfThenElse :: CmmExpr -- Boolean
256 -> Code -- Then part
257 -> Code -- Else part
258 -> Code
259 -- Emit (if e then x else y)
260 emitIfThenElse cond then_part else_part
261 = do { then_id <- newLabelC
262 ; else_id <- newLabelC
263 ; join_id <- newLabelC
264 ; stmtC (CmmCondBranch cond then_id)
265 ; else_part
266 ; stmtC (CmmBranch join_id)
267 ; labelC then_id
268 ; then_part
269 ; labelC join_id
270 }
271
272 emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Code
273 emitRtsCall fun args = emitRtsCall' [] fun args Nothing
274 -- The 'Nothing' says "save all global registers"
275
276 emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Code
277 emitRtsCallWithVols fun args vols
278 = emitRtsCall' [] fun args (Just vols)
279
280 emitRtsCallWithResult :: LocalReg -> MachHint -> LitString
281 -> [(CmmExpr,MachHint)] -> Code
282 emitRtsCallWithResult res hint fun args
283 = emitRtsCall' [(res,hint)] fun args Nothing
284
285 -- Make a call to an RTS C procedure
286 emitRtsCall'
287 :: CmmHintFormals
288 -> LitString
289 -> [(CmmExpr,MachHint)]
290 -> Maybe [GlobalReg]
291 -> Code
292 emitRtsCall' res fun args vols = do
293 srt <- getSRTInfo
294 stmtsC caller_save
295 stmtC (CmmCall target res args srt)
296 stmtsC caller_load
297 where
298 (caller_save, caller_load) = callerSaveVolatileRegs vols
299 target = CmmForeignCall fun_expr CCallConv
300 fun_expr = mkLblExpr (mkRtsCodeLabel fun)
301
302
303 -------------------------------------------------------------------------
304 --
305 -- Strings gnerate a top-level data block
306 --
307 -------------------------------------------------------------------------
308
309 emitDataLits :: CLabel -> [CmmLit] -> Code
310 -- Emit a data-segment data block
311 emitDataLits lbl lits
312 = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
313
314 mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
315 -- Emit a data-segment data block
316 mkDataLits lbl lits
317 = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
318
319 emitRODataLits :: CLabel -> [CmmLit] -> Code
320 -- Emit a read-only data block
321 emitRODataLits lbl lits
322 = emitData section (CmmDataLabel lbl : map CmmStaticLit lits)
323 where section | any needsRelocation lits = RelocatableReadOnlyData
324 | otherwise = ReadOnlyData
325 needsRelocation (CmmLabel _) = True
326 needsRelocation (CmmLabelOff _ _) = True
327 needsRelocation _ = False
328
329 mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
330 mkRODataLits lbl lits
331 = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
332 where section | any needsRelocation lits = RelocatableReadOnlyData
333 | otherwise = ReadOnlyData
334 needsRelocation (CmmLabel _) = True
335 needsRelocation (CmmLabelOff _ _) = True
336 needsRelocation _ = False
337
338 mkStringCLit :: String -> FCode CmmLit
339 -- Make a global definition for the string,
340 -- and return its label
341 mkStringCLit str = mkByteStringCLit (map (fromIntegral.ord) str)
342
343 mkByteStringCLit :: [Word8] -> FCode CmmLit
344 mkByteStringCLit bytes
345 = do { uniq <- newUnique
346 ; let lbl = mkStringLitLabel uniq
347 ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes]
348 ; return (CmmLabel lbl) }
349
350 -------------------------------------------------------------------------
351 --
352 -- Assigning expressions to temporaries
353 --
354 -------------------------------------------------------------------------
355
356 assignNonPtrTemp :: CmmExpr -> FCode CmmExpr
357 -- For a non-trivial expression, e, create a local
358 -- variable and assign the expression to it
359 assignNonPtrTemp e
360 | isTrivialCmmExpr e = return e
361 | otherwise = do { reg <- newNonPtrTemp (cmmExprRep e)
362 ; stmtC (CmmAssign (CmmLocal reg) e)
363 ; return (CmmReg (CmmLocal reg)) }
364
365 assignPtrTemp :: CmmExpr -> FCode CmmExpr
366 -- For a non-trivial expression, e, create a local
367 -- variable and assign the expression to it
368 assignPtrTemp e
369 | isTrivialCmmExpr e = return e
370 | otherwise = do { reg <- newPtrTemp (cmmExprRep e)
371 ; stmtC (CmmAssign (CmmLocal reg) e)
372 ; return (CmmReg (CmmLocal reg)) }
373
374 newNonPtrTemp :: MachRep -> FCode LocalReg
375 newNonPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindNonPtr) }
376
377 newPtrTemp :: MachRep -> FCode LocalReg
378 newPtrTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep KindPtr) }
379
380
381 -------------------------------------------------------------------------
382 --
383 -- Building case analysis
384 --
385 -------------------------------------------------------------------------
386
387 emitSwitch
388 :: CmmExpr -- Tag to switch on
389 -> [(ConTagZ, CgStmts)] -- Tagged branches
390 -> Maybe CgStmts -- Default branch (if any)
391 -> ConTagZ -> ConTagZ -- Min and Max possible values; behaviour
392 -- outside this range is undefined
393 -> Code
394
395 -- ONLY A DEFAULT BRANCH: no case analysis to do
396 emitSwitch tag_expr [] (Just stmts) _ _
397 = emitCgStmts stmts
398
399 -- Right, off we go
400 emitSwitch tag_expr branches mb_deflt lo_tag hi_tag
401 = -- Just sort the branches before calling mk_sritch
402 do { mb_deflt_id <-
403 case mb_deflt of
404 Nothing -> return Nothing
405 Just stmts -> do id <- forkCgStmts stmts; return (Just id)
406
407 ; dflags <- getDynFlags
408 ; let via_C | HscC <- hscTarget dflags = True
409 | otherwise = False
410
411 ; stmts <- mk_switch tag_expr (sortLe le branches)
412 mb_deflt_id lo_tag hi_tag via_C
413 ; emitCgStmts stmts
414 }
415 where
416 (t1,_) `le` (t2,_) = t1 <= t2
417
418
419 mk_switch :: CmmExpr -> [(ConTagZ, CgStmts)]
420 -> Maybe BlockId -> ConTagZ -> ConTagZ -> Bool
421 -> FCode CgStmts
422
423 -- SINGLETON TAG RANGE: no case analysis to do
424 mk_switch tag_expr [(tag,stmts)] _ lo_tag hi_tag via_C
425 | lo_tag == hi_tag
426 = ASSERT( tag == lo_tag )
427 return stmts
428
429 -- SINGLETON BRANCH, NO DEFUALT: no case analysis to do
430 mk_switch tag_expr [(tag,stmts)] Nothing lo_tag hi_tag via_C
431 = return stmts
432 -- The simplifier might have eliminated a case
433 -- so we may have e.g. case xs of
434 -- [] -> e
435 -- In that situation we can be sure the (:) case
436 -- can't happen, so no need to test
437
438 -- SINGLETON BRANCH: one equality check to do
439 mk_switch tag_expr [(tag,stmts)] (Just deflt) lo_tag hi_tag via_C
440 = return (CmmCondBranch cond deflt `consCgStmt` stmts)
441 where
442 cond = cmmNeWord tag_expr (CmmLit (mkIntCLit tag))
443 -- We have lo_tag < hi_tag, but there's only one branch,
444 -- so there must be a default
445
446 -- ToDo: we might want to check for the two branch case, where one of
447 -- the branches is the tag 0, because comparing '== 0' is likely to be
448 -- more efficient than other kinds of comparison.
449
450 -- DENSE TAG RANGE: use a switch statment.
451 --
452 -- We also use a switch uncoditionally when compiling via C, because
453 -- this will get emitted as a C switch statement and the C compiler
454 -- should do a good job of optimising it. Also, older GCC versions
455 -- (2.95 in particular) have problems compiling the complicated
456 -- if-trees generated by this code, so compiling to a switch every
457 -- time works around that problem.
458 --
459 mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C
460 | use_switch -- Use a switch
461 = do { branch_ids <- mapM forkCgStmts (map snd branches)
462 ; let
463 tagged_blk_ids = zip (map fst branches) (map Just branch_ids)
464
465 find_branch :: ConTagZ -> Maybe BlockId
466 find_branch i = assocDefault mb_deflt tagged_blk_ids i
467
468 -- NB. we have eliminated impossible branches at
469 -- either end of the range (see below), so the first
470 -- tag of a real branch is real_lo_tag (not lo_tag).
471 arms = [ find_branch i | i <- [real_lo_tag..real_hi_tag]]
472
473 switch_stmt = CmmSwitch (cmmOffset tag_expr (- real_lo_tag)) arms
474
475 ; ASSERT(not (all isNothing arms))
476 return (oneCgStmt switch_stmt)
477 }
478
479 -- if we can knock off a bunch of default cases with one if, then do so
480 | Just deflt <- mb_deflt, (lowest_branch - lo_tag) >= n_branches
481 = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
482 ; let cond = cmmULtWord tag_expr' (CmmLit (mkIntCLit lowest_branch))
483 branch = CmmCondBranch cond deflt
484 ; stmts <- mk_switch tag_expr' branches mb_deflt
485 lowest_branch hi_tag via_C
486 ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
487 }
488
489 | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches
490 = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
491 ; let cond = cmmUGtWord tag_expr' (CmmLit (mkIntCLit highest_branch))
492 branch = CmmCondBranch cond deflt
493 ; stmts <- mk_switch tag_expr' branches mb_deflt
494 lo_tag highest_branch via_C
495 ; return (assign_tag `consCgStmt` (branch `consCgStmt` stmts))
496 }
497
498 | otherwise -- Use an if-tree
499 = do { (assign_tag, tag_expr') <- assignNonPtrTemp' tag_expr
500 -- To avoid duplication
501 ; lo_stmts <- mk_switch tag_expr' lo_branches mb_deflt
502 lo_tag (mid_tag-1) via_C
503 ; hi_stmts <- mk_switch tag_expr' hi_branches mb_deflt
504 mid_tag hi_tag via_C
505 ; hi_id <- forkCgStmts hi_stmts
506 ; let cond = cmmUGeWord tag_expr' (CmmLit (mkIntCLit mid_tag))
507 branch_stmt = CmmCondBranch cond hi_id
508 ; return (assign_tag `consCgStmt` (branch_stmt `consCgStmt` lo_stmts))
509 }
510 -- we test (e >= mid_tag) rather than (e < mid_tag), because
511 -- the former works better when e is a comparison, and there
512 -- are two tags 0 & 1 (mid_tag == 1). In this case, the code
513 -- generator can reduce the condition to e itself without
514 -- having to reverse the sense of the comparison: comparisons
515 -- can't always be easily reversed (eg. floating
516 -- pt. comparisons).
517 where
518 use_switch = {- pprTrace "mk_switch" (
519 ppr tag_expr <+> text "n_tags:" <+> int n_tags <+>
520 text "branches:" <+> ppr (map fst branches) <+>
521 text "n_branches:" <+> int n_branches <+>
522 text "lo_tag:" <+> int lo_tag <+>
523 text "hi_tag:" <+> int hi_tag <+>
524 text "real_lo_tag:" <+> int real_lo_tag <+>
525 text "real_hi_tag:" <+> int real_hi_tag) $ -}
526 ASSERT( n_branches > 1 && n_tags > 1 )
527 n_tags > 2 && (via_C || (dense && big_enough))
528 -- up to 4 branches we use a decision tree, otherwise
529 -- a switch (== jump table in the NCG). This seems to be
530 -- optimal, and corresponds with what gcc does.
531 big_enough = n_branches > 4
532 dense = n_branches > (n_tags `div` 2)
533 n_branches = length branches
534
535 -- ignore default slots at each end of the range if there's
536 -- no default branch defined.
537 lowest_branch = fst (head branches)
538 highest_branch = fst (last branches)
539
540 real_lo_tag
541 | isNothing mb_deflt = lowest_branch
542 | otherwise = lo_tag
543
544 real_hi_tag
545 | isNothing mb_deflt = highest_branch
546 | otherwise = hi_tag
547
548 n_tags = real_hi_tag - real_lo_tag + 1
549
550 -- INVARIANT: Provided hi_tag > lo_tag (which is true)
551 -- lo_tag <= mid_tag < hi_tag
552 -- lo_branches have tags < mid_tag
553 -- hi_branches have tags >= mid_tag
554
555 (mid_tag,_) = branches !! (n_branches `div` 2)
556 -- 2 branches => n_branches `div` 2 = 1
557 -- => branches !! 1 give the *second* tag
558 -- There are always at least 2 branches here
559
560 (lo_branches, hi_branches) = span is_lo branches
561 is_lo (t,_) = t < mid_tag
562
563
564 assignNonPtrTemp' e
565 | isTrivialCmmExpr e = return (CmmNop, e)
566 | otherwise = do { reg <- newNonPtrTemp (cmmExprRep e)
567 ; return (CmmAssign (CmmLocal reg) e, CmmReg (CmmLocal reg)) }
568
569 emitLitSwitch :: CmmExpr -- Tag to switch on
570 -> [(Literal, CgStmts)] -- Tagged branches
571 -> CgStmts -- Default branch (always)
572 -> Code -- Emit the code
573 -- Used for general literals, whose size might not be a word,
574 -- where there is always a default case, and where we don't know
575 -- the range of values for certain. For simplicity we always generate a tree.
576 --
577 -- ToDo: for integers we could do better here, perhaps by generalising
578 -- mk_switch and using that. --SDM 15/09/2004
579 emitLitSwitch scrut [] deflt
580 = emitCgStmts deflt
581 emitLitSwitch scrut branches deflt_blk
582 = do { scrut' <- assignNonPtrTemp scrut
583 ; deflt_blk_id <- forkCgStmts deflt_blk
584 ; blk <- mk_lit_switch scrut' deflt_blk_id (sortLe le branches)
585 ; emitCgStmts blk }
586 where
587 le (t1,_) (t2,_) = t1 <= t2
588
589 mk_lit_switch :: CmmExpr -> BlockId
590 -> [(Literal,CgStmts)]
591 -> FCode CgStmts
592 mk_lit_switch scrut deflt_blk_id [(lit,blk)]
593 = return (consCgStmt if_stmt blk)
594 where
595 cmm_lit = mkSimpleLit lit
596 rep = cmmLitRep cmm_lit
597 cond = CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit]
598 if_stmt = CmmCondBranch cond deflt_blk_id
599
600 mk_lit_switch scrut deflt_blk_id branches
601 = do { hi_blk <- mk_lit_switch scrut deflt_blk_id hi_branches
602 ; lo_blk <- mk_lit_switch scrut deflt_blk_id lo_branches
603 ; lo_blk_id <- forkCgStmts lo_blk
604 ; let if_stmt = CmmCondBranch cond lo_blk_id
605 ; return (if_stmt `consCgStmt` hi_blk) }
606 where
607 n_branches = length branches
608 (mid_lit,_) = branches !! (n_branches `div` 2)
609 -- See notes above re mid_tag
610
611 (lo_branches, hi_branches) = span is_lo branches
612 is_lo (t,_) = t < mid_lit
613
614 cond = CmmMachOp (mkLtOp mid_lit)
615 [scrut, CmmLit (mkSimpleLit mid_lit)]
616
617 -------------------------------------------------------------------------
618 --
619 -- Simultaneous assignment
620 --
621 -------------------------------------------------------------------------
622
623
624 emitSimultaneously :: CmmStmts -> Code
625 -- Emit code to perform the assignments in the
626 -- input simultaneously, using temporary variables when necessary.
627 --
628 -- The Stmts must be:
629 -- CmmNop, CmmComment, CmmAssign, CmmStore
630 -- and nothing else
631
632
633 -- We use the strongly-connected component algorithm, in which
634 -- * the vertices are the statements
635 -- * an edge goes from s1 to s2 iff
636 -- s1 assigns to something s2 uses
637 -- that is, if s1 should *follow* s2 in the final order
638
639 type CVertex = (Int, CmmStmt) -- Give each vertex a unique number,
640 -- for fast comparison
641
642 emitSimultaneously stmts
643 = codeOnly $
644 case filterOut isNopStmt (stmtList stmts) of
645 -- Remove no-ops
646 [] -> nopC
647 [stmt] -> stmtC stmt -- It's often just one stmt
648 stmt_list -> doSimultaneously1 (zip [(1::Int)..] stmt_list)
649
650 doSimultaneously1 :: [CVertex] -> Code
651 doSimultaneously1 vertices
652 = let
653 edges = [ (vertex, key1, edges_from stmt1)
654 | vertex@(key1, stmt1) <- vertices
655 ]
656 edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,
657 stmt1 `mustFollow` stmt2
658 ]
659 components = stronglyConnComp edges
660
661 -- do_components deal with one strongly-connected component
662 -- Not cyclic, or singleton? Just do it
663 do_component (AcyclicSCC (n,stmt)) = stmtC stmt
664 do_component (CyclicSCC [(n,stmt)]) = stmtC stmt
665
666 -- Cyclic? Then go via temporaries. Pick one to
667 -- break the loop and try again with the rest.
668 do_component (CyclicSCC ((n,first_stmt) : rest))
669 = do { from_temp <- go_via_temp first_stmt
670 ; doSimultaneously1 rest
671 ; stmtC from_temp }
672
673 go_via_temp (CmmAssign dest src)
674 = do { tmp <- newNonPtrTemp (cmmRegRep dest) -- TODO FIXME NOW if the pair of assignments move across a call this will be wrong
675 ; stmtC (CmmAssign (CmmLocal tmp) src)
676 ; return (CmmAssign dest (CmmReg (CmmLocal tmp))) }
677 go_via_temp (CmmStore dest src)
678 = do { tmp <- newNonPtrTemp (cmmExprRep src) -- TODO FIXME NOW if the pair of assignemnts move across a call this will be wrong
679 ; stmtC (CmmAssign (CmmLocal tmp) src)
680 ; return (CmmStore dest (CmmReg (CmmLocal tmp))) }
681 in
682 mapCs do_component components
683
684 mustFollow :: CmmStmt -> CmmStmt -> Bool
685 CmmAssign reg _ `mustFollow` stmt = anySrc (reg `regUsedIn`) stmt
686 CmmStore loc e `mustFollow` stmt = anySrc (locUsedIn loc (cmmExprRep e)) stmt
687 CmmNop `mustFollow` stmt = False
688 CmmComment _ `mustFollow` stmt = False
689
690
691 anySrc :: (CmmExpr -> Bool) -> CmmStmt -> Bool
692 -- True if the fn is true of any input of the stmt
693 anySrc p (CmmAssign _ e) = p e
694 anySrc p (CmmStore e1 e2) = p e1 || p e2 -- Might be used in either side
695 anySrc p (CmmComment _) = False
696 anySrc p CmmNop = False
697 anySrc p other = True -- Conservative
698
699 regUsedIn :: CmmReg -> CmmExpr -> Bool
700 reg `regUsedIn` CmmLit _ = False
701 reg `regUsedIn` CmmLoad e _ = reg `regUsedIn` e
702 reg `regUsedIn` CmmReg reg' = reg == reg'
703 reg `regUsedIn` CmmRegOff reg' _ = reg == reg'
704 reg `regUsedIn` CmmMachOp _ es = any (reg `regUsedIn`) es
705
706 locUsedIn :: CmmExpr -> MachRep -> CmmExpr -> Bool
707 -- (locUsedIn a r e) checks whether writing to r[a] could affect the value of
708 -- 'e'. Returns True if it's not sure.
709 locUsedIn loc rep (CmmLit _) = False
710 locUsedIn loc rep (CmmLoad e ld_rep) = possiblySameLoc loc rep e ld_rep
711 locUsedIn loc rep (CmmReg reg') = False
712 locUsedIn loc rep (CmmRegOff reg' _) = False
713 locUsedIn loc rep (CmmMachOp _ es) = any (locUsedIn loc rep) es
714
715 possiblySameLoc :: CmmExpr -> MachRep -> CmmExpr -> MachRep -> Bool
716 -- Assumes that distinct registers (eg Hp, Sp) do not
717 -- point to the same location, nor any offset thereof.
718 possiblySameLoc (CmmReg r1) rep1 (CmmReg r2) rep2 = r1==r2
719 possiblySameLoc (CmmReg r1) rep1 (CmmRegOff r2 0) rep2 = r1==r2
720 possiblySameLoc (CmmRegOff r1 0) rep1 (CmmReg r2) rep2 = r1==r2
721 possiblySameLoc (CmmRegOff r1 start1) rep1 (CmmRegOff r2 start2) rep2
722 = r1==r2 && end1 > start2 && end2 > start1
723 where
724 end1 = start1 + machRepByteWidth rep1
725 end2 = start2 + machRepByteWidth rep2
726
727 possiblySameLoc l1 rep1 (CmmLit _) rep2 = False
728 possiblySameLoc l1 rep1 l2 rep2 = True -- Conservative
729
730 -------------------------------------------------------------------------
731 --
732 -- Static Reference Tables
733 --
734 -------------------------------------------------------------------------
735
736 -- There is just one SRT for each top level binding; all the nested
737 -- bindings use sub-sections of this SRT. The label is passed down to
738 -- the nested bindings via the monad.
739
740 getSRTInfo :: FCode C_SRT
741 getSRTInfo = do
742 srt_lbl <- getSRTLabel
743 srt <- getSRT
744 case srt of
745 -- TODO: Should we panic in this case?
746 -- Someone obviously thinks there should be an SRT
747 NoSRT -> return NoC_SRT
748 SRT off len bmp
749 | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
750 -> do id <- newUnique
751 let srt_desc_lbl = mkLargeSRTLabel id
752 emitRODataLits srt_desc_lbl
753 ( cmmLabelOffW srt_lbl off
754 : mkWordCLit (fromIntegral len)
755 : map mkWordCLit bmp)
756 return (C_SRT srt_desc_lbl 0 srt_escape)
757
758 SRT off len bmp
759 | otherwise
760 -> return (C_SRT srt_lbl off (fromIntegral (head bmp)))
761 -- The fromIntegral converts to StgHalfWord
762
763 srt_escape = (-1) :: StgHalfWord