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