k-nucleotide Haskell GHC program

-- The Computer Language Benchmarks Game
-- https://salsa.debian.org/benchmarksgame-team/benchmarksgame/
--
-- Contributed by Branimir Maksimovic

import qualified Data.ByteString.Char8 as S
import qualified Data.HashTable.IO as H
import qualified Data.Map as M
import Text.Printf
import Data.List
import Data.Maybe
import Data.Char
import Data.IORef
import Control.Concurrent

main = do
    let skip = do
            l <- S.getLine
            if S.isPrefixOf (S.pack ">THREE") l
                then return ()
                else skip
    skip
    s <- S.getContents
    let content = S.map toUpper $ S.filter ((/=) '\n') 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 :: S.ByteString -> Int -> IO ()
writeFrequencies input size = do
    mp <- tcalculate input size
    let sorted = sortBy (\(_,x) (_,y) -> y `compare` x) $ M.toList mp
        sum = fromIntegral ((S.length input) + 1 - size)
    mapM_ (\(k,v)-> do
        printf "%s %.3f\n" 
            (S.unpack k) ((100 * (fromIntegral v)/sum)::Double)) sorted
    putChar '\n'

writeCount :: S.ByteString -> String -> IO ()
writeCount input string = do
    let size = length string
    mp <- tcalculate input size
    let v = fromJust $ M.lookup (S.pack string) mp
    printf "%d\t%s\n" v string

tcalculate :: S.ByteString -> Int -> IO (M.Map S.ByteString Int) 
tcalculate input size = do
    let 
        l = [0..63]
        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
    let result = M.empty
    results <- mapM takeMVar vars
    return $ foldl (\res m -> foldl 
                               (\m (k,v)->M.insertWith (+) k v m)
                                res m)
                   result results

calculate :: S.ByteString -> Int -> Int -> Int -> IO [(S.ByteString,Int)]
calculate input beg size incr = do
    let updateMap freqmap word = do
           lu <- H.lookup freqmap word
           case lu of 
            Nothing -> do
                ref <- newIORef 1
                H.insert freqmap word ref
            Just x -> modifyIORef' x (+1)
           return freqmap
        word inp pos sz = S.take size $ S.drop pos inp
        calculate' freqmap i
            | i >= ((S.length input)+1 - size) = return ()
            | otherwise = do
                ht <- updateMap freqmap $ word input i size
                calculate' ht (i+incr)
    freqmap <- H.new :: IO (HashTable S.ByteString (IORef Int))
    calculate' freqmap beg
    lst <- H.toList freqmap
    mapM (\(x,y)-> do
            v <- readIORef y
            return (x,v)) lst
    

type HashTable k v = H.BasicHashTable k v
    

NOTES:
64-bit Ubuntu quad core
The Glorious Glasgow Haskell
Compilation System,
version 9.10.1
LLVM version 18.1.3


 Thu, 01 Aug 2024 19:20:18 GMT

MAKE:
mv knucleotide.ghc knucleotide.hs
~/.ghcup/bin/ghc --make -fllvm -O2 -XBangPatterns -threaded -rtsopts -funbox-strict-fields -XBinaryLiterals -XDerivingStrategies -XGeneralizedNewtypeDeriving -XOverloadedStrings -XScopedTypeVariables -XTypeApplications -package hashable -package unordered-containers -package pvar -package ghc-compact knucleotide.hs -o knucleotide.ghc_run
Loaded package environment from /home/dunham/.ghc/x86_64-linux-9.10.1/environments/default
[1 of 2] Compiling Main             ( knucleotide.hs, knucleotide.o )
[2 of 2] Linking knucleotide.ghc_run
rm knucleotide.hs

21.68s to complete and log all make actions

COMMAND LINE:
 ./knucleotide.ghc_run +RTS -N4 -K2048M -RTS 0 < knucleotide-input25000000.txt

PROGRAM OUTPUT:
A 30.295
T 30.151
C 19.800
G 19.754

AA 9.177
TA 9.132
AT 9.131
TT 9.091
CA 6.002
AC 6.001
AG 5.987
GA 5.984
CT 5.971
TC 5.971
GT 5.957
TG 5.956
CC 3.917
GC 3.911
CG 3.909
GG 3.902

1471758	GGT
446535	GGTA
47336	GGTATT
893	GGTATTTTAATT
893	GGTATTTTAATTTATAGT