[commit: ghc] wip/T9136: Work on smarter constant folding (115fd8b)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T9136
Link       : http://ghc.haskell.org/trac/ghc/changeset/115fd8b04364a962c348510b7c65c1e0d603ebf9/ghc

>---------------------------------------------------------------

commit 115fd8b04364a962c348510b7c65c1e0d603ebf9
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Fri May 23 15:35:44 2014 +0200

    Work on smarter constant folding
    
    Which finds constants further apart like in (x + 8) - 1 or
    (8 + x) + (y - 3). This is #9136.
    
    Currently it only works for + and may need more thought; I’m currently
    in a hurry...


>---------------------------------------------------------------

115fd8b04364a962c348510b7c65c1e0d603ebf9
 compiler/prelude/PrelRules.lhs | 43 +++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 42 insertions(+), 1 deletion(-)

diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index d2e648f..2bbf26a 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -83,9 +83,15 @@ primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ]
 
 -- Int operations
 primOpRules nm IntAddOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))
-                                               , identityDynFlags zeroi ]
+                                               , identityDynFlags zeroi
+                                               , assocBinaryLit IntAddOp (intOp2 (+))
+                                               , litsToRight IntAddOp
+                                               , treesToLeft IntAddOp
+                                               , litsGoUp IntAddOp
+                                               ]
 primOpRules nm IntSubOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))
                                                , rightIdentityDynFlags zeroi
+                                               , minusToPlus IntAddOp
                                                , equalArgs >> retLit zeroi ]
 primOpRules nm IntMulOp    = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))
                                                , zeroElem zeroi
@@ -678,6 +684,34 @@ binaryLit op = do
   [Lit l1, Lit l2] <- getArgs
   liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2)
 
+assocBinaryLit :: PrimOp -> (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr
+assocBinaryLit primop op = do
+  dflags <- getDynFlags
+  [(Var primop_id `App` t) `App` Lit l1, Lit l2] <- getArgs
+  matchPrimOpId primop primop_id
+  Just r <- return $ op dflags (convFloating dflags l1) (convFloating dflags l2)
+  return $ Var primop_id `App` t `App` r
+
+litsToRight :: PrimOp -> RuleM CoreExpr
+litsToRight op = do
+  [Lit l, t] <- getArgs
+  return $ Var (mkPrimOpId op) `App` t `App` Lit l
+
+treesToLeft :: PrimOp -> RuleM CoreExpr
+treesToLeft op = do
+  [t1, (Var primop_id `App` t2) `App` t3] <- getArgs
+  matchPrimOpId op primop_id
+  return $ Var (mkPrimOpId op) `App` (Var (mkPrimOpId op) `App` t1 `App` t2)
+                               `App` t3
+
+litsGoUp :: PrimOp -> RuleM CoreExpr
+litsGoUp op = do
+  [(Var primop_id `App` t1) `App` Lit l, t2] <- getArgs
+  matchPrimOpId op primop_id
+  return $ Var (mkPrimOpId op) `App` (Var (mkPrimOpId op) `App` t1 `App` t2)
+                               `App` Lit l
+
+
 binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr
 binaryCmpLit op = do
   dflags <- getDynFlags
@@ -734,6 +768,13 @@ equalArgs = do
 nonZeroLit :: Int -> RuleM ()
 nonZeroLit n = getLiteral n >>= guard . not . isZeroLit
 
+minusToPlus :: PrimOp -> RuleM CoreExpr
+minusToPlus op = do
+    [x, Lit (MachInt y)] <- getArgs
+    dflags <- getDynFlags
+    Just r <- return $ intResult dflags (-y)
+    return $ Var (mkPrimOpId op) `App` x `App` r
+
 -- When excess precision is not requested, cut down the precision of the
 -- Rational value to that of Float/Double. We confuse host architecture
 -- and target architecture here, but it's convenient (and wrong :-).