lookupBindGroupOcc: recommend names in the same namespace (#17593)
[ghc.git] / testsuite / tests / perf / should_run / T13623.hs
1 {-# LANGUAGE BangPatterns, GADTs, ExistentialQuantification #-}
2 {-# OPTIONS_GHC -cpp #-}
3
4 module Main where
5
6
7 import Data.Int
8 import GHC.Types
9
10
11 foo :: Int -> Int -> IO Int
12 foo = \i j -> sfoldl' (+) 0 $ xs i j +++ ys i j
13 where xs k l = senumFromStepN k l 200000
14 ys k l = senumFromStepN k l 300000
15 {-# Inline xs #-}
16 {-# Inline ys #-}
17 {-# Inline foo #-}
18
19
20 -- We narrow the result to 32-bits to account for the fact that this overflows
21 -- on 32-bit machines.
22 main = do { n <- foo 1 1; print (fromIntegral n :: Int32) }
23
24
25
26 -------------------------------------------------------------------------------
27 -- vector junk
28 -------------------------------------------------------------------------------
29
30 #define PHASE_FUSED [1]
31 #define PHASE_INNER [0]
32
33 #define INLINE_FUSED INLINE PHASE_FUSED
34 #define INLINE_INNER INLINE PHASE_INNER
35
36 data Stream m a = forall s. Stream (s -> m (Step s a)) s
37
38 data Step s a where
39 Yield :: a -> s -> Step s a
40 Skip :: s -> Step s a
41 Done :: Step s a
42
43 senumFromStepN :: (Num a, Monad m) => a -> a -> Int -> Stream m a
44 {-# INLINE_FUSED senumFromStepN #-}
45 senumFromStepN x y n = x `seq` y `seq` n `seq` Stream step (x,n)
46 where
47 {-# INLINE_INNER step #-}
48 step (w,m) | m > 0 = return $ Yield w (w+y,m-1)
49 | otherwise = return $ Done
50
51 sfoldl' :: Monad m => (a -> b -> a) -> a -> Stream m b -> m a
52 {-# INLINE sfoldl' #-}
53 sfoldl' f = sfoldlM' (\a b -> return (f a b))
54
55 sfoldlM' :: Monad m => (a -> b -> m a) -> a -> Stream m b -> m a
56 {-# INLINE_FUSED sfoldlM' #-}
57 sfoldlM' m w (Stream step t) = foldlM'_loop SPEC w t
58 where
59 foldlM'_loop !_ z s
60 = z `seq`
61 do
62 r <- step s
63 case r of
64 Yield x s' -> do { z' <- m z x; foldlM'_loop SPEC z' s' }
65 Skip s' -> foldlM'_loop SPEC z s'
66 Done -> return z
67
68 infixr 5 +++
69 (+++) :: Monad m => Stream m a -> Stream m a -> Stream m a
70 {-# INLINE_FUSED (+++) #-}
71 Stream stepa ta +++ Stream stepb tb = Stream step (Left ta)
72 where
73 {-# INLINE_INNER step #-}
74 step (Left sa) = do
75 r <- stepa sa
76 case r of
77 Yield x sa' -> return $ Yield x (Left sa')
78 Skip sa' -> return $ Skip (Left sa')
79 Done -> return $ Skip (Right tb)
80 step (Right sb) = do
81 r <- stepb sb
82 case r of
83 Yield x sb' -> return $ Yield x (Right sb')
84 Skip sb' -> return $ Skip (Right sb')
85 Done -> return $ Done