update for changes in hetmet Makefile
[ghc-hetmet.git] / compiler / cmm / CmmOpt.hs
1 {-# OPTIONS -w #-}
2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
6 -- for details
7
8 -----------------------------------------------------------------------------
9 --
10 -- Cmm optimisation
11 --
12 -- (c) The University of Glasgow 2006
13 --
14 -----------------------------------------------------------------------------
15
16 module CmmOpt (
17         cmmMiniInline,
18         cmmMachOpFold,
19         cmmLoopifyForC,
20  ) where
21
22 #include "HsVersions.h"
23
24 import OldCmm
25 import CmmUtils
26 import CLabel
27 import StaticFlags
28
29 import UniqFM
30 import Unique
31 import FastTypes
32 import Outputable
33
34 import Data.Bits
35 import Data.Word
36 import Data.Int
37
38 -- -----------------------------------------------------------------------------
39 -- The mini-inliner
40
41 {-
42 This pass inlines assignments to temporaries that are used just
43 once.  It works as follows:
44
45   - count uses of each temporary
46   - for each temporary that occurs just once:
47         - attempt to push it forward to the statement that uses it
48         - only push forward past assignments to other temporaries
49           (assumes that temporaries are single-assignment)
50         - if we reach the statement that uses it, inline the rhs
51           and delete the original assignment.
52
53 [N.B. In the Quick C-- compiler, this optimization is achieved by a
54  combination of two dataflow passes: forward substitution (peephole
55  optimization) and dead-assignment elimination.  ---NR]
56
57 Possible generalisations: here is an example from factorial
58
59 Fac_zdwfac_entry:
60     cmG:
61         _smi = R2;
62         if (_smi != 0) goto cmK;
63         R1 = R3;
64         jump I64[Sp];
65     cmK:
66         _smn = _smi * R3;
67         R2 = _smi + (-1);
68         R3 = _smn;
69         jump Fac_zdwfac_info;
70
71 We want to inline _smi and _smn.  To inline _smn:
72
73    - we must be able to push forward past assignments to global regs.
74      We can do this if the rhs of the assignment we are pushing
75      forward doesn't refer to the global reg being assigned to; easy
76      to test.
77
78 To inline _smi:
79
80    - It is a trivial replacement, reg for reg, but it occurs more than
81      once.
82    - We can inline trivial assignments even if the temporary occurs
83      more than once, as long as we don't eliminate the original assignment
84      (this doesn't help much on its own).
85    - We need to be able to propagate the assignment forward through jumps;
86      if we did this, we would find that it can be inlined safely in all
87      its occurrences.
88 -}
89
90 countUses :: UserOfLocalRegs a => a -> UniqFM Int
91 countUses a = foldRegsUsed (\m r -> addToUFM m r (count m r + 1)) emptyUFM a
92   where count m r = lookupWithDefaultUFM m (0::Int) r
93
94 cmmMiniInline :: [CmmBasicBlock] -> [CmmBasicBlock]
95 cmmMiniInline blocks = map do_inline blocks 
96   where do_inline (BasicBlock id stmts)
97           = BasicBlock id (cmmMiniInlineStmts (countUses blocks) stmts)
98
99 cmmMiniInlineStmts :: UniqFM Int -> [CmmStmt] -> [CmmStmt]
100 cmmMiniInlineStmts uses [] = []
101 cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
102         -- not used at all: just discard this assignment
103   | Nothing <- lookupUFM uses u
104   = cmmMiniInlineStmts uses stmts
105
106         -- used once: try to inline at the use site
107   | Just 1 <- lookupUFM uses u,
108     Just stmts' <- lookForInline u expr stmts
109   = 
110 #ifdef NCG_DEBUG
111      trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $
112 #endif
113      cmmMiniInlineStmts uses stmts'
114
115 cmmMiniInlineStmts uses (stmt:stmts)
116   = stmt : cmmMiniInlineStmts uses stmts
117
118 lookForInline u expr (stmt : rest)
119   | Just 1 <- lookupUFM (countUses stmt) u, ok_to_inline
120   = Just (inlineStmt u expr stmt : rest)
121
122   | ok_to_skip
123   = case lookForInline u expr rest of
124            Nothing    -> Nothing
125            Just stmts -> Just (stmt:stmts)
126
127   | otherwise 
128   = Nothing
129
130   where
131         -- we don't inline into CmmCall if the expression refers to global
132         -- registers.  This is a HACK to avoid global registers clashing with
133         -- C argument-passing registers, really the back-end ought to be able
134         -- to handle it properly, but currently neither PprC nor the NCG can
135         -- do it.  See also CgForeignCall:load_args_into_temps.
136     ok_to_inline = case stmt of
137                      CmmCall{} -> hasNoGlobalRegs expr
138                      _ -> True
139
140    -- We can skip over assignments to other tempoararies, because we
141    -- know that expressions aren't side-effecting and temporaries are
142    -- single-assignment.
143     ok_to_skip = case stmt of
144                  CmmNop -> True
145                  CmmAssign (CmmLocal (LocalReg u' _)) rhs | u' /= u -> True
146                  CmmAssign g@(CmmGlobal _) rhs -> not (g `regUsedIn` expr)
147                  _other -> False
148
149
150 inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
151 inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
152 inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2)
153 inlineStmt u a (CmmCall target regs es srt ret)
154    = CmmCall (infn target) regs es' srt ret
155    where infn (CmmCallee fn cconv) = CmmCallee (inlineExpr u a fn) cconv
156          infn (CmmPrim p) = CmmPrim p
157          es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ]
158 inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d
159 inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d
160 inlineStmt u a (CmmJump e d) = CmmJump (inlineExpr u a e) d
161 inlineStmt u a other_stmt = other_stmt
162
163 inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr
164 inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _)))
165   | u == u' = a
166   | otherwise = e
167 inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off)
168   | u == u' = CmmMachOp (MO_Add width) [a, CmmLit (CmmInt (fromIntegral off) width)]
169   | otherwise = e
170   where
171     width = typeWidth rep
172 inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep
173 inlineExpr u a (CmmMachOp op es) = CmmMachOp op (map (inlineExpr u a) es)
174 inlineExpr u a other_expr = other_expr
175
176 -- -----------------------------------------------------------------------------
177 -- MachOp constant folder
178
179 -- Now, try to constant-fold the MachOps.  The arguments have already
180 -- been optimized and folded.
181
182 cmmMachOpFold
183     :: MachOp           -- The operation from an CmmMachOp
184     -> [CmmExpr]        -- The optimized arguments
185     -> CmmExpr
186
187 cmmMachOpFold op arg@[CmmLit (CmmInt x rep)]
188   = case op of
189       MO_S_Neg r -> CmmLit (CmmInt (-x) rep)
190       MO_Not r   -> CmmLit (CmmInt (complement x) rep)
191
192         -- these are interesting: we must first narrow to the 
193         -- "from" type, in order to truncate to the correct size.
194         -- The final narrow/widen to the destination type
195         -- is implicit in the CmmLit.
196       MO_SF_Conv from to -> CmmLit (CmmFloat (fromInteger x) to)
197       MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
198       MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to)
199
200       _ -> panic "cmmMachOpFold: unknown unary op"
201
202
203 -- Eliminate conversion NOPs
204 cmmMachOpFold (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = x
205 cmmMachOpFold (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = x
206
207 -- Eliminate nested conversions where possible
208 cmmMachOpFold conv_outer args@[CmmMachOp conv_inner [x]]
209   | Just (rep1,rep2,signed1) <- isIntConversion conv_inner,
210     Just (_,   rep3,signed2) <- isIntConversion conv_outer
211   = case () of
212         -- widen then narrow to the same size is a nop
213       _ | rep1 < rep2 && rep1 == rep3 -> x
214         -- Widen then narrow to different size: collapse to single conversion
215         -- but remember to use the signedness from the widening, just in case
216         -- the final conversion is a widen.
217         | rep1 < rep2 && rep2 > rep3 ->
218             cmmMachOpFold (intconv signed1 rep1 rep3) [x]
219         -- Nested widenings: collapse if the signedness is the same
220         | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->
221             cmmMachOpFold (intconv signed1 rep1 rep3) [x]
222         -- Nested narrowings: collapse
223         | rep1 > rep2 && rep2 > rep3 ->
224             cmmMachOpFold (MO_UU_Conv rep1 rep3) [x]
225         | otherwise ->
226             CmmMachOp conv_outer args
227   where
228         isIntConversion (MO_UU_Conv rep1 rep2) 
229           = Just (rep1,rep2,False)
230         isIntConversion (MO_SS_Conv rep1 rep2)
231           = Just (rep1,rep2,True)
232         isIntConversion _ = Nothing
233
234         intconv True  = MO_SS_Conv
235         intconv False = MO_UU_Conv
236
237 -- ToDo: a narrow of a load can be collapsed into a narrow load, right?
238 -- but what if the architecture only supports word-sized loads, should
239 -- we do the transformation anyway?
240
241 cmmMachOpFold mop args@[CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
242   = case mop of
243         -- for comparisons: don't forget to narrow the arguments before
244         -- comparing, since they might be out of range.
245         MO_Eq r   -> CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordWidth)
246         MO_Ne r   -> CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordWidth)
247
248         MO_U_Gt r -> CmmLit (CmmInt (if x_u >  y_u then 1 else 0) wordWidth)
249         MO_U_Ge r -> CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordWidth)
250         MO_U_Lt r -> CmmLit (CmmInt (if x_u <  y_u then 1 else 0) wordWidth)
251         MO_U_Le r -> CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordWidth)
252
253         MO_S_Gt r -> CmmLit (CmmInt (if x_s >  y_s then 1 else 0) wordWidth) 
254         MO_S_Ge r -> CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordWidth)
255         MO_S_Lt r -> CmmLit (CmmInt (if x_s <  y_s then 1 else 0) wordWidth)
256         MO_S_Le r -> CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordWidth)
257
258         MO_Add r -> CmmLit (CmmInt (x + y) r)
259         MO_Sub r -> CmmLit (CmmInt (x - y) r)
260         MO_Mul r -> CmmLit (CmmInt (x * y) r)
261         MO_U_Quot r | y /= 0 -> CmmLit (CmmInt (x_u `quot` y_u) r)
262         MO_U_Rem  r | y /= 0 -> CmmLit (CmmInt (x_u `rem`  y_u) r)
263         MO_S_Quot r | y /= 0 -> CmmLit (CmmInt (x `quot` y) r)
264         MO_S_Rem  r | y /= 0 -> CmmLit (CmmInt (x `rem` y) r)
265
266         MO_And   r -> CmmLit (CmmInt (x .&. y) r)
267         MO_Or    r -> CmmLit (CmmInt (x .|. y) r)
268         MO_Xor   r -> CmmLit (CmmInt (x `xor` y) r)
269
270         MO_Shl   r -> CmmLit (CmmInt (x `shiftL` fromIntegral y) r)
271         MO_U_Shr r -> CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)
272         MO_S_Shr r -> CmmLit (CmmInt (x `shiftR` fromIntegral y) r)
273
274         other      -> CmmMachOp mop args
275
276    where
277         x_u = narrowU xrep x
278         y_u = narrowU xrep y
279         x_s = narrowS xrep x
280         y_s = narrowS xrep y
281         
282
283 -- When possible, shift the constants to the right-hand side, so that we
284 -- can match for strength reductions.  Note that the code generator will
285 -- also assume that constants have been shifted to the right when
286 -- possible.
287
288 cmmMachOpFold op [x@(CmmLit _), y]
289    | not (isLit y) && isCommutableMachOp op 
290    = cmmMachOpFold op [y, x]
291
292 -- Turn (a+b)+c into a+(b+c) where possible.  Because literals are
293 -- moved to the right, it is more likely that we will find
294 -- opportunities for constant folding when the expression is
295 -- right-associated.
296 --
297 -- ToDo: this appears to introduce a quadratic behaviour due to the
298 -- nested cmmMachOpFold.  Can we fix this?
299 --
300 -- Why do we check isLit arg1?  If arg1 is a lit, it means that arg2
301 -- is also a lit (otherwise arg1 would be on the right).  If we
302 -- put arg1 on the left of the rearranged expression, we'll get into a
303 -- loop:  (x1+x2)+x3 => x1+(x2+x3)  => (x2+x3)+x1 => x2+(x3+x1) ...
304 --
305 -- Also don't do it if arg1 is PicBaseReg, so that we don't separate the
306 -- PicBaseReg from the corresponding label (or label difference).
307 --
308 cmmMachOpFold mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
309    | mop2 `associates_with` mop1
310      && not (isLit arg1) && not (isPicReg arg1)
311    = cmmMachOpFold mop2 [arg1, cmmMachOpFold mop1 [arg2,arg3]]
312    where
313      MO_Add{} `associates_with` MO_Sub{} = True
314      mop1 `associates_with` mop2 =
315         mop1 == mop2 && isAssociativeMachOp mop1
316
317 -- special case: (a - b) + c  ==>  a + (c - b)
318 cmmMachOpFold mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]
319    | not (isLit arg1) && not (isPicReg arg1)
320    = cmmMachOpFold mop1 [arg1, cmmMachOpFold mop2 [arg3,arg2]]
321
322 -- Make a RegOff if we can
323 cmmMachOpFold (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]
324   = CmmRegOff reg (fromIntegral (narrowS rep n))
325 cmmMachOpFold (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
326   = CmmRegOff reg (off + fromIntegral (narrowS rep n))
327 cmmMachOpFold (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]
328   = CmmRegOff reg (- fromIntegral (narrowS rep n))
329 cmmMachOpFold (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
330   = CmmRegOff reg (off - fromIntegral (narrowS rep n))
331
332 -- Fold label(+/-)offset into a CmmLit where possible
333
334 cmmMachOpFold (MO_Add _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
335   = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
336 cmmMachOpFold (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)]
337   = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
338 cmmMachOpFold (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
339   = CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i))))
340
341
342 -- Comparison of literal with widened operand: perform the comparison
343 -- at the smaller width, as long as the literal is within range.
344
345 -- We can't do the reverse trick, when the operand is narrowed:
346 -- narrowing throws away bits from the operand, there's no way to do
347 -- the same comparison at the larger size.
348
349 #if i386_TARGET_ARCH || x86_64_TARGET_ARCH
350 -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try
351
352 cmmMachOpFold cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
353   |     -- if the operand is widened:
354     Just (rep, signed, narrow_fn) <- maybe_conversion conv,
355         -- and this is a comparison operation:
356     Just narrow_cmp <- maybe_comparison cmp rep signed,
357         -- and the literal fits in the smaller size:
358     i == narrow_fn rep i
359         -- then we can do the comparison at the smaller size
360   = cmmMachOpFold narrow_cmp [x, CmmLit (CmmInt i rep)]
361  where
362     maybe_conversion (MO_UU_Conv from to)
363         | to > from
364         = Just (from, False, narrowU)
365     maybe_conversion (MO_SS_Conv from to)
366         | to > from
367         = Just (from, True, narrowS)
368
369         -- don't attempt to apply this optimisation when the source
370         -- is a float; see #1916
371     maybe_conversion _ = Nothing
372     
373         -- careful (#2080): if the original comparison was signed, but
374         -- we were doing an unsigned widen, then we must do an
375         -- unsigned comparison at the smaller size.
376     maybe_comparison (MO_U_Gt _) rep _     = Just (MO_U_Gt rep)
377     maybe_comparison (MO_U_Ge _) rep _     = Just (MO_U_Ge rep)
378     maybe_comparison (MO_U_Lt _) rep _     = Just (MO_U_Lt rep)
379     maybe_comparison (MO_U_Le _) rep _     = Just (MO_U_Le rep)
380     maybe_comparison (MO_Eq   _) rep _     = Just (MO_Eq   rep)
381     maybe_comparison (MO_S_Gt _) rep True  = Just (MO_S_Gt rep)
382     maybe_comparison (MO_S_Ge _) rep True  = Just (MO_S_Ge rep)
383     maybe_comparison (MO_S_Lt _) rep True  = Just (MO_S_Lt rep)
384     maybe_comparison (MO_S_Le _) rep True  = Just (MO_S_Le rep)
385     maybe_comparison (MO_S_Gt _) rep False = Just (MO_U_Gt rep)
386     maybe_comparison (MO_S_Ge _) rep False = Just (MO_U_Ge rep)
387     maybe_comparison (MO_S_Lt _) rep False = Just (MO_U_Lt rep)
388     maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep)
389     maybe_comparison _ _ _ = Nothing
390
391 #endif
392
393 -- We can often do something with constants of 0 and 1 ...
394
395 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 0 _))]
396   = case mop of
397         MO_Add   r -> x
398         MO_Sub   r -> x
399         MO_Mul   r -> y
400         MO_And   r -> y
401         MO_Or    r -> x
402         MO_Xor   r -> x
403         MO_Shl   r -> x
404         MO_S_Shr r -> x
405         MO_U_Shr r -> x
406         MO_Ne    r | isComparisonExpr x -> x
407         MO_Eq    r | Just x' <- maybeInvertCmmExpr x -> x'
408         MO_U_Gt  r | isComparisonExpr x -> x
409         MO_S_Gt  r | isComparisonExpr x -> x
410         MO_U_Lt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth)
411         MO_S_Lt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth)
412         MO_U_Ge  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth)
413         MO_S_Ge  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth)
414         MO_U_Le  r | Just x' <- maybeInvertCmmExpr x -> x'
415         MO_S_Le  r | Just x' <- maybeInvertCmmExpr x -> x'
416         other    -> CmmMachOp mop args
417
418 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))]
419   = case mop of
420         MO_Mul    r -> x
421         MO_S_Quot r -> x
422         MO_U_Quot r -> x
423         MO_S_Rem  r -> CmmLit (CmmInt 0 rep)
424         MO_U_Rem  r -> CmmLit (CmmInt 0 rep)
425         MO_Ne    r | Just x' <- maybeInvertCmmExpr x -> x'
426         MO_Eq    r | isComparisonExpr x -> x
427         MO_U_Lt  r | Just x' <- maybeInvertCmmExpr x -> x'
428         MO_S_Lt  r | Just x' <- maybeInvertCmmExpr x -> x'
429         MO_U_Gt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth)
430         MO_S_Gt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth)
431         MO_U_Le  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth)
432         MO_S_Le  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth)
433         MO_U_Ge  r | isComparisonExpr x -> x
434         MO_S_Ge  r | isComparisonExpr x -> x
435         other       -> CmmMachOp mop args
436
437 -- Now look for multiplication/division by powers of 2 (integers).
438
439 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt n _))]
440   = case mop of
441         MO_Mul rep
442            | Just p <- exactLog2 n ->
443                  cmmMachOpFold (MO_Shl rep) [x, CmmLit (CmmInt p rep)]
444         MO_U_Quot rep
445            | Just p <- exactLog2 n ->
446                  cmmMachOpFold (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)]
447         MO_S_Quot rep
448            | Just p <- exactLog2 n, 
449              CmmReg _ <- x ->   -- We duplicate x below, hence require
450                                 -- it is a reg.  FIXME: remove this restriction.
451                 -- shift right is not the same as quot, because it rounds
452                 -- to minus infinity, whereasq quot rounds toward zero.
453                 -- To fix this up, we add one less than the divisor to the
454                 -- dividend if it is a negative number.
455                 --
456                 -- to avoid a test/jump, we use the following sequence:
457                 --      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)
458                 --      x2 = y & (divisor-1)
459                 --      result = (x+x2) >>= log2(divisor)
460                 -- this could be done a bit more simply using conditional moves,
461                 -- but we're processor independent here.
462                 --
463                 -- we optimise the divide by 2 case slightly, generating
464                 --      x1 = x >> word_size-1  (unsigned)
465                 --      return = (x + x1) >>= log2(divisor)
466                 let 
467                     bits = fromIntegral (widthInBits rep) - 1
468                     shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep
469                     x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)]
470                     x2 = if p == 1 then x1 else
471                          CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]
472                     x3 = CmmMachOp (MO_Add rep) [x, x2]
473                 in
474                 cmmMachOpFold (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)]
475         other
476            -> unchanged
477     where
478        unchanged = CmmMachOp mop args
479
480 -- Anything else is just too hard.
481
482 cmmMachOpFold mop args = CmmMachOp mop args
483
484 -- -----------------------------------------------------------------------------
485 -- exactLog2
486
487 -- This algorithm for determining the $\log_2$ of exact powers of 2 comes
488 -- from GCC.  It requires bit manipulation primitives, and we use GHC
489 -- extensions.  Tough.
490 -- 
491 -- Used to be in MachInstrs --SDM.
492 -- ToDo: remove use of unboxery --SDM.
493
494 -- Unboxery removed in favor of FastInt; but is the function supposed to fail
495 -- on inputs >= 2147483648, or was that just an implementation artifact?
496 -- And is this speed-critical, or can we just use Integer operations
497 -- (including Data.Bits)?
498 --  --Isaac Dupree
499
500 exactLog2 :: Integer -> Maybe Integer
501 exactLog2 x_
502   = if (x_ <= 0 || x_ >= 2147483648) then
503        Nothing
504     else
505        case iUnbox (fromInteger x_) of { x ->
506        if (x `bitAndFastInt` negateFastInt x) /=# x then
507           Nothing
508        else
509           Just (toInteger (iBox (pow2 x)))
510        }
511   where
512     pow2 x | x ==# _ILIT(1) = _ILIT(0)
513            | otherwise = _ILIT(1) +# pow2 (x `shiftR_FastInt` _ILIT(1))
514
515
516 -- -----------------------------------------------------------------------------
517 -- Loopify for C
518
519 {-
520  This is a simple pass that replaces tail-recursive functions like this:
521
522    fac() {
523      ...
524      jump fac();
525    }
526
527  with this:
528
529   fac() {
530    L:
531      ...
532      goto L;
533   }
534
535   the latter generates better C code, because the C compiler treats it
536   like a loop, and brings full loop optimisation to bear.
537
538   In my measurements this makes little or no difference to anything
539   except factorial, but what the hell.
540 -}
541
542 cmmLoopifyForC :: RawCmmTop -> RawCmmTop
543 cmmLoopifyForC p@(CmmProc info entry_lbl
544                  (ListGraph blocks@(BasicBlock top_id _ : _)))
545   | null info = p  -- only if there's an info table, ignore case alts
546   | otherwise =  
547 --  pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $
548   CmmProc info entry_lbl (ListGraph blocks')
549   where blocks' = [ BasicBlock id (map do_stmt stmts)
550                   | BasicBlock id stmts <- blocks ]
551
552         do_stmt (CmmJump (CmmLit (CmmLabel lbl)) _) | lbl == jump_lbl
553                 = CmmBranch top_id
554         do_stmt stmt = stmt
555
556         jump_lbl | tablesNextToCode = entryLblToInfoLbl entry_lbl
557                  | otherwise        = entry_lbl
558
559 cmmLoopifyForC top = top
560
561 -- -----------------------------------------------------------------------------
562 -- Utils
563
564 isLit (CmmLit _) = True
565 isLit _          = False
566
567 isComparisonExpr :: CmmExpr -> Bool
568 isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
569 isComparisonExpr _other             = False
570
571 isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True
572 isPicReg _ = False
573