Ticket #3736: SpeedTestChorus.hs

File SpeedTestChorus.hs, 10.3 KB (added by guest, 4 years ago)
Line 
1{-# OPTIONS_GHC -funbox-strict-fields -ddump-simpl -O #-}
2{-# LANGUAGE ExistentialQuantification #-}
3{-  -dverbose-core2core -ddump-simpl-stats -}
4{-
5This module demonstrates the following:
6mainMonolithic1Generator performs the same computation as mainMonolithic1Compose
7but the former is more than two times slower than latter.
8This is serious since in more complex signal processing programs
9this factor seems to multiply.
10I assume that the problem is that 'mixGen' is not inlined.
11Instead GHC seems to have decided to specialise mixGen.
12In contrast to mainMonolithic1Compose,
13mainMonolithic1Generator uses a data type with existential quantification.
14But this alone is not the problem,
15since mainMonolithic0 and mainMonolithic0Generator run with the same speed.
16
17The program can be compiled using
18> ghc -package storablevector-0.2.5 -O speedtest/SpeedTestChorus.hs
19
20
21Exporting only main causes warnings about unused functions,
22but it also reduces the core output to a third.
23-}
24module Main (main) where
25
26import qualified Data.StorableVector.Lazy.Builder as Builder
27import qualified Data.StorableVector.ST.Strict as SVSTS
28import qualified Data.StorableVector.ST.Lazy   as SVSTL
29import qualified Data.StorableVector as SV
30import qualified Data.StorableVector.Lazy as SVL
31-- import qualified Data.StorableVector.Private as SVP
32
33import Control.Monad.ST.Lazy (ST, runST, strictToLazyST, )
34
35import Foreign.Storable (Storable, )
36import GHC.Float (float2Int, int2Float, double2Int, int2Double, )
37
38import Sound.Frame.Stereo as Stereo
39
40-- import qualified Data.Strictness.HT as Strict
41
42import Data.Monoid (mempty, mappend, )
43
44
45{-
46I started with Storable instance for pairs from storable-tuple,
47that was implemented using the storable-record framework at this time.
48I got run-time around 5 seconds.
49When I used inlining then the computation time increased to 8s!
50Then I switch to sample-frame:Sound.Frame.Stereo
51computation time dropped to 1.4 seconds.
52At this time I already switched back
53from the storable-record based implementation to a custom one
54of the Storable Stereo instance.
55With this implementation inlining doesn't change the run-time.
56But then I noted that the generated file
57contained only one saw wave tone.
58This problem disappeared by not using -O2 option, but only -O.
59Monolithic and chunky require about 2.6 seconds,
60whereas monolithicStrict needs 3.8 seconds.
61After inlining monolithicStrict needs 1.8 seconds.
62-}
63
64type Phase = (Float, Float, Float)
65
66{-# INLINE saw #-}
67saw :: Num a => a -> a
68saw t = 1-2*t
69
70{-# INLINE sawChorus #-}
71sawChorus :: Phase -> Float
72sawChorus (pl0,pl1,pl2) =
73   0.3 * (saw pl0 + saw pl1 + saw pl2)
74
75{-
76Much faster than @snd . properFraction@ but fails for large numbers.
77-}
78class (Num a, Ord a) => Fraction a where
79   fraction :: a -> a
80
81instance Fraction Float where
82   {-# INLINE fraction #-}
83   fraction x = x - int2Float (float2Int x)
84
85instance Fraction Double where
86   {-# INLINE fraction #-}
87   fraction x = x - int2Double (double2Int x)
88
89{-
90fraction = Strict.arguments1 $ \x ->
91   let y = x - int2Float (float2Int x)
92   in  y
93-}
94{-
95   in  if y<0
96         then y+1
97         else y
98-}
99{-
100   if x==0
101     then 0
102     else x - int2Float (float2Int x)
103-}
104--   rnf x `seq` x - int2Float (float2Int x)
105
106
107{-# INLINE generator0Freq #-}
108generator0Freq ::
109   Fraction a => a -> a -> Maybe (a, a)
110generator0Freq freq =
111   \p -> Just (saw p, fraction (p+freq))
112
113{-# INLINE generator0 #-}
114generator0 ::
115   Float -> Maybe (Float, Float)
116generator0 = generator0Freq 0.01
117
118
119{-# INLINE runLoopSTStrict #-}
120runLoopSTStrict ::
121   (Storable a) =>
122   Int -> (s -> Maybe (a, s)) -> s -> SV.Vector a
123runLoopSTStrict n f s =
124   SVSTS.runSTVector
125      (do v <- SVSTS.new_ n
126          let go i s0 =
127                if i<n
128                  then
129                    case f s0 of
130                       Nothing -> return v
131                       Just (a,s1) ->
132--                          SVST.write v i a >> go (succ i) s1
133                          SVSTS.unsafeWrite v i a >> go (succ i) s1
134                  else return v
135          go 0 s)
136
137{-# INLINE runLoopSTLazy #-}
138runLoopSTLazy ::
139   (Storable a) =>
140   Int -> (s -> Maybe (a, s)) -> s -> SV.Vector a
141runLoopSTLazy n f s =
142   SVSTL.runSTVector
143      (do v <- SVSTL.new_ n
144          let go s0 i =
145                if i<n
146                  then
147                    case f s0 of
148                       Nothing -> return v
149                       Just (a,s1) ->
150                          {-
151                          Strict pattern matching on () is necessary
152                          in order to avoid a memory leak.
153                          Working in ST.Lazy is still
154                          three times slower than ST.Strict
155                          -}
156                          strictToLazyST (SVSTS.unsafeWrite v i a >> return (succ i))
157                           >>= go s1
158--                          SVSTL.unsafeWrite v i a >>= \() -> go s1 (succ i)
159--                          SVSTL.unsafeWrite v i a >> go s1 (succ i)
160                  else return v
161          go s 0)
162
163
164{-# INLINE runBuilder #-}
165runBuilder ::
166   (Storable a) =>
167   SVL.ChunkSize -> (s -> Maybe (a, s)) -> s -> SVL.Vector a
168runBuilder chunkSize f s =
169   Builder.toLazyStorableVector chunkSize
170      (let go s0 =
171              case f s0 of
172                 Nothing -> mempty
173                 Just (a,s1) ->
174                    mappend (Builder.put a) (go s1)
175       in  go s)
176
177
178{- |
179Build a generator from two other generators
180by handling their state in parallel and mix their results.
181-}
182{-# INLINE mix #-}
183mix ::
184   (Num y) =>
185   (s -> Maybe (y, s)) ->
186   (t -> Maybe (y, t)) ->
187   ((s,t) -> Maybe (y, (s,t)))
188mix f g (s0,t0) =
189   do (a,s1) <- f s0
190      (b,t1) <- g t0
191      return ((a+b), (s1,t1))
192
193
194{- |
195This is like a list without storage.
196It is like stream-fusion:Data.Stream
197but without Skip constructor.
198-}
199data Generator a =
200   forall s.
201      Generator (s -> Maybe (a, s)) s
202
203{-# INLINE runGeneratorMonolithic #-}
204runGeneratorMonolithic :: Storable a => Int -> Generator a -> SV.Vector a
205runGeneratorMonolithic size (Generator f s) =
206   fst $ SV.unfoldrN size f s
207
208{- SPECIALISE INLINE generator0Gen :: Float -> Float -> Generator Float -}
209{-# INLINE generator0Gen #-}
210generator0Gen ::
211   Fraction a => a -> a -> Generator a
212generator0Gen freq phase =
213   Generator (\p -> Just (saw p, fraction (p+freq))) phase
214
215{- SPECIALISE INLINE mixGen :: Generator Float -> Generator Float -> Generator Float -}
216{-# INLINE mixGen #-}
217mixGen ::
218   (Num y) =>
219   Generator y ->
220   Generator y ->
221   Generator y
222mixGen (Generator f s) (Generator g t) =
223   Generator (\(s0,t0) ->
224      do (a,s1) <- f s0
225         (b,t1) <- g t0
226         return ((a+b), (s1,t1))) (s,t)
227
228
229
230{-# INLINE incPhase #-}
231incPhase :: Phase -> Phase -> Phase
232incPhase (d0,d1,d2) (p0,p1,p2) =
233   (fraction (p0+d0), fraction (p1+d1), fraction (p2+d2))
234
235{-# INLINE generator1 #-}
236generator1 ::
237   Phase -> Maybe (Float, Phase)
238generator1 =
239   \p -> Just (sawChorus p, incPhase dl p)
240
241
242{-# INLINE generator2 #-}
243generator2 ::
244   (Phase, Phase) -> Maybe (T Float, (Phase, Phase))
245generator2 =
246   \(pl, pr) ->
247      Just (Stereo.cons (sawChorus pl) (sawChorus pr),
248         (incPhase dl pl, incPhase dr pr))
249
250{-# INLINE dl #-}
251{-# INLINE dr #-}
252dl, dr :: Phase
253(dl,dr) =
254   ((0.01008, 0.01003, 0.00990),
255    (0.00992, 0.00997, 0.01010))
256
257{-# INLINE initPhase2 #-}
258initPhase2 :: (Phase, Phase)
259initPhase2 =
260   ((0,0.7,0.1), (0.3,0.4,0.6))
261
262
263size :: Int
264size = 10000000
265
266mainMonolithic0 :: IO ()
267mainMonolithic0 =
268   SV.writeFile "speed.f32"
269      (fst $ SV.unfoldrN size generator0 0)
270{-
271real    0m0.423s
272user    0m0.256s
273sys     0m0.152s
274-}
275
276mainMonolithic0Generator :: IO ()
277mainMonolithic0Generator =
278   SV.writeFile "speed.f32"
279      (runGeneratorMonolithic size
280          (generator0Gen (0.01::Float) 0))
281
282mainMonolithic0STStrict :: IO ()
283mainMonolithic0STStrict =
284   SV.writeFile "speed.f32"
285      (runLoopSTStrict size (generator0Freq (0.01::Float)) 0)
286{-
287real    0m0.430s
288user    0m0.288s
289sys     0m0.132s
290-}
291
292mainMonolithic0STLazy :: IO ()
293mainMonolithic0STLazy =
294   SV.writeFile "speed.f32"
295      (runLoopSTLazy size (generator0Freq (0.01::Float)) 0)
296{-
297real    0m0.886s
298user    0m0.752s
299sys     0m0.128s
300-}
301
302mainMonolithic1 :: IO ()
303mainMonolithic1 =
304   SV.writeFile "speed.f32"
305      (fst $ SV.unfoldrN size generator1 (fst initPhase2))
306
307mainMonolithic1Composed :: IO ()
308mainMonolithic1Composed =
309   SV.writeFile "speed.f32"
310      (fst $ SV.unfoldrN size
311          (let (f0,f1,f2) = dl
312           in  (generator0Freq f0 `mix` generator0Freq f1)
313                  `mix` generator0Freq f2)
314          (let (p0,p1,p2) = fst initPhase2
315           in  ((p0,p1),p2)))
316{-
317real    0m0.974s
318user    0m0.812s
319sys     0m0.160s
320-}
321
322mainMonolithic1Generator :: IO ()
323mainMonolithic1Generator =
324   SV.writeFile "speed.f32"
325      (runGeneratorMonolithic size
326          (let (f0,f1,f2) = dl
327               (p0,p1,p2) = fst initPhase2
328           in  (generator0Gen f0 p0 `mixGen` generator0Gen f1 p1)
329                  `mixGen` generator0Gen f2 p2))
330{-
331real    0m2.244s
332user    0m2.084s
333sys     0m0.152s
334-}
335
336mainMonolithic2 :: IO ()
337mainMonolithic2 =
338   SV.writeFile "speed.f32"
339      (fst $ SV.unfoldrN size generator2 initPhase2)
340
341{-
342mainMonolithicStrict2 :: IO ()
343mainMonolithicStrict2 =
344   SV.writeFile "speed.f32"
345      (fst $ SVP.unfoldrStrictN size generator2 initPhase2)
346
347mainMonolithicTransition2 :: IO ()
348mainMonolithicTransition2 =
349   SV.writeFile "speed.f32"
350      (fst $ SVP.unfoldrTransitionN size
351          (\(pl,pr) -> (incPhase dl pl, incPhase dr pr))
352          (\(pl,pr) ->
353              Just (Stereo.cons (sawChorus pl) (sawChorus pr)))
354          initPhase2)
355-}
356
357
358mainChunky0 :: IO ()
359mainChunky0 =
360   SVL.writeFile "speed.f32"
361      (SVL.take size $
362       SVL.unfoldr SVL.defaultChunkSize generator0 0)
363{-
364real    0m0.428s
365user    0m0.292s
366sys     0m0.132s
367-}
368
369mainChunky0Builder :: IO ()
370mainChunky0Builder =
371   SVL.writeFile "speed.f32"
372      (SVL.take size $
373       runBuilder SVL.defaultChunkSize generator0 0)
374{-
375real    0m1.107s
376user    0m0.968s
377sys     0m0.140s
378-}
379
380mainChunky1 :: IO ()
381mainChunky1 =
382   SVL.writeFile "speed.f32"
383      (SVL.take size $
384       SVL.unfoldr SVL.defaultChunkSize generator1 (fst initPhase2))
385{-
386real    0m0.938s
387user    0m0.812s
388sys     0m0.116s
389-}
390
391mainChunky2 :: IO ()
392mainChunky2 =
393   SVL.writeFile "speed.f32"
394      (SVL.take size $
395       SVL.unfoldr SVL.defaultChunkSize generator2 initPhase2)
396{-
397real    0m2.220s
398user    0m1.400s
399sys     0m0.192s
400-}
401
402main :: IO ()
403main =
404--   mainMonolithic0STLazy
405   mainChunky0Builder