[Git][ghc/ghc][wip/T23578] Also change Enum Int64
Jaro Reinders (@Noughtmare)
gitlab at gitlab.haskell.org
Mon Jul 10 08:29:21 UTC 2023
Jaro Reinders pushed to branch wip/T23578 at Glasgow Haskell Compiler / GHC
Commits:
f5c665f4 by Jaro Reinders at 2023-07-10T10:29:11+02:00
Also change Enum Int64
- - - - -
2 changed files:
- libraries/base/GHC/Int.hs
- libraries/base/GHC/Word.hs
Changes:
=====================================
libraries/base/GHC/Int.hs
=====================================
@@ -753,27 +753,153 @@ instance Enum Int64 where
| x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int)
= I# (int64ToInt# x#)
| otherwise = fromEnumError "Int64" x
-#if WORD_SIZE_IN_BITS < 64
+
-- See Note [Stable Unfolding for list producers] in GHC.Enum
{-# INLINE enumFrom #-}
- enumFrom = integralEnumFrom
- -- See Note [Stable Unfolding for list producers] in GHC.Enum
- {-# INLINE enumFromThen #-}
- enumFromThen = integralEnumFromThen
+ enumFrom (I64# x) = eftInt64 x maxInt64#
+ where !(I64# maxInt64#) = maxBound
+ -- Blarg: technically I guess enumFrom isn't strict!
+
-- See Note [Stable Unfolding for list producers] in GHC.Enum
{-# INLINE enumFromTo #-}
- enumFromTo = integralEnumFromTo
- -- See Note [Stable Unfolding for list producers] in GHC.Enum
- {-# INLINE enumFromThenTo #-}
- enumFromThenTo = integralEnumFromThenTo
-#else
- -- See Note [Stable Unfolding for list producers] in GHC.Enum
- {-# INLINE enumFrom #-}
- enumFrom = boundedEnumFrom
+ enumFromTo (I64# x) (I64# y) = eftInt64 x y
+
-- See Note [Stable Unfolding for list producers] in GHC.Enum
{-# INLINE enumFromThen #-}
- enumFromThen = boundedEnumFromThen
-#endif
+ enumFromThen (I64# x1) (I64# x2) = efdInt64 x1 x2
+
+ -- See Note [Stable Unfolding for list producers] in GHC.Enum
+ {-# INLINE enumFromThenTo #-}
+ enumFromThenTo (I64# x1) (I64# x2) (I64# y) = efdtInt64 x1 x2 y
+
+
+-----------------------------------------------------
+-- eftInt64 and eftInt64FB deal with [a..b], which is the
+-- most common form, so we take a lot of care
+-- In particular, we have rules for deforestation
+
+-- See Note [How the Enum rules work] in GHC.Enum
+{-# RULES
+"eftInt64" [~1] forall x y. eftInt64 x y = build (\ c n -> eftInt64FB c n x y)
+"eftInt64List" [1] eftInt64FB (:) [] = eftInt64
+ #-}
+
+{-# NOINLINE [1] eftInt64 #-}
+eftInt64 :: Int64# -> Int64# -> [Int64]
+-- [x1..x2]
+eftInt64 x0 y | isTrue# (x0 `geInt64#` y) = []
+ | otherwise = go x0
+ where
+ go x = I64# x : if isTrue# (x `eqInt64#` y)
+ then []
+ else go (x `plusInt64#` (intToInt64# 1#))
+
+{-# INLINE [0] eftInt64FB #-} -- See Note [Inline FB functions] in GHC.List
+eftInt64FB :: (Int64 -> r -> r) -> r -> Int64# -> Int64# -> r
+eftInt64FB c n x0 y | isTrue# (x0 `geInt64#` y) = n
+ | otherwise = go x0
+ where
+ go x = I64# x `c` if isTrue# (x `eqInt64#` y)
+ then n
+ else go (x `plusInt64#` (intToInt64# 1#))
+ -- Watch out for y=maxBound; hence ==, not >
+ -- Be very careful not to have more than one "c"
+ -- so that when eftInfFB is inlined we can inline
+ -- whatever is bound to "c"
+
+
+-----------------------------------------------------
+-- efdInt64 and efdtInt64 deal with [a,b..] and [a,b..c].
+-- The code is more complicated because of worries about Int64 overflow.
+
+-- See Note [How the Enum rules work] in GHC.Enum
+{-# RULES
+"efdtInt64" [~1] forall x1 x2 y.
+ efdtInt64 x1 x2 y = build (\ c n -> efdtInt64FB c n x1 x2 y)
+"efdtInt64UpList" [1] efdtInt64FB (:) [] = efdtInt64
+ #-}
+
+efdInt64 :: Int64# -> Int64# -> [Int64]
+-- [x1,x2..maxInt64]
+efdInt64 x1 x2
+ | isTrue# (x2 `geInt64#` x1) = case maxBound of I64# y -> efdtInt64Up x1 x2 y
+ | otherwise = case maxBound of I64# y -> efdtInt64Dn x1 x2 y
+
+{-# NOINLINE [1] efdtInt64 #-}
+efdtInt64 :: Int64# -> Int64# -> Int64# -> [Int64]
+-- [x1,x2..y]
+efdtInt64 x1 x2 y
+ | isTrue# (x2 `geInt64#` x1) = efdtInt64Up x1 x2 y
+ | otherwise = efdtInt64Dn x1 x2 y
+
+{-# INLINE [0] efdtInt64FB #-} -- See Note [Inline FB functions] in GHC.List
+efdtInt64FB :: (Int64 -> r -> r) -> r -> Int64# -> Int64# -> Int64# -> r
+efdtInt64FB c n x1 x2 y
+ | isTrue# (x2 `geInt64#` x1) = efdtInt64UpFB c n x1 x2 y
+ | otherwise = efdtInt64DnFB c n x1 x2 y
+
+-- Requires x2 >= x1
+efdtInt64Up :: Int64# -> Int64# -> Int64# -> [Int64]
+efdtInt64Up x1 x2 y -- Be careful about overflow!
+ | isTrue# (y `ltInt64#` x2) = if isTrue# (y `ltInt64#` x1) then [] else [I64# x1]
+ | otherwise = -- Common case: x1 <= x2 <= y
+ let !delta = x2 `subInt64#` x1 -- >= 0
+ !y' = y `subInt64#` delta -- x1 <= y' <= y; hence y' is representable
+
+ -- Invariant: x <= y
+ -- Note that: z <= y' => z + delta won't overflow
+ -- so we are guaranteed not to overflow if/when we recurse
+ go_up x | isTrue# (x `gtInt64#` y') = [I64# x]
+ | otherwise = I64# x : go_up (x `plusInt64#` delta)
+ in I64# x1 : go_up x2
+
+-- Requires x2 >= x1
+{-# INLINE [0] efdtInt64UpFB #-} -- See Note [Inline FB functions] in GHC.List
+efdtInt64UpFB :: (Int64 -> r -> r) -> r -> Int64# -> Int64# -> Int64# -> r
+efdtInt64UpFB c n x1 x2 y -- Be careful about overflow!
+ | isTrue# (y `ltInt64#` x2) = if isTrue# (y `ltInt64#` x1) then n else I64# x1 `c` n
+ | otherwise = -- Common case: x1 <= x2 <= y
+ let !delta = x2 `subInt64#` x1 -- >= 0
+ !y' = y `subInt64#` delta -- x1 <= y' <= y; hence y' is representable
+
+ -- Invariant: x <= y
+ -- Note that: z <= y' => z + delta won't overflow
+ -- so we are guaranteed not to overflow if/when we recurse
+ go_up x | isTrue# (x `geInt64#` y') = I64# x `c` n
+ | otherwise = I64# x `c` go_up (x `plusInt64#` delta)
+ in I64# x1 `c` go_up x2
+
+-- Requires x2 <= x1
+efdtInt64Dn :: Int64# -> Int64# -> Int64# -> [Int64]
+efdtInt64Dn x1 x2 y -- Be careful about underflow!
+ | isTrue# (y `geInt64#` x2) = if isTrue# (y `geInt64#` x1) then [] else [I64# x1]
+ | otherwise = -- Common case: x1 >= x2 >= y
+ let !delta = x2 `subInt64#` x1 -- <= 0
+ !y' = y `subInt64#` delta -- y <= y' <= x1; hence y' is representable
+
+ -- Invariant: x >= y
+ -- Note that: z >= y' => z + delta won't underflow
+ -- so we are guaranteed not to underflow if/when we recurse
+ go_dn x | isTrue# (x `ltInt64#` y') = [I64# x]
+ | otherwise = I64# x : go_dn (x `plusInt64#` delta)
+ in I64# x1 : go_dn x2
+
+-- Requires x2 <= x1
+{-# INLINE [0] efdtInt64DnFB #-} -- See Note [Inline FB functions] in GHC.List
+efdtInt64DnFB :: (Int64 -> r -> r) -> r -> Int64# -> Int64# -> Int64# -> r
+efdtInt64DnFB c n x1 x2 y -- Be careful about underflow!
+ | isTrue# (y `geInt64#` x2) = if isTrue# (y `geInt64#` x1) then n else I64# x1 `c` n
+ | otherwise = -- Common case: x1 >= x2 >= y
+ let !delta = x2 `subInt64#` x1 -- <= 0
+ !y' = y `subInt64#` delta -- y <= y' <= x1; hence y' is representable
+
+ -- Invariant: x >= y
+ -- Note that: z >= y' => z + delta won't underflow
+ -- so we are guaranteed not to underflow if/when we recurse
+ go_dn x | isTrue# (x `ltInt64#` y') = I64# x `c` n
+ | otherwise = I64# x `c` go_dn (x `plusInt64#` delta)
+ in I64# x1 `c` go_dn x2
+
-- | @since 2.01
instance Integral Int64 where
=====================================
libraries/base/GHC/Word.hs
=====================================
@@ -731,17 +731,21 @@ instance Enum Word64 where
= I# (word2Int# (word64ToWord# x#))
| otherwise = fromEnumError "Word64" x
+ -- See Note [Stable Unfolding for list producers] in GHC.Enum
{-# INLINE enumFrom #-}
enumFrom (W64# x#) = eftWord64 x# maxWord#
where !(W64# maxWord#) = maxBound
-- Blarg: technically I guess enumFrom isn't strict!
+ -- See Note [Stable Unfolding for list producers] in GHC.Enum
{-# INLINE enumFromTo #-}
enumFromTo (W64# x) (W64# y) = eftWord64 x y
+ -- See Note [Stable Unfolding for list producers] in GHC.Enum
{-# INLINE enumFromThen #-}
enumFromThen (W64# x1) (W64# x2) = efdWord64 x1 x2
+ -- See Note [Stable Unfolding for list producers] in GHC.Enum
{-# INLINE enumFromThenTo #-}
enumFromThenTo (W64# x1) (W64# x2) (W64# y) = efdtWord64 x1 x2 y
@@ -811,7 +815,7 @@ efdtWord64 x1 x2 y
efdtWord64FB :: (Word64 -> r -> r) -> r -> Word64# -> Word64# -> Word64# -> r
efdtWord64FB c n x1 x2 y
| isTrue# (x2 `geWord64#` x1) = efdtWord64UpFB c n x1 x2 y
- | otherwise = efdtWord64DnFB c n x1 x2 y
+ | otherwise = efdtWord64DnFB c n x1 x2 y
-- Requires x2 >= x1
efdtWord64Up :: Word64# -> Word64# -> Word64# -> [Word64]
@@ -825,7 +829,7 @@ efdtWord64Up x1 x2 y -- Be careful about overflow!
-- Note that: z <= y' => z + delta won't overflow
-- so we are guaranteed not to overflow if/when we recurse
go_up x | isTrue# (x `gtWord64#` y') = [W64# x]
- | otherwise = W64# x : go_up (x `plusWord64#` delta)
+ | otherwise = W64# x : go_up (x `plusWord64#` delta)
in W64# x1 : go_up x2
-- Requires x2 >= x1
@@ -841,7 +845,7 @@ efdtWord64UpFB c n x1 x2 y -- Be careful about overflow!
-- Note that: z <= y' => z + delta won't overflow
-- so we are guaranteed not to overflow if/when we recurse
go_up x | isTrue# (x `gtWord64#` y') = W64# x `c` n
- | otherwise = W64# x `c` go_up (x `plusWord64#` delta)
+ | otherwise = W64# x `c` go_up (x `plusWord64#` delta)
in W64# x1 `c` go_up x2
-- Requires x2 <= x1
@@ -856,7 +860,7 @@ efdtWord64Dn x1 x2 y -- Be careful about underflow!
-- Note that: z >= y' => z + delta won't underflow
-- so we are guaranteed not to underflow if/when we recurse
go_dn x | isTrue# (x `ltWord64#` y') = [W64# x]
- | otherwise = W64# x : go_dn (x `plusWord64#` delta)
+ | otherwise = W64# x : go_dn (x `plusWord64#` delta)
in W64# x1 : go_dn x2
-- Requires x2 <= x1
@@ -872,7 +876,7 @@ efdtWord64DnFB c n x1 x2 y -- Be careful about underflow!
-- Note that: z >= y' => z + delta won't underflow
-- so we are guaranteed not to underflow if/when we recurse
go_dn x | isTrue# (x `ltWord64#` y') = W64# x `c` n
- | otherwise = W64# x `c` go_dn (x `plusWord64#` delta)
+ | otherwise = W64# x `c` go_dn (x `plusWord64#` delta)
in W64# x1 `c` go_dn x2
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f5c665f4cc6a56127f716e36c4e5242e57502333
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f5c665f4cc6a56127f716e36c4e5242e57502333
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/20230710/9638b022/attachment-0001.html>
More information about the ghc-commits
mailing list