ICFPC 2006 task on Haskell is too slow

Question

I am learning Haskell, and as a task for myself I was trying to implement a Universal Machine from ICFP Contest 2006. I came up with a code, which, at a first glance, seems to be working. However, when I try to execute any application for that Universal Machine provided on the contest's website (e.g. sandmark.umz), my implementation is too slow to actually run anything. Self-check did not finish in a couple of hours, and I had to kill the process. So, I am clearly doing something wrong, I just don't know what.

I have tried to use Haskell's profiler, but I couldn't make any sense out of those numbers as well. Garbage collection doesn't seem to be taking a lot of time (3 seconds out of 173 seconds of a sample). However, total allocated memory during those 173 seconds was almost 6 GB, while the maximum heap size was 13 MB.

Could you help me understand, what is wrong with my code? I know that the amount of code is quite large, but I am not sure how to come up with a minimum reproducible example in my case, when I don't really know what is relevant, and what is not. Thank you.

module Main where

import System.Environment (getArgs)
import System.Exit (exitSuccess)
import System.IO (hPutStrLn, stderr)
import System.IO.Error (catchIOError)
import Control.Monad (when)
import Control.Monad.Loops (iterateM_)
import Data.Array.IO (IOUArray, newArray, newListArray, readArray, writeArray, mapArray)
import Data.Bits
import Data.Binary.Get (getWord32be, runGet, isEmpty, Get)
import Data.Char (chr, ord)
import Data.Word (Word32)
import Data.Maybe (fromJust)

import qualified Data.IntMap.Strict as M
import qualified Data.ByteString.Lazy as B
import qualified Data.IntSet as IntSet

data UMState = UMState {
    getFinger :: Word32,
    getRegisters :: IOUArray Int Word32,
    getArrays :: M.IntMap (IOUArray Word32 Word32),
    getFreeIds :: [Int],
    getMaxId :: Int,
    getCopiedPlatters :: IntSet.IntSet
}

getOperation :: Word32 -> Int
getOperation x = fromIntegral $ (x `shiftR` 28) .&. 15

getRegisterIds :: Word32 -> (Int, Int, Int)
getRegisterIds x = (fromIntegral $ (x `shiftR` 6) .&. 7, fromIntegral $ (x `shiftR` 3) .&. 7, fromIntegral $ x .&. 7)

getOrthography :: Word32 -> (Int, Word32)
getOrthography x = (fromIntegral $ (x `shiftR` 25) .&. 7, x .&. 33554431)

setFinger :: UMState -> Word32 -> UMState
setFinger (UMState {
        getFinger = _,
        getRegisters = regs,
        getArrays = arr,
        getFreeIds = fids,
        getMaxId = mid,
        getCopiedPlatters = cp
    }) f' = UMState {
        getFinger = f',
        getRegisters = regs,
        getArrays = arr,
        getFreeIds = fids,
        getMaxId = mid,
        getCopiedPlatters = cp
}

removePlatter :: UMState -> Int -> UMState
removePlatter (UMState {
        getFinger = f,
        getRegisters = regs,
        getArrays = arr,
        getFreeIds = fids,
        getMaxId = mid,
        getCopiedPlatters = cp
    }) pid = UMState {
        getFinger = f,
        getRegisters = regs,
        getArrays = M.delete pid arr,
        getFreeIds = (pid:fids),
        getMaxId = mid,
        getCopiedPlatters = cp
}

insertPlatter :: UMState -> Int -> IOUArray Word32 Word32 -> UMState
insertPlatter (UMState {
        getFinger = f,
        getRegisters = regs,
        getArrays = arr,
        getFreeIds = fids@(hfid:tfids),
        getMaxId = mid,
        getCopiedPlatters = cp
    }) pid platter = UMState {
        getFinger = f,
        getRegisters = regs,
        getArrays = M.insert pid platter arr,
        getFreeIds = if pid == hfid then tfids else fids,
        getMaxId = max mid pid,
        getCopiedPlatters = cp
}
insertPlatter (UMState {
        getFinger = f,
        getRegisters = regs,
        getArrays = arr,
        getFreeIds = [],
        getMaxId = mid,
        getCopiedPlatters = cp
    }) pid platter = UMState {
        getFinger = f,
        getRegisters = regs,
        getArrays = M.insert pid platter arr,
        getFreeIds = [],
        getMaxId = max mid pid,
        getCopiedPlatters = cp
}

setCopiedPlatters :: UMState -> IntSet.IntSet -> UMState
setCopiedPlatters (UMState {
        getFinger = f,
        getRegisters = regs,
        getArrays = arr,
        getFreeIds = fids,
        getMaxId = mid,
        getCopiedPlatters = _
    }) copied' = UMState {
        getFinger = f,
        getRegisters = regs,
        getArrays = arr,
        getFreeIds = fids,
        getMaxId = mid,
        getCopiedPlatters = copied'
}

main = do
    args <- getArgs
    fileName <- parseArgs $ filter (\arg -> arg /= "--") args
    platters <- B.readFile fileName
    array0 <- listToArray (runGet readPlatters platters)
    regs <- (newArray (0, 7) 0 :: IO (IOUArray Int Word32))
    let initState = (UMState {
            getFinger = 0,
            getRegisters = regs,
            getArrays = M.insert 0 array0 M.empty,
            getFreeIds = [],
            getMaxId = 0,
            getCopiedPlatters = IntSet.empty
        })
        in iterateM_ spinCycle initState

parseArgs :: [String] -> IO (String)
parseArgs [arg] = return arg
parseArgs args = fail $ "Exactly one argument expected. Found: " ++ (show args)

readPlatters :: Get [Word32]
readPlatters = do
    empty <- isEmpty
    if empty 
        then return []
        else do
            platter <- getWord32be
            theRest <- readPlatters
            return (platter:theRest)

listToArray :: [Word32] -> IO (IOUArray Word32 Word32)
listToArray lst = newListArray (fromIntegral 0, fromIntegral (length lst) - 1) lst

spinCycle :: UMState -> IO (UMState)
spinCycle state = do
    platter <- readArray (fromJust (M.lookup 0 (getArrays state))) (getFinger state)
    let state' = setFinger state $ getFinger state + 1
        (aId, bId, cId) = getRegisterIds platter
        regs = getRegisters state' 
        arrays = getArrays state' in (
            case (getOperation platter) of
                0 -> do
                    runConditionalMove aId bId cId regs
                    return state'
                1 -> do
                    runArrayIndex aId bId cId regs arrays
                    return state'
                2 -> runArrayAmendment aId bId cId state'
                3 -> do
                    runAddition aId bId cId regs
                    return state'
                4 -> do
                    runMultiplication aId bId cId regs
                    return state'
                5 -> do
                    runDivision aId bId cId regs
                    return state'
                6 -> do
                    runNand aId bId cId regs
                    return state'
                7 -> runHalt
                8 -> runAllocation bId cId state'
                9 -> runAbandonment cId state'
                10 -> do
                    runOutput cId regs
                    return state'
                11 -> do
                    runInput cId regs
                    return state'
                12 -> runLoadProgram bId cId state'
                13 -> do
                    let (reg, val) = getOrthography platter
                        in (runOrthography reg val regs)
                    return state'
       )

-- #0. Conditional Move.
runConditionalMove :: Int -> Int -> Int -> IOUArray Int Word32 -> IO ()
runConditionalMove a b c regs = do
    hPutStrLn stderr ("conditionalMove " ++ (show a) ++ " " ++ (show b) ++ " " ++ (show c))
    cRead <- readArray regs c
    when (cRead /= 0) $ do
        bRead <- readArray regs b
        writeArray regs a bRead

-- #1. Array Index.
runArrayIndex :: Int -> Int -> Int -> IOUArray Int Word32 -> M.IntMap (IOUArray Word32 Word32) -> IO ()
runArrayIndex a b c regs arrays = do
    hPutStrLn stderr ("arrayIndex " ++ (show a) ++ " " ++ (show b) ++ " " ++ (show c))
    bRead <- readArray regs b
    cRead <- readArray regs c
    val <- readArray (fromJust (M.lookup (fromIntegral bRead) arrays)) cRead
    writeArray regs a val

-- #2. Array Amendment.
runArrayAmendment :: Int -> Int -> Int -> UMState -> IO (UMState)
runArrayAmendment a b c state = do
    hPutStrLn stderr ("arrayAmendment " ++ (show a) ++ " " ++ (show b) ++ " " ++ (show c))
    aRead <- readArray (getRegisters state) a
    bRead <- readArray (getRegisters state) b
    cRead <- readArray (getRegisters state) c
    stateToWrite <- if IntSet.member (fromIntegral aRead) (getCopiedPlatters state) then (do
        pCopy <- mapArray id (fromJust (M.lookup (fromIntegral aRead) (getArrays state)))
        let state' = insertPlatter state (fromIntegral aRead) pCopy
            state'' = setCopiedPlatters state' $ IntSet.delete (fromIntegral aRead) (getCopiedPlatters state')
            in return state''
        ) else return state
    writeArray (fromJust (M.lookup (fromIntegral aRead) (getArrays stateToWrite))) bRead cRead
    return stateToWrite

-- #3. Addition.
runAddition :: Int -> Int -> Int -> IOUArray Int Word32 -> IO ()
runAddition a b c regs = do
    hPutStrLn stderr ("addition " ++ (show a) ++ " " ++ (show b) ++ " " ++ (show c))
    bRead <- readArray regs b
    cRead <- readArray regs c
    writeArray regs a (bRead + cRead)

-- #4. Multiplication.
runMultiplication :: Int -> Int -> Int -> IOUArray Int Word32 -> IO ()
runMultiplication a b c regs = do
    hPutStrLn stderr ("multiplication " ++ (show a) ++ " " ++ (show b) ++ " " ++ (show c))
    bRead <- readArray regs b
    cRead <- readArray regs c
    writeArray regs a (bRead * cRead)

-- #5. Division.
runDivision :: Int -> Int -> Int -> IOUArray Int Word32 -> IO ()
runDivision a b c regs = do
    hPutStrLn stderr ("division " ++ (show a) ++ " " ++ (show b) ++ " " ++ (show c))
    bRead <- readArray regs b
    cRead <- readArray regs c
    writeArray regs a (bRead `div` cRead)

-- #6. Not-And.
runNand :: Int -> Int -> Int -> IOUArray Int Word32 -> IO ()
runNand a b c regs = do
    hPutStrLn stderr ("nand " ++ (show a) ++ " " ++ (show b) ++ " " ++ (show c))
    bRead <- readArray regs b
    cRead <- readArray regs c
    writeArray regs a (complement $ bRead .&. cRead)

-- #7. Halt.
runHalt = exitSuccess :: IO (UMState)

-- #8. Allocation.
runAllocation :: Int -> Int -> UMState -> IO (UMState)
runAllocation b c state = do
    hPutStrLn stderr ("allocation " ++ (show b) ++ " " ++ (show c))
    cRead <- readArray (getRegisters state) c
    pArray <- (newArray (0, cRead) 0 :: IO (IOUArray Word32 Word32))
    (state', newId) <-
        case (getFreeIds state) of
            (freeId:_) -> return (insertPlatter state freeId pArray, freeId)
            [] -> let maxId' = getMaxId state + 1 in return (insertPlatter state maxId' pArray, maxId')
    writeArray (getRegisters state') b (fromIntegral newId)
    return state'

-- #9. Abandonment.
runAbandonment :: Int -> UMState -> IO (UMState)
runAbandonment c state = do
    hPutStrLn stderr ("abandonment " ++ (show c))
    cRead <- readArray (getRegisters state) c
    return (removePlatter state $ fromIntegral cRead)

-- #10. Output.
runOutput :: Int -> IOUArray Int Word32 -> IO ()
runOutput c regs = do
    cRead <- readArray regs c
    when (cRead < 256) $ putChar . chr . fromIntegral $ cRead

-- #11. Input.
runInput :: Int -> IOUArray Int Word32 -> IO ()
runInput c regs = do
    cRead <- getChar `catchIOError` (\_ -> return $ chr 255)
    writeArray regs c (fromIntegral $ ord cRead)

-- #12. Load Program.
runLoadProgram :: Int -> Int -> UMState -> IO (UMState)
runLoadProgram b c state = do
    hPutStrLn stderr ("loadProgram " ++ (show b) ++ " " ++ (show c))
    bRead <- readArray (getRegisters state) b
    cRead <- readArray (getRegisters state) c
    let bReadInt = fromIntegral bRead
        pCopy = fromJust (M.lookup bReadInt (getArrays state))
        copied = IntSet.insert 0 (getCopiedPlatters state)
        copied' = IntSet.insert bReadInt copied
        state' = insertPlatter state 0 pCopy
        state'' = setFinger state' cRead
        state''' = setCopiedPlatters state'' copied'
        in return state'''

-- #13. Orthography.
runOrthography :: Int -> Word32 -> IOUArray Int Word32 -> IO ()
runOrthography reg val regs = writeArray regs reg val

user_7203016 · Answer

Total allocation of 3 gigabytes for a Haskell programming running for 176 seconds is miniscule. Most Haskell programs allocate 3-6 gigabytes per second for their entire runtime. In your case, much of the program is running in tight, allocation-free loops (generally a good thing when you're trying to write a fast program), which may explain the small amount of allocation. The small proportion of time spent garbage collecting is also a good sign.

I tested your program on sandmark.umz andcodex.umz, built with -O2 and no profiling.

I believe the main problem is that the hPutStrLn logging lines are generating tons of output, so your universal machine is spending all its time writing logs.

Comment out all the hPutStrLn lines, and SANDmark prints a line every few seconds. I have no idea how fast it's supposed to be, but it's certainly running.

For Codex, it completes the self-check succeeded in a few seconds and accepts a 32-character key. If you enter the wrong key, it prints "wrong key". If you enter the right key, it prints "decrypting..." At this point, it seems to freeze up, so I suspect your implementation is too slow, but not nearly as slow as you were reporting.

Note that you may find it helpful to turn off buffering on stdin and stdout at the start of main:

main = do
    hSetBuffering stdin NoBuffering
    hSetBuffering stdout NoBuffering
    ...

so that the getChar and putChar-based I/O operate immediately. This isn't strictly necessary, but might help avoid apparent lockups that are actually just buffering issues.

ICFPC 2006 task on Haskell is too slow

1 Answers