Multithreaded Hakyll

Multithreaded Hakyll

I thought I could make my Hakyll site generator faster with multithreading. My attempt below has reduced the time to generate 150,000 pages from 31 minutes (with this), to 22 minutes.

It is a little bit hardcoded due to my lack of experience with Haskell. I need the numbers list that generate the numbered file paths "charity-{n}" to be pulled from the actual directory names.

Compiled with:

ghc -Wtabs -O2 -fexcess-precision -optc-O3 -optc-ffast-math -fforce-recomp --make -with-rtsopts="-N18 -H4096m" -threaded site_multi_thread.hs

site_multi_thread.hs

--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
import           Data.Monoid (mappend)
import           Hakyll
import           Hakyll.Web.Paginate
import           Hakyll.Core.Identifier.Pattern (fromGlob)

import           Hakyll.Core.Configuration
import           System.FilePath  (isAbsolute, normalise, takeFileName)
import           Data.List        (isPrefixOf, isSuffixOf)
import           System.Process   (system)


import           GHC.Conc.Sync

import qualified Data.Map as M
import Control.Monad (liftM,forM)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent (forkIO,threadDelay,forkFinally)

import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar, MVar)
--------------------------------------------------------------------------------
       



config_x :: String -> Configuration
config_x x = Configuration
    { destinationDirectory = "_site_m"  ++  x
    , storeDirectory       = "_cache_m" ++  x
    , tmpDirectory         = "_cache_m" ++  x ++ "/tmp"
    , providerDirectory    = "."
    , ignoreFile           = ignoreFile'
    , deployCommand        = "echo 'No deploy command specified' && exit 1"
    , deploySite           = system . deployCommand
    , inMemoryCache        = True
    , previewHost          = "127.0.0.1"
    , previewPort          = 8000
    }
  where
    ignoreFile' path
        | "."    `isPrefixOf` fileName = True
        | "#"    `isPrefixOf` fileName = True
        | "~"    `isSuffixOf` fileName = True
        | ".swp" `isSuffixOf` fileName = True
        | otherwise                    = False
      where
        fileName = takeFileName path


makeString :: String -> Pattern
makeString x =  fromGlob ("posts/charity-" ++ x ++ "/*/*")
        
run_x x = do
                hakyllWith (config_x x) $ do 
                  

                                                        
                    match (makeString x) $ do
                        route $ setExtension "html"
                        compile $ pandocCompiler
                            >>= loadAndApplyTemplate "templates/post.html"    postCtx
                            >>= loadAndApplyTemplate "templates/default.html" postCtx
                            >>= relativizeUrls                            
                            
                    match "templates/*" $ compile templateBodyCompiler
                    



run_main x = do
                hakyllWith (config_x x) $ do 

                    match "images/*" $ do
                        route   idRoute
                        compile copyFileCompiler
                        
                    match "css/*" $ do
                        route   idRoute
                        compile compressCssCompiler

                    match (fromList ["about.rst", "contact.markdown"]) $ do
                        route   $ setExtension "html"
                        compile $ pandocCompiler
                            >>= loadAndApplyTemplate "templates/default.html" defaultContext
                            >>= relativizeUrls

                    match "templates/*" $ compile templateBodyCompiler

                

forkThread :: IO () -> IO (MVar ())
forkThread proc = do
    handle <- newEmptyMVar
    _ <- forkFinally proc (\_ -> putMVar handle ())
    return handle                
                
                

main = 
    do
        main_thread <- forkThread (run_main "X")
        threads <- forM [10, 21, 24, 27, 30, 50, 53, 80,11, 22, 25, 28, 31, 51, 56, 81,20, 23, 26, 29, 32, 52, 70, 90] (\v -> forkThread (run_x (show v)))
            
        mapM_ takeMVar threads
        takeMVar main_thread
        
        
            


            

    
--------------------------------------------------------------------------------
postCtx :: Context String
postCtx =
    dateField "date" "%B %e, %Y" `mappend`
    defaultContext