The Computer Language
24.09 Benchmarks Game

fannkuch-redux Haskell GHC #6 program

source code

{-
The Computer Language Benchmarks Game

https://salsa.debian.org/benchmarksgame-team/benchmarksgame/

Contributed by Branimir Maksimovic.
Optimized/rewritten by Bryan O'Sullivan.
Parallelized and rewritten by James Brock.

Build:
ghc --make -fllvm -O2 -threaded -XBangPatterns -XScopedTypeVariables -rtsopts fannkuch-redux.hs -o fannkuch-redux

Run 1-Core:
fannkuch-redux +RTS -N1 -RTS 12

Run 4-Core:
fannkuch-redux +RTS -N4 -RTS 12
-}

module Main(main) where

import System.Environment
import Data.Bits
import Data.List
import Control.Monad
import Control.Concurrent
import Control.Concurrent.Async

import qualified Data.Vector.Unboxed.Mutable as VM
import qualified Data.Vector.Generic.Mutable as VG


main :: IO ()
main = do
    n <- readIO . head =<< getArgs

    (maxFlipsCount, checkSum) <- fannkuch n

    putStr $ unlines
        [ show checkSum
        , "Pfannkuchen(" ++ show n ++ ") = " ++ show maxFlipsCount
        ]


fannkuch
    :: Int
        -- ^ n, the size of the fannkuch-redux problem.
    -> IO (Int, Int)
        -- ^ (max flips count, checksum)
fannkuch !n = do

    -- Number of permutations to consider.
    let numPermutations = factorial n

    -- Number of cores available for work.
    numCapabilities <- getNumCapabilities

    -- The amount of work which we would like to give to each core.
    let workSize = max 1000 $ numPermutations `div` numCapabilities

    -- Divide up the permutations into workSize units
    let workBoundary = takeWhile (<=numPermutations) $ iterate (+workSize) 1

    -- Upper and lower permutation index bounds for each workSize unit
    let workRanges = zip workBoundary $ tail workBoundary ++ [numPermutations+1]

    -- Perform the work.
    results <- mapConcurrently (uncurry $ work n) workRanges

    -- Gather up the results and return.
    return $ foldl1' (\(fc0,cs0) (fc1,cs1) -> (max fc0 fc1, cs0+cs1)) results


-- | Basic tail-call factorial. Never called on the hot path of this program.
factorial :: Int -> Int
factorial z0 = go z0 1
  where
    go 1 !answer = answer
    go !z !answer = go (z-1) (answer*z)


-- | Work function which counts flips and calculates checksum for a range of
-- permutations.
work
    :: Int
        -- ^ n, The size of the fannkuch-redux problem.
    -> Int
        -- ^ Lower bound inclusive of the permutation indices for this work.
    -> Int
        -- ^ Upper bound exclusive of the permutation indices for this work.
    -> IO (Int, Int)
        -- ^ (max flips count, checksum)
work !n !permIndexBegin !permIndexEnd = do

    -- Allocate mutable vector memory in the worker thread. Hopefully no two
    -- threads will allocate mutable vectors which share a cache line.

    -- Permutation vector.
    perm  :: VM.IOVector Int <- VM.unsafeNew n

    -- Working temporary permutation vector.
    tperm :: VM.IOVector Int <- VM.unsafeNew n

    -- Count vector.
    --
    -- > To optimize the process I use an intermediate data structure,
    -- > count[], which keeps count of how many rotations have been done
    -- > at every level.
    count :: VM.IOVector Int <- VM.unsafeNew n

    -- Initialize the perm and count vectors.
    permIndex n permIndexBegin perm count

    -- Preserve these mutually-recursive loop and count_flips functions
    -- from fannkuch-redux Haskell GHC #4 because they seem unimprovably fast.
    let
        loop
            :: Int -- c,  checksum
            -> Int -- m,  flip count
            -> Int -- pc, permutation index
            -> IO(Int,Int)
        loop !c !m !pc
            | pc == (permIndexEnd-1) = return (m, c)
            | otherwise = do
                permNext n perm count
                VM.unsafeCopy tperm perm
                let count_flips :: Int -> IO (Int, Int)
                    count_flips !flips = {-# SCC "count_flips" #-} do
                        f <- VM.unsafeRead tperm 0
                        if f == 1
                        then loop
                                (c + (if pc .&. 1 == 0 then flips else -flips))
                                (max m flips)
                                (pc+1)
                        else do
                            VG.reverse $ VM.unsafeSlice 0 f tperm
                            count_flips (flips+1)
                count_flips 0
    loop 0 0 (permIndexBegin-1)


-- | Generate the next permutation vector and count vector.
permNext
    :: Int -- ^ Permutation length.
    -> VM.IOVector Int -- ^ Vector to be mutated to next permutation.
    -> VM.IOVector Int -- ^ count vector for recursion depth state.
    -> IO ()
permNext !n !perm !count = go 1
  where
    go
        :: Int -- ^ i loops over [1..n-1]
        -> IO ()
    go !i
        | i >= n    = return ()
        | otherwise = do

            -- left-rotate the first i+1 places of perm
            rotateLeft perm $ i+1

            counti <- VM.unsafeRead count i
            if counti >= i
            then do
                VM.unsafeWrite count i 0
                go $ i+1
            else do
                VM.unsafeWrite count i $ counti+1
                return ()


-- | From a permutation index, generate permutation vector and count vector.
--
-- > It should be clear now how to generate a permutation and corresponding
-- > count[] array from an arbitrary index. Basically,
-- >
-- > count[k] = ( index % (k+1)! ) / k!
-- >
-- > is the number of rotations we need to perform on elements 0..k.
-- > Doing it in the descending order from n-1 to 1 gives us both the count[]
-- > array and the permutation.
permIndex
    :: Int -- ^ Permutation length.
    -> Int -- ^ ith permutation index, 1-based.
    -> VM.IOVector Int -- ^ Mutable permutation vector output.
    -> VM.IOVector Int -- ^ Mutable count vector output.
    -> IO ()
permIndex !n !i !perm !count = do

    -- initialize perm to [1,2,..n]
    forM_ [0..n-1] (\k -> VM.unsafeWrite perm k $ k + 1)

    VM.unsafeWrite count 0 0 -- count[0] is always 0.

    -- forM_ k = [n-1..1] over the count vector
    forM_ (take (n-1) $ iterate (subtract 1) (n-1)) $ \ k -> do
        let countk = (i `mod` factorial (k+1)) `div` factorial k
        VM.unsafeWrite count k countk
        replicateM_ countk $ rotateLeft perm $ k+1


-- | Left-rotate the first i places of perm where i >= 2.
rotateLeft
    :: VM.IOVector Int
    -> Int -- ^ Precondition: i >= 2
    -> IO ()
rotateLeft !perm !i = do
    !perm0 <- VM.unsafeRead perm 0
    VM.unsafeMove (VM.unsafeSlice 0 (i-1) perm) (VM.unsafeSlice 1 (i-1) perm)
    VM.unsafeWrite perm (i-1) perm0
    

notes, command-line, and program output

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:09:23 GMT

MAKE:
mv fannkuchredux.ghc-6.ghc fannkuchredux.ghc-6.hs
~/.ghcup/bin/ghc --make -fllvm -O2 -XBangPatterns -threaded -rtsopts -XScopedTypeVariables fannkuchredux.ghc-6.hs -o fannkuchredux.ghc-6.ghc_run
Loaded package environment from /home/dunham/.ghc/x86_64-linux-9.10.1/environments/default
[1 of 2] Compiling Main             ( fannkuchredux.ghc-6.hs, fannkuchredux.ghc-6.o )
fannkuchredux.ghc-6.hs:35:19: warning: [GHC-63394] [-Wx-partial]
    In the use of ‘head’
    (imported from Data.List, but defined in GHC.Internal.List):
    "This is a partial function, it throws an error on empty lists. Use pattern matching, 'Data.List.uncons' or 'Data.Maybe.listToMaybe' instead. Consider refactoring to use "Data.List.NonEmpty"."
   |
35 |     n <- readIO . head =<< getArgs
   |                   ^^^^

fannkuchredux.ghc-6.hs:65:41: warning: [GHC-63394] [-Wx-partial]
    In the use of ‘tail’
    (imported from Data.List, but defined in GHC.Internal.List):
    "This is a partial function, it throws an error on empty lists. Replace it with 'drop' 1, or use pattern matching or 'GHC.Internal.Data.List.uncons' instead. Consider refactoring to use "Data.List.NonEmpty"."
   |
65 |     let workRanges = zip workBoundary $ tail workBoundary ++ [numPermutations+1]
   |                                         ^^^^

[2 of 2] Linking fannkuchredux.ghc-6.ghc_run
rm fannkuchredux.ghc-6.hs

20.11s to complete and log all make actions

COMMAND LINE:
 ./fannkuchredux.ghc-6.ghc_run +RTS -N4 -RTS 12

PROGRAM OUTPUT:
3968050
Pfannkuchen(12) = 65