Haskell上的ICFPC2006任务太慢

Question

我正在学习Haskell，作为我自己的任务，我试图实现2006年ICFP竞赛中的通用机器。我想出了一个代码，乍一看似乎是有效的。然而，当我试图为比赛网站上提供的通用机器执行任何应用程序(例如sandmark.umz(时，我的实现速度太慢，无法实际运行任何程序。自检没有在几个小时内完成，我不得不终止这个过程。所以，我显然做错了什么，我只是不知道是什么。

我试过使用Haskell的探查器，但我也无法理解这些数字。垃圾收集似乎不需要花费太多时间(173秒的样本中有3秒(。然而，在这173秒内，分配的总内存几乎为6GB，而最大堆大小为13MB。

你能帮我理解吗，我的代码出了什么问题？我知道代码量很大，但我不确定如何在我的情况下提出一个最低限度的可重复示例，因为我真的不知道什么是相关的，什么不是。非常感谢。

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

Answer 1

运行176秒的Haskell编程所需的3GB的总分配量非常小。大多数Haskell程序在整个运行时每秒分配3-6 GB。在您的情况下，程序的大部分都在紧凑的、无分配的循环中运行(当您试图编写快速程序时，这通常是一件好事(，这可能解释了少量的分配。花在垃圾收集上的时间比例很小也是一个好迹象

我在sandmark.umz和codex.umz上测试了您的程序，它们是用-O2构建的，没有评测。

我认为主要的问题是hPutStrLn日志行产生了大量的输出，所以你的通用机器把所有的时间都花在了写日志上。

注释掉所有hPutStrLn行，SANDmark每隔几秒钟打印一行。我不知道它应该有多快，但它肯定在运行。

对于Codex，它在几秒钟内完成self-check succeeded并接受一个32个字符的密钥。如果您输入错误的键，它将打印"；错误的键"；。如果您输入正确的键，它将打印"；正在解密"在这一点上，它似乎冻结了，所以我怀疑您的实现太慢了，但没有您报告的那么慢。

请注意，在main:开始时关闭stdin和stdout上的缓冲可能会有所帮助

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

使得基于CCD_ 10和CCD_。这并不是绝对必要的，但可能有助于避免明显的封锁，而这些封锁实际上只是缓冲问题。