flat-mcmc

commit f5e22006f136e705e999535dd1ecf2cd7a03c9a1
parent 9817fda834e3e02e82776c9e22e75f8e72de260b
Author: Jared Tobin <jared@jtobin.ca>
Date:   Mon, 28 Nov 2016 21:24:07 +1300

Use 'sparks' scheduler from monad-par.

The 'direct' scheduler was throwing MVar blocked errors.

Diffstat:
M
flat-mcmc.cabal
 | 
12
++++++------
M
lib/Numeric/MCMC/Flat.hs
 | 
16
++++++++--------
M
src/Main.hs
 | 
4
++--
M
stack.yaml
 | 
2
+-

4 files changed, 17 insertions(+), 17 deletions(-)
diff --git a/flat-mcmc.cabal b/flat-mcmc.cabal
@@ -1,5 +1,5 @@
 name:                flat-mcmc
-version:             1.2.2
+version:             1.3.0
 synopsis:            Painless general-purpose sampling.
 homepage:            https://github.com/jtobin/flat-mcmc
 license:             MIT
@@ -59,10 +59,10 @@ library
     , monad-par        >= 0.3.4.7 && < 1
     , monad-par-extras >= 0.3.3 && < 1
     , mwc-probability  >= 1.0.1 && < 2
-    , pipes            >  4     && < 5
-    , primitive
-    , text
-    , transformers
+    , pipes            >= 4     && < 5
+    , primitive        >= 0.6   && < 1
+    , text             >= 1.2   && < 2
+    , transformers     >= 0.2   && < 0.6
     , vector           >= 0.10  && < 1
 
 Test-suite rosenbrock
@@ -94,7 +94,7 @@ executable bnn-example
   main-is:             Main.hs
   default-language:    Haskell2010
   ghc-options:
-    -rtsopts -threaded
+    -O2 -Wall -rtsopts -threaded
   build-depends:
       base
     , flat-mcmc
diff --git a/lib/Numeric/MCMC/Flat.hs b/lib/Numeric/MCMC/Flat.hs
@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-type-defaults #-}
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 
@@ -39,8 +40,8 @@ module Numeric.MCMC.Flat (
 
 import Control.Monad (replicateM)
 import Control.Monad.Par (NFData)
-import Control.Monad.Par.Scheds.Direct hiding (put, get)
 import Control.Monad.Par.Combinator (parMap)
+import Control.Monad.Par.Scheds.Sparks hiding (get)
 import Control.Monad.Primitive (PrimMonad, PrimState, RealWorld)
 import Control.Monad.Trans.State.Strict (get, put, execStateT)
 import Data.Monoid
@@ -104,8 +105,8 @@ acceptProb target particle proposal z =
 {-# INLINE acceptProb #-}
 
 move :: Target Particle -> Particle -> Particle -> Double -> Double -> Particle
-move target p0 p1 z zc =
-  let proposal = stretch p0 p1 z
+move target !p0 p1 z zc =
+  let !proposal = stretch p0 p1 z
       pAccept  = acceptProb target p0 proposal z
   in  if   zc <= min 1 (exp pAccept)
       then proposal
@@ -122,17 +123,16 @@ execute
 execute target e0 e1 n = do
   zs  <- replicateM n symmetric
   zcs <- replicateM n uniform
-  vjs <- replicateM n (uniformR (1, n))
+  js  <- U.replicateM n (uniformR (1, n))
 
   let granularity = truncate (fromIntegral n / 2)
 
-      js      = U.fromList vjs
       w0 k    = e0 `V.unsafeIndex` pred k
       w1 k ks = e1 `V.unsafeIndex` pred (ks `U.unsafeIndex` pred k)
 
 
       worker (k, z, zc) = move target (w0 k) (w1 k js) z zc
-      result = runPar $
+      !result = runPar $
         parMapChunk granularity worker (zip3 [1..n] zs zcs)
 
   return $! V.fromList result
@@ -151,8 +151,8 @@ flat = do
       e1   = V.unsafeSlice n n chainPosition
   result0 <- lift (execute chainTarget e0 e1 n)
   result1 <- lift (execute chainTarget e1 result0 n)
-  let ensemble = V.concat [result0, result1]
-  put (Chain chainTarget ensemble)
+  let !ensemble = V.concat [result0, result1]
+  put $! (Chain chainTarget ensemble)
 {-# INLINE flat #-}
 
 chain :: PrimMonad m => Chain -> Gen (PrimState m) -> Producer Chain m ()
diff --git a/src/Main.hs b/src/Main.hs
@@ -3,7 +3,7 @@
 module Main where
 
 import Numeric.MCMC.Flat
-import qualified Data.Vector.Unboxed as U (Vector, toList, fromList)
+import qualified Data.Vector.Unboxed as U (toList, fromList)
 import qualified Data.Vector as V (fromList)
 
 bnn :: Particle -> Double
@@ -19,5 +19,5 @@ ensemble = V.fromList [
   ]
 
 main :: IO ()
-main = withSystemRandom . asGenIO $ mcmc 1000 ensemble bnn
+main = withSystemRandom . asGenIO $ mcmc 10000 ensemble bnn
 
diff --git a/stack.yaml b/stack.yaml
@@ -2,4 +2,4 @@ flags: {}
 packages:
   - '.'
 extra-deps: []
-resolver: lts-7.0
+resolver: lts-7.9