module CmmOpt (
cmmMiniInline,
cmmMachOpFold,
cmmLoopifyForC,
) where
#include "HsVersions.h"
import Cmm
import CmmExpr
import CmmUtils
import CLabel
import StaticFlags
import UniqFM
import Unique
import FastTypes
import Outputable
import Data.Bits
import Data.Word
import Data.Int
countUses :: UserOfLocalRegs a => a -> UniqFM Int
countUses a = foldRegsUsed (\m r -> addToUFM m r (count m r + 1)) emptyUFM a
where count m r = lookupWithDefaultUFM m (0::Int) r
cmmMiniInline :: [CmmBasicBlock] -> [CmmBasicBlock]
cmmMiniInline blocks = map do_inline blocks
where do_inline (BasicBlock id stmts)
= BasicBlock id (cmmMiniInlineStmts (countUses blocks) stmts)
cmmMiniInlineStmts :: UniqFM Int -> [CmmStmt] -> [CmmStmt]
cmmMiniInlineStmts uses [] = []
cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
| Nothing <- lookupUFM uses u
= cmmMiniInlineStmts uses stmts
| Just 1 <- lookupUFM uses u,
Just stmts' <- lookForInline u expr stmts
=
#ifdef NCG_DEBUG
trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $
#endif
cmmMiniInlineStmts uses stmts'
cmmMiniInlineStmts uses (stmt:stmts)
= stmt : cmmMiniInlineStmts uses stmts
lookForInline u expr (stmt : rest)
| Just 1 <- lookupUFM (countUses stmt) u, ok_to_inline
= Just (inlineStmt u expr stmt : rest)
| ok_to_skip
= case lookForInline u expr rest of
Nothing -> Nothing
Just stmts -> Just (stmt:stmts)
| otherwise
= Nothing
where
ok_to_inline = case stmt of
CmmCall{} -> hasNoGlobalRegs expr
_ -> True
ok_to_skip = case stmt of
CmmNop -> True
CmmAssign (CmmLocal (LocalReg u' _)) rhs | u' /= u -> True
CmmAssign g@(CmmGlobal _) rhs -> not (g `regUsedIn` expr)
_other -> False
inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2)
inlineStmt u a (CmmCall target regs es srt ret)
= CmmCall (infn target) regs es' srt ret
where infn (CmmCallee fn cconv) = CmmCallee (inlineExpr u a fn) cconv
infn (CmmPrim p) = CmmPrim p
es' = [ (CmmHinted (inlineExpr u a e) hint) | (CmmHinted e hint) <- es ]
inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d
inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d
inlineStmt u a (CmmJump e d) = CmmJump (inlineExpr u a e) d
inlineStmt u a other_stmt = other_stmt
inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr
inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _)))
| u == u' = a
| otherwise = e
inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off)
| u == u' = CmmMachOp (MO_Add width) [a, CmmLit (CmmInt (fromIntegral off) width)]
| otherwise = e
where
width = typeWidth rep
inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep
inlineExpr u a (CmmMachOp op es) = CmmMachOp op (map (inlineExpr u a) es)
inlineExpr u a other_expr = other_expr
cmmMachOpFold
:: MachOp
-> [CmmExpr]
-> CmmExpr
cmmMachOpFold op arg@[CmmLit (CmmInt x rep)]
= case op of
MO_S_Neg r -> CmmLit (CmmInt (x) rep)
MO_Not r -> CmmLit (CmmInt (complement x) rep)
MO_SF_Conv from to -> CmmLit (CmmFloat (fromInteger x) to)
MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to)
_ -> panic "cmmMachOpFold: unknown unary op"
cmmMachOpFold (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = x
cmmMachOpFold (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = x
cmmMachOpFold conv_outer args@[CmmMachOp conv_inner [x]]
| Just (rep1,rep2,signed1) <- isIntConversion conv_inner,
Just (_, rep3,signed2) <- isIntConversion conv_outer
= case () of
_ | rep1 < rep2 && rep1 == rep3 -> x
| rep1 < rep2 && rep2 > rep3 ->
cmmMachOpFold (intconv signed1 rep1 rep3) [x]
| rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->
cmmMachOpFold (intconv signed1 rep1 rep3) [x]
| rep1 > rep2 && rep2 > rep3 ->
cmmMachOpFold (MO_UU_Conv rep1 rep3) [x]
| otherwise ->
CmmMachOp conv_outer args
where
isIntConversion (MO_UU_Conv rep1 rep2)
= Just (rep1,rep2,False)
isIntConversion (MO_SS_Conv rep1 rep2)
= Just (rep1,rep2,True)
isIntConversion _ = Nothing
intconv True = MO_SS_Conv
intconv False = MO_UU_Conv
cmmMachOpFold mop args@[CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
= case mop of
MO_Eq r -> CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordWidth)
MO_Ne r -> CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordWidth)
MO_U_Gt r -> CmmLit (CmmInt (if x_u > y_u then 1 else 0) wordWidth)
MO_U_Ge r -> CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordWidth)
MO_U_Lt r -> CmmLit (CmmInt (if x_u < y_u then 1 else 0) wordWidth)
MO_U_Le r -> CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordWidth)
MO_S_Gt r -> CmmLit (CmmInt (if x_s > y_s then 1 else 0) wordWidth)
MO_S_Ge r -> CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordWidth)
MO_S_Lt r -> CmmLit (CmmInt (if x_s < y_s then 1 else 0) wordWidth)
MO_S_Le r -> CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordWidth)
MO_Add r -> CmmLit (CmmInt (x + y) r)
MO_Sub r -> CmmLit (CmmInt (x y) r)
MO_Mul r -> CmmLit (CmmInt (x * y) r)
MO_U_Quot r | y /= 0 -> CmmLit (CmmInt (x_u `quot` y_u) r)
MO_U_Rem r | y /= 0 -> CmmLit (CmmInt (x_u `rem` y_u) r)
MO_S_Quot r | y /= 0 -> CmmLit (CmmInt (x `quot` y) r)
MO_S_Rem r | y /= 0 -> CmmLit (CmmInt (x `rem` y) r)
MO_And r -> CmmLit (CmmInt (x .&. y) r)
MO_Or r -> CmmLit (CmmInt (x .|. y) r)
MO_Xor r -> CmmLit (CmmInt (x `xor` y) r)
MO_Shl r -> CmmLit (CmmInt (x `shiftL` fromIntegral y) r)
MO_U_Shr r -> CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)
MO_S_Shr r -> CmmLit (CmmInt (x `shiftR` fromIntegral y) r)
other -> CmmMachOp mop args
where
x_u = narrowU xrep x
y_u = narrowU xrep y
x_s = narrowS xrep x
y_s = narrowS xrep y
cmmMachOpFold op [x@(CmmLit _), y]
| not (isLit y) && isCommutableMachOp op
= cmmMachOpFold op [y, x]
cmmMachOpFold mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
| mop1 == mop2 && isAssociativeMachOp mop1
&& not (isLit arg1) && not (isPicReg arg1)
= cmmMachOpFold mop1 [arg1, cmmMachOpFold mop2 [arg2,arg3]]
cmmMachOpFold (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]
= CmmRegOff reg (fromIntegral (narrowS rep n))
cmmMachOpFold (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
= CmmRegOff reg (off + fromIntegral (narrowS rep n))
cmmMachOpFold (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]
= CmmRegOff reg ( fromIntegral (narrowS rep n))
cmmMachOpFold (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
= CmmRegOff reg (off fromIntegral (narrowS rep n))
cmmMachOpFold (MO_Add _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
= CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
cmmMachOpFold (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)]
= CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
cmmMachOpFold (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
= CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i))))
#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
cmmMachOpFold cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
|
Just (rep, signed, narrow_fn) <- maybe_conversion conv,
Just narrow_cmp <- maybe_comparison cmp rep signed,
i == narrow_fn rep i
= cmmMachOpFold narrow_cmp [x, CmmLit (CmmInt i rep)]
where
maybe_conversion (MO_UU_Conv from to)
| to > from
= Just (from, False, narrowU)
maybe_conversion (MO_SS_Conv from to)
| to > from
= Just (from, True, narrowS)
maybe_conversion _ = Nothing
maybe_comparison (MO_U_Gt _) rep _ = Just (MO_U_Gt rep)
maybe_comparison (MO_U_Ge _) rep _ = Just (MO_U_Ge rep)
maybe_comparison (MO_U_Lt _) rep _ = Just (MO_U_Lt rep)
maybe_comparison (MO_U_Le _) rep _ = Just (MO_U_Le rep)
maybe_comparison (MO_Eq _) rep _ = Just (MO_Eq rep)
maybe_comparison (MO_S_Gt _) rep True = Just (MO_S_Gt rep)
maybe_comparison (MO_S_Ge _) rep True = Just (MO_S_Ge rep)
maybe_comparison (MO_S_Lt _) rep True = Just (MO_S_Lt rep)
maybe_comparison (MO_S_Le _) rep True = Just (MO_S_Le rep)
maybe_comparison (MO_S_Gt _) rep False = Just (MO_U_Gt rep)
maybe_comparison (MO_S_Ge _) rep False = Just (MO_U_Ge rep)
maybe_comparison (MO_S_Lt _) rep False = Just (MO_U_Lt rep)
maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep)
maybe_comparison _ _ _ = Nothing
#endif
cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 0 _))]
= case mop of
MO_Add r -> x
MO_Sub r -> x
MO_Mul r -> y
MO_And r -> y
MO_Or r -> x
MO_Xor r -> x
MO_Shl r -> x
MO_S_Shr r -> x
MO_U_Shr r -> x
MO_Ne r | isComparisonExpr x -> x
MO_Eq r | Just x' <- maybeInvertCmmExpr x -> x'
MO_U_Gt r | isComparisonExpr x -> x
MO_S_Gt r | isComparisonExpr x -> x
MO_U_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth)
MO_S_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth)
MO_U_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth)
MO_S_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth)
MO_U_Le r | Just x' <- maybeInvertCmmExpr x -> x'
MO_S_Le r | Just x' <- maybeInvertCmmExpr x -> x'
other -> CmmMachOp mop args
cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))]
= case mop of
MO_Mul r -> x
MO_S_Quot r -> x
MO_U_Quot r -> x
MO_S_Rem r -> CmmLit (CmmInt 0 rep)
MO_U_Rem r -> CmmLit (CmmInt 0 rep)
MO_Ne r | Just x' <- maybeInvertCmmExpr x -> x'
MO_Eq r | isComparisonExpr x -> x
MO_U_Lt r | Just x' <- maybeInvertCmmExpr x -> x'
MO_S_Lt r | Just x' <- maybeInvertCmmExpr x -> x'
MO_U_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth)
MO_S_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth)
MO_U_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth)
MO_S_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth)
MO_U_Ge r | isComparisonExpr x -> x
MO_S_Ge r | isComparisonExpr x -> x
other -> CmmMachOp mop args
cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt n _))]
= case mop of
MO_Mul rep
| Just p <- exactLog2 n ->
CmmMachOp (MO_Shl rep) [x, CmmLit (CmmInt p rep)]
MO_U_Quot rep
| Just p <- exactLog2 n ->
CmmMachOp (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)]
MO_S_Quot rep
| Just p <- exactLog2 n,
CmmReg _ <- x ->
let
bits = fromIntegral (widthInBits rep) 1
shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep
x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)]
x2 = if p == 1 then x1 else
CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n1) rep)]
x3 = CmmMachOp (MO_Add rep) [x, x2]
in
CmmMachOp (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)]
other
-> unchanged
where
unchanged = CmmMachOp mop args
cmmMachOpFold mop args = CmmMachOp mop args
exactLog2 :: Integer -> Maybe Integer
exactLog2 x_
= if (x_ <= 0 || x_ >= 2147483648) then
Nothing
else
case iUnbox (fromInteger x_) of { x ->
if (x `bitAndFastInt` negateFastInt x) /=# x then
Nothing
else
Just (toInteger (iBox (pow2 x)))
}
where
pow2 x | x ==# _ILIT(1) = _ILIT(0)
| otherwise = _ILIT(1) +# pow2 (x `shiftR_FastInt` _ILIT(1))
cmmLoopifyForC :: RawCmmTop -> RawCmmTop
cmmLoopifyForC p@(CmmProc info entry_lbl []
(ListGraph blocks@(BasicBlock top_id _ : _)))
| null info = p
| otherwise =
CmmProc info entry_lbl [] (ListGraph blocks')
where blocks' = [ BasicBlock id (map do_stmt stmts)
| BasicBlock id stmts <- blocks ]
do_stmt (CmmJump (CmmLit (CmmLabel lbl)) _) | lbl == jump_lbl
= CmmBranch top_id
do_stmt stmt = stmt
jump_lbl | tablesNextToCode = entryLblToInfoLbl entry_lbl
| otherwise = entry_lbl
cmmLoopifyForC top = top
isLit (CmmLit _) = True
isLit _ = False
isComparisonExpr :: CmmExpr -> Bool
isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
isComparisonExpr _other = False
isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True
isPicReg _ = False