# HG changeset patch # User Daichi TOMA # Date 1390368209 -32400 # Node ID 9df5178e867c173149c19f945fe0be291865929c # Parent 74a4c7cdc50bb39c7528bf2ad166ff1d57ae1545# Parent d6e95f88cda95013d3230985388dee767665c200 merge diff -r 74a4c7cdc50b -r 9df5178e867c test/ParWrite.hs --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/test/ParWrite.hs Wed Jan 22 14:23:29 2014 +0900 @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Parallel +import Control.Parallel.Strategies +import Text.Printf +import Jungle +import Data.Maybe +import Data.List +import Data.Time.Clock +import qualified Data.ByteString.Lazy.Char8 as B +import Control.Exception +import System.Environment + +treeId :: String +treeId = "test_tree" + +treeId2 :: String +treeId2 = "hoge_tree" + +treeDepth :: Int +treeDepth = 5 + +lastPos :: [Int] +lastPos = last $ concatMap permutations . subsequences $ [0..treeDepth] + +writeCount :: Int +writeCount = 100000 + +main = do + jungle <- createTree createJungle treeId + jungle <- createTree jungle treeId2 + + node <- getRootNode jungle treeId + let + miniTree = testTree node treeDepth + + updateRootNode jungle treeId miniTree + + putStrLn $ show $ size miniTree + + t0 <- getCurrentTime + printTimeSince t0 + + sequence_ $ runEval $ dualWrite jungle + tree1 <- getRootNode jungle treeId + tree2 <- getRootNode jungle treeId2 + + print $ fromJust (getAttributes tree1 lastPos (show (writeCount-1))) + print $ fromJust (getAttributes tree2 lastPos (show (writeCount-1))) + + printTimeSince t0 + +-- parallel write for two trees by singleWrite +dualWrite jungle = do + x <- rpar (mapM runEval (singleWrite jungle writeCount treeId)) + y <- rpar (mapM runEval (singleWrite jungle writeCount treeId2)) + return [x, y] + +-- paralell write for single tree +singleWrite :: Jungle -> Int -> String -> [Eval (IO ())] +singleWrite jungle writeCount treeId = zipWith parApply (writeFunctions writeCount) (repeat jungle) + where + parApply f jungle = (rseq.runEval.rpar) (updateRootNodeWith f jungle treeId) + +-- generate functions to node update +writeFunctions :: Int -> [(Node -> Node)] +writeFunctions writeCount = map apply [0..writeCount] + where + apply x node = putAttribute node lastPos (show x) (B.pack . show $ x) + + +-- utils from ParRead + +testTree node h = foldl' (add h) node (concatMap permutations . subsequences $ [0..h]) + where + add w node h = addc node h w + +addc node h w = foldl' (add h) node [0..w] + where + add h node pos = addNewChildAt node h pos + +printTimeSince t0 = do + t1 <- getCurrentTime + printf "time: %.2fs\n" (realToFrac (diffUTCTime t1 t0) :: Double)