fannkuch-redux Haskell GHC #3 program

{-  The Computer Language Benchmarks Game
    https://salsa.debian.org/benchmarksgame-team/benchmarksgame/
    contributed by Louis Wasserman
    
    This should be compiled with:
    	-threaded -O2 -fexcess-precision -fasm
    and run with:
    	+RTS -N<number of cores> -RTS <input>
-}

import Control.Concurrent
import Control.Monad
import System.Environment
import Foreign hiding (rotate)
import Data.Monoid

type Perm = Ptr Word8

data F = F {-# UNPACK #-} !Int {-# UNPACK #-} !Int

instance Monoid F where
	mempty = F 0 0
	F s1 m1 `mappend` F s2 m2 = F (s1 + s2) (max m1 m2)

incPtr = (`advancePtr` 1)
decPtr = (`advancePtr` (-1))

flop :: Int -> Perm -> IO ()
flop k xs = flopp xs (xs `advancePtr` k)
 where flopp i j = when (i < j) $ swap i j >> flopp (incPtr i) (decPtr j)
       swap i j = do
	a <- peek i
	b <- peek j
	poke j a
	poke i b

flopS :: Perm -> (Int -> IO a) -> IO a
flopS !xs f = do
	let go !acc = do
		k <- peekElemOff xs 0
		if k == 0 then f acc else flop (fromIntegral k) xs >> go (acc+1)
	go 0

increment :: Ptr Word8 -> Ptr Word8 -> IO ()
increment !p !ct = do
	first <- peekElemOff p 1
	pokeElemOff p 1 =<< peekElemOff p 0
	pokeElemOff p 0 first
	
	let go !i !first = do
		ci <- peekElemOff ct i
		if fromIntegral ci < i then pokeElemOff ct i (ci+1) else do
			pokeElemOff ct i 0
			let !i' = i + 1
			moveArray p (incPtr p) i'
			pokeElemOff p i' first
			go i' =<< peekElemOff p 0
	go 1 first  

genPermutations :: Int -> Int -> Int -> Ptr Word8 -> Ptr Word8 -> IO F
genPermutations !n !l !r !perm !count = allocaArray n $ \ destF -> do
	let upd j !f run = do
		p0 <- peekElemOff perm 0
		if p0 == 0 then increment perm count >> run f else do
			copyArray destF perm n
			increment perm count
			flopS destF $ \ flops -> 
				run (f `mappend` F (checksum j flops) flops)
	let go j !f = if j >= r then return f else upd j f (go (j+1))
	go l mempty
 where checksum i f = if i .&. 1 == 0 then f else -f

facts :: [Int]
facts = scanl (*) 1 [1..12]

unrank :: Int -> Int -> (Ptr Word8 -> Ptr Word8 -> IO a) -> IO a
unrank !idx !n f = allocaArray n $ \ p -> allocaArray n $ \ count ->
  allocaArray n $ \ pp -> do
	mapM_ (\ i -> pokeElemOff p i (fromIntegral i)) [0..n-1]
	let go i !idx = when (i >= 0) $ do
		let fi = facts !! i
		let (q, r) = idx `quotRem` fi
		pokeElemOff count i (fromIntegral q)
		copyArray pp p (i+1)
		let go' j = when (j <= i) $ do
			let jq = j + q
			pokeElemOff p j =<< peekElemOff pp (if jq <= i then jq else jq - i - 1)
			go' (j+1)
		go' 0
		go (i-1) r
	go (n-1) idx
	f p count

main = do
   n <- fmap (read.head) getArgs
   let fact = product [1..n]
   let bk = fact `quot` 4
   vars <- forM [0,bk..fact-1] $ \ ix -> do
   	var <- newEmptyMVar
   	forkIO (unrank ix n $ \ p -> genPermutations n ix (min fact (ix + bk)) p >=> putMVar var)
   	return var
   F chksm mflops <- liftM mconcat (mapM takeMVar vars)
   putStrLn $ (show chksm) ++ "\nPfannkuchen(" ++ (show n) ++ ") = " ++ (show $ mflops)
    

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


Tue, 05 May 2020 21:45:33 GMT

MAKE:
mv fannkuchredux.ghc-3.ghc fannkuchredux.ghc-3.hs
/opt/src/ghc-8.8.1/bin/ghc --make -fllvm -O2 -XBangPatterns -threaded -rtsopts -XScopedTypeVariables fannkuchredux.ghc-3.hs -o fannkuchredux.ghc-3.ghc_run
Loaded package environment from /home/dunham/.ghc/x86_64-linux-8.8.1/environments/default
[1 of 1] Compiling Main             ( fannkuchredux.ghc-3.hs, fannkuchredux.ghc-3.o )

fannkuchredux.ghc-3.hs:21:10: error:
    • No instance for (Semigroup F)
        arising from the superclasses of an instance declaration
    • In the instance declaration for ‘Monoid F’
   |
21 | instance Monoid F where
   |          ^^^^^^^^
make: [/home/dunham/8000-benchmarksgame/nanobench/makefiles/u64q.programs.Makefile:231: fannkuchredux.ghc-3.ghc_run] Error 1 (ignored)
rm fannkuchredux.ghc-3.hs

11.39s to complete and log all make actions

COMMAND LINE:
./fannkuchredux.ghc-3.ghc_run +RTS -N4 -RTS 10

MAKE ERROR