Defer inlining of Ord methods
authorBen Gamari <ben@smart-cactus.org>
Wed, 30 Mar 2016 08:46:39 +0000 (10:46 +0200)
committerBen Gamari <ben@smart-cactus.org>
Wed, 30 Mar 2016 19:22:26 +0000 (21:22 +0200)
This performs the same refactoring performed in D1980 for Eq on Ord,
rewriting the class operations in terms of monomorphic helpers than can
be reliably matched in rewrite rules.

libraries/base/GHC/Int.hs
libraries/base/GHC/Word.hs
libraries/ghc-prim/GHC/Classes.hs

index 62a5a68..cad6607 100644 (file)
@@ -24,11 +24,11 @@ module GHC.Int (
         uncheckedIShiftL64#, uncheckedIShiftRA64#,
         -- * Equality operators
         -- | See GHC.Classes#matching_overloaded_methods_in_rules
-        eqInt, neInt,
-        eqInt8, neInt8,
-        eqInt16, neInt16,
-        eqInt32, neInt32,
-        eqInt64, neInt64
+        eqInt, neInt, gtInt, geInt, ltInt, leInt,
+        eqInt8, neInt8, gtInt8, geInt8, ltInt8, leInt8,
+        eqInt16, neInt16, gtInt16, geInt16, ltInt16, leInt16,
+        eqInt32, neInt32, gtInt32, geInt32, ltInt32, leInt32,
+        eqInt64, neInt64, gtInt64, geInt64, ltInt64, leInt64
     ) where
 
 import Data.Bits
@@ -54,7 +54,7 @@ import GHC.Show
 -- Int8 is represented in the same way as Int. Operations may assume
 -- and must ensure that it holds only values from its logical range.
 
-data {-# CTYPE "HsInt8" #-} Int8 = I8# Int# deriving (Ord)
+data {-# CTYPE "HsInt8" #-} Int8 = I8# Int#
 -- ^ 8-bit signed integer type
 
 -- See GHC.Classes#matching_overloaded_methods_in_rules
@@ -68,6 +68,22 @@ neInt8 (I8# x) (I8# y) = isTrue# (x /=# y)
 {-# INLINE [1] eqInt8 #-}
 {-# INLINE [1] neInt8 #-}
 
+instance Ord Int8 where
+    (<)  = ltInt8
+    (<=) = leInt8
+    (>=) = geInt8
+    (>)  = gtInt8
+
+{-# INLINE [1] gtInt8 #-}
+{-# INLINE [1] geInt8 #-}
+{-# INLINE [1] ltInt8 #-}
+{-# INLINE [1] leInt8 #-}
+gtInt8, geInt8, ltInt8, leInt8 :: Int8 -> Int8 -> Bool
+(I8# x) `gtInt8` (I8# y) = isTrue# (x >#  y)
+(I8# x) `geInt8` (I8# y) = isTrue# (x >=# y)
+(I8# x) `ltInt8` (I8# y) = isTrue# (x <#  y)
+(I8# x) `leInt8` (I8# y) = isTrue# (x <=# y)
+
 instance Show Int8 where
     showsPrec p x = showsPrec p (fromIntegral x :: Int)
 
@@ -226,7 +242,7 @@ instance FiniteBits Int8 where
 -- Int16 is represented in the same way as Int. Operations may assume
 -- and must ensure that it holds only values from its logical range.
 
-data {-# CTYPE "HsInt16" #-} Int16 = I16# Int# deriving (Ord)
+data {-# CTYPE "HsInt16" #-} Int16 = I16# Int#
 -- ^ 16-bit signed integer type
 
 -- See GHC.Classes#matching_overloaded_methods_in_rules
@@ -240,6 +256,22 @@ neInt16 (I16# x) (I16# y) = isTrue# (x /=# y)
 {-# INLINE [1] eqInt16 #-}
 {-# INLINE [1] neInt16 #-}
 
+instance Ord Int16 where
+    (<)  = ltInt16
+    (<=) = leInt16
+    (>=) = geInt16
+    (>)  = gtInt16
+
+{-# INLINE [1] gtInt16 #-}
+{-# INLINE [1] geInt16 #-}
+{-# INLINE [1] ltInt16 #-}
+{-# INLINE [1] leInt16 #-}
+gtInt16, geInt16, ltInt16, leInt16 :: Int16 -> Int16 -> Bool
+(I16# x) `gtInt16` (I16# y) = isTrue# (x >#  y)
+(I16# x) `geInt16` (I16# y) = isTrue# (x >=# y)
+(I16# x) `ltInt16` (I16# y) = isTrue# (x <#  y)
+(I16# x) `leInt16` (I16# y) = isTrue# (x <=# y)
+
 instance Show Int16 where
     showsPrec p x = showsPrec p (fromIntegral x :: Int)
 
@@ -403,7 +435,7 @@ instance FiniteBits Int16 where
 -- from its logical range.
 #endif
 
-data {-# CTYPE "HsInt32" #-} Int32 = I32# Int# deriving (Ord)
+data {-# CTYPE "HsInt32" #-} Int32 = I32# Int#
 -- ^ 32-bit signed integer type
 
 -- See GHC.Classes#matching_overloaded_methods_in_rules
@@ -417,6 +449,22 @@ neInt32 (I32# x) (I32# y) = isTrue# (x /=# y)
 {-# INLINE [1] eqInt32 #-}
 {-# INLINE [1] neInt32 #-}
 
+instance Ord Int32 where
+    (<)  = ltInt32
+    (<=) = leInt32
+    (>=) = geInt32
+    (>)  = gtInt32
+
+{-# INLINE [1] gtInt32 #-}
+{-# INLINE [1] geInt32 #-}
+{-# INLINE [1] ltInt32 #-}
+{-# INLINE [1] leInt32 #-}
+gtInt32, geInt32, ltInt32, leInt32 :: Int32 -> Int32 -> Bool
+(I32# x) `gtInt32` (I32# y) = isTrue# (x >#  y)
+(I32# x) `geInt32` (I32# y) = isTrue# (x >=# y)
+(I32# x) `ltInt32` (I32# y) = isTrue# (x <#  y)
+(I32# x) `leInt32` (I32# y) = isTrue# (x <=# y)
+
 instance Show Int32 where
     showsPrec p x = showsPrec p (fromIntegral x :: Int)
 
@@ -606,10 +654,20 @@ neInt64 (I64# x) (I64# y) = isTrue# (x `neInt64#` y)
 {-# INLINE [1] neInt64 #-}
 
 instance Ord Int64 where
-    (I64# x#) <  (I64# y#) = isTrue# (x# `ltInt64#` y#)
-    (I64# x#) <= (I64# y#) = isTrue# (x# `leInt64#` y#)
-    (I64# x#) >  (I64# y#) = isTrue# (x# `gtInt64#` y#)
-    (I64# x#) >= (I64# y#) = isTrue# (x# `geInt64#` y#)
+    (<)  = ltInt64
+    (<=) = leInt64
+    (>=) = geInt64
+    (>)  = gtInt64
+
+{-# INLINE [1] gtInt64 #-}
+{-# INLINE [1] geInt64 #-}
+{-# INLINE [1] ltInt64 #-}
+{-# INLINE [1] leInt64 #-}
+gtInt64, geInt64, ltInt64, leInt64 :: Int64 -> Int64 -> Bool
+(I64# x) `gtInt64` (I64# y) = isTrue# (x `gtInt64#` y)
+(I64# x) `geInt64` (I64# y) = isTrue# (x `geInt64#` y)
+(I64# x) `ltInt64` (I64# y) = isTrue# (x `ltInt64#` y)
+(I64# x) `leInt64` (I64# y) = isTrue# (x `leInt64#` y)
 
 instance Show Int64 where
     showsPrec p x = showsPrec p (toInteger x)
@@ -773,7 +831,7 @@ a `iShiftRA64#` b | isTrue# (b >=# 64#) = if isTrue# (a `ltInt64#` (intToInt64#
 -- Operations may assume and must ensure that it holds only values
 -- from its logical range.
 
-data {-# CTYPE "HsInt64" #-} Int64 = I64# Int# deriving (Ord)
+data {-# CTYPE "HsInt64" #-} Int64 = I64# Int#
 -- ^ 64-bit signed integer type
 
 -- See GHC.Classes#matching_overloaded_methods_in_rules
@@ -787,6 +845,22 @@ neInt64 (I64# x) (I64# y) = isTrue# (x /=# y)
 {-# INLINE [1] eqInt64 #-}
 {-# INLINE [1] neInt64 #-}
 
+instance Ord Int64 where
+    (<)  = ltInt64
+    (<=) = leInt64
+    (>=) = geInt64
+    (>)  = gtInt64
+
+{-# INLINE [1] gtInt64 #-}
+{-# INLINE [1] geInt64 #-}
+{-# INLINE [1] ltInt64 #-}
+{-# INLINE [1] leInt64 #-}
+gtInt64, geInt64, ltInt64, leInt64 :: Int64 -> Int64 -> Bool
+(I64# x) `gtInt64` (I64# y) = isTrue# (x >#  y)
+(I64# x) `geInt64` (I64# y) = isTrue# (x >=# y)
+(I64# x) `ltInt64` (I64# y) = isTrue# (x <#  y)
+(I64# x) `leInt64` (I64# y) = isTrue# (x <=# y)
+
 instance Show Int64 where
     showsPrec p x = showsPrec p (fromIntegral x :: Int)
 
index 384cf38..3424f83 100644 (file)
@@ -33,11 +33,11 @@ module GHC.Word (
 
     -- * Equality operators
     -- | See GHC.Classes#matching_overloaded_methods_in_rules
-    eqWord, neWord,
-    eqWord8, neWord8,
-    eqWord16, neWord16,
-    eqWord32, neWord32,
-    eqWord64, neWord64
+    eqWord, neWord, gtWord, geWord, ltWord, leWord,
+    eqWord8, neWord8, gtWord8, geWord8, ltWord8, leWord8,
+    eqWord16, neWord16, gtWord16, geWord16, ltWord16, leWord16,
+    eqWord32, neWord32, gtWord32, geWord32, ltWord32, leWord32,
+    eqWord64, neWord64, gtWord64, geWord64, ltWord64, leWord64
     ) where
 
 import Data.Bits
@@ -62,7 +62,7 @@ import GHC.Show
 -- Word8 is represented in the same way as Word. Operations may assume
 -- and must ensure that it holds only values from its logical range.
 
-data {-# CTYPE "HsWord8" #-} Word8 = W8# Word# deriving (Ord)
+data {-# CTYPE "HsWord8" #-} Word8 = W8# Word#
 -- ^ 8-bit unsigned integer type
 
 -- See GHC.Classes#matching_overloaded_methods_in_rules
@@ -76,6 +76,22 @@ neWord8 (W8# x) (W8# y) = isTrue# (x `neWord#` y)
 {-# INLINE [1] eqWord8 #-}
 {-# INLINE [1] neWord8 #-}
 
+instance Ord Word8 where
+    (<)  = ltWord8
+    (<=) = leWord8
+    (>=) = geWord8
+    (>)  = gtWord8
+
+{-# INLINE [1] gtWord8 #-}
+{-# INLINE [1] geWord8 #-}
+{-# INLINE [1] ltWord8 #-}
+{-# INLINE [1] leWord8 #-}
+gtWord8, geWord8, ltWord8, leWord8 :: Word8 -> Word8 -> Bool
+(W8# x) `gtWord8` (W8# y) = isTrue# (x `gtWord#` y)
+(W8# x) `geWord8` (W8# y) = isTrue# (x `geWord#` y)
+(W8# x) `ltWord8` (W8# y) = isTrue# (x `ltWord#` y)
+(W8# x) `leWord8` (W8# y) = isTrue# (x `leWord#` y)
+
 instance Show Word8 where
     showsPrec p x = showsPrec p (fromIntegral x :: Int)
 
@@ -222,7 +238,7 @@ instance FiniteBits Word8 where
 -- Word16 is represented in the same way as Word. Operations may assume
 -- and must ensure that it holds only values from its logical range.
 
-data {-# CTYPE "HsWord16" #-} Word16 = W16# Word# deriving (Ord)
+data {-# CTYPE "HsWord16" #-} Word16 = W16# Word#
 -- ^ 16-bit unsigned integer type
 
 -- See GHC.Classes#matching_overloaded_methods_in_rules
@@ -236,6 +252,22 @@ neWord16 (W16# x) (W16# y) = isTrue# (x `neWord#` y)
 {-# INLINE [1] eqWord16 #-}
 {-# INLINE [1] neWord16 #-}
 
+instance Ord Word16 where
+    (<)  = ltWord16
+    (<=) = leWord16
+    (>=) = geWord16
+    (>)  = gtWord16
+
+{-# INLINE [1] gtWord16 #-}
+{-# INLINE [1] geWord16 #-}
+{-# INLINE [1] ltWord16 #-}
+{-# INLINE [1] leWord16 #-}
+gtWord16, geWord16, ltWord16, leWord16 :: Word16 -> Word16 -> Bool
+(W16# x) `gtWord16` (W16# y) = isTrue# (x `gtWord#` y)
+(W16# x) `geWord16` (W16# y) = isTrue# (x `geWord#` y)
+(W16# x) `ltWord16` (W16# y) = isTrue# (x `ltWord#` y)
+(W16# x) `leWord16` (W16# y) = isTrue# (x `leWord#` y)
+
 instance Show Word16 where
     showsPrec p x = showsPrec p (fromIntegral x :: Int)
 
@@ -425,7 +457,7 @@ byteSwap16 (W16# w#) = W16# (narrow16Word# (byteSwap16# w#))
 
 #endif
 
-data {-# CTYPE "HsWord32" #-} Word32 = W32# Word# deriving (Ord)
+data {-# CTYPE "HsWord32" #-} Word32 = W32# Word#
 -- ^ 32-bit unsigned integer type
 
 -- See GHC.Classes#matching_overloaded_methods_in_rules
@@ -439,6 +471,22 @@ neWord32 (W32# x) (W32# y) = isTrue# (x `neWord#` y)
 {-# INLINE [1] eqWord32 #-}
 {-# INLINE [1] neWord32 #-}
 
+instance Ord Word32 where
+    (<)  = ltWord32
+    (<=) = leWord32
+    (>=) = geWord32
+    (>)  = gtWord32
+
+{-# INLINE [1] gtWord32 #-}
+{-# INLINE [1] geWord32 #-}
+{-# INLINE [1] ltWord32 #-}
+{-# INLINE [1] leWord32 #-}
+gtWord32, geWord32, ltWord32, leWord32 :: Word32 -> Word32 -> Bool
+(W32# x) `gtWord32` (W32# y) = isTrue# (x `gtWord#` y)
+(W32# x) `geWord32` (W32# y) = isTrue# (x `geWord#` y)
+(W32# x) `ltWord32` (W32# y) = isTrue# (x `ltWord#` y)
+(W32# x) `leWord32` (W32# y) = isTrue# (x `leWord#` y)
+
 instance Num Word32 where
     (W32# x#) + (W32# y#)  = W32# (narrow32Word# (x# `plusWord#` y#))
     (W32# x#) - (W32# y#)  = W32# (narrow32Word# (x# `minusWord#` y#))
@@ -608,10 +656,20 @@ neWord64 (W64# x) (W64# y) = isTrue# (x `neWord64#` y)
 {-# INLINE [1] neWord64 #-}
 
 instance Ord Word64 where
-    (W64# x#) <  (W64# y#) = isTrue# (x# `ltWord64#` y#)
-    (W64# x#) <= (W64# y#) = isTrue# (x# `leWord64#` y#)
-    (W64# x#) >  (W64# y#) = isTrue# (x# `gtWord64#` y#)
-    (W64# x#) >= (W64# y#) = isTrue# (x# `geWord64#` y#)
+    (<)  = ltWord64
+    (<=) = leWord64
+    (>=) = geWord64
+    (>)  = gtWord64
+
+{-# INLINE [1] gtWord64 #-}
+{-# INLINE [1] geWord64 #-}
+{-# INLINE [1] ltWord64 #-}
+{-# INLINE [1] leWord64 #-}
+gtWord64, geWord64, ltWord64, leWord64 :: Word64 -> Word64 -> Bool
+(W64# x) `gtWord64` (W64# y) = isTrue# (x `gtWord64#` y)
+(W64# x) `geWord64` (W64# y) = isTrue# (x `geWord64#` y)
+(W64# x) `ltWord64` (W64# y) = isTrue# (x `ltWord64#` y)
+(W64# x) `leWord64` (W64# y) = isTrue# (x `leWord64#` y)
 
 instance Num Word64 where
     (W64# x#) + (W64# y#)  = W64# (int64ToWord64# (word64ToInt64# x# `plusInt64#` word64ToInt64# y#))
@@ -719,7 +777,7 @@ a `shiftRL64#` b | isTrue# (b >=# 64#) = wordToWord64# 0##
 -- Operations may assume and must ensure that it holds only values
 -- from its logical range.
 
-data {-# CTYPE "HsWord64" #-} Word64 = W64# Word# deriving (Ord)
+data {-# CTYPE "HsWord64" #-} Word64 = W64# Word#
 -- ^ 64-bit unsigned integer type
 
 -- See GHC.Classes#matching_overloaded_methods_in_rules
@@ -733,6 +791,22 @@ neWord64 (W64# x) (W64# y) = isTrue# (x `neWord#` y)
 {-# INLINE [1] eqWord64 #-}
 {-# INLINE [1] neWord64 #-}
 
+instance Ord Word64 where
+    (<)  = ltWord64
+    (<=) = leWord64
+    (>=) = geWord64
+    (>)  = gtWord64
+
+{-# INLINE [1] gtWord64 #-}
+{-# INLINE [1] geWord64 #-}
+{-# INLINE [1] ltWord64 #-}
+{-# INLINE [1] leWord64 #-}
+gtWord64, geWord64, ltWord64, leWord64 :: Word64 -> Word64 -> Bool
+(W64# x) `gtWord64` (W64# y) = isTrue# (x `gtWord#` y)
+(W64# x) `geWord64` (W64# y) = isTrue# (x `geWord#` y)
+(W64# x) `ltWord64` (W64# y) = isTrue# (x `ltWord#` y)
+(W64# x) `leWord64` (W64# y) = isTrue# (x `leWord#` y)
+
 instance Num Word64 where
     (W64# x#) + (W64# y#)  = W64# (x# `plusWord#` y#)
     (W64# x#) - (W64# y#)  = W64# (x# `minusWord#` y#)
index 65fdfcc..9c40449 100644 (file)
@@ -44,6 +44,7 @@ module GHC.Classes(
     eqFloat, eqDouble,
     -- ** Monomorphic comparison operators
     gtInt, geInt, leInt, ltInt, compareInt, compareInt#,
+    gtWord, geWord, leWord, ltWord, compareWord, compareWord#,
 
     -- * Functions over Bool
     (&&), (||), not,
@@ -89,9 +90,9 @@ with a known @Word8@. As written, however, this rule will be quite fragile as
 the @(==)@ class operation rule may rewrite the predicate before our @break@
 rule has a chance to fire.
 
-For this reason, most of the primitive types in @base@ have 'Eq' instances
-defined in terms of helper functions with inlinings delayed to phase 1. For
-instance, @Word8@\'s @Eq@ instance looks like,
+For this reason, most of the primitive types in @base@ have 'Eq' and 'Ord'
+instances defined in terms of helper functions with inlinings delayed to phase
+1. For instance, @Word8@\'s @Eq@ instance looks like,
 
 > instance Eq Word8 where
 >     (==) = eqWord8
@@ -108,7 +109,8 @@ against @eqWord8@,
 
 > {-# RULES "break -> breakByte" forall a. break (`eqWord8` x) = breakByte x #-}
 
-Currently this is only done for '(==)' and '(/=)'.
+Currently this is only done for '(==)', '(/=)', '(<)', '(<=)', '(>)', and '(>=)'
+for the types in "GHC.Word" and "GHC.Int".
 -}
 
 -- | The 'Eq' class defines equality ('==') and inequality ('/=').
@@ -328,7 +330,6 @@ instance (Ord a) => Ord [a] where
 
 deriving instance Ord Bool
 deriving instance Ord Ordering
-deriving instance Ord Word
 
 -- We don't use deriving for Ord Char, because for Ord the derived
 -- instance defines only compare, which takes two primops.  Then
@@ -388,6 +389,33 @@ compareInt# x# y#
     | isTrue# (x# ==# y#) = EQ
     | True                = GT
 
+instance Ord Word where
+    compare = compareWord
+    (<)     = ltWord
+    (<=)    = leWord
+    (>=)    = geWord
+    (>)     = gtWord
+
+-- See GHC.Classes#matching_overloaded_methods_in_rules
+{-# INLINE [1] gtWord #-}
+{-# INLINE [1] geWord #-}
+{-# INLINE [1] ltWord #-}
+{-# INLINE [1] leWord #-}
+gtWord, geWord, ltWord, leWord :: Word -> Word -> Bool
+(W# x) `gtWord` (W# y) = isTrue# (x `gtWord#` y)
+(W# x) `geWord` (W# y) = isTrue# (x `geWord#` y)
+(W# x) `ltWord` (W# y) = isTrue# (x `ltWord#` y)
+(W# x) `leWord` (W# y) = isTrue# (x `leWord#` y)
+
+compareWord :: Word -> Word -> Ordering
+(W# x#) `compareWord` (W# y#) = compareWord# x# y#
+
+compareWord# :: Word# -> Word# -> Ordering
+compareWord# x# y#
+    | isTrue# (x# `ltWord#` y#) = LT
+    | isTrue# (x# `eqWord#` y#) = EQ
+    | True                      = GT
+
 -- OK, so they're technically not part of a class...:
 
 -- Boolean functions