[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 2 commits: Add missing int64/word64-to-double/float rules (#23907)

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Fri Sep 15 12:37:57 UTC 2023



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
d1adc7ae by Sylvain Henry at 2023-09-15T08:37:43-04:00
Add missing int64/word64-to-double/float rules (#23907)

CLC proposal: https://github.com/haskell/core-libraries-committee/issues/203

- - - - -
807dfb4c by Mario Blažević at 2023-09-15T08:37:48-04:00
Fix and test TH pretty-printing of type operator role declarations

This commit fixes and tests `Language.Haskell.TH.Ppr.pprint` so that it
correctly pretty-prints `type role` declarations for operator names.

Fixes #23954

- - - - -


9 changed files:

- libraries/base/GHC/Float.hs
- libraries/base/changelog.md
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- + testsuite/tests/numeric/should_compile/T23907.hs
- + testsuite/tests/numeric/should_compile/T23907.stderr
- testsuite/tests/numeric/should_compile/all.T
- + testsuite/tests/th/T23954.hs
- + testsuite/tests/th/T23954.stdout
- testsuite/tests/th/all.T


Changes:

=====================================
libraries/base/GHC/Float.hs
=====================================
@@ -1810,3 +1810,22 @@ foreign import prim "stg_doubleToWord64zh"
 
 "Word# -> Natural -> Double#"
   forall x. naturalToDouble# (NS x) = word2Double# x #-}
+
+-- We don't have word64ToFloat/word64ToDouble primops (#23908), only
+-- word2Float/word2Double, so we can only perform these transformations when
+-- word-size is 64-bit.
+#if WORD_SIZE_IN_BITS == 64
+{-# RULES
+
+"Int64# -> Integer -> Float#"
+  forall x. integerToFloat# (integerFromInt64# x) = int2Float# (int64ToInt# x)
+
+"Int64# -> Integer -> Double#"
+  forall x. integerToDouble# (integerFromInt64# x) = int2Double# (int64ToInt# x)
+
+"Word64# -> Integer -> Float#"
+  forall x. integerToFloat# (integerFromWord64# x) = word2Float# (word64ToWord# x)
+
+"Word64# -> Integer -> Double#"
+  forall x. integerToDouble# (integerFromWord64# x) = word2Double# (word64ToWord# x) #-}
+#endif


=====================================
libraries/base/changelog.md
=====================================
@@ -4,6 +4,7 @@
   * Export `foldl'` from `Prelude` ([CLC proposal #167](https://github.com/haskell/core-libraries-committee/issues/167))
   * Add a `RULE` to `Prelude.lookup`, allowing it to participate in list fusion ([CLC proposal #174](https://github.com/haskell/core-libraries-committee/issues/175))
   * The `Enum Int64` and `Enum Word64` instances now use native operations on 32-bit platforms, increasing performance by up to 1.5x on i386 and up to 5.6x with the JavaScript backend. ([CLC proposal #187](https://github.com/haskell/core-libraries-committee/issues/187))
+  * Add rewrite rules for conversion between Int64/Word64 and Float/Double on 64-bit architectures ([CLC proposal #203](https://github.com/haskell/core-libraries-committee/issues/203)).
 
 ## 4.19.0.0 *TBA*
   * Add `{-# WARNING in "x-partial" #-}` to `Data.List.{head,tail}`.


=====================================
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
=====================================
@@ -456,7 +456,7 @@ ppr_dec _ (ClosedTypeFamilyD tfhead eqns)
     ppr_eqn (TySynEqn mb_bndrs lhs rhs)
       = ppr_bndrs mb_bndrs <+> ppr lhs <+> text "=" <+> ppr rhs
 ppr_dec _ (RoleAnnotD name roles)
-  = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)
+  = hsep [ text "type role", pprName' Applied name ] <+> hsep (map ppr roles)
 ppr_dec _ (StandaloneDerivD ds cxt ty)
   = hsep [ text "deriving"
          , maybe empty ppr_deriv_strategy ds


=====================================
testsuite/tests/numeric/should_compile/T23907.hs
=====================================
@@ -0,0 +1,67 @@
+module T23907 (loop) where
+
+import Data.Word
+import Data.Bits
+
+{-# NOINLINE loop #-}
+loop :: Int -> Double -> SMGen -> (Double, SMGen)
+loop 0 !a !s = (a, s)
+loop n !a !s = loop (n - 1) (a + b) t where (b, t) = nextDouble s
+
+mix64 :: Word64 -> Word64
+mix64 z0 =
+   -- MurmurHash3Mixer
+    let z1 = shiftXorMultiply 33 0xff51afd7ed558ccd z0
+        z2 = shiftXorMultiply 33 0xc4ceb9fe1a85ec53 z1
+        z3 = shiftXor 33 z2
+    in z3
+
+shiftXor :: Int -> Word64 -> Word64
+shiftXor n w = w `xor` (w `shiftR` n)
+
+shiftXorMultiply :: Int -> Word64 -> Word64 -> Word64
+shiftXorMultiply n k w = shiftXor n w * k
+
+nextWord64 :: SMGen -> (Word64, SMGen)
+nextWord64 (SMGen seed gamma) = (mix64 seed', SMGen seed' gamma)
+  where
+    seed' = seed + gamma
+
+nextDouble :: SMGen -> (Double, SMGen)
+nextDouble g = case nextWord64 g of
+    (w64, g') -> (fromIntegral (w64 `shiftR` 11) * doubleUlp, g')
+
+data SMGen = SMGen !Word64 !Word64 -- seed and gamma; gamma is odd
+
+mkSMGen :: Word64 -> SMGen
+mkSMGen s = SMGen (mix64 s) (mixGamma (s + goldenGamma))
+
+goldenGamma :: Word64
+goldenGamma = 0x9e3779b97f4a7c15
+
+floatUlp :: Float
+floatUlp =  1.0 / fromIntegral (1 `shiftL` 24 :: Word32)
+
+doubleUlp :: Double
+doubleUlp =  1.0 / fromIntegral (1 `shiftL` 53 :: Word64)
+
+mix64variant13 :: Word64 -> Word64
+mix64variant13 z0 =
+   -- Better Bit Mixing - Improving on MurmurHash3's 64-bit Finalizer
+   -- http://zimbry.blogspot.fi/2011/09/better-bit-mixing-improving-on.html
+   --
+   -- Stafford's Mix13
+    let z1 = shiftXorMultiply 30 0xbf58476d1ce4e5b9 z0 -- MurmurHash3 mix constants
+        z2 = shiftXorMultiply 27 0x94d049bb133111eb z1
+        z3 = shiftXor 31 z2
+    in z3
+
+mixGamma :: Word64 -> Word64
+mixGamma z0 =
+    let z1 = mix64variant13 z0 .|. 1             -- force to be odd
+        n  = popCount (z1 `xor` (z1 `shiftR` 1))
+    -- see: http://www.pcg-random.org/posts/bugs-in-splitmix.html
+    -- let's trust the text of the paper, not the code.
+    in if n >= 24
+        then z1
+        else z1 `xor` 0xaaaaaaaaaaaaaaaa


=====================================
testsuite/tests/numeric/should_compile/T23907.stderr
=====================================
@@ -0,0 +1,57 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 90, types: 62, coercions: 0, joins: 0/3}
+
+$WSMGen
+  = \ conrep conrep1 ->
+      case conrep of { W64# unbx ->
+      case conrep1 of { W64# unbx1 -> SMGen unbx unbx1 }
+      }
+
+Rec {
+$wloop
+  = \ ww ww1 ww2 ww3 ->
+      case ww of ds {
+        __DEFAULT ->
+          let { seed' = plusWord64# ww2 ww3 } in
+          let {
+            x#
+              = timesWord64#
+                  (xor64# seed' (uncheckedShiftRL64# seed' 33#))
+                  18397679294719823053#Word64 } in
+          let {
+            x#1
+              = timesWord64#
+                  (xor64# x# (uncheckedShiftRL64# x# 33#))
+                  14181476777654086739#Word64 } in
+          $wloop
+            (-# ds 1#)
+            (+##
+               ww1
+               (*##
+                  (word2Double#
+                     (word64ToWord#
+                        (uncheckedShiftRL64#
+                           (xor64# x#1 (uncheckedShiftRL64# x#1 33#)) 11#)))
+                  1.1102230246251565e-16##))
+            seed'
+            ww3;
+        0# -> (# ww1, ww2, ww3 #)
+      }
+end Rec }
+
+loop
+  = \ ds a s ->
+      case ds of { I# ww ->
+      case a of { D# ww1 ->
+      case s of { SMGen ww2 ww3 ->
+      case $wloop ww ww1 ww2 ww3 of { (# ww4, ww5, ww6 #) ->
+      (D# ww4, SMGen ww5 ww6)
+      }
+      }
+      }
+      }
+
+
+


=====================================
testsuite/tests/numeric/should_compile/all.T
=====================================
@@ -20,3 +20,4 @@ test('T20448', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-b
 test('T19641', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-binds -dsuppress-uniques'])
 test('T15547', normal, compile, ['-ddump-simpl -O -dsuppress-all -dno-typeable-binds -dsuppress-uniques'])
 test('T23019', normal, compile, ['-O'])
+test('T23907', [ when(wordsize(32), expect_broken(23908))], compile, ['-ddump-simpl -O2 -dsuppress-all -dno-typeable-binds -dsuppress-uniques'])


=====================================
testsuite/tests/th/T23954.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE Haskell2010, RoleAnnotations, TemplateHaskell, TypeOperators #-}
+
+import Language.Haskell.TH (runQ)
+import Language.Haskell.TH.Ppr (pprint)
+
+main =
+  runQ [d|
+         data a ## b
+         type role (##) nominal nominal
+       |]
+  >>= putStrLn . pprint


=====================================
testsuite/tests/th/T23954.stdout
=====================================
@@ -0,0 +1,2 @@
+data (##_0) a_1 b_2
+type role (##_0) nominal nominal
\ No newline at end of file


=====================================
testsuite/tests/th/all.T
=====================================
@@ -580,7 +580,6 @@ test('T22559a', normal, compile_fail, [''])
 test('T22559b', normal, compile_fail, [''])
 test('T22559c', normal, compile_fail, [''])
 test('T23525', normal, compile, [''])
-test('T23927', normal, compile_and_run, [''])
 test('CodeQ_HKD', normal, compile, [''])
 test('T23748', normal, compile, [''])
 test('T23796', normal, compile, [''])
@@ -588,3 +587,5 @@ test('T23829_timely', normal, compile, [''])
 test('T23829_tardy', normal, warn_and_run, [''])
 test('T23829_hasty', normal, compile_fail, [''])
 test('T23829_hasty_b', normal, compile_fail, [''])
+test('T23927', normal, compile_and_run, [''])
+test('T23954', normal, compile_and_run, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7be210dcac7c8855d76600e3a6afbde1c9461a83...807dfb4c859fb53f2c1ad2cebc47cd48963e8dd3

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7be210dcac7c8855d76600e3a6afbde1c9461a83...807dfb4c859fb53f2c1ad2cebc47cd48963e8dd3
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/20230915/d329bd1c/attachment-0001.html>


More information about the ghc-commits mailing list