Haskell-尽管foldl'和严格的数据结构，内存使用量过多

html5 • • 问答

鉴于程序应该做什么，我有一个程序正在使用“过多”内存。有问题的代码片段（每个 GHC 堆分析+RTS -h）如下。

import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict

weeklyOwnerCache :: (RealFloat v) => [Int] -> [Int] -> Int -> v -> IntMap (v, Integer) -> IntMap (v, Integer)
weeklyOwnerCache rosterStates rosterIndices player projection cache = foldl' updateState cache rosterStates
  where
    updateState c s = Data.IntMap.Strict.insert s (optimalRosterAtState rosterIndices player projection c s) c

optimalRosterAtState :: (RealFloat v) => [Int] -> Int -> v -> IntMap (v, Integer) -> Int -> (v, Integer)
optimalRosterAtState rosterIndices player projection cache state = foldl' (p r->max p (selectPlayer r)) (priorValue, priorSelection) validRosterIndices
  where
    (priorValue, priorSelection) = cache Data.IntMap.Strict.! state
    validRosterIndices = filter (isValidAssignment state) rosterIndices
    selectPlayer r = selection r player projection cache state

selection :: (RealFloat v) => Int -> Int -> v -> IntMap (v, Integer) -> Int -> (v, Integer)
selection rosterIndex player projection cache state = (newValue, newSelections)
  where
    rosterSpotValue = 10 ^ rosterIndex
    priorState = state - rosterSpotValue
    (priorValue, priorSelections) = cache Data.IntMap.Strict.! priorState
    newValue = priorValue + projection
    newSelections = priorSelections .|. bit player

isValidAssignment :: Int -> Int -> Bool
isValidAssignment rosterState rosterIndex = digitValue rosterState rosterIndex > 0

digitValue :: Int -> Int -> Int
digitValue n i = (n `quot` (10 ^ i)) `rem` 10

尽管使用foldl'并Data.IntMap.Strict试图控制内存占用，它仍然需要许多超出我认为合理的倍数：

  • 有 8 个所有者和 16 周 = 108 个总缓存（每个一个IntMap (v, Integer)）。
  • 每个缓存有 128 个Int键，值从0到12221。
  • 每个值 ( Double, Integer) 和Integer都在任何时候最多设置 15 位（范围为 0 到 ~200）。我认为这可以用几个词来形容……也许是 64 个字节？
  • 总共 108 个缓存 * 128 个键 *（8 个键大小 + ~72 个值大小）= ~1.1M 字节
  • 但是这个代码块在小运行中消耗了大约 220MB（即包含此代码的循环的 10 次迭代），尽管它的大小是固定的，但在 100 次迭代时消耗 2GB+。我的代码库的其他方面没有相同的线性内存消耗。

我已经重构了一个列表理解，foldl'专门weeklyOwnerCache用于无济于事。是否有任何其他代码行似乎具有有问题的内存消耗属性？

编辑以在处理最小复制示例时添加其他相关信息

我进行了下面建议的编辑（即使用 bang 模式强制评估），但无济于事。当我将代码提取到一个最小的复制示例中时，还有另一条可能相关的信息。

的weeklyCache IntMap对象坐在HashMap o [IntMap (Selection v)]结构（由所有者键控中，〜16个长列表是一个weeklyCache的每个元素）。使用惰性列表是否可能导致这种情况？

另一种可能性是newGame元组本身（这是我所有其他库模块的“游戏规则界面”）导致这种情况。根据下面的反馈，如果newGame元组在传递到我的库中之前仅被评估为 WHNF Main.hs（例如 100-10000 模拟等），则这可能是我的问题，我应该有一个严格的参数化data Game ...类型一个接口而不是一个元组。

下面Rules是可执行文件部分的完整库代码：

{-# LANGUAGE DerivingStrategies#-}
{-# LANGUAGE BangPatterns#-}

module Games.Rules.Draft ( newGame ) where

import Data.Bits ( xor, (.&.), (.|.), complement, popCount, clearBit, setBit, bit)
import Data.Hashable ( Hashable ( hashWithSalt ) )
import Data.List ( foldl' )

import Data.Array (Array)
import qualified Data.Array
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict
import Data.IntMap.Strict (IntMap)
import qualified Data.IntMap.Strict

--import Debug.Trace ( trace )

data Selection v = Selection !v !Integer deriving stock (Eq, Ord, Show)

data State o v = State
  { pick :: Int
  , selected :: Integer --relies on ownerToIndex to shift bits.
  , remaining :: Integer
  , caches :: HashMap o [IntMap (Selection v)] -- indexed by owner, then rosterState
  } deriving stock (Eq, Ord, Show)

instance Hashable (State o v) where
  hashWithSalt s (State _ sel _ _) =
    s `hashWithSalt` sel


--newGame :: (Eq o, Hashable o, Eq r, Hashable r, Eq p, Hashable p, RealFloat v, Show o, Show v)
newGame :: (Eq o, Hashable o, Eq r, Hashable r, Eq p, Hashable p, RealFloat v)
  => [o] -> Int -> Bool -> [(n, t, [p], [v])] -> [(p, [r])] -> [(r, Int)]
  -> (State o v, [o], State o v-> Bool, State o v-> o, State o v-> [Int], State o v-> Int -> o -> v, State o v -> Int -> State o v)
newGame owners rounds isSnake players positionToRosterSpots startingRosterSpots = (iS, owners, iT, cO, m, r, ns)
  where
    -- helper
    ownerCount = length owners
    ownerFromIndex = Data.Array.listArray (0, ownerCount-1) owners
    ownerToIndex = Data.HashMap.Strict.fromList $ zip owners [0..ownerCount-1]
    playerCount = length players
    (_, _, _, proj) = head players
    weekCount = length proj
    playerProjections = Data.Array.listArray (0, playerCount-1) [projections | (_, _, _, projections) <- players]
    rosterSpotCount = length startingRosterSpots
    rosterSpotIndices = [rosterSpotCount-1, rosterSpotCount-2..0]
    rosterSpotToIndex = Data.HashMap.Strict.fromList $ zip (map fst startingRosterSpots) rosterSpotIndices
    rosterSpotIndicesFromPositions = positionsToRosterSpotIndices positionToRosterSpots rosterSpotToIndex
    playerRosterIndices = Data.Array.listArray (0, playerCount-1) [rosterSpotIndicesFromPositions pos | (_, _, pos, _) <- players]
    rosterStates = rosterInts startingRosterSpots
    fullProblem = head rosterStates
    -- API
    iS = initialState owners playerCount weekCount rosterStates
    iT state = pick state == min (ownerCount * rounds) playerCount
    cO = currentOwner isSnake ownerCount ownerFromIndex
    m = setBits . remaining
    r = reward cO playerProjections playerRosterIndices fullProblem
    ns = nextState cO ownerToIndex playerCount playerProjections playerRosterIndices rosterStates

-- API functions

initialState :: (Eq o, Hashable o, RealFloat v) => [o] -> Int -> Int -> [Int] -> State o v
initialState owners playerCount weekCount rosterStates = State{pick=0, selected=0, remaining=initialRemaining, caches=initialCache}
  where
    initialRemaining = 2 ^ playerCount - 1
    initialCache = initialRewardCaches owners weekCount rosterStates

currentOwner :: Bool -> Int -> Array Int o -> State o v -> o
currentOwner isSnake ownerCount ownerFromIndex state = ownerFromIndex Data.Array.! ownerIndex
  where
    roundPick = pick state `rem` ownerCount
    isForward = even $ pick state `quot` ownerCount
    ownerIndex = if not isSnake || isForward then roundPick else ownerCount - roundPick - 1

--reward :: (Eq o, Hashable o, RealFloat v, Show o, Show v) => (State o v -> o) -> Array Int [v] -> Array Int [Int] -> Int -> State o v -> Int -> o -> v
--reward currentOwnerFromState playerProjections playerRosterIndices fullProblem state player owner | trace ("reward " ++ show state ++ " " ++ show player ++ " " ++ show owner) False = undefined
reward :: (Eq o, Hashable o, RealFloat v) => (State o v -> o) -> Array Int [v] -> Array Int [Int] -> Int -> State o v -> Int -> o -> v
reward currentOwnerFromState playerProjections playerRosterIndices fullProblem state player owner
    | owner /= currentOwnerFromState state = 0
    | otherwise = sum [weeklyReward fullProblem rosterIndices player p c | (p, c) <- weeks]
        where
          rosterIndices = playerRosterIndices Data.Array.! player
          projections = playerProjections Data.Array.! player
          weeks = zip projections (caches state Data.HashMap.Strict.! owner)

nextState :: (Eq o, Hashable o, RealFloat v) => (State o v -> o) -> HashMap o Int -> Int -> Array Int [v] -> Array Int [Int] -> [Int] -> State o v -> Int -> State o v
nextState currentOwnerFromState ownerToIndex playerCount playerProjections playerRosterIndices rosterStates state player = State nextPick nextSelected nextRemaining nextCaches
  where
    nextPick = pick state + 1
    owner = currentOwnerFromState state
    currentOwnerIndex = ownerToIndex Data.HashMap.Strict.! owner
    playerBit = currentOwnerIndex * playerCount + player
    nextSelected = setBit (selected state) playerBit
    nextRemaining = clearBit (remaining state) player -- no shift
    nextCaches = Data.HashMap.Strict.insert owner newOwnerCache priorCaches
      where
        priorCaches = caches state
        rosterIndices = playerRosterIndices Data.Array.! player
        projections = playerProjections Data.Array.! player
        weeks = zip projections (caches state Data.HashMap.Strict.! owner)
        newOwnerCache = [weeklyOwnerCache rosterStates rosterIndices player p c | (p, c) <- weeks]

-- helper functions

initialRewardCaches :: (Eq o, Hashable o, RealFloat v) => [o] -> Int -> [Int] -> HashMap o [IntMap (Selection v)]
initialRewardCaches owners weekCount rosterStates = Data.HashMap.Strict.fromList [(o, initialCache) | o<-owners]
  where
    initialCache = initialOwnerCache weekCount rosterStates

initialOwnerCache :: (RealFloat v) => Int -> [Int] -> [IntMap (Selection v)]
initialOwnerCache weekCount rosterStates = replicate weekCount initialCache
  where
    initialCache = initialWeeklyRewardCache rosterStates

initialWeeklyRewardCache :: (RealFloat v) => [Int] -> IntMap (Selection v)
initialWeeklyRewardCache = foldl' (t s->Data.IntMap.Strict.insert s (Selection 0.0 0) t) Data.IntMap.Strict.empty

rosterInts :: [(r, Int)] -> [Int]
rosterInts startingRosterSpots = map digitsToInt digits
  where
    digits = sequence [[n, n-1..0] | n <- map snd startingRosterSpots]

digitsToInt :: [Int] -> Int
digitsToInt d = sum $ zipWith (e p->e*10^p) d [n, n-1..0]
  where
    n = length d - 1

setBits :: Integer -> [Int]
setBits 0 = []
setBits n = popCount (b - 1) : setBits (n `xor` b)
  where
    b = n .&. (complement n + 1)

positionsToRosterSpotIndices :: (Eq p, Hashable p, Eq r, Hashable r) => [(p, [r])] -> HashMap r Int -> [p] -> [Int]
positionsToRosterSpotIndices positionToRosterSpots rosterSpotToIndex positions = setBits bitSet
  where
    pToRSMap = Data.HashMap.Strict.fromList positionToRosterSpots
    bitSet = foldl' (b p->bitSetFromPosition pToRSMap rosterSpotToIndex p .|. b) 0 positions

bitSetFromPosition :: (Eq p, Hashable p, Eq r, Hashable r) => HashMap p [r] -> HashMap r Int -> p -> Integer
bitSetFromPosition positionToRosterSpot rosterSpotToIndex position = bitSet
  where
    rosterSpots = positionToRosterSpot Data.HashMap.Strict.! position
    bitSet = foldl' (b r->bitSetFromRosterSpot rosterSpotToIndex r .|. b) 0 rosterSpots

bitSetFromRosterSpot :: (Eq r, Hashable r) => HashMap r Int -> r -> Integer
bitSetFromRosterSpot rosterSpotToIndex rosterSpot = bit (rosterSpotToIndex Data.HashMap.Strict.! rosterSpot)

--weeklyReward :: (RealFloat v, Show v) => Int -> [Int] -> Int -> v -> IntMap (Selection v) -> v
--weeklyReward fullProblem rosterIndices player projection cache | trace ("weeklyReward " ++ show fullProblem ++ " " ++ show rosterIndices ++ " " ++ show player ++ " " ++ show projection) False = undefined
weeklyReward :: (RealFloat v) => Int -> [Int] -> Int -> v -> IntMap (Selection v) -> v
weeklyReward fullProblem rosterIndices player projection cache = optimalValue - priorValue
  where
    (Selection priorValue _) = cache Data.IntMap.Strict.! fullProblem
    (Selection optimalValue _) = optimalRosterAtState rosterIndices player projection cache fullProblem

--weeklyOwnerCache :: (RealFloat v) => [Int] -> [Int] -> Int -> v -> IntMap (Selection v) -> IntMap (Selection v)
--weeklyOwnerCache rosterStates rosterIndices player projection cache = Data.IntMap.Strict.fromList optimalRosters
--  where
--    optimalRosters = [(state, optimalRosterAtState rosterIndices player projection cache state) | state <- rosterStates]

weeklyOwnerCache :: (RealFloat v) => [Int] -> [Int] -> Int -> v -> IntMap (Selection v) -> IntMap (Selection v)
weeklyOwnerCache rosterStates rosterIndices player projection cache = foldl' updateState cache rosterStates
  where
    updateState c s = Data.IntMap.Strict.insert s (optimalRosterAtState rosterIndices player projection c s) c

optimalRosterAtState :: (RealFloat v) => [Int] -> Int -> v -> IntMap (Selection v) -> Int -> Selection v
optimalRosterAtState rosterIndices player projection cache state = foldl' (p r->max p (selectPlayer r)) prior validRosterIndices
  where
    prior = cache Data.IntMap.Strict.! state
    validRosterIndices = filter (isValidAssignment state) rosterIndices
    selectPlayer r = selection r player projection cache state

selection :: (RealFloat v) => Int -> Int -> v -> IntMap (Selection v) -> Int -> Selection v
selection rosterIndex player projection cache state = Selection newValue newSelections
  where
    rosterSpotValue = 10 ^ rosterIndex
    priorState = state - rosterSpotValue
    (Selection priorValue priorSelections) = cache Data.IntMap.Strict.! priorState
    newValue = priorValue + projection
    newSelections = priorSelections .|. bit player

isValidAssignment :: Int -> Int -> Bool
isValidAssignment rosterState rosterIndex = digitValue rosterState rosterIndex > 0

digitValue :: Int -> Int -> Int
digitValue n i = (n `quot` (10 ^ i)) `rem` 10

编辑以添加完整的源代码库

我在提取复制行为的最小示例时遇到了麻烦，所以我只是发布了完整的存储库。

BitBucket 回购在这里。一旦构建，当 in 时gameshs，stack exec draftsim-mcoffq-exe app/draftsim.json 13 3复制行为。

以上是Haskell-尽管foldl'和严格的数据结构，内存使用量过多的全部内容。
THE END
分享
二维码
< <上一篇
下一篇>>