Ticket #3737: SpeedTestChorus.hs

File SpeedTestChorus.hs, 12.2 KB (added by guest, 6 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 qualified 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 tone0 #-}
120tone0 :: Float -> Float -> SVL.Vector Float
121tone0 freq phase =
122   SVL.unfoldr SVL.defaultChunkSize (generator0Freq freq) phase
123
124
125{-# INLINE runLoopSTStrict #-}
126runLoopSTStrict ::
127   (Storable a) =>
128   Int -> (s -> Maybe (a, s)) -> s -> SV.Vector a
129runLoopSTStrict n f s =
130   SVSTS.runSTVector
131      (do v <- SVSTS.new_ n
132          let go i s0 =
133                if i<n
134                  then
135                    case f s0 of
136                       Nothing -> return v
137                       Just (a,s1) ->
138--                          SVST.write v i a >> go (succ i) s1
139                          SVSTS.unsafeWrite v i a >> go (succ i) s1
140                  else return v
141          go 0 s)
142
143{-# INLINE runLoopSTLazy #-}
144runLoopSTLazy ::
145   (Storable a) =>
146   Int -> (s -> Maybe (a, s)) -> s -> SV.Vector a
147runLoopSTLazy n f s =
148   SVSTL.runSTVector
149      (do v <- SVSTL.new_ n
150          let go s0 i =
151                if i<n
152                  then
153                    case f s0 of
154                       Nothing -> return v
155                       Just (a,s1) ->
156                          {-
157                          Strict pattern matching on () is necessary
158                          in order to avoid a memory leak.
159                          Working in ST.Lazy is still
160                          three times slower than ST.Strict
161                          -}
162                          strictToLazyST (SVSTS.unsafeWrite v i a >> return (succ i))
163                           >>= go s1
164--                          SVSTL.unsafeWrite v i a >>= \() -> go s1 (succ i)
165--                          SVSTL.unsafeWrite v i a >> go s1 (succ i)
166                  else return v
167          go s 0)
168
169
170{-# INLINE runBuilder #-}
171runBuilder ::
172   (Storable a) =>
173   SVL.ChunkSize -> (s -> Maybe (a, s)) -> s -> SVL.Vector a
174runBuilder chunkSize f s =
175   Builder.toLazyStorableVector chunkSize
176      (let go s0 =
177              case f s0 of
178                 Nothing -> mempty
179                 Just (a,s1) ->
180                    mappend (Builder.put a) (go s1)
181       in  go s)
182
183
184infixl 6 `mix`, `mixGen`, `mixVec`
185
186{- |
187Build a generator from two other generators
188by handling their state in parallel and mix their results.
189-}
190{-# INLINE mix #-}
191mix ::
192   (Num y) =>
193   (s -> Maybe (y, s)) ->
194   (t -> Maybe (y, t)) ->
195   ((s,t) -> Maybe (y, (s,t)))
196mix f g (s0,t0) =
197   do (a,s1) <- f s0
198      (b,t1) <- g t0
199      return ((a+b), (s1,t1))
200
201
202{- |
203This is like a list without storage.
204It is like stream-fusion:Data.Stream
205but without Skip constructor.
206-}
207data Generator a =
208   forall s.
209      Generator (s -> Maybe (a, s)) s
210
211{-# INLINE runGeneratorMonolithic #-}
212runGeneratorMonolithic :: Storable a => Int -> Generator a -> SV.Vector a
213runGeneratorMonolithic size (Generator f s) =
214   fst $ SV.unfoldrN size f s
215
216{- SPECIALISE INLINE generator0Gen :: Float -> Float -> Generator Float -}
217{-# INLINE generator0Gen #-}
218generator0Gen ::
219   Fraction a => a -> a -> Generator a
220generator0Gen freq phase =
221   Generator (\p -> Just (saw p, fraction (p+freq))) phase
222
223{- SPECIALISE INLINE mixGen :: Generator Float -> Generator Float -> Generator Float -}
224{-# INLINE mixGen #-}
225mixGen ::
226   (Num y) =>
227   Generator y ->
228   Generator y ->
229   Generator y
230mixGen (Generator f s) (Generator g t) =
231   Generator (\(s0,t0) ->
232      do (a,s1) <- f s0
233         (b,t1) <- g t0
234         return ((a+b), (s1,t1))) (s,t)
235
236
237
238{-# INLINE incPhase #-}
239incPhase :: Phase -> Phase -> Phase
240incPhase (d0,d1,d2) (p0,p1,p2) =
241   (fraction (p0+d0), fraction (p1+d1), fraction (p2+d2))
242
243{-# INLINE generator1 #-}
244generator1 ::
245   Phase -> Maybe (Float, Phase)
246generator1 =
247   \p -> Just (sawChorus p, incPhase dl p)
248
249
250{-# SPECIALISE mixVec :: SVL.Vector Float -> SVL.Vector Float -> SVL.Vector Float #-}
251{- disabled INLINE mixVec -}
252mixVec ::
253   (Num y, Storable y) =>
254   SVL.Vector y ->
255   SVL.Vector y ->
256   SVL.Vector y
257mixVec xs0 ys0 =
258   let recourse xt@(x:_) yt@(y:_) =
259          let z = SV.zipWith (+) x y
260              n = SV.length z
261          in  z : recourse
262                     (SVL.chunks $ SVL.drop n $ SVL.fromChunks xt)
263                     (SVL.chunks $ SVL.drop n $ SVL.fromChunks yt)
264       recourse xs [] = xs
265       recourse [] ys = ys
266   in  SVL.fromChunks $
267       recourse (SVL.chunks xs0) (SVL.chunks ys0)
268
269
270{-# INLINE generator2 #-}
271generator2 ::
272   (Phase, Phase) -> Maybe (Stereo.T Float, (Phase, Phase))
273generator2 =
274   \(pl, pr) ->
275      Just (Stereo.cons (sawChorus pl) (sawChorus pr),
276         (incPhase dl pl, incPhase dr pr))
277
278{-# INLINE dl #-}
279{-# INLINE dr #-}
280dl, dr :: Phase
281(dl,dr) =
282   ((0.01008, 0.01003, 0.00990),
283    (0.00992, 0.00997, 0.01010))
284
285{-# INLINE initPhase2 #-}
286initPhase2 :: (Phase, Phase)
287initPhase2 =
288   ((0,0.7,0.1), (0.3,0.4,0.6))
289
290
291size :: Int
292size = 10000000
293
294mainMonolithic0 :: IO ()
295mainMonolithic0 =
296   SV.writeFile "speed.f32"
297      (fst $ SV.unfoldrN size generator0 0)
298{-
299real    0m0.423s
300user    0m0.256s
301sys     0m0.152s
302-}
303
304mainMonolithic0Generator :: IO ()
305mainMonolithic0Generator =
306   SV.writeFile "speed.f32"
307      (runGeneratorMonolithic size
308          (generator0Gen (0.01::Float) 0))
309
310mainMonolithic0STStrict :: IO ()
311mainMonolithic0STStrict =
312   SV.writeFile "speed.f32"
313      (runLoopSTStrict size (generator0Freq (0.01::Float)) 0)
314{-
315real    0m0.430s
316user    0m0.288s
317sys     0m0.132s
318-}
319
320mainMonolithic0STLazy :: IO ()
321mainMonolithic0STLazy =
322   SV.writeFile "speed.f32"
323      (runLoopSTLazy size (generator0Freq (0.01::Float)) 0)
324{-
325real    0m0.886s
326user    0m0.752s
327sys     0m0.128s
328-}
329
330mainMonolithic1 :: IO ()
331mainMonolithic1 =
332   SV.writeFile "speed.f32"
333      (fst $ SV.unfoldrN size generator1 (fst initPhase2))
334
335mainMonolithic1Composed :: IO ()
336mainMonolithic1Composed =
337   SV.writeFile "speed.f32"
338      (fst $ SV.unfoldrN size
339          (let (f0,f1,f2) = dl
340           in  generator0Freq f0 `mix`
341               generator0Freq f1 `mix`
342               generator0Freq f2)
343          (let (p0,p1,p2) = fst initPhase2
344           in  ((p0,p1),p2)))
345{-
346real    0m0.974s
347user    0m0.812s
348sys     0m0.160s
349-}
350
351mainMonolithic1Generator :: IO ()
352mainMonolithic1Generator =
353   SV.writeFile "speed.f32"
354      (runGeneratorMonolithic size
355          (let (f0,f1,f2) = dl
356               (p0,p1,p2) = fst initPhase2
357           in  generator0Gen f0 p0 `mixGen`
358               generator0Gen f1 p1 `mixGen`
359               generator0Gen f2 p2))
360{-
361real    0m2.244s
362user    0m2.084s
363sys     0m0.152s
364-}
365
366mainMonolithic1GeneratorFold :: IO ()
367mainMonolithic1GeneratorFold =
368   SV.writeFile "speed.f32"
369      (runGeneratorMonolithic size
370          (let (f0,f1,f2) = dl
371               (p0,p1,p2) = fst initPhase2
372           in  foldl1 mixGen $
373               map (uncurry generator0Gen) $
374               [(f0,p0), (f1,p1), (f2,p2)]))
375{-
376real    0m3.006s
377user    0m2.816s
378sys     0m0.180s
379-}
380
381mainMonolithic2 :: IO ()
382mainMonolithic2 =
383   SV.writeFile "speed.f32"
384      (fst $ SV.unfoldrN size generator2 initPhase2)
385
386{-
387mainMonolithicStrict2 :: IO ()
388mainMonolithicStrict2 =
389   SV.writeFile "speed.f32"
390      (fst $ SVP.unfoldrStrictN size generator2 initPhase2)
391
392mainMonolithicTransition2 :: IO ()
393mainMonolithicTransition2 =
394   SV.writeFile "speed.f32"
395      (fst $ SVP.unfoldrTransitionN size
396          (\(pl,pr) -> (incPhase dl pl, incPhase dr pr))
397          (\(pl,pr) ->
398              Just (Stereo.cons (sawChorus pl) (sawChorus pr)))
399          initPhase2)
400-}
401
402
403mainChunky0 :: IO ()
404mainChunky0 =
405   SVL.writeFile "speed.f32"
406      (SVL.take size $
407       SVL.unfoldr SVL.defaultChunkSize generator0 0)
408{-
409real    0m0.428s
410user    0m0.292s
411sys     0m0.132s
412-}
413
414mainChunky0Builder :: IO ()
415mainChunky0Builder =
416   SVL.writeFile "speed.f32"
417      (SVL.take size $
418       runBuilder SVL.defaultChunkSize generator0 0)
419{-
420real    0m1.107s
421user    0m0.968s
422sys     0m0.140s
423-}
424
425mainChunky1 :: IO ()
426mainChunky1 =
427   SVL.writeFile "speed.f32"
428      (SVL.take size $
429       SVL.unfoldr SVL.defaultChunkSize generator1 (fst initPhase2))
430{-
431real    0m0.938s
432user    0m0.812s
433sys     0m0.116s
434-}
435
436mainChunky1MixFlat :: IO ()
437mainChunky1MixFlat =
438   SVL.writeFile "speed.f32"
439      (let (f0,f1,f2) = dl
440           (p0,p1,p2) = fst initPhase2
441       in  SVL.take size $
442           tone0 f0 p0 `mixVec`
443           tone0 f1 p1 `mixVec`
444           tone0 f2 p2)
445{-
446real    0m3.932s
447user    0m2.112s
448sys     0m0.156s
449-}
450
451mainChunky1MixFold :: IO ()
452mainChunky1MixFold =
453   SVL.writeFile "speed.f32"
454      (let (f0,f1,f2) = dl
455           (p0,p1,p2) = fst initPhase2
456       in  SVL.take size $
457           foldl1 mixVec $
458           map (uncurry tone0) $
459           [(f0,p0), (f1,p1), (f2,p2)])
460{-
461real    0m1.611s
462user    0m1.476s
463sys     0m0.108s
464-}
465
466mainChunky2 :: IO ()
467mainChunky2 =
468   SVL.writeFile "speed.f32"
469      (SVL.take size $
470       SVL.unfoldr SVL.defaultChunkSize generator2 initPhase2)
471{-
472real    0m2.220s
473user    0m1.400s
474sys     0m0.192s
475-}
476
477main :: IO ()
478main =
479   mainMonolithic1GeneratorFold