Skip to content

Commit

Permalink
Added nofib benchmark "coins". The performance is comparable to Versi…
Browse files Browse the repository at this point in the history 
…on 7

on Harpertown windows.
  • Loading branch information
@cchen15
cchen15 committed Mar 18, 2011
1 parent 0882173 commit fbb63bf
Showing 1 changed file with 240 additions and 0 deletions.
240 changes: 240 additions & 0 deletions examples/coins/coins.hs
View file
@@ -0,0 +1,240 @@
{-# LANGUAGE BangPatterns #-}

import Data.List
import System.Environment
import Control.Parallel
import Control.Parallel.Strategies
import Control.Applicative
import Control.Monad.Par

-- Rough results, GHC 6.13: (val=777)
-- V1 (SDM): 2.2s
-- V2 (SDM): 2.7s
-- V3 (SDM, parallel): 1.0s on 7 cores
-- V4 (original): got bored waiting
-- V5 (HWL assoc): 5.2s
-- V6 (SDM, Int result): 0.9s
-- V7 (SDM, parallel): 0.2s on 7 cores

-----------------------------------------------------------------------------
-- Version 1: returns results as a list of list of coins

payL :: Int -> [(Int,Int)] -> [Int] -> [[Int]]
payL 0 coins acc = [acc]
payL _ [] acc = []
payL val ((c,q):coins) acc
| c > val = payL val coins acc
| otherwise = left ++ right
where
left = payL (val - c) coins' (c:acc)
right = payL val coins acc

coins' | q == 1 = coins
| otherwise = (c,q-1) : coins

-----------------------------------------------------------------------------
-- Version 2: uses a custom AList type to avoid repeated appends

-- The idea here is that by avoiding the append we might be able to
-- parallelise this more easily by just forcing evaluation to WHNF at
-- each level. I haven't parallelised this version yet, though (V5
-- below is much easier) --SDM

data AList a = ANil | ASing a | Append (AList a) (AList a)

lenA :: AList a -> Int
lenA ANil = 0
lenA (ASing _) = 1
lenA (Append l r) = lenA l + lenA r

append ANil r = r
append l ANil = l -- **
append l r = Append l r

-- making append less strict (omit ** above) can make the algorithm
-- faster in sequential mode, because it runs in constant space.
-- However, ** helps parallelism.

payA :: Int -> [(Int,Int)] -> [Int] -> AList [Int]
payA 0 coins acc = ASing acc
payA _ [] acc = ANil
payA val ((c,q):coins) acc
| c > val = payA val coins acc
| otherwise = append left right -- strict in l, maybe strict in r
where
left = payA (val - c) coins' (c:acc)
right = payA val coins acc
coins' | q == 1 = coins
| otherwise = (c,q-1) : coins

-----------------------------------------------------------------------------
-- Version 3: parallel version of V2

payA_par :: Int -> Int -> [(Int,Int)] -> [Int] -> AList [Int]
payA_par 0 val coins acc = payA val coins acc
payA_par _ 0 coins acc = ASing acc
payA_par _ _ [] acc = ANil
payA_par depth val ((c,q):coins) acc
| c > val = payA_par depth val coins acc
| otherwise = res

where
res = unEval $ pure append <*> rpar left <*> rwhnf right

left = payA_par (if q == 1 then (depth-1) else depth) (val - c) coins' (c:acc)
right = payA_par (depth-1) val coins acc

coins' | q == 1 = coins
| otherwise = (c,q-1) : coins

-----------------------------------------------------------------------------
-- Version 4: original list-of-list version (very slow)

pay :: Int -> Int -> [Int] -> [Int] -> [[Int]]
pay _ 0 coins accum = [accum]
pay _ val [] _ = []
pay pri val coins accum =
res
where --
coins' = dropWhile (>val) coins
coin_vals = nub coins'
res = concat ( map
( \ c -> let
new_coins =
((dropWhile (>c) coins')\\[c])
in
pay (pri-1)
(val-c)
new_coins
(c:accum)
)
coin_vals )


-----------------------------------------------------------------------------
-- Version 5: assoc-list version (by HWL?)

-- assoc-list-based version; still multiple list traversals
pay1 :: Int -> Int -> [(Int,Int)] -> [(Int,Int)] -> [[(Int,Int)]]
pay1 _ 0 coins accum = [accum]
pay1 _ val [] _ = []
pay1 pri val coins accum = res
where --
coins' = dropWhile ((>val) . fst) coins
res = concat (
map
( \ (c,q) -> let
-- several traversals
new_coins =
filter (not . (==0) . snd) $
map (\ x'@(c',q') -> if c==c' then (c',q'-1) else x') $
dropWhile ((>c) . fst) $
coins'
new_accum =
map (\ x'@(c',q') -> if c==c' then (c',q'+1) else x') accum
in
pay1 (pri-1)
(val-c)
new_coins
new_accum
)
coins' )

-----------------------------------------------------------------------------
-- Version 6: just return the number of results, not the results themselves

payN :: Int -> [(Int,Int)] -> Int
payN 0 coins = 1
payN _ [] = 0
payN val ((c,q):coins)
| c > val = payN val coins
| otherwise = left + right
where
left = payN (val - c) coins'
right = payN val coins

coins' | q == 1 = coins
| otherwise = (c,q-1) : coins

-----------------------------------------------------------------------------
-- Version 7: parallel version of payN

payN_par :: Int -> Int -> [(Int,Int)] -> Int
payN_par 0 val coins = payN val coins
payN_par _ 0 coins = 1
payN_par _ _ [] = 0
payN_par depth val ((c,q):coins)
| c > val = payN_par depth val coins
| otherwise = res

where
res = right `par` left `pseq` left + right

left = payN_par (if q == 1 then (depth-1) else depth) (val - c) coins'
right = payN_par (depth-1) val coins

coins' | q == 1 = coins
| otherwise = (c,q-1) : coins

-----------------------------------------------------------------------------

-----------------------------------------------------------------------------
-- Version 8: monad-par version of payN
-- Competitive with Version 7.

payN_mp :: Int -> Int -> [(Int,Int)] -> Int
payN_mp depth val coins =
runPar $
payN_mpM depth val coins

payN_mpM :: Int -> Int -> [(Int,Int)] -> Par Int
payN_mpM 0 val coins = return $ payN val coins
payN_mpM _ 0 coins = return 1
payN_mpM _ _ [] = return 0
payN_mpM depth val ((c,q):coins)
| c > val = payN_mpM depth val coins
| otherwise = res

where
res =
do lv <- spawn $ left
r <- right
l <- get lv
return (l + r)

left = payN_mpM (if q == 1 then (depth-1) else depth) (val - c) coins'
right = payN_mpM (depth-1) val coins

coins' | q == 1 = coins
| otherwise = (c,q-1) : coins

-----------------------------------------------------------------------------


-- driver

main = do
let vals = [250, 100, 25, 10, 5, 1]
-- let quants = [1, 3, 2, 5, 7, 12] -- small setup
-- let quants = [5, 8, 8, 9, 12, 17] -- std setup
let quants = [55, 88, 88, 99, 122, 177] -- large setup

let coins = concat (zipWith replicate quants vals)
coins1 = zip vals quants

[n, arg] <- fmap (fmap read) getArgs

case n of
-- sequential, list of results
1 -> print $ length $ payL arg coins1 []
-- sequential, append-list of results
2 -> print $ lenA $ payA arg coins1 []
-- parallel, append-list of results
3 -> print $ lenA $ payA_par 4 arg coins1 []

4 -> print $ length (pay 0 arg coins [])
5 -> print $ length (pay1 0 arg coins1 (map (\(c,q) -> (c,0)) coins1))
6 -> print $ payN arg coins1
7 -> print $ payN_par 4 arg coins1
8 -> print $ payN_mp 4 arg coins1

0 comments on commit fbb63bf

Please sign in to comment.