Hi, I have tried to implement knucleotide benchmark program this time:

http://benchmarksgame.alioth.debian.org/u64q/performance.php?test=knucleotide

Implementation is shorter (uses hashtable from hashtables package),

but two time slower then current Haskell entry ( which is too low level

for my taste :)).

What is interesting is that if I try to place Int64 as a key to

hash table, performance is even slower.

Strange that dropping and taking from bytestring would be

faster than packing string in 64 bit int and directly indexing.

If someone can see something that can bring performance on par

with current haskell entry , I would post it , otherwise no point,

except that program is shorter and not low level.

{-# Language BangPatterns #-}

--

-- The Computer Language Benchmarks Game

-- http://benchmarksgame.alioth.debian.org/

--

-- Contributed by Branimir Maksimovic

--

import Data.Char

import Data.List

import Data.IORef

import qualified Data.HashTable.IO as H

import qualified Data.ByteString.Char8 as S

import Control.Concurrent

import Text.Printf

main = do

    s <- S.getContents

    let content = (S.map toUpper . S.concat . tail .

                  dropWhile (\l->not $ S.isPrefixOf (S.pack ">THREE") l) .

                  S.lines) s

    mapM_ (execute content) actions

data Actions = I Int | S String

actions = [I 1,I 2,

           S "GGT",S "GGTA",S "GGTATT",S "GGTATTTTAATT",S "GGTATTTTAATTTATAGT"]

execute content (I i) = writeFrequencies content i

execute content (S s) = writeCount content s

writeFrequencies input size = do

    ht <- tcalculate input size

    lst <- H.foldM (\lst (k,v)->do 

        v' <- readIORef v

        return $ insertBy (\(_,x) (_,y)->y `compare` x) (k,v') lst) [] ht

    let sum = fromIntegral ((S.length input) + 1 - size)

    mapM_ (\(k,v)-> do

        printf "%s %.3f\n" 

            (S.unpack k) ((100 * (fromIntegral v)/sum)::Double)) lst

    putChar '\n'

writeCount input string = do

    let size = length string

    ht <- tcalculate input size

    res <- H.lookup ht (S.pack string)

    case res of 

        Nothing -> putStrLn $ string ++ " not found..."

        Just v -> do

            r <- readIORef v

            printf "%d\t%s\n" r (string::String)

tcalculate input size = do

    let 

        l = [0..7]

        actions = map (\i -> (calculate input i size (length l))) l

    vars <- mapM (\action -> do

                    var <- newEmptyMVar

                    forkIO $ do

                        answer <- action

                        putMVar var answer

                    return var) actions

    result <- newTable

    results <- mapM takeMVar vars

    mapM_ (\ht -> H.foldM (\lst (k,v) -> do 

                            res <- H.lookup lst k

                            case res of

                                Nothing -> do

                                    r1 <- readIORef v

                                    r2 <- newIORef r1

                                    H.insert lst k r2

                                Just v1 -> do

                                    r1 <- readIORef v1

                                    r2 <- readIORef v

                                    writeIORef v1 (r1+r2)

                            return lst) result ht) results

    return result

    

calculate input beg size incr = do

    ht <- newTable

    let

        calculate' :: S.ByteString -> Int -> IO HashTable

        calculate' str i 

         | i >= ((S.length input)+1 - size) = return ht

         | otherwise = do

            res <- H.lookup ht k

            case res of

                Nothing -> do

                    !r <- newIORef 1

                    H.insert ht k r

                Just v -> do

                    !r <- readIORef v

                    writeIORef v (r+1)

            calculate' (S.drop incr str) (i+incr)

                where k = S.take size str

    calculate' (S.drop beg input) beg

type HashTable = H.BasicHashTable S.ByteString (IORef Int) 

newTable :: IO HashTable

newTable = H.new

_______________________________________________
Haskell-Cafe mailing list
Haskell-Cafe@haskell.org
http://www.haskell.org/mailman/listinfo/haskell-cafe