From 9ce44336ce8344ea640fdb88e47b13fd4a249ddd Mon Sep 17 00:00:00 2001
From: meooow25 <soumiksarkar.3120@gmail.com>
Date: Sat, 11 Mar 2023 01:23:52 +0530
Subject: [PATCH] Improve the situation with the stimes cycle
Currently the Semigroup stimes cycle is resolved in GHC.Base by
importing stimes implementations from a hs-boot file. Resolve the cycle
using hs-boot files for required classes (Num, Integral) instead. Now
stimes can be defined directly in GHC.Base, making inlining and
specialization possible.
This leads to some new boot files for `GHC.Num` and `GHC.Real`, the
methods for those are only used to implement `stimes` so it doesn't
appear that these boot files will introduce any new performance traps.
Metric Decrease:
T13386
T8095
Metric Increase:
T13253
T13386
T18698a
T18698b
T19695
T8095
---
libraries/base/Data/Semigroup/Internal.hs | 34 +-------
.../base/Data/Semigroup/Internal.hs-boot | 13 ----
libraries/base/GHC/Base.hs | 78 ++++++++++++++++---
libraries/base/GHC/Base.hs-boot | 9 ---
libraries/base/GHC/Enum.hs-boot | 10 +++
libraries/base/GHC/Num.hs-boot | 24 ++++++
libraries/base/GHC/Real.hs-boot | 33 +++++++-
libraries/base/changelog.md | 1 +
.../tests/simplCore/should_compile/T23074.hs | 14 ++++
.../simplCore/should_compile/T23074.stderr | 8 ++
.../tests/simplCore/should_compile/all.T | 2 +-
11 files changed, 157 insertions(+), 69 deletions(-)
delete mode 100644 libraries/base/Data/Semigroup/Internal.hs-boot
delete mode 100644 libraries/base/GHC/Base.hs-boot
create mode 100644 libraries/base/GHC/Enum.hs-boot
create mode 100644 libraries/base/GHC/Num.hs-boot
create mode 100644 testsuite/tests/simplCore/should_compile/T23074.hs
create mode 100644 testsuite/tests/simplCore/should_compile/T23074.stderr
diff --git a/libraries/base/Data/Semigroup/Internal.hs b/libraries/base/Data/Semigroup/Internal.hs
index e6b79d607969..1e5b3dc828fc 100644
--- a/libraries/base/Data/Semigroup/Internal.hs
+++ b/libraries/base/Data/Semigroup/Internal.hs
@@ -14,8 +14,7 @@
-- 'Semigroup' class some.
--
-- This module exists mostly to simplify or workaround import-graph
--- issues; there is also a .hs-boot file to allow "GHC.Base" and other
--- modules to import method default implementations for 'stimes'
+-- issues.
--
-- @since 4.11.0.0
module Data.Semigroup.Internal where
@@ -67,43 +66,12 @@ stimesMonoid n x0 = case compare n 0 of
| y == 1 = x `mappend` z
| otherwise = g (x `mappend` x) (y `quot` 2) (x `mappend` z) -- See Note [Half of y - 1]
--- this is used by the class definition in GHC.Base;
--- it lives here to avoid cycles
-stimesDefault :: (Integral b, Semigroup a) => b -> a -> a
-stimesDefault y0 x0
- | y0 <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected"
- | otherwise = f x0 y0
- where
- f x y
- | even y = f (x <> x) (y `quot` 2)
- | y == 1 = x
- | otherwise = g (x <> x) (y `quot` 2) x -- See Note [Half of y - 1]
- g x y z
- | even y = g (x <> x) (y `quot` 2) z
- | y == 1 = x <> z
- | otherwise = g (x <> x) (y `quot` 2) (x <> z) -- See Note [Half of y - 1]
-
{- Note [Half of y - 1]
~~~~~~~~~~~~~~~~~~~~~
Since y is guaranteed to be odd and positive here,
half of y - 1 can be computed as y `quot` 2, optimising subtraction away.
-}
-stimesMaybe :: (Integral b, Semigroup a) => b -> Maybe a -> Maybe a
-stimesMaybe _ Nothing = Nothing
-stimesMaybe n (Just a) = case compare n 0 of
- LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier"
- EQ -> Nothing
- GT -> Just (stimes n a)
-
-stimesList :: Integral b => b -> [a] -> [a]
-stimesList n x
- | n < 0 = errorWithoutStackTrace "stimes: [], negative multiplier"
- | otherwise = rep n
- where
- rep 0 = []
- rep i = x ++ rep (i - 1)
-
-- | The dual of a 'Monoid', obtained by swapping the arguments of 'mappend'.
--
-- >>> getDual (mappend (Dual "Hello") (Dual "World"))
diff --git a/libraries/base/Data/Semigroup/Internal.hs-boot b/libraries/base/Data/Semigroup/Internal.hs-boot
deleted file mode 100644
index b433772739fc..000000000000
--- a/libraries/base/Data/Semigroup/Internal.hs-boot
+++ /dev/null
@@ -1,13 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Data.Semigroup.Internal where
-
-import {-# SOURCE #-} GHC.Real (Integral)
-import {-# SOURCE #-} GHC.Base (Semigroup,Monoid,Maybe)
-import GHC.Num.Integer () -- See Note [Depend on GHC.Num.Integer] in GHC.Base
-
-stimesIdempotentMonoid :: (Integral b, Monoid a) => b -> a -> a
-
-stimesDefault :: (Integral b, Semigroup a) => b -> a -> a
-stimesMaybe :: (Integral b, Semigroup a) => b -> Maybe a -> Maybe a
-stimesList :: Integral b => b -> [a] -> [a]
diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs
index d2f1cf4728a0..0583e5b40d93 100644
--- a/libraries/base/GHC/Base.hs
+++ b/libraries/base/GHC/Base.hs
@@ -127,13 +127,9 @@ import {-# SOURCE #-} GHC.IO (mkUserError, mplusIO)
import GHC.Tuple (Solo (MkSolo)) -- Note [Depend on GHC.Tuple]
import GHC.Num.Integer () -- Note [Depend on GHC.Num.Integer]
--- for 'class Semigroup'
-import {-# SOURCE #-} GHC.Real (Integral)
-import {-# SOURCE #-} Data.Semigroup.Internal ( stimesDefault
- , stimesMaybe
- , stimesList
- , stimesIdempotentMonoid
- )
+-- See Note [Semigroup stimes cycle]
+import {-# SOURCE #-} GHC.Num (Num (..))
+import {-# SOURCE #-} GHC.Real (Integral (..))
-- $setup
-- >>> import GHC.Num
@@ -181,6 +177,38 @@ GHC.Tuple, so we use the same rule as for Integer --- see Note [Depend on
GHC.Num.Integer] --- to explain this to the build system. We make GHC.Base
depend on GHC.Tuple, and everything else depends on GHC.Base or Prelude.
+
+Note [Semigroup stimes cycle]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Semigroup is defined in this module, GHC.Base, with the method
+stimes :: (Semigroup a, Integral b) => b -> a -> a
+
+This presents a problem.
+* We use Integral methods (quot, rem) and Num methods (-) in stimes definitions
+ in this module. Num is a superclass of Integral.
+* Num is defined in GHC.Num, which imports GHC.Base.
+* Enum is defined in GHC.Enum, which imports GHC.Base and GHC.Num. Enum is a
+ superclass of Integral. We don't use any Enum methods here, but it is relevant
+ (read on).
+* Integral is defined in GHC.Real, which imports GHC.Base, GHC.Num, and
+ GHC.Enum.
+
+We resolve this web of dependencies with hs-boot files. The rules
+https://ghc.gitlab.haskell.org/ghc/doc/users_guide/separate_compilation.html#how-to-compile-mutually-recursive-modules
+require us to put either the full declarations or only the instance head for
+classes in a hs-boot file.
+So we put the full class decls for Num and Integral in Num.hs-boot and
+Real.hs-boot respectively. This also forces us to have an Enum.hs-boot.
+
+An obvious alternative is to move the class decls for Num, Enum, Real, and
+Integral here. We don't do that because we would then need to move all the
+instances (for Int, Word, Integer, etc.) here as well, or leave those instances
+as orphans, which is generally bad.
+
+We previously resolved this problem in a different way, with an hs-boot for
+Semigroup.Internal that provided stimes implementations. This made them
+impossible to inline or specialize when used in this module. We no longer have
+that problem because we only import classes and not implementations.
-}
#if 0
@@ -282,10 +310,26 @@ class Semigroup a where
-- >>> stimes 4 [1]
-- [1,1,1,1]
stimes :: Integral b => b -> a -> a
- stimes = stimesDefault
+ stimes y0 x0
+ | y0 <= 0 = errorWithoutStackTrace "stimes: positive multiplier expected"
+ | otherwise = f x0 y0
+ where
+ f x y
+ | y `rem` 2 == 0 = f (x <> x) (y `quot` 2)
+ | y == 1 = x
+ | otherwise = g (x <> x) (y `quot` 2) x -- See Note [Half of y - 1]
+ g x y z
+ | y `rem` 2 == 0 = g (x <> x) (y `quot` 2) z
+ | y == 1 = x <> z
+ | otherwise = g (x <> x) (y `quot` 2) (x <> z) -- See Note [Half of y - 1]
{-# MINIMAL (<>) | sconcat #-}
+{- Note [Half of y - 1]
+ ~~~~~~~~~~~~~~~~~~~~~
+ Since y is guaranteed to be odd and positive here,
+ half of y - 1 can be computed as y `quot` 2, optimising subtraction away.
+-}
-- | The class of monoids (types with an associative binary operation that
-- has an identity). Instances should satisfy the following:
@@ -351,7 +395,12 @@ instance Semigroup [a] where
(<>) = (++)
{-# INLINE (<>) #-}
- stimes = stimesList
+ stimes n x
+ | n < 0 = errorWithoutStackTrace "stimes: [], negative multiplier"
+ | otherwise = rep n
+ where
+ rep 0 = []
+ rep i = x ++ rep (i - 1)
-- | @since 2.01
instance Monoid [a] where
@@ -471,7 +520,10 @@ instance Semigroup Ordering where
EQ <> y = y
GT <> _ = GT
- stimes = stimesIdempotentMonoid
+ stimes n x = case compare n 0 of
+ LT -> errorWithoutStackTrace "stimes: Ordering, negative multiplier"
+ EQ -> EQ
+ GT -> x
-- lexicographical ordering
-- | @since 2.01
@@ -484,7 +536,11 @@ instance Semigroup a => Semigroup (Maybe a) where
a <> Nothing = a
Just a <> Just b = Just (a <> b)
- stimes = stimesMaybe
+ stimes _ Nothing = Nothing
+ stimes n (Just a) = case compare n 0 of
+ LT -> errorWithoutStackTrace "stimes: Maybe, negative multiplier"
+ EQ -> Nothing
+ GT -> Just (stimes n a)
-- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to
-- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be
diff --git a/libraries/base/GHC/Base.hs-boot b/libraries/base/GHC/Base.hs-boot
deleted file mode 100644
index 64e636552543..000000000000
--- a/libraries/base/GHC/Base.hs-boot
+++ /dev/null
@@ -1,9 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module GHC.Base (Maybe, Semigroup, Monoid) where
-
-import GHC.Maybe (Maybe)
-import GHC.Types ()
-
-class Semigroup a
-class Monoid a
diff --git a/libraries/base/GHC/Enum.hs-boot b/libraries/base/GHC/Enum.hs-boot
new file mode 100644
index 000000000000..6854d0fc44d7
--- /dev/null
+++ b/libraries/base/GHC/Enum.hs-boot
@@ -0,0 +1,10 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.Enum (Enum) where
+
+-- For why this file exists
+-- See Note [Semigroup stimes cycle] in GHC.Base
+
+import GHC.Types ()
+
+class Enum a
diff --git a/libraries/base/GHC/Num.hs-boot b/libraries/base/GHC/Num.hs-boot
new file mode 100644
index 000000000000..2a051ee73b15
--- /dev/null
+++ b/libraries/base/GHC/Num.hs-boot
@@ -0,0 +1,24 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module GHC.Num (Num (..)) where
+
+-- For why this file exists
+-- See Note [Semigroup stimes cycle] in GHC.Base
+
+import GHC.Num.Integer (Integer)
+import GHC.Types ()
+
+infixl 7 *
+infixl 6 +, -
+
+class Num a where
+ {-# MINIMAL (+), (*), abs, signum, fromInteger, (negate | (-)) #-}
+
+ (+), (-), (*) :: a -> a -> a
+ negate :: a -> a
+ abs :: a -> a
+ signum :: a -> a
+ fromInteger :: Integer -> a
+
+ x - y = x + negate y
+ negate x = 0 - x
diff --git a/libraries/base/GHC/Real.hs-boot b/libraries/base/GHC/Real.hs-boot
index b462c1c2995c..ea27699ad387 100644
--- a/libraries/base/GHC/Real.hs-boot
+++ b/libraries/base/GHC/Real.hs-boot
@@ -1,7 +1,36 @@
{-# LANGUAGE NoImplicitPrelude #-}
-module GHC.Real where
+module GHC.Real (Integral (..)) where
+-- For why this file exists
+-- See Note [Semigroup stimes cycle] in GHC.Base
+
+import GHC.Classes (Ord)
+import GHC.Num.Integer (Integer)
import GHC.Types ()
-class Integral a
+import {-# SOURCE #-} GHC.Num (Num)
+import {-# SOURCE #-} GHC.Enum (Enum)
+
+data Ratio a
+type Rational = Ratio Integer
+
+class (Num a, Ord a) => Real a where
+ toRational :: a -> Rational
+
+class (Real a, Enum a) => Integral a where
+ quot :: a -> a -> a
+ rem :: a -> a -> a
+ div :: a -> a -> a
+ mod :: a -> a -> a
+ quotRem :: a -> a -> (a,a)
+ divMod :: a -> a -> (a,a)
+ toInteger :: a -> Integer
+
+ n `quot` d = q where (q,_) = quotRem n d
+ n `rem` d = r where (_,r) = quotRem n d
+ n `div` d = q where (q,_) = divMod n d
+ n `mod` d = r where (_,r) = divMod n d
+
+ divMod n d = if signum r == negate (signum d) then (q-1, r+d) else qr
+ where qr@(q,r) = quotRem n d
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index b39988105021..bb608a641b0d 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -33,6 +33,7 @@
* Implement `GHC.IORef.atomicSwapIORef` via a new dedicated primop `atomicSwapMutVar#` ([CLC proposal #139](https://github.com/haskell/core-libraries-committee/issues/139))
* Change codebuffers to use an unboxed implementation, while providing a compatibility layer using pattern synonyms. ([CLC proposal #134](https://github.com/haskell/core-libraries-committee/issues/134))
* Add nominal role annotations to SNat/SSymbol/SChar ([CLC proposal #170](https://github.com/haskell/core-libraries-committee/issues/170))
+ * Make `Semigroup`'s `stimes` specializable. ([CLC proposal #8](https://github.com/haskell/core-libraries-committee/issues/8))
## 4.18.0.0 *March 2023*
* Shipped with GHC 9.6.1
diff --git a/testsuite/tests/simplCore/should_compile/T23074.hs b/testsuite/tests/simplCore/should_compile/T23074.hs
new file mode 100644
index 000000000000..b5d8bf8ca4fc
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T23074.hs
@@ -0,0 +1,14 @@
+module T23074 where
+
+import Data.Semigroup
+
+-- Test that stimes for SumInt is specialized
+
+newtype SumInt = SumInt Int
+
+instance Semigroup SumInt where
+ SumInt x <> SumInt y = SumInt (x + y)
+
+
+foo :: Int -> SumInt -> SumInt
+foo = stimes
diff --git a/testsuite/tests/simplCore/should_compile/T23074.stderr b/testsuite/tests/simplCore/should_compile/T23074.stderr
new file mode 100644
index 000000000000..297edf9da89b
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T23074.stderr
@@ -0,0 +1,8 @@
+
+==================== Tidy Core rules ====================
+"SPEC $cstimes @Int"
+ forall ($dIntegral :: Integral Int).
+ $fSemigroupSumInt_$cstimes @Int $dIntegral
+ = foo
+
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index e8ebc39ca3a7..c4ff3222a9f4 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -484,8 +484,8 @@ test('T23307a', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppres
test('T23307b', normal, compile, ['-O'])
test('T23307c', normal, compile, ['-O'])
test('T23426', normal, compile, ['-O'])
-
test('T23491a', [extra_files(['T23491.hs']), grep_errmsg(r'Float out')], multimod_compile, ['T23491', '-ffull-laziness -ddump-full-laziness'])
test('T23491b', [extra_files(['T23491.hs']), grep_errmsg(r'Float inwards')], multimod_compile, ['T23491', '-ffloat-in -ddump-float-in'])
test('T23491c', [extra_files(['T23491.hs']), grep_errmsg(r'Liberate case')], multimod_compile, ['T23491', '-fliberate-case -ddump-liberate-case'])
test('T23491d', [extra_files(['T23491.hs']), grep_errmsg(r'Static argument')], multimod_compile, ['T23491', '-fstatic-argument-transformation -ddump-static-argument-transformation'])
+test('T23074', normal, compile, ['-O -ddump-rules'])
--
GitLab