Multithreading-Benchmark: Haskell schlägt Java und Python
Seite 5: Nachtrag
Aufgrund der Diskussion im Forum haben wir die Autorin gebeten, uns die gesamten Haskell-Skripte zur Verfügung zu stellen. Sie betont, dass sämtliche Tests Konsolen-Ausgaben enthielten: "Wenn der Code keine Ausgaben enthielte, dann wären auch bei mir die Tests in 0.NIX durchgelaufen". Wie das folgende Bild verdeutlicht.
Im Folgenden nun die Skripte:
module MyCounter
(
countdown
, resetCounter
, decCounter
, decT
, loopCounter
, inc
, MAX(..)
, MIN(..)
, MyCounter(..)
, Countdown(..)
, Steps (..)
) where
import Control.Monad (forever)
import Control.Concurrent.STM
import Control.Concurrent.MVar
import Control.Concurrent (forkIO,threadDelay)
import System.Exit as Exit
import qualified Lib as Lib
data MyCounter = MyCounter Int deriving (Eq)
data Countdown = C MyCounter | M MAX | N MIN deriving (Show,Eq)
data MAX = MAX Int deriving (Eq)
data MIN = MIN Int deriving (Eq)
data Steps = Steps Int deriving (Eq)
type CounterVar = TVar Countdown
instance Show MyCounter where
show (MyCounter i) = show i
instance Show MAX where
show (MAX i) = show i
instance Show MIN where
show (MIN i) = show i
instance Show Steps where
show (Steps i) = "Modified counter " ++ (show i) ++ " times."
myCompare :: Countdown -> Countdown -> Ordering
(M (MAX n)) `myCompare` (C (MyCounter i))
| n == i = EQ
| n < i = LT
| otherwise = GT
(N (MIN n)) `myCompare` (C (MyCounter i))
| n == i = EQ
| n < i = LT
| otherwise = GT
c@(C (MyCounter _)) `myCompare` m@(N (MIN _)) = m `myCompare` c
c@(C (MyCounter _)) `myCompare` m@(M (MAX _)) = m `myCompare` c
resetCounter :: Countdown -> IO CounterVar
resetCounter (M (MAX n)) = do
tstore <- atomically $ newTVar (C (MyCounter n))
return tstore
resetCounter (N (MIN n)) = do
tstore <- atomically $ newTVar (C (MyCounter n))
return tstore
decCounter' :: Countdown -> Countdown
decCounter' (C (MyCounter c)) = C (MyCounter (c - 1))
incCounter' :: Countdown -> Countdown
incCounter' (C (MyCounter c)) = C (MyCounter (c + 1))
inc :: CounterVar -> IO ()
inc tstore = do
v <- Lib.getTVar tstore
let newValue = incCounter' v
Lib.modifyTVar_ tstore newValue
decT :: CounterVar -> IO ()
decT r = do
v <- Lib.getTVar r
let min' = N (MIN 0)
newCounter = decCounter' v
putStrLn $ show newCounter
atomically $ (
do
check (myCompare min' v == LT )
writeTVar r newCounter
--decT r
)
decCounter :: CounterVar -> Steps -> Int -> IO ()
decCounter tstore s@(Steps n) i = do
c <- Lib.getTVar tstore
let min' = N (MIN 0)
newCounter = decCounter' c
res = auxCompare min' c
if (auxCompare min' c == LT )
then do
Lib.modifyTVar_ tstore newCounter
decCounter tstore (Steps (succ n)) i
else (putStrLn $ "Finished Thread Number: " ++ (show i)) >> return ()
where
auxCompare x y = x `myCompare` y
countdown :: CounterVar -> Int -> IO ()
countdown tstore 0 = return ()
countdown tstore n = do
forkIO $ decCounter tstore (Steps 0) n
countdown tstore (n-1)
loopCounter :: CounterVar -> Int -> IO ()
loopCounter _ 0 = return ()
loopCounter tstore n = do
c <- Lib.getTVar tstore
putStrLn $ "Current value: " ++ (show c)
loopCounter tstore (n-1)
module MyCLI
(
dispatch
) where
import qualified MyCounter as C
import qualified Lib as Lib
import qualified Data.Text as T
import Control.Concurrent.Async (replicateConcurrently_,async,wait,mapConcurrently_)
import Text.Read (readMaybe)
import GHC.Conc (numCapabilities)
import Control.Monad (forever)
import Control.Concurrent (forkIO,threadDelay)
import System.Random (mkStdGen,getStdGen,StdGen)
import Data.List (take)
lastBits :: Int
lastBits = 10
threshold :: Int
threshold = 100000
localHost :: Server.MyHost
localHost = Server.MyHost "127.0.0.1"
maxConns :: C.MAX
maxConns = C.MAX 4096
dispatch :: String -> [String] -> IO ()
dispatch "countdown-test" args = countdownTest args
dispatch command args = doesntExist command args
doesntExist :: String -> [String] -> IO ()
doesntExist command _ =
putStrLn $ "The " ++ command ++ " command doesn't exist."
countdownTest :: [String] -> IO ()
countdownTest (nString:[]) = do
let mn = readMaybe nString :: Maybe Int
auxCountdowntest mn Nothing
countdownTest (nString:numString:[]) = do
let mn = readMaybe nString :: Maybe Int
mt = readMaybe numString :: Maybe Int
auxCountdowntest mn mt
countdownTest _ = putStrLn "The countdown command takes exactly two arguments."
auxCountdowntest :: Maybe Int -> Maybe Int -> IO ()
auxCountdowntest mn mt = do
case (mn,mt) of
(Just n,Just t) -> do
tstore <- C.resetCounter (C.M (C.MAX n))
r <- async $ C.loopCounter tstore n
let nList = [1..t]
mapConcurrently_ (\i -> C.decCounter tstore (C.Steps 0) i) nList
c <- Lib.getTVar tstore
putStrLn $ "Countdown from " ++ (show n) ++ " using " ++ (show t) ++ " cores stopped at: " ++ (show c)
(Just n,_) -> do
tstore <- C.resetCounter (C.M (C.MAX n))
r <- async $ C.loopCounter tstore n
let nList = [1..numCapabilities]
mapConcurrently_ (\i -> C.decCounter tstore (C.Steps 0) i) nList
c <- Lib.getTVar tstore
putStrLn $ "Countdown from " ++ (show n) ++ " using " ++ (show numCapabilities) ++ " cores stopped at: " ++ (show c)
_ -> putStrLn "The countdown command takes exactly two numbers."
module Main (main) where
import System.Environment (getArgs)
main :: IO ()
main = do
(command:argList) <- getArgs
CLI.dispatch command argList
module Lib
(
modifyTVar_
, getTVar
, async
, printList
, finiteRandoms
, toString
) where
import Control.Monad (forever)
import Control.Concurrent.STM
import Control.Concurrent (forkIO)
import System.IO.Unsafe (unsafePerformIO)
import System.Random
import Data.List (intercalate)
import qualified Data.Text as T
data Async a = Async (TVar a)
--async :: IO a b -> TVar a -> b -> Int -> IO String
--async :: (IO a b) -> a -> b -> [Char] -> IO [Char]
async :: (Show c,Show b) => (a -> b -> IO ()) -> a -> b -> c -> IO ()
async action tstore x n = do
tId <- forkIO ( do
r <- action tstore x
putStrLn $ "Finished Thread Number: " ++ (show n) ++ " :: "++(show r)
)
return ()
modifyTVar_ :: TVar a -> a -> IO ()
modifyTVar_ tv newVal = do
atomically $ writeTVar tv newVal
-- gets the variable stored in a tv variable
getTVar :: TVar b -> IO b
getTVar tv = do
store <- atomically $ readTVar tv
return store
getTvalue :: TVar (Maybe T.Text) -> String
getTvalue tstore = case (unsafePerformIO $ getTVar tstore) of
Just mytext -> T.unpack mytext
_ -> ""
printList :: (Show a) => [a] -> IO ()
printList xs = mapM_ print xs
toString :: (Show a) => [a] -> String
toString xs = intercalate ", " (map show xs)
finiteRandoms :: (RandomGen g, Random a, Num n, Eq n) => n -> g -> ([a],g)
finiteRandoms 0 gen = ([],gen)
finiteRandoms n gen =
let (value,newGen) = random gen
(restOfList, finalGen) = finiteRandoms (n-1) newGen
in (value:restOfList,finalGen)
Aufgrund der Hinweise im Forum haben wir einen Nachtrag mit den kompletten Haskell-Skripten und einem Bild der Konsole-Ausgaben angefügt. Ferner gab es noch eine kleine Korrektur in der prepare-Methode im Java-Code.
(who)