Solved memory leak issue when Jack is connected. There still is a leak when Jack...

diff --git a/CLOC.md b/CLOC.md
index 41b0246da7d905fbbcdf70c3326938e22a6cbcdf..ad587fed271f8bbb2179083d941a56a4469eeb33 100644 (file)
--- a/CLOC.md
+++ b/CLOC.md
@@ -1,9 +1,9 @@
 
-cloc|https://github.com/AlDanial/cloc v 1.66  T=0.09 s (299.7 files/s, 25153.0 lines/s)
+cloc|github.com/AlDanial/cloc v 1.70  T=0.04 s (502.7 files/s, 62473.3 lines/s)
 --- | ---
 
 Language|files|blank|comment|code
 :-------|-------:|-------:|-------:|-------:
-Haskell|26|341|439|1402
+Haskell|21|384|371|1855
 --------|--------|--------|--------|--------
-SUM:|26|341|439|1402
+SUM:|21|384|371|1855

diff --git a/RMCA.cabal b/RMCA.cabal
index a66e57124796263ff14d84dfa34d5ac350760bad..11dd69a3f6f17d87089bb56e952e2ff91c382920 100644 (file)
--- a/RMCA.cabal
+++ b/RMCA.cabal
@@ -19,7 +19,7 @@ data-files:          img/*.png, img/*.svg
 
 executable RMCA
   main-is:             RMCA/Main.hs
-  -- other-modules:
+  other-modules:       Paths_RMCA
   other-extensions:    MultiParamTypeClasses
                      , ScopedTypeVariables
                      , Arrows
@@ -47,4 +47,41 @@ executable RMCA
   hs-source-dirs:      src
   build-tools:         hsc2hs
   default-language:    Haskell2010
-  ghc-options:         -O2 -threaded -W
\ No newline at end of file
+  ghc-options:         -O2 -threaded -W
+
+-- executable RMCA.prof
+--   main-is:             RMCA/Main.hs
+--   other-modules:       Paths_RMCA
+--   other-extensions:    MultiParamTypeClasses
+--                      , ScopedTypeVariables
+--                      , Arrows
+--                      , FlexibleInstances
+--                      , TypeSynonymInstances
+--                      , FlexibleContexts
+--                      , GeneralizedNewtypeDeriving
+--   build-depends:       base >=4.8 && <4.10
+--                      , array >=0.5 && <0.6
+--                      , cairo >=0.13 && <0.14
+--                      , keera-hails-reactivevalues >=0.2 && <0.3
+--                      , Yampa >=0.10 && <0.11
+--                      , gtk-helpers >=0.0 && <0.1
+--                      , gtk >=0.14 && <0.15
+--                      , keera-hails-reactive-gtk >=0.3 && <0.4
+--                      , keera-hails-reactive-yampa >=0.0 && <0.1
+--                      , containers >=0.5 && <0.6
+--                      , jack >=0.7 && <0.8
+--                      , midi >=0.2 && <0.3
+--                      , explicit-exception >=0.1 && <0.2
+--                      , transformers >=0.4 && <0.6
+--                      , event-list >=0.1 && <0.2
+--                      , keera-callbacks >=0.1 && <0.2
+--                      , glib >=0.13 && <0.14
+--   hs-source-dirs:      src
+--   build-tools:         hsc2hs
+--   default-language:    Haskell2010
+--   ghc-options:         -O2
+--                        -threaded
+--                        -W
+--                        -fprof-auto
+--                        -prof
+--                        "-with-rtsopts=-p -s -h -i0.1"

diff --git a/src/RMCA/Auxiliary.hs b/src/RMCA/Auxiliary.hs
index d201b1b071a78f0f42d39ac10399ad4c03ced629..e95dc335e371e39cb6711721e12bf631138c20ab 100644 (file)
--- a/src/RMCA/Auxiliary.hs
+++ b/src/RMCA/Auxiliary.hs
@@ -30,7 +30,7 @@ fromMaybeM_ = fromMaybe (return ())
 stepBack :: SF a (Maybe a)
 stepBack = sscan f (Nothing, Nothing) >>^ snd
   where f :: (Maybe a, Maybe a) -> a -> (Maybe a, Maybe a)
-        f (Nothing,Nothing) x' = (Just x', Nothing)
+        f (Nothing,_) x' = (Just x', Nothing)
         f (Just x, _) x' = (Just x', Just x)
 
 -- Just like stepBack but the output value is always defined and is
@@ -47,10 +47,18 @@ onChange = proc x -> do
   x' <- stepBack -< x
   let makeEvent x x'
         | isNothing x' = NoEvent
-        | isJust x' = let x'' = fromJust x' in
+        | otherwise = let x'' = fromJust x' in
             if x'' == x then NoEvent else Event x
   returnA -< makeEvent x x'
 
+varFreqSine :: SF DTime Double
+varFreqSine = sin ^<< (2*pi*) ^<< integral <<^ (1/)
+
+repeatedlyS :: a -> SF DTime (Event a)
+repeatedlyS x = proc dt -> do
+  (sw,sw') <- (identity &&& stepBack) <<< varFreqSine -< 2*dt
+  edgeTag x <<^ maybe True (< 0) -< (*) <$> return sw <*> sw'
+
 -- Similar to onChange but contains its initial value in the first
 -- event.
 onChange' :: (Eq a) => SF a (Event a)
@@ -59,7 +67,7 @@ onChange' = proc x -> do
   -- If it's the first value, throw an Event, else behave like onChange.
   let makeEvent x x'
         | isNothing x' = Event x
-        | isJust x' = let x'' = fromJust x' in
+        | otherwise = let x'' = fromJust x' in
             if x'' == x then NoEvent else Event x
   returnA -< makeEvent x x'
 

diff --git a/src/RMCA/Global/Clock.hs b/src/RMCA/Global/Clock.hs
index a6f13e07c2aaa85957123c01a72a0fff4c615b3d..627f3d87afb1e1ba4107ccec3b2d34b3b57b9278 100644 (file)
--- a/src/RMCA/Global/Clock.hs
+++ b/src/RMCA/Global/Clock.hs
@@ -8,6 +8,7 @@ import FRP.Yampa
 import RMCA.Auxiliary
 import RMCA.Semantics
 
+{-
 -- The initial value is arbitrary but never appears because the switch
 -- is immediate.
 metronome :: SF Tempo (Event Beat)
@@ -18,6 +19,9 @@ metronome = switch (repeatedly (tempoToQNoteIvl 120) ()
         metronome' t = switch (repeatedly (tempoToQNoteIvl t) ()
                                &&&
                                onChange) metronome'
+-}
+metronome :: SF Tempo (Event Beat)
+metronome = repeatedlyS () <<^ tempoToQNoteIvl
 
 -- Tempo is the number of quarter notes per minute.
 tempoToQNoteIvl :: Tempo -> DTime

diff --git a/src/RMCA/Layer/Board.hs b/src/RMCA/Layer/Board.hs
index 2c3b5f1439cd257fbae024a6b2e35f51e603bc5e..c5755da97fdd9cf0cb76fbb07e8912b6276c5f55 100644 (file)
--- a/src/RMCA/Layer/Board.hs
+++ b/src/RMCA/Layer/Board.hs
@@ -9,24 +9,6 @@ import RMCA.Semantics
 
 data BoardRun = BoardStart | BoardStop deriving Eq
 
-{-
--- The state of the board is described by the list of the playheads
--- and the different actions onto the board.
-boardAction :: SF ((Board, Layer, [PlayHead]), Event BeatNo)
-               (Event ([PlayHead], [Note]))
-boardAction = proc ((board, Layer { relPitch    = rp
-                                  , strength    = s
-                                  },ph), ebno) ->
-  arr $ fmap (uncurry5 advanceHeads)
-  -< ebno `tag` (board, fromEvent ebno, rp, s, ph)
-  --returnA -< traceShow e e
-
-boardSF :: SF (Board, Layer, [PlayHead], Tempo) (Event ([PlayHead], [Note]))
-boardSF = proc (board, l, ph, t) -> do
-  ebno <- layerMetronome -< (t, l)
-  boardAction -< ((board, l, ph), ebno)
--}
-
 singleBoard :: [PlayHead]
             -> SF (Board, Layer, Event BeatNo) (Event ([PlayHead], [Note]))
 singleBoard iPh = proc (board, Layer { relPitch = rp

diff --git a/src/RMCA/Layer/Layer.hs b/src/RMCA/Layer/Layer.hs
index 70045072c9a924e5d14b9117ac395b54cd6a014c..723d9df1f0a2189fca76776ebf377ae9a4ec6683 100644 (file)
--- a/src/RMCA/Layer/Layer.hs
+++ b/src/RMCA/Layer/Layer.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE Arrows #-}
+{-# LANGUAGE Arrows, TupleSections #-}
 
 module RMCA.Layer.Layer where
 
@@ -20,16 +20,11 @@ layerTempo :: SF (Tempo, Layer) LTempo
 layerTempo = proc (t, Layer { relTempo = r }) ->
   returnA -< floor $ r * fromIntegral t
 
--- The layer is modified after the beat as been
-layerMetronome' :: BeatNo -> SF (Tempo, Layer) (Event BeatNo)
-layerMetronome' b = proc (t, l@Layer { beatsPerBar = bpb }) -> do
-  eb <- metronome <<< layerTempo -< (t, l)
-  returnA -< eb `tag` nextBeatNo bpb b
-
+-- /!\ To be changed in the initialization of the bpb /!\
 layerMetronome :: SF (Tempo, Layer) (Event BeatNo)
-layerMetronome = layerMetronome'' 0
-  where layerMetronome'' no = dSwitch (layerMetronome' no >>^ dup)
-                              layerMetronome''
+layerMetronome = proc (t,l@Layer { beatsPerBar = bpb }) -> do
+  eb <- metronome <<< layerTempo -< (t,l)
+  accumBy (\bn bpb -> nextBeatNo bpb bn) 1 -< eb `tag` bpb
 
 layerRV :: CBMVar Layer -> ReactiveFieldReadWrite IO Layer
 layerRV mvar = ReactiveFieldReadWrite setter getter notifier