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

【问题标题】：Haskell - Excessive memory usage despite foldl' and strict data structuresHaskell - 尽管 foldl' 和严格的数据结构，内存使用过多
【发布时间】：2021-09-06 02:31:25
【问题描述】：

鉴于程序应该执行的操作，我有一个程序正在使用“过多”内存。有问题的代码片段（每个 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 模式强制评估），但无济于事。虽然我将代码提取到一个最小的复制示例中，但还有另一条信息可能是相关的。

weeklyCacheIntMap 对象位于HashMap o [IntMap (Selection v)] 结构中（由所有者键入，~16 长列表的每个元素是一个每周缓存）。使用惰性列表是否可能导致这种情况？

另一种可能性是 newGame 元组本身（这是我所有其他库模块的“游戏规则接口”）导致了这种情况。根据下面的反馈，如果 newGame 元组在 Main.hs 中传递到我的库之前仅被评估为 WHNF（例如到 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 repo here。构建完成后，在 gameshs 中时，stack exec draftsim-mcoffq-exe app/draftsim.json 13 3 会复制该行为。

【问题讨论】：

  • 我建议您包含完整的程序，包括 main 以及您如何编译和运行该程序。
  • 会的。它分布在 6-7 个库模块 + 主......一千行代码中。尝试提取最小再现示例。

标签： haskell


【解决方案1】：

没有完整的工作示例，很难确定任何内容。

据我所知，最可能的问题是，您的严格操作只会将元组 (v, Integer) 强制为弱头范式，但强制元组只会强制元组构造函数，而 v和Integer 本身仍未被评估。

所以，作为第一遍，尝试对selection 中的值进行一些强制：

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

（注意最后两行的 bang 模式。）

如果这不起作用，作为第二遍，尝试将您的元组类型 (v, Integer) 替换为严格版本：

data Selection v = Selection !v !Integer

看看能不能解决问题。

【讨论】：

    猜你喜欢
    • 2012-11-12
    • 1970-01-01
    • 1970-01-01
    • 1970-01-01
    • 1970-01-01
    • 1970-01-01
    • 2021-12-20
    • 2015-01-08
    • 1970-01-01
    相关资源
    最近更新 更多
    热门标签
    Java Python linux javascript Mysql C# Docker 算法 前端 SpringBoot Redis Vue spring 设计模式 .net core .net kubernetes c++ 数据库 数据结构 大数据 js 机器学习 微服务 Android Go 程序员 面试 JVM ASP.net core 云原生 人工智能 后端 PHP git CSS golang k8s Nginx Django mybatis 深度学习 多线程 React 架构 devops 爬虫 云计算 Spring Boot LeetCode