[commit: nofib] master: Add the fannkuch-redux shootout benchmark (ee93adf)
Johan Tibell
johan.tibell at gmail.com
Tue Feb 5 20:00:55 CET 2013
Repository : ssh://darcs.haskell.org//srv/darcs/nofib
On branch : master
http://hackage.haskell.org/trac/ghc/changeset/ee93adf1b0538c3ef9cbfd08f408cfe55d07cc1b
>---------------------------------------------------------------
commit ee93adf1b0538c3ef9cbfd08f408cfe55d07cc1b
Author: Johan Tibell <johan.tibell at gmail.com>
Date: Tue Feb 5 11:00:39 2013 -0800
Add the fannkuch-redux shootout benchmark
>---------------------------------------------------------------
.gitignore | 1 +
shootout/Makefile | 2 +-
shootout/fannkuch-redux/Main.hs | 103 +++++++++++++++++++++
shootout/{pidigits => fannkuch-redux}/Makefile | 8 +-
shootout/fannkuch-redux/fannkuch-redux.faststdout | 2 +
shootout/fannkuch-redux/fannkuch-redux.slowstdout | 2 +
shootout/fannkuch-redux/fannkuch-redux.stdout | 2 +
7 files changed, 115 insertions(+), 5 deletions(-)
diff --git a/.gitignore b/.gitignore
index bf0eebb..c25cc51 100644
--- a/.gitignore
+++ b/.gitignore
@@ -51,6 +51,7 @@ real/scs/scs
real/symalg/symalg
real/veritas/veritas
+shootout/fannkuch-redux/fannkuck-redux
shootout/pidigits/pidigits
spectral/ansi/ansi
diff --git a/shootout/Makefile b/shootout/Makefile
index 45ed28e..406998d 100644
--- a/shootout/Makefile
+++ b/shootout/Makefile
@@ -1,7 +1,7 @@
TOP = ..
include $(TOP)/mk/boilerplate.mk
-SUBDIRS = pidigits
+SUBDIRS = fannkuch-redux pidigits
include $(TOP)/mk/target.mk
diff --git a/shootout/fannkuch-redux/Main.hs b/shootout/fannkuch-redux/Main.hs
new file mode 100644
index 0000000..d115350
--- /dev/null
+++ b/shootout/fannkuch-redux/Main.hs
@@ -0,0 +1,103 @@
+{- The Computer Language Benchmarks Game
+ http://benchmarksgame.alioth.debian.org/
+ contributed by Louis Wasserman
+
+ This should be compiled with:
+ -threaded -O2 -fexcess-precision -fasm
+ and run with:
+ +RTS -N<number of cores> -RTS <input>
+-}
+
+import Control.Concurrent
+import Control.Monad
+import System.Environment
+import Foreign hiding (rotate)
+import Data.Monoid
+
+type Perm = Ptr Word8
+
+data F = F {-# UNPACK #-} !Int {-# UNPACK #-} !Int
+
+instance Monoid F where
+ mempty = F 0 0
+ F s1 m1 `mappend` F s2 m2 = F (s1 + s2) (max m1 m2)
+
+incPtr = (`advancePtr` 1)
+decPtr = (`advancePtr` (-1))
+
+flop :: Int -> Perm -> IO ()
+flop k xs = flopp xs (xs `advancePtr` k)
+ where flopp i j = when (i < j) $ swap i j >> flopp (incPtr i) (decPtr j)
+ swap i j = do
+ a <- peek i
+ b <- peek j
+ poke j a
+ poke i b
+
+flopS :: Perm -> (Int -> IO a) -> IO a
+flopS !xs f = do
+ let go !acc = do
+ k <- peekElemOff xs 0
+ if k == 0 then f acc else flop (fromIntegral k) xs >> go (acc+1)
+ go 0
+
+increment :: Ptr Word8 -> Ptr Word8 -> IO ()
+increment !p !ct = do
+ first <- peekElemOff p 1
+ pokeElemOff p 1 =<< peekElemOff p 0
+ pokeElemOff p 0 first
+
+ let go !i !first = do
+ ci <- peekElemOff ct i
+ if fromIntegral ci < i then pokeElemOff ct i (ci+1) else do
+ pokeElemOff ct i 0
+ let !i' = i + 1
+ moveArray p (incPtr p) i'
+ pokeElemOff p i' first
+ go i' =<< peekElemOff p 0
+ go 1 first
+
+genPermutations :: Int -> Int -> Int -> Ptr Word8 -> Ptr Word8 -> IO F
+genPermutations !n !l !r !perm !count = allocaArray n $ \ destF -> do
+ let upd j !f run = do
+ p0 <- peekElemOff perm 0
+ if p0 == 0 then increment perm count >> run f else do
+ copyArray destF perm n
+ increment perm count
+ flopS destF $ \ flops ->
+ run (f `mappend` F (checksum j flops) flops)
+ let go j !f = if j >= r then return f else upd j f (go (j+1))
+ go l mempty
+ where checksum i f = if i .&. 1 == 0 then f else -f
+
+facts :: [Int]
+facts = scanl (*) 1 [1..12]
+
+unrank :: Int -> Int -> (Ptr Word8 -> Ptr Word8 -> IO a) -> IO a
+unrank !idx !n f = allocaArray n $ \ p -> allocaArray n $ \ count ->
+ allocaArray n $ \ pp -> do
+ mapM_ (\ i -> pokeElemOff p i (fromIntegral i)) [0..n-1]
+ let go i !idx = when (i >= 0) $ do
+ let fi = facts !! i
+ let (q, r) = idx `quotRem` fi
+ pokeElemOff count i (fromIntegral q)
+ copyArray pp p (i+1)
+ let go' j = when (j <= i) $ do
+ let jq = j + q
+ pokeElemOff p j =<< peekElemOff pp (if jq <= i then jq else jq - i - 1)
+ go' (j+1)
+ go' 0
+ go (i-1) r
+ go (n-1) idx
+ f p count
+
+main = do
+ n <- fmap (read.head) getArgs
+ let fact = product [1..n]
+ let bk = fact `quot` 4
+ vars <- forM [0,bk..fact-1] $ \ ix -> do
+ var <- newEmptyMVar
+ forkIO (unrank ix n $ \ p -> genPermutations n ix (min fact (ix + bk)) p >=> putMVar var)
+ return var
+ F chksm mflops <- liftM mconcat (mapM takeMVar vars)
+ putStrLn $ (show chksm) ++ "\nPfannkuchen(" ++ (show n) ++ ") = " ++ (show $ mflops)
diff --git a/shootout/pidigits/Makefile b/shootout/fannkuch-redux/Makefile
similarity index 64%
copy from shootout/pidigits/Makefile
copy to shootout/fannkuch-redux/Makefile
index c84f48a..facb262 100644
--- a/shootout/pidigits/Makefile
+++ b/shootout/fannkuch-redux/Makefile
@@ -2,10 +2,10 @@ TOP = ../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/target.mk
-FAST_OPTS = 10000
-NORM_OPTS = 10000
-SLOW_OPTS = 10000
+FAST_OPTS = 10
+NORM_OPTS = 11
+SLOW_OPTS = 12 # official shootout setting
# The benchmark game also uses -fllvm, which we can't since it might
# not be available on the developer's machine.
-HC_OPTS += -O2
+HC_OPTS += -XBangPatterns -O2
diff --git a/shootout/fannkuch-redux/fannkuch-redux.faststdout b/shootout/fannkuch-redux/fannkuch-redux.faststdout
new file mode 100644
index 0000000..16353a6
--- /dev/null
+++ b/shootout/fannkuch-redux/fannkuch-redux.faststdout
@@ -0,0 +1,2 @@
+73196
+Pfannkuchen(10) = 38
diff --git a/shootout/fannkuch-redux/fannkuch-redux.slowstdout b/shootout/fannkuch-redux/fannkuch-redux.slowstdout
new file mode 100644
index 0000000..adf77d7
--- /dev/null
+++ b/shootout/fannkuch-redux/fannkuch-redux.slowstdout
@@ -0,0 +1,2 @@
+3968050
+Pfannkuchen(12) = 65
diff --git a/shootout/fannkuch-redux/fannkuch-redux.stdout b/shootout/fannkuch-redux/fannkuch-redux.stdout
new file mode 100644
index 0000000..fc0c78f
--- /dev/null
+++ b/shootout/fannkuch-redux/fannkuch-redux.stdout
@@ -0,0 +1,2 @@
+556355
+Pfannkuchen(11) = 51
More information about the ghc-commits
mailing list