PageRenderTime 53ms CodeModel.GetById 20ms RepoModel.GetById 1ms app.codeStats 0ms

/hdph/src/Test/HdpH/sumeuler.hs

http://github.com/PatrickMaier/HdpH
Haskell | 334 lines | 234 code | 62 blank | 38 comment | 1 complexity | 0c898d7b45efd3389a4dc939d91b2ab1 MD5 | raw file
Possible License(s): BSD-3-Clause
  1. -- Sum of totients in HdpH
  2. --
  3. -- Author: Patrick Maier
  4. -----------------------------------------------------------------------------
  5. {-# LANGUAGE FlexibleInstances #-} -- req'd for some ToClosure instances
  6. {-# LANGUAGE TemplateHaskell #-} -- req'd for mkClosure, etc
  7. {-# OPTIONS_GHC -fno-warn-orphans #-}
  8. module Main where
  9. import Prelude
  10. import Control.Exception (evaluate)
  11. import Control.Monad (when, (<=<))
  12. import Data.List (stripPrefix)
  13. import Data.Functor ((<$>))
  14. import Data.List (transpose)
  15. import Data.Monoid (mconcat)
  16. import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
  17. import System.Environment (getArgs)
  18. import System.IO (stdout, stderr, hSetBuffering, BufferMode(..))
  19. import System.Random (mkStdGen, setStdGen)
  20. import Control.Parallel.HdpH
  21. (RTSConf(..), defaultRTSConf, updateConf,
  22. Par, runParIO,
  23. force, fork, spark, new, get, put, glob, rput,
  24. IVar, GIVar,
  25. Thunk(Thunk), Closure, unClosure, mkClosure,
  26. toClosure, ToClosure(locToClosure),
  27. static, StaticToClosure, staticToClosure,
  28. StaticDecl, declare, register, here)
  29. import qualified Control.Parallel.HdpH as HdpH (declareStatic)
  30. import Control.Parallel.HdpH.Dist (one)
  31. import Control.Parallel.HdpH.Strategies
  32. (parMapNF, parMapChunkedNF, parMapSlicedNF,
  33. ForceCC(locForceCC), StaticForceCC, staticForceCC)
  34. import qualified Control.Parallel.HdpH.Strategies as Strategies (declareStatic)
  35. -----------------------------------------------------------------------------
  36. -- Euler's totient function (for positive integers)
  37. totient :: Int -> Integer
  38. totient n = toInteger $ length $ filter (\ k -> gcd n k == 1) [1 .. n]
  39. -----------------------------------------------------------------------------
  40. -- sequential sum of totients
  41. sum_totient :: [Int] -> Integer
  42. sum_totient = sum . map totient
  43. -----------------------------------------------------------------------------
  44. -- parallel sum of totients; shared memory
  45. par_sum_totient_chunked :: Int -> Int -> Int -> Par Integer
  46. par_sum_totient_chunked lower upper chunksize =
  47. sum <$> (mapM get =<< (mapM fork_sum_euler $ chunked_list))
  48. where
  49. chunked_list = chunk chunksize [upper, upper - 1 .. lower] :: [[Int]]
  50. par_sum_totient_sliced :: Int -> Int -> Int -> Par Integer
  51. par_sum_totient_sliced lower upper slices =
  52. sum <$> (mapM get =<< (mapM fork_sum_euler $ sliced_list))
  53. where
  54. sliced_list = slice slices [upper, upper - 1 .. lower] :: [[Int]]
  55. fork_sum_euler :: [Int] -> Par (IVar Integer)
  56. fork_sum_euler xs = do v <- new
  57. fork $ force (sum_totient xs) >>= put v
  58. return v
  59. -----------------------------------------------------------------------------
  60. -- parallel sum of totients; distributed memory
  61. dist_sum_totient_chunked :: Int -> Int -> Int -> Par Integer
  62. dist_sum_totient_chunked lower upper chunksize = do
  63. sum <$> (mapM get_and_unClosure =<< (mapM spark_sum_euler $ chunked_list))
  64. where
  65. chunked_list = chunk chunksize [upper, upper - 1 .. lower] :: [[Int]]
  66. dist_sum_totient_sliced :: Int -> Int -> Int -> Par Integer
  67. dist_sum_totient_sliced lower upper slices = do
  68. sum <$> (mapM get_and_unClosure =<< (mapM spark_sum_euler $ sliced_list))
  69. where
  70. sliced_list = slice slices [upper, upper - 1 .. lower] :: [[Int]]
  71. spark_sum_euler :: [Int] -> Par (IVar (Closure Integer))
  72. spark_sum_euler xs = do
  73. v <- new
  74. gv <- glob v
  75. spark one $(mkClosure [| spark_sum_euler_abs (xs, gv) |])
  76. return v
  77. spark_sum_euler_abs :: ([Int], GIVar (Closure Integer)) -> Thunk (Par ())
  78. spark_sum_euler_abs (xs, gv) =
  79. Thunk $ force (sum_totient xs) >>= rput gv . toClosure
  80. get_and_unClosure :: IVar (Closure a) -> Par a
  81. get_and_unClosure = return . unClosure <=< get
  82. -----------------------------------------------------------------------------
  83. -- parallel sum of totients; distributed memory (using plain task farm)
  84. farm_sum_totient_chunked :: Int -> Int -> Int -> Par Integer
  85. farm_sum_totient_chunked lower upper chunksize =
  86. sum <$> parMapNF $(mkClosure [| sum_totient |]) chunked_list
  87. where
  88. chunked_list = chunk chunksize [upper, upper - 1 .. lower] :: [[Int]]
  89. farm_sum_totient_sliced :: Int -> Int -> Int -> Par Integer
  90. farm_sum_totient_sliced lower upper slices =
  91. sum <$> parMapNF $(mkClosure [| sum_totient |]) sliced_list
  92. where
  93. sliced_list = slice slices [upper, upper - 1 .. lower] :: [[Int]]
  94. -----------------------------------------------------------------------------
  95. -- parallel sum of totients; distributed memory (chunking/slicing task farms)
  96. chunkfarm_sum_totient :: Int -> Int -> Int -> Par Integer
  97. chunkfarm_sum_totient lower upper chunksize =
  98. sum <$> parMapChunkedNF chunksize $(mkClosure [| totient |]) list
  99. where
  100. list = [upper, upper - 1 .. lower] :: [Int]
  101. slicefarm_sum_totient :: Int -> Int -> Int -> Par Integer
  102. slicefarm_sum_totient lower upper slices =
  103. sum <$> parMapSlicedNF slices $(mkClosure [| totient |]) list
  104. where
  105. list = [upper, upper - 1 .. lower] :: [Int]
  106. -----------------------------------------------------------------------------
  107. -- chunking up lists; inverse of 'chunk n' is 'concat'
  108. chunk :: Int -> [a] -> [[a]]
  109. chunk _ [] = []
  110. chunk n xs = ys : chunk n zs where (ys,zs) = splitAt n xs
  111. -----------------------------------------------------------------------------
  112. -- slicing lists; inverse of 'slice n' is 'unslice'
  113. slice :: Int -> [a] -> [[a]]
  114. slice n = transpose . chunk n
  115. unslice :: [[a]] -> [a]
  116. unslice = concat . transpose
  117. -----------------------------------------------------------------------------
  118. -- Static declaration (just before 'main')
  119. -- Empty splice; TH hack to make all environment abstractions visible.
  120. $(return [])
  121. -- orphan ToClosure and ForceCC instances (unavoidably so)
  122. instance ToClosure Int where locToClosure = $(here)
  123. instance ToClosure [Int] where locToClosure = $(here)
  124. instance ToClosure Integer where locToClosure = $(here)
  125. instance ForceCC Integer where locForceCC = $(here)
  126. declareStatic :: StaticDecl
  127. declareStatic =
  128. mconcat
  129. [HdpH.declareStatic, -- declare Static deserialisers
  130. Strategies.declareStatic, -- from imported modules
  131. declare (staticToClosure :: StaticToClosure Int),
  132. declare (staticToClosure :: StaticToClosure [Int]),
  133. declare (staticToClosure :: StaticToClosure Integer),
  134. declare (staticForceCC :: StaticForceCC Integer),
  135. declare $(static 'spark_sum_euler_abs),
  136. declare $(static 'sum_totient),
  137. declare $(static 'totient)]
  138. -----------------------------------------------------------------------------
  139. -- initialisation, argument processing and 'main'
  140. -- time an IO action
  141. timeIO :: IO a -> IO (a, NominalDiffTime)
  142. timeIO action = do t0 <- getCurrentTime
  143. x <- action
  144. t1 <- getCurrentTime
  145. return (x, diffUTCTime t1 t0)
  146. -- initialize random number generator
  147. initrand :: Int -> IO ()
  148. initrand seed = do
  149. when (seed /= 0) $ do
  150. setStdGen (mkStdGen seed)
  151. -- parse runtime system config options (+ seed for random number generator)
  152. -- abort if there is an error
  153. parseOpts :: [String] -> IO (RTSConf, Int, [String])
  154. parseOpts args = do
  155. either_conf <- updateConf args defaultRTSConf
  156. case either_conf of
  157. Left err_msg -> error $ "parseOpts: " ++ err_msg
  158. Right (conf, []) -> return (conf, 0, [])
  159. Right (conf, arg':args') ->
  160. case stripPrefix "-rand=" arg' of
  161. Just s -> return (conf, read s, args')
  162. Nothing -> return (conf, 0, arg':args')
  163. -- parse (optional) arguments in this order:
  164. -- * version to run
  165. -- * lower bound for Euler's totient function
  166. -- * upper bound for Euler's totient function
  167. -- * size of chunks (evaluated sequentially)
  168. parseArgs :: [String] -> (Int, Int, Int, Int)
  169. parseArgs [] = (defVers, defLower, defUpper, defChunk)
  170. parseArgs (s:ss) =
  171. let go :: Int -> [String] -> (Int, Int, Int, Int)
  172. go v [] = (v, defLower, defUpper, defChunk)
  173. go v [s1] = (v, defLower, read s1, defChunk)
  174. go v [s1,s2] = (v, read s1, read s2, defChunk)
  175. go v (s1:s2:s3:_) = (v, read s1, read s2, read s3)
  176. in case stripPrefix "v" s of
  177. Just s' -> go (read s') ss
  178. Nothing -> go defVers (s:ss)
  179. defVers, defLower, defUpper, defChunk :: Int
  180. defVers = 7
  181. defLower = 1
  182. defUpper = 20000
  183. defChunk = 100
  184. main :: IO ()
  185. main = do
  186. hSetBuffering stdout LineBuffering
  187. hSetBuffering stderr LineBuffering
  188. register declareStatic
  189. opts_args <- getArgs
  190. (conf, seed, args) <- parseOpts opts_args
  191. let (version, lower, upper, gran_arg) = parseArgs args
  192. initrand seed
  193. case version of
  194. 0 -> do (x, t) <- timeIO $ evaluate
  195. (sum_totient [upper, upper - 1 .. lower])
  196. putStrLn $
  197. "{v0} sum $ map totient [" ++ show lower ++ ".." ++
  198. show upper ++ "] = " ++ show x ++
  199. " {runtime=" ++ show t ++ "}"
  200. 1 -> do (output, t) <- timeIO $ evaluate =<< runParIO conf
  201. (par_sum_totient_chunked lower upper gran_arg)
  202. case output of
  203. Just x -> putStrLn $
  204. "{v1, chunksize=" ++ show gran_arg ++ "} " ++
  205. "sum $ map totient [" ++ show lower ++ ".." ++
  206. show upper ++ "] = " ++ show x ++
  207. " {runtime=" ++ show t ++ "}"
  208. Nothing -> return ()
  209. 2 -> do (output, t) <- timeIO $ evaluate =<< runParIO conf
  210. (dist_sum_totient_chunked lower upper gran_arg)
  211. case output of
  212. Just x -> putStrLn $
  213. "{v2, chunksize=" ++ show gran_arg ++ "} " ++
  214. "sum $ map totient [" ++ show lower ++ ".." ++
  215. show upper ++ "] = " ++ show x ++
  216. " {runtime=" ++ show t ++ "}"
  217. Nothing -> return ()
  218. 3 -> do (output, t) <- timeIO $ evaluate =<< runParIO conf
  219. (farm_sum_totient_chunked lower upper gran_arg)
  220. case output of
  221. Just x -> putStrLn $
  222. "{v3, chunksize=" ++ show gran_arg ++ "} " ++
  223. "sum $ map totient [" ++ show lower ++ ".." ++
  224. show upper ++ "] = " ++ show x ++
  225. " {runtime=" ++ show t ++ "}"
  226. Nothing -> return ()
  227. 4 -> do (output, t) <- timeIO $ evaluate =<< runParIO conf
  228. (chunkfarm_sum_totient lower upper gran_arg)
  229. case output of
  230. Just x -> putStrLn $
  231. "{v4, chunksize=" ++ show gran_arg ++ "} " ++
  232. "sum $ map totient [" ++ show lower ++ ".." ++
  233. show upper ++ "] = " ++ show x ++
  234. " {runtime=" ++ show t ++ "}"
  235. Nothing -> return ()
  236. 5 -> do (output, t) <- timeIO $ evaluate =<< runParIO conf
  237. (par_sum_totient_sliced lower upper gran_arg)
  238. case output of
  239. Just x -> putStrLn $
  240. "{v5, slices=" ++ show gran_arg ++ "} " ++
  241. "sum $ map totient [" ++ show lower ++ ".." ++
  242. show upper ++ "] = " ++ show x ++
  243. " {runtime=" ++ show t ++ "}"
  244. Nothing -> return ()
  245. 6 -> do (output, t) <- timeIO $ evaluate =<< runParIO conf
  246. (dist_sum_totient_sliced lower upper gran_arg)
  247. case output of
  248. Just x -> putStrLn $
  249. "{v6, slices=" ++ show gran_arg ++ "} " ++
  250. "sum $ map totient [" ++ show lower ++ ".." ++
  251. show upper ++ "] = " ++ show x ++
  252. " {runtime=" ++ show t ++ "}"
  253. Nothing -> return ()
  254. 7 -> do (output, t) <- timeIO $ evaluate =<< runParIO conf
  255. (farm_sum_totient_sliced lower upper gran_arg)
  256. case output of
  257. Just x -> putStrLn $
  258. "{v7, slices=" ++ show gran_arg ++ "} " ++
  259. "sum $ map totient [" ++ show lower ++ ".." ++
  260. show upper ++ "] = " ++ show x ++
  261. " {runtime=" ++ show t ++ "}"
  262. Nothing -> return ()
  263. 8 -> do (output, t) <- timeIO $ evaluate =<< runParIO conf
  264. (slicefarm_sum_totient lower upper gran_arg)
  265. case output of
  266. Just x -> putStrLn $
  267. "{v8, slices=" ++ show gran_arg ++ "} " ++
  268. "sum $ map totient [" ++ show lower ++ ".." ++
  269. show upper ++ "] = " ++ show x ++
  270. " {runtime=" ++ show t ++ "}"
  271. Nothing -> return ()
  272. _ -> return ()