X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmmOpt.hs;h=b96aa4aa8910ec70a2916b6644a825414911bcb5;hp=eba96531f3253131c153ee468b0c8baa7324f14f;hb=ae72991e2f0343c075a30c0a5a7d4ac18e9ef500;hpb=d5c5c4eb1d9f6d382d3ef1a12be284a411451788

diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index eba9653..b96aa4a 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -1,3 +1,10 @@
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 -----------------------------------------------------------------------------
 --
 -- Cmm optimisation
@@ -15,10 +22,10 @@ module CmmOpt (
 #include "HsVersions.h"
 
 import Cmm
+import CmmExpr
 import CmmUtils
 import CLabel
 import MachOp
-import SMRep
 import StaticFlags
 
 import UniqFM
@@ -46,6 +53,10 @@ once.  It works as follows:
 	- if we reach the statement that uses it, inline the rhs
 	  and delete the original assignment.
 
+[N.B. In the Quick C-- compiler, this optimization is achieved by a
+ combination of two dataflow passes: forward substitution (peephole
+ optimization) and dead-assignment elimination.  ---NR]
+
 Possible generalisations: here is an example from factorial
 
 Fac_zdwfac_entry:
@@ -79,21 +90,23 @@ To inline _smi:
      its occurrences.
 -}
 
+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 
-	blockUses (BasicBlock _ stmts)
-	 = foldr (plusUFM_C (+)) emptyUFM (map getStmtUses stmts)
-
-	uses = foldr (plusUFM_C (+)) emptyUFM (map blockUses blocks)
-
-	do_inline (BasicBlock id stmts)
-	 = BasicBlock id (cmmMiniInlineStmts uses stmts)
-
+  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)
+cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _ _)) expr) : stmts)
+        -- not used at all: just discard this assignment
+  | Nothing <- lookupUFM uses u
+  = cmmMiniInlineStmts uses stmts
+
+        -- used once: try to inline at the use site
   | Just 1 <- lookupUFM uses u,
     Just stmts' <- lookForInline u expr stmts
   = 
@@ -109,9 +122,9 @@ cmmMiniInlineStmts uses (stmt:stmts)
 -- Try to inline a temporary assignment.  We can skip over assignments to
 -- other tempoararies, because we know that expressions aren't side-effecting
 -- and temporaries are single-assignment.
-lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _)) rhs) : rest)
+lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _ _)) rhs) : rest)
   | u /= u' 
-  = case lookupUFM (getExprUses rhs) u of
+  = case lookupUFM (countUses rhs) u of
 	Just 1 -> Just (inlineStmt u expr stmt : rest)
 	_other -> case lookForInline u expr rest of
 		     Nothing    -> Nothing
@@ -120,8 +133,10 @@ lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _)) rhs) : rest)
 lookForInline u expr (CmmNop : rest)
   = lookForInline u expr rest
 
+lookForInline _ _ [] = Nothing
+
 lookForInline u expr (stmt:stmts)
-  = case lookupUFM (getStmtUses stmt) u of
+  = case lookupUFM (countUses stmt) u of
 	Just 1 | ok_to_inline -> Just (inlineStmt u expr stmt : stmts)
 	_other -> Nothing
   where
@@ -134,36 +149,12 @@ lookForInline u expr (stmt:stmts)
 		     CmmCall{} -> hasNoGlobalRegs expr
 		     _ -> True
 
--- -----------------------------------------------------------------------------
--- Boring Cmm traversals for collecting usage info and substitutions.
-
-getStmtUses :: CmmStmt -> UniqFM Int
-getStmtUses (CmmAssign _ e) = getExprUses e
-getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2)
-getStmtUses (CmmCall target _ es _)
-   = plusUFM_C (+) (uses target) (getExprsUses (map fst es))
-   where uses (CmmForeignCall e _) = getExprUses e
-	 uses _ = emptyUFM
-getStmtUses (CmmCondBranch e _) = getExprUses e
-getStmtUses (CmmSwitch e _) = getExprUses e
-getStmtUses (CmmJump e _) = getExprUses e
-getStmtUses _ = emptyUFM
-
-getExprUses :: CmmExpr -> UniqFM Int
-getExprUses (CmmReg (CmmLocal (LocalReg u _))) = unitUFM u 1
-getExprUses (CmmRegOff (CmmLocal (LocalReg u _)) _) = unitUFM u 1
-getExprUses (CmmLoad e _) = getExprUses e
-getExprUses (CmmMachOp _ es) = getExprsUses es
-getExprUses _other = emptyUFM
-
-getExprsUses es = foldr (plusUFM_C (+)) emptyUFM (map getExprUses es)
-
 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 vols)
-   = CmmCall (infn target) regs es' vols
-   where infn (CmmForeignCall fn cconv) = CmmForeignCall fn cconv
+inlineStmt u a (CmmCall target regs es srt ret)
+   = CmmCall (infn target) regs es' srt ret
+   where infn (CmmCallee fn cconv) = CmmCallee fn cconv
 	 infn (CmmPrim p) = CmmPrim p
 	 es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ]
 inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d
@@ -172,10 +163,10 @@ 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' _)))
+inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _ _)))
   | u == u' = a
   | otherwise = e
-inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off)
+inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep _)) off)
   | u == u' = CmmMachOp (MO_Add rep) [a, CmmLit (CmmInt (fromIntegral off) rep)]
   | otherwise = e
 inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep
@@ -339,6 +330,41 @@ cmmMachOpFold (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)]
 cmmMachOpFold (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
   = CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i))))
 
+
+-- Comparison of literal with narrowed/widened operand: perform
+-- the comparison at a different width, as long as the literal is
+-- within range.
+
+#if i386_TARGET_ARCH || x86_64_TARGET_ARCH
+-- powerPC NCG has a TODO for I8/I16 comparisons, so don't try
+
+cmmMachOpFold cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
+  | Just (rep, narrow) <- maybe_conversion conv,
+    Just narrow_cmp <- maybe_comparison cmp rep,
+    let narrow_i = narrow rep i,
+    narrow_i == i
+  = cmmMachOpFold narrow_cmp [x, CmmLit (CmmInt narrow_i rep)]
+ where
+    maybe_conversion (MO_U_Conv from _) = Just (from, narrowU)
+    maybe_conversion (MO_S_Conv from _)
+        | not (isFloatingRep from) = Just (from, narrowS)
+        -- don't attempt to apply this optimisation when the source
+        -- is a float; see #1916
+    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_S_Gt _) rep = Just (MO_S_Gt rep)
+    maybe_comparison (MO_S_Ge _) rep = Just (MO_S_Ge rep)
+    maybe_comparison (MO_S_Lt _) rep = Just (MO_S_Lt rep)
+    maybe_comparison (MO_S_Le _) rep = Just (MO_S_Le rep)
+    maybe_comparison (MO_Eq   _) rep = Just (MO_Eq   rep)
+    maybe_comparison _ _ = Nothing
+
+#endif
+
 -- We can often do something with constants of 0 and 1 ...
 
 cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 0 _))]
@@ -353,15 +379,15 @@ cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 0 _))]
     	MO_S_Shr r -> x
     	MO_U_Shr r -> x
         MO_Ne    r | isComparisonExpr x -> x
-	MO_Eq    r | Just x' <- maybeInvertConditionalExpr 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 wordRep)
 	MO_S_Lt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
 	MO_U_Ge  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
 	MO_S_Ge  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
-	MO_U_Le  r | Just x' <- maybeInvertConditionalExpr x -> x'
-	MO_S_Le  r | Just x' <- maybeInvertConditionalExpr x -> x'
+	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))]
@@ -371,10 +397,10 @@ cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))]
     	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' <- maybeInvertConditionalExpr x -> x'
+        MO_Ne    r | Just x' <- maybeInvertCmmExpr x -> x'
 	MO_Eq    r | isComparisonExpr x -> x
-	MO_U_Lt  r | Just x' <- maybeInvertConditionalExpr x -> x'
-	MO_S_Lt  r | Just x' <- maybeInvertConditionalExpr 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 wordRep)
 	MO_S_Gt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
 	MO_U_Le  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
@@ -499,12 +525,12 @@ narrowS _ _ = panic "narrowTo"
   except factorial, but what the hell.
 -}
 
-cmmLoopifyForC :: CmmTop -> CmmTop
-cmmLoopifyForC p@(CmmProc info entry_lbl [] blocks@(BasicBlock top_id _ : _))
+cmmLoopifyForC :: RawCmmTop -> RawCmmTop
+cmmLoopifyForC p@(CmmProc info entry_lbl [] (ListGraph blocks@(BasicBlock top_id _ : _)))
   | null info = p  -- only if there's an info table, ignore case alts
   | otherwise =  
 --  pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $
-  CmmProc info entry_lbl [] blocks' 
+  CmmProc info entry_lbl [] (ListGraph blocks')
   where blocks' = [ BasicBlock id (map do_stmt stmts)
 		  | BasicBlock id stmts <- blocks ]
 
@@ -527,10 +553,8 @@ isComparisonExpr :: CmmExpr -> Bool
 isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
 isComparisonExpr _other 	    = False
 
-maybeInvertConditionalExpr :: CmmExpr -> Maybe CmmExpr
-maybeInvertConditionalExpr (CmmMachOp op args) 
-  | Just op' <- maybeInvertComparison op = Just (CmmMachOp op' args)
-maybeInvertConditionalExpr _ = Nothing
-
 isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True
 isPicReg _ = False
+
+_unused :: FS.FastString -- stops a warning
+_unused = undefined