mirror of
https://github.com/facebook/Haxl.git
synced 2024-10-04 06:07:32 +03:00
f64f27ba01
Summary: Pull Request resolved: https://github.com/facebook/Haxl/pull/114 When processing batches it would be quite easy to double count the allocations from child threads. This diff fixes it by setting the counter to zero after taking the current allocation count Reviewed By: malmerey Differential Revision: D19580472 fbshipit-source-id: 4b9a97f75e82052f4c5d94e1a6762a862a907ffb
86 lines
1.9 KiB
Haskell
86 lines
1.9 KiB
Haskell
-- Copyright (c) 2014-present, Facebook, Inc.
|
|
-- All rights reserved.
|
|
--
|
|
-- This source code is distributed under the terms of a BSD license,
|
|
-- found in the LICENSE file.
|
|
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module WorkDataSource (
|
|
mkWorkState,
|
|
work,
|
|
) where
|
|
|
|
import Haxl.Prelude
|
|
import Prelude ()
|
|
|
|
import Haxl.Core
|
|
|
|
import Control.Exception
|
|
import Data.Hashable
|
|
import Data.Typeable
|
|
import Control.Monad (void)
|
|
import Control.Concurrent.MVar
|
|
|
|
|
|
data Work a where
|
|
Work :: Integer -> Work Integer
|
|
deriving Typeable
|
|
|
|
deriving instance Eq (Work a)
|
|
deriving instance Show (Work a)
|
|
instance ShowP Work where showp = show
|
|
|
|
instance Hashable (Work a) where
|
|
hashWithSalt s (Work a) = hashWithSalt s (0::Int,a)
|
|
|
|
instance DataSourceName Work where
|
|
dataSourceName _ = "Work"
|
|
|
|
instance StateKey Work where
|
|
data State Work = WorkState
|
|
|
|
newtype Service = Service (MVar [IO ()])
|
|
|
|
run :: Work a -> IO a
|
|
run (Work n) = evaluate (sum [1..n]) >> return n
|
|
|
|
mkService :: IO Service
|
|
mkService = Service <$> newMVar []
|
|
|
|
process :: Service -> IO ()
|
|
process (Service q) = do
|
|
r <- swapMVar q []
|
|
sequence_ r
|
|
|
|
enqueue :: Service -> Work a -> IO (IO (Either SomeException a))
|
|
enqueue (Service q) w = do
|
|
res <- newEmptyMVar
|
|
let r = do
|
|
v <- Control.Exception.try $ run w
|
|
putMVar res v
|
|
modifyMVar_ q (return . (:) r)
|
|
return (takeMVar res)
|
|
|
|
instance DataSource u Work where
|
|
fetch = backgroundFetchAcquireReleaseMVar
|
|
mkService
|
|
(\_ -> return ())
|
|
-- pretend we are ready so that process does the work
|
|
(\_ _ m -> void $ tryPutMVar m ())
|
|
process
|
|
enqueue
|
|
|
|
|
|
mkWorkState :: State Work
|
|
mkWorkState = WorkState
|
|
|
|
work :: Integer -> GenHaxl u w Integer
|
|
work n = dataFetch (Work n)
|