157c05dc97dfdb4517188b32ad0f8eff189532ba
[nofib.git] / shootout / fannkuch-redux / Main.hs
1 {- The Computer Language Benchmarks Game
2 http://benchmarksgame.alioth.debian.org/
3 contributed by Louis Wasserman
4
5 This should be compiled with:
6 -threaded -O2 -fexcess-precision -fasm
7 and run with:
8 +RTS -N<number of cores> -RTS <input>
9 -}
10
11 import Control.Concurrent
12 import Control.Monad
13 import System.Environment
14 import Foreign hiding (rotate)
15 import Data.Semigroup
16
17 type Perm = Ptr Word8
18
19 data F = F {-# UNPACK #-} !Int {-# UNPACK #-} !Int
20
21 instance Semigroup F where
22 F s1 m1 <> F s2 m2 = F (s1 + s2) (max m1 m2)
23
24 instance Monoid F where
25 mempty = F 0 0
26 mappend = (<>)
27
28 incPtr = (`advancePtr` 1)
29 decPtr = (`advancePtr` (-1))
30
31 flop :: Int -> Perm -> IO ()
32 flop k xs = flopp xs (xs `advancePtr` k)
33 where flopp i j = when (i < j) $ swap i j >> flopp (incPtr i) (decPtr j)
34 swap i j = do
35 a <- peek i
36 b <- peek j
37 poke j a
38 poke i b
39
40 flopS :: Perm -> (Int -> IO a) -> IO a
41 flopS !xs f = do
42 let go !acc = do
43 k <- peekElemOff xs 0
44 if k == 0 then f acc else flop (fromIntegral k) xs >> go (acc+1)
45 go 0
46
47 increment :: Ptr Word8 -> Ptr Word8 -> IO ()
48 increment !p !ct = do
49 first <- peekElemOff p 1
50 pokeElemOff p 1 =<< peekElemOff p 0
51 pokeElemOff p 0 first
52
53 let go !i !first = do
54 ci <- peekElemOff ct i
55 if fromIntegral ci < i then pokeElemOff ct i (ci+1) else do
56 pokeElemOff ct i 0
57 let !i' = i + 1
58 moveArray p (incPtr p) i'
59 pokeElemOff p i' first
60 go i' =<< peekElemOff p 0
61 go 1 first
62
63 genPermutations :: Int -> Int -> Int -> Ptr Word8 -> Ptr Word8 -> IO F
64 genPermutations !n !l !r !perm !count = allocaArray n $ \ destF -> do
65 let upd j !f run = do
66 p0 <- peekElemOff perm 0
67 if p0 == 0 then increment perm count >> run f else do
68 copyArray destF perm n
69 increment perm count
70 flopS destF $ \ flops ->
71 run (f `mappend` F (checksum j flops) flops)
72 let go j !f = if j >= r then return f else upd j f (go (j+1))
73 go l mempty
74 where checksum i f = if i .&. 1 == 0 then f else -f
75
76 facts :: [Int]
77 facts = scanl (*) 1 [1..12]
78
79 unrank :: Int -> Int -> (Ptr Word8 -> Ptr Word8 -> IO a) -> IO a
80 unrank !idx !n f = allocaArray n $ \ p -> allocaArray n $ \ count ->
81 allocaArray n $ \ pp -> do
82 mapM_ (\ i -> pokeElemOff p i (fromIntegral i)) [0..n-1]
83 let go i !idx = when (i >= 0) $ do
84 let fi = facts !! i
85 let (q, r) = idx `quotRem` fi
86 pokeElemOff count i (fromIntegral q)
87 copyArray pp p (i+1)
88 let go' j = when (j <= i) $ do
89 let jq = j + q
90 pokeElemOff p j =<< peekElemOff pp (if jq <= i then jq else jq - i - 1)
91 go' (j+1)
92 go' 0
93 go (i-1) r
94 go (n-1) idx
95 f p count
96
97 main = do
98 n <- fmap (read.head) getArgs
99 let fact = product [1..n]
100 let bk = fact `quot` 4
101 vars <- forM [0,bk..fact-1] $ \ ix -> do
102 var <- newEmptyMVar
103 forkIO (unrank ix n $ \ p -> genPermutations n ix (min fact (ix + bk)) p >=> putMVar var)
104 return var
105 F chksm mflops <- liftM mconcat (mapM takeMVar vars)
106 putStrLn $ (show chksm) ++ "\nPfannkuchen(" ++ (show n) ++ ") = " ++ (show $ mflops)