[Git][ghc/ghc][master] Core: add absorb rules for binary or/and (#16351)

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
383af074 by Sylvain Henry at 2024-09-26T04:16:06-04:00
Core: add absorb rules for binary or/and (#16351)

Rules:
  x or (x and y) ==> x
  x and (x or y) ==> x

- - - - -


4 changed files:

- compiler/GHC/Core/Opt/ConstantFold.hs
- + testsuite/tests/codeGen/should_compile/T16351.hs
- + testsuite/tests/codeGen/should_compile/T16351.stderr
- testsuite/tests/codeGen/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/ConstantFold.hs
=====================================
@@ -3056,6 +3056,11 @@ andFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of
     -- (l1 or x) and (l2 or y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y)
     -- increase operation numbers
 
+    -- x and (y or ... or x or ... or z) ==> x
+    (x, is_or_list num_ops -> Just xs)
+      | any (cheapEqExpr x) xs
+      -> Just x
+
     _ -> Nothing
     where
       mkL = Lit . mkNumLiteral platform num_ops
@@ -3079,6 +3084,11 @@ orFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of
     -- (l1 and x) or (l2 and y) ==> (l1 and l2) or (x and l2) or (l1 and y) or (x and y)
     -- increase operation numbers
 
+    -- x or (y and ... and x and ... and z) ==> x
+    (x, is_and_list num_ops -> Just xs)
+      | any (cheapEqExpr x) xs
+      -> Just x
+
     _ -> Nothing
     where
       mkL = Lit . mkNumLiteral platform num_ops
@@ -3117,7 +3127,7 @@ is_op op e = case e of
  App (OpVal op') x | op == op' -> Just x
  _                             -> Nothing
 
-is_add, is_sub, is_mul, is_and, is_or, is_div :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)
+is_add, is_sub, is_mul, is_and, is_or, is_div :: NumOps -> CoreExpr -> Maybe (CoreArg, CoreArg)
 is_add num_ops e = is_binop (numAdd num_ops) e
 is_sub num_ops e = is_binop (numSub num_ops) e
 is_mul num_ops e = is_binop (numMul num_ops) e
@@ -3128,6 +3138,25 @@ is_div num_ops e = numDiv num_ops >>= \op -> is_binop op e
 is_neg :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr)
 is_neg num_ops e = numNeg num_ops >>= \op -> is_op op e
 
+-- Return a list of operands for a given operation.
+-- E.e. is_and_list (a and ... and z) => [a,...,z] for any nesting of the and
+-- operation
+is_list :: (CoreExpr -> Maybe (CoreArg,CoreArg)) -> CoreExpr -> Maybe [CoreArg]
+is_list f e_org = case f e_org of -- do we have the operator at all?
+  Just (a,b) -> Just (go [a,b])
+  Nothing    -> Nothing
+  where
+    go = \case
+      []     -> []
+      (e:es) -> case f e of
+        -- we can't split any more: add to the result list
+        Nothing    -> e : go es
+        Just (a,b) -> go (a:b:es)
+
+is_and_list, is_or_list :: NumOps -> CoreExpr -> Maybe [CoreArg]
+is_and_list ops = is_list (is_and ops)
+is_or_list  ops = is_list (is_or  ops)
+
 -- match operation with a literal (handles commutativity)
 is_lit_add, is_lit_mul, is_lit_and, is_lit_or :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)
 is_lit_add num_ops e = is_lit' is_add num_ops e


=====================================
testsuite/tests/codeGen/should_compile/T16351.hs
=====================================
@@ -0,0 +1,23 @@
+module T16351 where
+
+import Data.Bits
+
+x1,x2,x3,x4,x5,x6,x7,x8 :: Int -> Int -> Int
+
+x1 a b = a .&. (a .|. b)
+x2 a b = a .|. (a .&. b)
+x3 a b = a .&. (b .|. a)
+x4 a b = a .|. (b .&. a)
+x5 a b = (a .|. b) .&. a
+x6 a b = (a .&. b) .|. a
+x7 a b = (b .|. a) .&. a
+x8 a b = (b .&. a) .|. a
+
+-- add more nesting
+x10,x11,x12,x13,x14 :: Int -> Int -> Int -> Int
+
+x10 a b c = a .&. ((a .|. b) .|. c)
+x11 a b c = a .&. (c .|. (a .|. b))
+x12 a b c = a .&. (c .|. (b .|. a))
+x13 a b c = a .&. ((b .|. a) .|. c)
+x14 a b c = a .&. ((c .|. (b .|. a)) .|. c)


=====================================
testsuite/tests/codeGen/should_compile/T16351.stderr
=====================================
@@ -0,0 +1,42 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 63, types: 72, coercions: 0, joins: 0/0}
+
+x14
+  = \ a b c ->
+      case a of wild { I# x# ->
+      case c of { I# x#1 -> case b of { I# x#2 -> wild } }
+      }
+
+x13
+  = \ a b c ->
+      case a of wild { I# x# ->
+      case b of { I# x#1 -> case c of { I# y# -> wild } }
+      }
+
+x12 = x14
+
+x11 = x14
+
+x10 = x13
+
+x8 = \ a b -> case b of { I# x# -> a }
+
+x7 = x8
+
+x6
+  = \ a b -> case a of wild { I# x# -> case b of { I# y# -> wild } }
+
+x5 = x6
+
+x4 = x6
+
+x3 = x6
+
+x2 = x6
+
+x1 = x6
+
+
+


=====================================
testsuite/tests/codeGen/should_compile/all.T
=====================================
@@ -143,3 +143,5 @@ test('T25166', [req_cmm], makefile_test, [])
 
 # dump Core to ensure that d is defined as: d = D 10## RUBBISH(IntRep)
 test('T25177', normal, compile, ['-O2 -dno-typeable-binds -ddump-simpl -dsuppress-all -dsuppress-uniques -v0'])
+
+test('T16351', normal, compile, ['-O2 -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/383af0743a46e0961c342261f13a4527ae838873

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/383af0743a46e0961c342261f13a4527ae838873
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240926/573aafc3/attachment-0001.html>