[Git][ghc/ghc][wip/backports-9.0] 2 commits: Bignum: match on small Integer/Natural

[Krzysztof Gogolewski]

Krzysztof Gogolewski pushed to branch wip/backports-9.0 at Glasgow Haskell Compiler / GHC


Commits:
a740aa0b by Sylvain Henry at 2020-10-12T15:10:13+02:00
Bignum: match on small Integer/Natural

Previously we only matched on *variables* whose unfoldings were a ConApp
of the form `IS lit#` or `NS lit##`. But we forgot to match on the
ConApp directly... As a consequence, constant folding only worked after
the FloatOut pass which creates bindings for most sub-expressions. With
this patch, matching on bignums works even with -O0 (see bignumMatch
test).

- - - - -
d09e7e41 by Sylvain Henry at 2020-10-12T15:10:30+02:00
Bignum: fix bigNatCompareWord# bug (#18813)

(cherry picked from commit 74ee1237bf243dd7d8b758a53695575c364c3088)

- - - - -


7 changed files:

- compiler/GHC/Core/SimpleOpt.hs
- libraries/ghc-bignum/src/GHC/Num/BigNat.hs
- + testsuite/tests/lib/integer/T18813.hs
- + testsuite/tests/lib/integer/T18813.stdout
- testsuite/tests/lib/integer/all.T
- + testsuite/tests/lib/integer/bignumMatch.hs
- + testsuite/tests/lib/integer/bignumMatch.stderr


Changes:

=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -1257,13 +1257,24 @@ exprIsLiteral_maybe env@(_, id_unf) e
          -> Just l
       Var v
          | Just rhs <- expandUnfolding_maybe (id_unf v)
-         , Just (_env,_fb,dc,_tys,[arg]) <- exprIsConApp_maybe env rhs
+         , Just b <- matchBignum env rhs
+         -> Just b
+      e
+         | Just b <- matchBignum env e
+         -> Just b
+
+         | otherwise
+         -> Nothing
+  where
+    matchBignum env e
+         | Just (_env,_fb,dc,_tys,[arg]) <- exprIsConApp_maybe env e
          , Just (LitNumber _ i) <- exprIsLiteral_maybe env arg
-         -> if
+         = if
             | dc == naturalNSDataCon -> Just (mkLitNatural i)
             | dc == integerISDataCon -> Just (mkLitInteger i)
             | otherwise              -> Nothing
-      _         -> Nothing
+         | otherwise
+         = Nothing
 
 {-
 Note [exprIsLambda_maybe]


=====================================
libraries/ghc-bignum/src/GHC/Num/BigNat.hs
=====================================
@@ -339,7 +339,7 @@ bigNatCompareWord# a b
    | bigNatIsZero a                   = cmpW# 0## b
    | isTrue# (wordArraySize# a ># 1#) = GT
    | True
-   = cmpW# (indexWordArray# a 1#) b
+   = cmpW# (indexWordArray# a 0#) b
 
 -- | Compare a BigNat and a Word
 bigNatCompareWord :: BigNat# -> Word -> Ordering


=====================================
testsuite/tests/lib/integer/T18813.hs
=====================================
@@ -0,0 +1,22 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE MagicHash    #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -O0 #-}
+
+import GHC.Exts
+import GHC.Num.BigNat  (bigNatCompareWord#, bigNatFromWord#)
+import GHC.Num.Integer (integerGcd)
+
+main :: IO ()
+main = do
+   let
+      x = noinline (14205695611797621937 :: Integer)
+      y = noinline (2 :: Word)
+   print (integerGcd x (toInteger y))
+   print (toInteger (gcd (fromInteger x) y :: Word))
+
+   let
+      x@(W# x#) = 1 :: Word
+      !x'       = bigNatFromWord# x#
+   print (bigNatCompareWord# x' x#)
+   print (compare x x)


=====================================
testsuite/tests/lib/integer/T18813.stdout
=====================================
@@ -0,0 +1,4 @@
+1
+1
+EQ
+EQ


=====================================
testsuite/tests/lib/integer/all.T
=====================================
@@ -10,6 +10,8 @@ test('gcdeInteger', normal, compile_and_run, [''])
 test('integerPowMod', [], compile_and_run, [''])
 test('integerGcdExt', [], compile_and_run, [''])
 test('integerRecipMod', [], compile_and_run, [''])
+test('bignumMatch', [], compile, [''])
+test('T18813', [], compile_and_run, [''])
 
 # skip ghci as it doesn't support unboxed tuples
 test('integerImportExport', [omit_ways(['ghci'])], compile_and_run, [''])


=====================================
testsuite/tests/lib/integer/bignumMatch.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE MagicHash #-}
+{-# OPTIONS_GHC -ddump-rule-firings -O0 -v0 #-}
+
+module Test where
+
+import GHC.Num.Integer
+
+foo :: Integer
+foo = IS 45# `integerAdd` (IS 0# `integerMul` IS 18#)


=====================================
testsuite/tests/lib/integer/bignumMatch.stderr
=====================================
@@ -0,0 +1,2 @@
+Rule fired: integerMul (BUILTIN)
+Rule fired: integerAdd (BUILTIN)



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/15c4eb1f774c15d653358e9dcae1e55791c4bbfd...d09e7e41cf79fe981a61eae46a93d8881859ff1f

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/15c4eb1f774c15d653358e9dcae1e55791c4bbfd...d09e7e41cf79fe981a61eae46a93d8881859ff1f
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/20201012/43714e32/attachment-0001.html>