哈斯克爾緩慢的數組訪問？

Question

我在Kattis上做了這個汽車遊戲問題：https://open.kattis.com/problems/cargame 有五秒鐘的時間限制，但在最後一個實例中，我的代碼需要更長的時間才能運行。我相當肯定我做了正確的事情（從大O的角度來看），所以現在我需要以某種方式對其進行優化。 我下載測試數據來自： http://challenge.csc.kth.se/2013/challenge-2013.tar.bz2

從剖析，似乎最喜歡的containsSub花費的運行時間這只不過是一個數組尾遞歸調用一起訪問了。此外，它只被稱爲大約100M次，爲什麼需要6.5秒才能運行（我的筆記本電腦有6.5秒，我發現Kattis通常大約是速度的兩倍，可能更像是13秒）。在統計頁面上，一些C++解決方案在一秒之內運行。甚至有些python解決方案几乎不能在5秒鐘的時間內完成。

module Main where 

import   Control.Monad 
import   Data.Array   (Array, (!), (//)) 
import qualified Data.Array   as Array 
import   Data.ByteString.Char8 (ByteString) 
import qualified Data.ByteString.Char8 as BS 
import   Data.Char 
import   Data.List 
import   Data.Maybe 

main::IO() 
main = do 
    [n, m] <- readIntsLn 
    dictWords <- replicateM n BS.getLine 
    let suffixChains = map (\w -> (w, buildChain w)) dictWords 
    replicateM_ m $ findChain suffixChains 

noWordMsg :: ByteString 
noWordMsg = BS.pack "No valid word" 

findChain :: [(ByteString, WordChain)] -> IO() 
findChain suffixChains = do 
    chrs <- liftM (BS.map toLower) BS.getLine 
    BS.putStrLn 
    (
     case find (containsSub chrs . snd) suffixChains of 
     Nothing -> noWordMsg 
     Just (w, _) -> w 
    ) 

readAsInt :: BS.ByteString -> Int 
readAsInt = fst . fromJust . BS.readInt 

readIntsLn :: IO [Int] 
readIntsLn = liftM (map readAsInt . BS.words) BS.getLine 

data WordChain = None | Rest (Array Char WordChain) 

emptyChars :: WordChain 
emptyChars = Rest . Array.listArray ('a', 'z') $ repeat None 

buildChain :: ByteString -> WordChain 
buildChain s = 
    case BS.uncons s of 
    Nothing -> emptyChars 
    Just (hd, tl) -> 
     let wc@(Rest m) = buildChain tl in 
     Rest $ m // [(hd, wc)] 

containsSub :: ByteString -> WordChain -> Bool 
containsSub _ None = False 
containsSub s (Rest m) = 
    case BS.uncons s of 
    Nothing -> True 
    Just (hd, tl) -> containsSub tl (m ! hd) 

---

編輯：TAKE 2：

我試圖建立一個懶惰的線索，以避免我已經搜索尋找的東西。例如，如果我已經遇到以'a'開頭的三聯體，那麼將來我可以跳過不包含'a'的任何內容。如果我已經搜索了一個三元組開始'ab'，我可以跳過任何不包含'ab'的東西。如果我已經搜索了確切的三元組'abc'，我只能從上次返回相同的結果。理論上，這應該有助於顯着的加速。在實踐中，運行時間是相同的。

此外，沒有seq的，分析需要永遠，並給出假結果（我猜不出爲什麼）。 隨着seqs，剖析說的時間大部分是在forLetter度過（這哪裏是數組訪問已經被移動到如此反覆，它看起來像數組訪問是慢的部分）

{-# LANGUAGE TupleSections #-} 

module Main where 

import   Control.Monad 
import   Data.Array   (Array, (!), (//)) 
import qualified Data.Array   as Array 
import qualified Data.Array.Base  as Base 
import   Data.ByteString.Char8 (ByteString) 
import qualified Data.ByteString.Char8 as BS 
import   Data.Char 
import   Data.Functor 
import   Data.Maybe 

main::IO() 
main = do 
    [n, m] <- readIntsLn 
    dictWords <- replicateM n BS.getLine 
    let suffixChainsL = map (\w -> (w, buildChain w)) dictWords 
    let suffixChains = foldr seq suffixChainsL suffixChainsL 
    suffixChains `seq` doProbs m suffixChains 

noWordMsg :: ByteString 
noWordMsg = BS.pack "No valid word" 

doProbs :: Int -> [(ByteString, WordChain)] -> IO() 
doProbs m chains = replicateM_ m doProb 
    where 
    cf = findChain chains 
    doProb = 
     do 
     chrs <- liftM (map toLower) getLine 
     BS.putStrLn . fromMaybe noWordMsg $ cf chrs 

findChain :: [(ByteString, WordChain)] -> String -> Maybe ByteString 
findChain [] = const Nothing 
findChain suffixChains@(shd : _) = doFind 
    where 
    letterMap :: Array Char (String -> Maybe ByteString) 
    letterMap = 
     Array.listArray ('a','z') 
     [findChain (mapMaybe (forLetter hd) suffixChains) | hd <- [0..25]] 
    endRes = Just $ fst shd 
    doFind :: String -> Maybe ByteString 
    doFind [] = endRes 
    doFind (hd : tl) = (letterMap ! hd) tl 
    forLetter :: Int -> (ByteString, WordChain) -> Maybe (ByteString, WordChain) 
    forLetter c (s, WC wc) = (s,) <$> wc `Base.unsafeAt` c 

readAsInt :: BS.ByteString -> Int 
readAsInt = fst . fromJust . BS.readInt 

readIntsLn :: IO [Int] 
readIntsLn = liftM (map readAsInt . BS.words) BS.getLine 

newtype WordChain = WC (Array Char (Maybe WordChain)) 

emptyChars :: WordChain 
emptyChars = WC . Array.listArray ('a', 'z') $ repeat Nothing 

buildChain :: ByteString -> WordChain 
buildChain = BS.foldr helper emptyChars 
    where 
    helper :: Char -> WordChain -> WordChain 
    helper hd wc@(WC m) = m `seq` WC (m // [(hd, Just wc)]) 

Answer 1

後的#haskell和#ghc IRC頻道很多討論，我發現這個問題是與此相關的GHC錯誤：https://ghc.haskell.org/trac/ghc/ticket/1168

的解決方案是簡單地改變doProbs

doProbs m chains = cf `seq` replicateM_ m doProb 
... 

的定義，或只與編譯-fno狀態，黑客

ghc的狀態黑客優化導致它在每次調用時不必要地重新計算cf（和相關的letterMap）。

所以它與數組訪問無關。

Answer 2

的uncons呼叫containsSub創建新的ByteString。嘗試通過保持偏移與索引的字符串，例如軌道飛馳起來：

containsSub' :: ByteString -> WordChain -> Bool 
containsSub' str wc = go 0 wc 
    where len = BS.length str 
     go _ None = False 
     go i (Rest m) | i >= len = True 
         | otherwise = go (i+1) (m ! BS.index str i)