避免因单子展开而产生的稀疏评估列表中的重击

问题描述

我有一个仿真库，该库使用包装在monad M中的FFI，并带有上下文。所有的外来函数都是纯函数，因此我决定将monad变为惰性，这通常对于流控制很方便。我将模拟表示为模拟框架的列表，可以通过写入文件或以图形方式显示框架来使用。

simulation :: [(Frame -> M Frame)] -> Frame -> M [Frame] 
simulation [] frame = return [frame]
simulation (step:steps) frame 
   = step frame >>= fmap (frame:) . simulation steps 

每个框架都包含一个由新包装的ForeignPtr组成的元组，我可以使用它们将其提升为Haskell表示形式

lift :: Frame -> M HFrame

由于仿真中的时间步很短，所以我只想查看我使用的每n帧

takeEvery n l = foldr cons nil l 0 where
    nil _ = []
    cons x rest 0 = x : rest n
    cons x rest n = rest (n-1)

所以我的代码看起来像

main = consume 
     $ takeEvery n 
     $ runM 
     $ simulation steps initialFrame >>= mapM lift

现在，问题是当我增加n时，会产生一个重击。我尝试了几种不同的方法来尝试严格评估simulation中的每个帧，但是我还没有弄清楚该如何做。 ForeignPtr似乎没有NFData实例，因此我不能使用deepseq，但是我对seq的所有尝试，包括对seq的使用元组中的每个元素都没有明显效果。

编辑：

应要求，我提供了更多细节，但我最初将其排除在外，因为我认为这些问题在很大程度上可能是困扰该问题的原因。

单子

newtype FT c a = FT (Context -> a)

instance Functor (FT c) where
    fmap f (FT a) = FT (f.a)

instance Applicative (FT c) where
    pure a = FT (\_ -> a)
    (<*>) (FT a) (FT b) = FT (\c -> a c $ b c)

instance Monad (FT c) where
    return = pure
    (>>=) (FT a) f = FT (\c -> (\(FT b) -> b c) $ f $ a c)

runFTIn :: Context -> (forall c. FT c a) -> a
runFTIn context (FT a) = a context


runFTWith :: [ContextOption] -> (forall c. FT c a) -> a
runFTWith options a
    = unsafePerformIO
    $ getContext options >>= \c -> return $ runFTIn c a
runFT = runFTWith []

unsafeLiftFromIO :: (Context -> IO a) -> FT c a
unsafeLiftFromIO a = FT (\c -> unsafePerformIO $ a c)

所有外部功能都从IO到unsafeLiftFromIO

newtype Box c = Box (ForeignPtr RawBox)
newtype Coordinates c = Coordinates (ForeignPtr RawCoordinates)
type Frame c = (Box c,Coordinates c)

liftBox :: Box c -> FT c HBox
liftCoordinates :: Coordinates c -> FT c HCoordinates
liftFrame (box,coordinates) = do
    box' <- liftBox box
    coordinates' <- liftCoordinates coordinates
    return (box',coordinates') 

steps本身应该是任意的(Frame c -> FT c (Frame c))，因此最好在较高级别的代码中严格执行。

EDIT2：

我现在已经尝试使用Streamly，但是问题仍然存在，所以我认为问题确实是在寻找一种严格评估ForeignPtr s的方法。

当前实现：

import Streamly
import qualified Streamly.Prelude as S
import qualified Streamly.Internal.Data.Stream.Serial as Serial

takeEvery n = Serial.unfoldrM ((fmap.fmap) (\(h,t) -> (h,S.drop (n-1) t)) . S.uncons)

(#) = flip ($)
simulation
    :: (IsStream t)
    => Frame c 
    -> t (FT c) (Frame c -> FT c (Frame c)) 
    -> t (FT c) (Frame c)
simulation frame = S.scanlM' (#) frame

EDIT3：

要弄清楚症状以及如何诊断问题。

该库调用在GPU上运行的OpenCL函数。我确信指针的释放已正确处理-ForeignPtr具有正确的释放功能，并且内存使用与steps的总数无关，只要该数目大于{{ 1}}。我发现，GPU上的内存使用基本上与n线性相关。我一直在进行此测试的消费者是

n

对于我的流式实现，

import qualified Data.ByteString.Lazy as BL
import Data.Binary
import Data.Binary.Put

writeTrajectory fn = fmap (BL.writeFile fn . runPut) . S.foldr ((>>).putFrame) (pure ()) . serially

对于原始实现。两者都应连续消耗流。我已经生成了writeTrajectory fn = BL.writeFile fn . runPut . MapM_ putFrame ，用于与steps进行测试。

我不确定如何更精确地分析GPU上的内存使用情况。这里使用系统内存不是问题。

更新： 我开始认为这不是严格的问题，而是GC问题。运行时系统不知道在GPU上分配的内存大小，因此也不知道要收集指针，因此当CPU端也有东西时，这将不再是问题，因为这会产生分配同样，激活GC。这将解释稍微不确定的内存使用情况，但与我见过的replicate呈线性相关。如何很好地解决这个问题是另一个问题，但是我怀疑我的代码将进行重大修改。

解决方法

我认为这个问题确实是在寻找一种严格评估ForeignPtrs的方法

如果这确实是问题所在，那么一种解决方法是更改​​simulation的第二个子句：

{-# LANGUAGE BangPatterns #-}

simulation :: [(Frame -> M Frame)] -> Frame -> M [Frame] 
simulation [] frame = return [frame]
simulation (step:steps) frame@(!_,!_)  -- Evaluate both components of the pair
   = step frame >>= fmap (frame:) . simulation steps