packman-0.3.0: Test/TestMThread.hs

-- testing serialisation with multiple concurrent threads

import GHC.Packing

import qualified Data.Array.IArray as A
import Control.Concurrent

import System.Environment
import System.IO
import System.Directory
import System.Exit

import qualified Data.ByteString as B

import Control.Exception

-- need a time-wasting function which allocates...
nfib :: Integer -> Integer
nfib 0 = 1
nfib 1 = 1
nfib n = let n1 = nfib (n-1)
             n2 = nfib (n-2)
         in 1 + 2*n1 + n2 - n1

fib :: Int -> Int 
fib x | x <= 1   = 1
      |otherwise = fib (x-1) + fib (x-2)

-- | duplicate data
duplicate :: a -> IO a
duplicate x = (deserialize =<< trySerialize x)

testeval :: (Show b) => String -> a -> (a -> b) -> String -> IO ()
testeval name dat f expected
    = do putStr name
         dat' <- duplicate dat
         let out = show (f dat')
         if (out /= expected)
         then do putStrLn (": FAILED\t unexpected " ++ out) 
                 error (name ++ " failed")
         else putStrLn (": OK\t" ++ out)

main
   = do hSetBuffering stdout NoBuffering

        args <- getArgs
        let u = if (null args) then 40 else read (head args)
            n = if length args < 2 then 10 else read (args!!1)

        putStrLn "Multithreaded test program for serialisation"
        let input  = [20..u]
            flt    =  filter (> 10000) 
            fibL   = (flt . map fib) input
-- [10946,17711,28657,46368,75025,121393,196418,317811,514229,832040,1346269]

        putStrLn "normal evaluation (take 3), should be \n[10946,17711,28657]"
        putStrLn (show $ take 3 fibL)

        let doThread i = 
                do v <- newEmptyMVar
                   -- note that all threads use fibL. Many calls to
                   -- trySerialize will block on blackholes (the core
                   -- operation will block and retry)
                   forkIO (do testeval (show i)
                                       (cycle fibL) (!!i)
                                       (show (fibL!!(i `mod` length fibL)))
                              putMVar v ())
                   return v
        vs <- mapM doThread [0..n-1]

        putStrLn "forked, waiting"
        mapM_ takeMVar vs
        putStrLn "done"
{-

        let f2 x y = fib (x+y)
        testeval "packing a function (2 arg.s)" f2 
                     (\f -> (take 3 . flt . map (f 0)) input)
                     "[10946,17711,28657]"

        let f3 x a b c y d = head $ map (map fib) 
                             [[(x+a+b+c+d)-const .. (y+a+b+c+d)-const ]]
            const  = head fibL - 1
            f3'    = f3 (head fibL) 0 0 
        const `seq` f3' `seq` 
         testeval "packing a list function (2 arg.s, 1 supplied)"
                  f3' (\f -> take 3 (flt (f 0 (u+const) 0)))
                  "[10946,17711,28657]"

        putStrLn "DONE"

        let n    = max 10 u
            size = 3*u -- default 120
            arr :: A.Array Int Int
            arr  = A.array (0,size-1)
                   [ (i,i) | i <- [0..size-1] ]
            output = A.amap (2*) arr

        -- output some of the original elements
        putStrLn $ show $ take n $ A.elems arr

        testeval "packing an unevaluated array"
                 output (take n . A.elems)
                 (show (take n [0,2..]))

-}