fannkuch Haskell GHC #2 program

Does this Haskell GHC program work for all the input values? Why not? Read ↓ the log. Does this program use optimized assembly code libraries? Is this program small and simple, or very optimized? How could this program be improved?

 N  CPU secs Elapsed secs Memory KB Code B ~ CPU Load
90.139681005  
101.349801005  
1116.579921005  
{-# OPTIONS -fglasgow-exts -O2 -optc-O3 #-}

-- The Great Computer Language Shootout
-- http://shootout.alioth.debian.org/
-- contributed by Don Stewart, translation from the C version

import Control.Monad
import Foreign
import System
import GHC.Base
import GHC.Ptr
import GHC.IOBase

main = do
    n <- getArgs >>= return . read . head
    k <- if n < 1 then return (0::Int) else fannkuch n
    putStrLn $ "Pfannkuchen(" ++ show n ++ ") = " ++ show (k - 1)

fannkuch n@(I# n#) = do
    perm            <- mallocArray n       :: IO (Ptr Int)
    (Ptr c#)        <- mallocArray n       :: IO (Ptr Int)
    perm1@(Ptr p1#) <- newArray [0 .. n-1] :: IO (Ptr Int)
    (Ptr rP)        <- newArray [n]        :: IO (Ptr Int)
    (Ptr flipsMaxP) <- newArray [0]        :: IO (Ptr Int)

    let go didpr = do
            didpr' <- if didpr < (30 :: Int)
                      then ppr 0 n perm1 >> putStr "\n" >> return (didpr + 1)
                      else return didpr

            IO $ \s ->
                case readIntOffAddr# rP 0# s of
                    (# s, r# #) -> case setcount c# r# s of
                        (# s, _ #) -> case writeIntOffAddr# rP 0# 1# s of
                            s -> (# s, () #)

            t <- IO $ \s ->
                case readIntOffAddr# p1# 0# s of
                    (# s, p1 #) -> case readIntOffAddr# p1# (n# -# 1#) s of
                        (# s, pn #) -> (# s, not (p1 ==# 0# || pn ==# (n# -# 1#)) #)

            when t $ exchange n perm perm1 flipsMaxP

            fm   <- IO $ \s -> case readIntOffAddr# flipsMaxP 0# s of
                                (# s, x #) -> (# s, I# x #)
            done <- IO $ \s -> rot rP n# p1# c# s
            if done then return fm else go didpr'
    go 0

------------------------------------------------------------------------

exchange n p@(Ptr a) p1@(Ptr b) fm = do
    copyArray (p `advancePtr` 1) (p1 `advancePtr` 1) (n-1)
    IO $ \s ->
        case readIntOffAddr# b 0# s  of { (# s, k #) ->
        case doswap k a 0# s         of { (# s, f #) ->
        case readIntOffAddr# fm 0# s of { (# s, m #) ->
        if m <# f then case writeIntOffAddr# fm 0# f s of s -> (# s, () #)
                  else (# s, () #)
        } } }
{-# INLINE exchange #-}

doswap k a f s =
    case swap 1# (k -# 1#) a s    of { (# s, _ #) ->
    case readIntOffAddr# a k s    of { (# s, j #) ->
    case writeIntOffAddr# a k k s of { s          ->
    if k /=# 0# then doswap j a (f +# 1#) s else (# s, (f +# 1#) #)
    } } }
{-# INLINE doswap #-}

swap i j a s =
    if i <# j then case readIntOffAddr#  a i s   of { (# s, x #) ->
                   case readIntOffAddr#  a j s   of { (# s, y #) ->
                   case writeIntOffAddr# a j x s of { s          ->
                   case writeIntOffAddr# a i y s of { s          ->
                   swap (i +# 1#) (j -# 1#) a s
                   } } } }
              else (# s, () #)
{-# INLINE swap #-}

loop r i a s =
    if i <# r then case readIntOffAddr# a (i +# 1#) s of
                    (# s, x #) -> case writeIntOffAddr# a i x s of
                        s -> loop r (i +# 1#) a s
              else (# s, () #)
{-# INLINE loop #-}

setcount p r s =
    if r ==# 1# then (# s, () #)
                else case writeIntOffAddr# p (r -# 1#) r s of
                        s -> setcount p (r -# 1#) s
{-# INLINE setcount #-}

rot rP n a cp s =
  case readIntOffAddr# rP 0# s of { (# s, r #) ->
  if r ==# n then (# s, True #)
             else case readIntOffAddr# a 0# s             of { (# s, p0 #) ->
                  case loop r 0# a s                      of { (# s, _ #)  ->
                  case writeIntOffAddr# a r p0 s          of { s           ->
                  case readIntOffAddr# cp r s             of { (# s, cr #) ->
                  case writeIntOffAddr# cp r (cr -# 1#) s of { s           ->
                  if cr -# 1# ># 0# then (# s, False #)
                                    else case inc s of s -> rot rP n a cp s
  } } } } } }
  where inc s = case readIntOffAddr# rP 0# s of
                  (# s, x #) -> writeIntOffAddr# rP 0# (x +# 1#) s
{-# INLINE rot #-}

ppr i n p = when (i < n) $ do
    putStr . show . (+1) =<< peek (p `advancePtr` i)
    ppr (i+1) n p

 about the program

 

 build & benchmark results

BUILD COMMANDS FOR: fannkuch.ghc-2.ghc

Sat Jan 19 19:20:53 PST 2008

cp /home/dunham/gp4/shootout/bench/fannkuch/fannkuch.ghc-2.ghc fannkuch.ghc-2.hs
/usr/bin/ghc --make -O2 -fglasgow-exts -fparr -optc-march=pentium4 fannkuch.ghc-2.hs -o fannkuch.ghc-2.ghc_run
[1 of 1] Compiling Main             ( fannkuch.ghc-2.hs, fannkuch.ghc-2.o )
Linking fannkuch.ghc-2.ghc_run ...
rm fannkuch.ghc-2.hs

=================================================================
COMMAND LINE (%A is single numeric argument):

 fannkuch.ghc-2.ghc_run $MB_GHCRTS %A 


PROGRAM OUTPUT
==============
1234567891011
2134567891011
2314567891011
3214567891011
3124567891011
1324567891011
2341567891011
3241567891011
3421567891011
4321567891011
4231567891011
2431567891011
3412567891011
4312567891011
4132567891011
1432567891011
1342567891011
3142567891011
4123567891011
1423567891011
1243567891011
2143567891011
2413567891011
4213567891011
2345167891011
3245167891011
3425167891011
4325167891011
4235167891011
2435167891011
Pfannkuchen(11) = 51

Revised BSD license