Ticket #13331: Repro13331.hs

File Repro13331.hs, 3.4 KB (added by dfeuer, 3 years ago)

Repro case

Line 
1{-# LANGUAGE MagicHash, BangPatterns #-}
2
3module Repro13331 where
4import GHC.Exts (reallyUnsafePtrEquality#, tagToEnum#, lazy)
5
6ptrEq :: a -> a -> Bool
7ptrEq x y = tagToEnum# (reallyUnsafePtrEquality# x y)
8{-# INLINE ptrEq #-}
9
10data Map k a = Bin !Int !k a (Map k a) (Map k a)
11             | Tip
12
13singleton :: k -> a -> Map k a
14singleton k a = Bin 1 k a Tip Tip
15
16balanceL :: k -> a -> Map k a -> Map k a -> Map k a
17balanceL !_ _ !_ !_ = undefined
18{-# NOINLINE balanceL #-}
19
20balanceR :: k -> a -> Map k a -> Map k a -> Map k a
21balanceR !_ _ !_ !_ = undefined
22{-# NOINLINE balanceR #-}
23
24-- The version of insert in containers 0.5.10.1. The choice not
25-- to close over anything in the `go` function was, I believe, Milan
26-- Straka's originally. He seemed to believe there were solid performance
27-- reasons for that choice, and I have never taken the measurements
28-- to see if that is still the case.
29origInsert :: Ord k => k -> a -> Map k a -> Map k a
30origInsert = go
31  where
32    go :: Ord k => k -> a -> Map k a -> Map k a
33    go !kx x Tip = singleton kx x
34    go !kx x t@(Bin sz ky y l r) =
35        case compare kx ky of
36            LT | l' `ptrEq` l -> t
37               | otherwise -> balanceL ky y l' r
38               where !l' = go kx x l
39            GT | r' `ptrEq` r -> t
40               | otherwise -> balanceR ky y l r'
41               where !r' = go kx x r
42            EQ | kx `ptrEq` ky && x `ptrEq` y -> t
43               | otherwise -> Bin sz kx x l r
44
45{-# INLINABLE origInsert #-}
46
47-- Specialization to Int. The specialization to (Int, Int) is
48-- even worse.
49origInsertInt :: Int -> a -> Map Int a -> Map Int a
50origInsertInt = origInsert
51
52-- A version that closes the `go` function over the key, and, in
53-- the non-specialized case, also over the `Ord` dictionary.
54-- In this version it's certainly easy for a human to see that the boxed key,
55-- k0, should be preserved in case we need it for the Tip case or the
56-- Bin/EQ/otherwise case. But GHC does not see that.
57myInsert :: Ord k => k -> a -> Map k a -> Map k a
58myInsert kx0 = go kx0
59  where
60    go !kx x Tip = singleton kx0 x
61    go !kx x t@(Bin sz ky y l r) =
62        case compare kx ky of
63            LT | l' `ptrEq` l -> t
64               | otherwise -> balanceL ky y l' r
65               where !l' = go kx x l
66            GT | r' `ptrEq` r -> t
67               | otherwise -> balanceR ky y l r'
68               where !r' = go kx x r
69            EQ | kx0 `ptrEq` ky && x `ptrEq` y -> t
70               | otherwise -> Bin sz kx0 x l r
71
72{-# INLINABLE myInsert #-}
73
74-- Specialization to Int
75myInsertInt :: Int -> a -> Map Int a -> Map Int a
76myInsertInt = myInsert
77
78-- The terrifying version that will appear in containers-0.5.10.2 unless
79-- someone has a better fix:
80
81insert :: Ord k => k -> a -> Map k a -> Map k a
82insert kx0 = go kx0 kx0
83  where
84    go :: Ord k => k -> k -> a -> Map k a -> Map k a
85    go orig !kx x Tip = singleton (lazy orig) x
86    go orig !kx x t@(Bin sz ky y l r) =
87        case compare kx ky of
88            LT | l' `ptrEq` l -> t
89               | otherwise -> balanceL ky y l' r
90               where !l' = go orig kx x l
91            GT | r' `ptrEq` r -> t
92               | otherwise -> balanceR ky y l r'
93               where !r' = go orig kx x r
94            EQ | x `ptrEq` y && (lazy orig `seq` (orig `ptrEq` ky)) -> t
95               | otherwise -> Bin sz (lazy orig) x l r
96
97{-# INLINABLE insert #-}
98
99-- Specialization to Int
100insertInt :: Int -> a -> Map Int a -> Map Int a
101insertInt = insert