fannkuch-redux Haskell GHC #4 program

{-  The Computer Language Benchmarks Game

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

    contributed by Branimir Maksimovic
    optimized/rewritten by Bryan O'Sullivan
    modified by Gabriel Gonzalez
    fix for GHC 9.2 by Artem Pelenitsyn    
-}

import System.Environment
import Text.Printf
import Data.Bits

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

main = do
    n <- getArgs >>= readIO.head
    (checksum,maxflips) <- fannkuch n
    printf "%d\nPfannkuchen(%d) = %d\n" checksum n maxflips

fannkuch :: Int -> IO (Int, Int)
fannkuch n = do
    perm <- V.unsafeThaw $ V.enumFromN 1 n
    !tperm <- VG.new n
    !cnt <- VG.replicate n 0
    let
        loop :: Int -> Int -> Int -> IO(Int,Int)
        loop !c !m !pc = do
            b <- next_permutation perm n cnt
            if b == False
            then return (c,m)
            else do
                VM.unsafeCopy tperm perm
                let 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 1

next_permutation :: VM.IOVector Int -> Int -> VM.IOVector Int -> IO Bool
next_permutation perm !n !cnt = loop 1
    where
    loop :: Int -> IO Bool
    loop i
        | i >= n = done i
        | otherwise = do
            tmp <- VM.unsafeRead perm 0
            let
                rotate :: Int -> IO()
                rotate j
                    | j >= i = VM.unsafeWrite perm i tmp
                    | otherwise = do
                        !v <- VM.unsafeRead perm (j+1)
                        VM.unsafeWrite perm j v
                        rotate (j+1)
            rotate 0
            v <- VM.unsafeRead cnt i
            if v >= i
            then VM.unsafeWrite cnt i 0 >> loop (i+1)
            else done i

    done :: Int -> IO Bool
    done i
        | i >= n = return False
        | otherwise = do
            v <- VM.unsafeRead cnt i
            VM.unsafeWrite cnt i (v+1)
            return True
    

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:04:59 GMT

MAKE:
mv fannkuchredux.ghc-4.ghc fannkuchredux.ghc-4.hs
~/.ghcup/bin/ghc --make -fllvm -O2 -XBangPatterns -threaded -rtsopts -XScopedTypeVariables fannkuchredux.ghc-4.hs -o fannkuchredux.ghc-4.ghc_run
Loaded package environment from /home/dunham/.ghc/x86_64-linux-9.10.1/environments/default
[1 of 2] Compiling Main             ( fannkuchredux.ghc-4.hs, fannkuchredux.ghc-4.o )
fannkuchredux.ghc-4.hs:20:29: warning: [GHC-63394] [-Wx-partial]
    In the use of ‘head’
    (imported from Prelude, 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"."
   |
20 |     n <- getArgs >>= readIO.head
   |                             ^^^^

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

18.05s to complete and log all make actions

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

PROGRAM OUTPUT:
3968050
Pfannkuchen(12) = 65