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