Ticket #13331: Minimal13331.hs

File Minimal13331.hs, 1.6 KB (added by dfeuer, 3 years ago)

A smaller reproduction

Line 
1{-# LANGUAGE MagicHash, BangPatterns #-}
2
3module Minimal13331 where
4
5data Map k a = Bin !Int !k a (Map k a) (Map k a)
6             | Tip
7
8singleton :: k -> a -> Map k a
9singleton k a = Bin 1 k a Tip Tip
10
11balanceL :: k -> a -> Map k a -> Map k a -> Map k a
12balanceL !_ _ !_ !_ = undefined
13{-# NOINLINE balanceL #-}
14
15balanceR :: k -> a -> Map k a -> Map k a -> Map k a
16balanceR !_ _ !_ !_ = undefined
17{-# NOINLINE balanceR #-}
18
19naiveInsert1 :: Ord k => k -> a -> Map k a -> Map k a
20naiveInsert1 kx0 = go kx0
21  where
22    go !kx x Tip = singleton kx0 x
23    go !kx x t@(Bin sz ky y l r) =
24        case compare kx ky of
25            LT -> balanceL ky y l' r
26               where !l' = go kx x l
27            GT -> balanceR ky y l r'
28               where !r' = go kx x r
29            EQ -> Bin sz kx0 x l r
30{-# INLINABLE naiveInsert1 #-}
31
32-- Specialization to Int. The specialization to (Int, Int) is
33-- even worse.
34naiveInsertInt1 :: Int -> a -> Map Int a -> Map Int a
35naiveInsertInt1 = naiveInsert1
36
37naiveInsert2 :: Ord k => k -> a -> Map k a -> Map k a
38naiveInsert2 = go
39  where
40    go :: Ord k => k -> a -> Map k a -> Map k a
41    go !kx x Tip = singleton kx x
42    go !kx x t@(Bin sz ky y l r) =
43        case compare kx ky of
44            LT -> balanceL ky y l' r
45               where !l' = go kx x l
46            GT -> balanceR ky y l r'
47               where !r' = go kx x r
48            EQ -> Bin sz kx x l r
49{-# INLINABLE naiveInsert2 #-}
50
51-- Specialization to Int. The specialization to (Int, Int) is
52-- even worse.
53naiveInsertInt2 :: Int -> a -> Map Int a -> Map Int a
54naiveInsertInt2 = naiveInsert2