diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,10 @@ -0 -- +## 0.1 + +* `grouping` is now productive. This means it can start spitting out results as it goes! To do this I created the `promises` package and switched to using it behind the scenes for many combinators that consume a `Group`. This has a bunch of knock-on effects: + * `grouping` is now working properly with respect to its law! + * `grouping` now uses an American-flag style top-down radix sort rather than a bottom up radix sort for all operations. This is sadly required for productivity. This will use a lot more memory for intermediate arrays, as we don't get to return them to storage after we're done. + * We now use much smaller intermediate arrays for `grouping`. Should we do the same for `sorting`? + +## 0 + * Initialized repository diff --git a/discrimination.cabal b/discrimination.cabal --- a/discrimination.cabal +++ b/discrimination.cabal @@ -1,6 +1,6 @@ name: discrimination category: Data, Sorting -version: 0 +version: 0.1 license: BSD3 cabal-version: >= 1.10 license-file: LICENSE @@ -43,12 +43,14 @@ build-depends: array >= 0.5 && < 0.6, base >= 4.7 && < 5, - containers >= 0.5 && < 0.6, + containers >= 0.4 && < 0.6, contravariant >= 1.3.1 && < 2, - deepseq >= 1.4 && < 1.5, + deepseq >= 1.3 && < 1.5, ghc-prim, + primitive >= 0.6 && < 0.7, profunctors >= 5 && < 6, + promises >= 0.2 && < 0.3, semigroups >= 0.16.2 && < 1, transformers >= 0.2 && < 0.5, vector >= 0.10 && < 0.11, - void >= 0.6 && < 1 + void >= 0.5 && < 1 diff --git a/src/Data/Discrimination.hs b/src/Data/Discrimination.hs --- a/src/Data/Discrimination.hs +++ b/src/Data/Discrimination.hs @@ -10,8 +10,9 @@ , nubWith , group , groupWith - , groupingBag - , groupingSet + , runGroup + -- , groupingBag + -- , groupingSet , groupingEq -- * Ordered , Sort(..) diff --git a/src/Data/Discrimination/Grouping.hs b/src/Data/Discrimination/Grouping.hs --- a/src/Data/Discrimination/Grouping.hs +++ b/src/Data/Discrimination/Grouping.hs @@ -22,150 +22,81 @@ , nub, nubWith , group, groupWith , groupingEq + , runGroup -- * Internals - , groupingBag - , groupingSet - , groupingShort , groupingNat ) where -import Control.Arrow -import Control.Monad +import Control.Monad hiding (mapM_) +import Control.Monad.Primitive +import Control.Monad.ST import Data.Bits import Data.Complex -import Data.Discrimination.Internal import Data.Foldable hiding (concat) -import Data.Functor import Data.Functor.Compose import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible import Data.Functor.Contravariant.Generic -import Data.IORef (IORef, newIORef, atomicModifyIORef) import Data.Int import Data.Monoid hiding (Any) +import Data.Primitive.MutVar +import Data.Promise import Data.Proxy import Data.Ratio import Data.Typeable import qualified Data.Vector.Mutable as UM import Data.Void import Data.Word -import GHC.Prim (Any, RealWorld) -import Prelude hiding (read, concat) -import System.IO.Unsafe -import Unsafe.Coerce -{- -import Data.Coerce -import Data.Primitive.Types (Addr(..)) -import GHC.IO (IO(IO)) -import qualified Data.Vector.Primitive as P -import qualified Data.Vector.Primitive.Mutable as PM -import Data.Primitive.ByteArray (MutableByteArray(MutableByteArray)) -import GHC.Prim (Any, State#, RealWorld, MutableByteArray#, Int#) -import GHC.IORef (IORef(IORef)) -import GHC.STRef (STRef(STRef)) --} - --- | Discriminator +import Prelude hiding (read, concat, mapM_) --- TODO: use [(a,b)] -> [NonEmpty b] to better indicate safety? -newtype Group a = Group { runGroup :: forall b. [(a,b)] -> [[b]] } - deriving Typeable +-- | Productive Stable Unordered Discriminator -#ifndef HLINT -type role Group representational -#endif +newtype Group a = Group + { getGroup :: forall m b. PrimMonad m + => (b -> m (b -> m ())) -> m (a -> b -> m ()) + } deriving Typeable instance Contravariant Group where - contramap f (Group g) = Group $ g . map (first f) + contramap f m = Group $ \k -> do + g <- getGroup m k + return (g . f) instance Divisible Group where - conquer = Group $ return . fmap snd - divide k (Group l) (Group r) = Group $ \xs -> - l [ (b, (c, d)) | (a,d) <- xs, let (b, c) = k a] >>= r + conquer = Group $ \ (k :: b -> m (b -> m ())) -> do + v <- newMutVar undefined + writeMutVar v $ \b -> k b >>= writeMutVar v + return $ \ _ b -> readMutVar v >>= ($ b) + divide f m n = Group $ \k -> do + kbcd <- getGroup m $ \ (c, d) -> do + kcd <- getGroup n k + kcd c d + return $ uncurry kcd + return $ \ a d -> case f a of + (b, c) -> kbcd b (c, d) + instance Decidable Group where - lose k = Group $ fmap (absurd.k.fst) - choose f (Group l) (Group r) = Group $ \xs -> let - ys = zipWith (\n (a,d) -> (f a, (n, d))) [0..] xs - in l [ (k,p) | (Left k, p) <- ys ] `mix` - r [ (k,p) | (Right k, p) <- ys ] + choose f m n = Group $ \k -> do + kb <- getGroup m k + kc <- getGroup n k + return (either kb kc . f) -mix :: [[(Int,b)]] -> [[(Int,b)]] -> [[b]] -mix [] bs = fmap snd <$> bs -mix as [] = fmap snd <$> as -mix asss@(((n,a):as):ass) bsss@(((m,b):bs):bss) - | n < m = (a:fmap snd as) : mix ass bsss - | otherwise = (b:fmap snd bs) : mix asss bss -mix _ _ = error "bad discriminator" + lose k = Group $ \_ -> return (absurd . k) instance Monoid (Group a) where mempty = conquer - mappend (Group l) (Group r) = Group $ \xs -> l [ (fst x, x) | x <- xs ] >>= r + mappend = divide (\a -> (a,a)) -------------------------------------------------------------------------------- -- Primitives -------------------------------------------------------------------------------- --- | Perform stable unordered discrimination by bucket. --- --- This reuses arrays unlike the more obvious ST implementation, so it wins by --- a huge margin in a race, especially when we have a large --- keyspace, sparsely used, with low contention. --- This will leak a number of arrays equal to the maximum concurrent --- contention for this resource. If this becomes a bottleneck we can --- make multiple stacks of working pads and index the stack with the --- hash of the current thread id to reduce contention at the expense --- of taking more memory. --- --- You should create a thunk that holds the discriminator from @groupingNat n@ --- for a known @n@ and then reuse it. groupingNat :: Int -> Group Int -groupingNat n = unsafePerformIO $ do - ts <- newIORef ([] :: [UM.MVector RealWorld [Any]]) - return $ Group $ go ts - where - step1 t keys (k, v) = UM.read t k >>= \vs -> case vs of - [] -> (k:keys) <$ UM.write t k [v] - _ -> keys <$ UM.write t k (v:vs) - step2 t vss k = do - es <- UM.read t k - (reverse es : vss) <$ UM.write t k [] - go :: IORef [UM.MVector RealWorld [Any]] -> [(Int, b)] -> [[b]] - go ts xs = unsafePerformIO $ do - mt <- atomicModifyIORef ts $ \case - (y:ys) -> (ys, Just y) - [] -> ([], Nothing) - t <- maybe (UM.replicate n []) (return . unsafeCoerce) mt - ys <- foldM (step1 t) [] xs - zs <- foldM (step2 t) [] ys - atomicModifyIORef ts $ \ws -> (unsafeCoerce t:ws, ()) - return zs - {-# NOINLINE go #-} -{-# NOINLINE groupingNat #-} - --- | Shared bucket set for small integers -groupingShort :: Group Int -groupingShort = groupingNat 65536 -{-# NOINLINE groupingShort #-} - -{- -foreign import prim "walk" walk :: Any -> MutableByteArray# s -> State# s -> (# State# s, Int# #) - -groupingSTRef :: Group Addr -> Group (STRef s a) -groupingSTRef (Group f) = Group $ \xs -> - let force !n !(!(STRef !_,_):ys) = force (n + 1) ys - force !n [] = n - in case force 0 xs of - !n -> unsafePerformIO $ do - mv@(PM.MVector _ _ (MutableByteArray mba)) <- PM.new n :: IO (PM.MVector RealWorld Addr) - IO $ \s -> case walk (unsafeCoerce xs) mba s of (# s', _ #) -> (# s', () #) - ys <- P.freeze mv - return $ f [ (a,snd kv) | kv <- xs | a <- P.toList ys ] -{-# NOINLINE groupingSTRef #-} - -groupingIORef :: forall a. Group Addr -> Group (IORef a) -groupingIORef = coerce (groupingSTRef :: Group Addr -> Group (STRef RealWorld a)) --} +groupingNat = \ n -> Group $ \k -> do + t <- UM.replicate n Nothing + return $ \ a b -> UM.read t a >>= \case + Nothing -> k b >>= UM.write t a . Just + Just k' -> k' b -------------------------------------------------------------------------------- -- * Unordered Discrimination (for partitioning) @@ -189,23 +120,31 @@ grouping = lose id instance Grouping Word8 where - grouping = contramap fromIntegral groupingShort + grouping = contramap fromIntegral (groupingNat 256) instance Grouping Word16 where - grouping = contramap fromIntegral groupingShort + grouping = divide (\x -> (fromIntegral (unsafeShiftR x 8), fromIntegral x .&. 0xff)) (groupingNat 256) (groupingNat 256) instance Grouping Word32 where - grouping = Group (runs <=< runGroup groupingShort . join . runGroup groupingShort . map radices) where - radices (x,b) = (fromIntegral x .&. 0xffff, (fromIntegral (unsafeShiftR x 16), (x,b))) + grouping = divide (\x -> ( (fromIntegral (unsafeShiftR x 24) , fromIntegral (unsafeShiftR x 16) .&. 0xff) + , (fromIntegral (unsafeShiftR x 8) .&. 0xff, fromIntegral x .&. 0xff) + ) + ) + (divide id (groupingNat 256) (groupingNat 256)) + (divide id (groupingNat 256) (groupingNat 256)) instance Grouping Word64 where - grouping = Group (runs <=< runGroup groupingShort . join . runGroup groupingShort . join - . runGroup groupingShort . join . runGroup groupingShort . map radices) - where - radices (x,b) = (fromIntegral x .&. 0xffff, (fromIntegral (unsafeShiftR x 16) .&. 0xffff - , (fromIntegral (unsafeShiftR x 32) .&. 0xffff, (fromIntegral (unsafeShiftR x 48) - , (x,b))))) - + grouping = divide (\x -> + ( ( (fromIntegral (unsafeShiftR x 56) , fromIntegral (unsafeShiftR x 48) .&. 0xff) + , (fromIntegral (unsafeShiftR x 40) .&. 0xff, fromIntegral (unsafeShiftR x 32) .&. 0xff) + ), + ( (fromIntegral (unsafeShiftR x 24) .&. 0xff, fromIntegral (unsafeShiftR x 16) .&. 0xff) + , (fromIntegral (unsafeShiftR x 8) .&. 0xff, fromIntegral x .&. 0xff) + ) + ) + ) + (divide id (divide id (groupingNat 256) (groupingNat 256)) (divide id (groupingNat 256) (groupingNat 256))) + (divide id (divide id (groupingNat 256) (groupingNat 256)) (divide id (groupingNat 256) (groupingNat 256))) instance Grouping Word where grouping @@ -213,10 +152,10 @@ | otherwise = contramap (fromIntegral :: Word -> Word64) grouping instance Grouping Int8 where - grouping = contramap (\x -> fromIntegral x + 128) groupingShort + grouping = contramap (\x -> fromIntegral x + 128) (groupingNat 256) instance Grouping Int16 where - grouping = contramap (\x -> fromIntegral x + 32768) groupingShort + grouping = contramap (\x -> fromIntegral (x - minBound) :: Word16) grouping instance Grouping Int32 where grouping = contramap (\x -> fromIntegral (x - minBound) :: Word32) grouping @@ -261,18 +200,42 @@ -- | Valid definition for @('==')@ in terms of 'Grouping'. groupingEq :: Grouping a => a -> a -> Bool -groupingEq a b = case runGroup grouping [(a,()),(b,())] of - _:_:_ -> False - _ -> True +groupingEq a b = runST $ do + rn <- newMutVar (0 :: Word8) + k <- getGroup grouping $ \_ -> do + modifyMutVar' rn (+1) + return return + k a () + k b () + n <- readMutVar rn + return $ n == 2 {-# INLINE groupingEq #-} +runGroup :: Group a -> [(a,b)] -> [[b]] +runGroup (Group m) xs = runLazy (\p0 -> do + rp <- newMutVar p0 + f <- m $ \ b -> do + p <- readMutVar rp + q <- promise [] + p' <- promise [] + p != (b : demand q) : demand p' + writeMutVar rp p' + rq <- newMutVar q + return $ \b' -> do + q' <- readMutVar rq + q'' <- promise [] + q' != b' : demand q'' + writeMutVar rq q'' + mapM_ (uncurry f) xs + ) [] + -------------------------------------------------------------------------------- -- * Combinators -------------------------------------------------------------------------------- -- | /O(n)/. Similar to 'Data.List.group', except we do not require groups to be clustered. -- --- This combinator still operates in linear time, at the expense of productivity. +-- This combinator still operates in linear time, at the expense of storing history. -- -- The result equivalence classes are _not_ sorted, but the grouping is stable. -- @@ -289,41 +252,29 @@ groupWith f as = runGroup grouping [(f a, a) | a <- as] -- | /O(n)/. This upgrades 'Data.List.nub' from @Data.List@ from /O(n^2)/ to /O(n)/ by using --- unordered discrimination. +-- productive unordered discrimination. -- -- @ -- 'nub' = 'nubWith' 'id' -- 'nub' as = 'head' 'Control.Applicative.<$>' 'group' as -- @ nub :: Grouping a => [a] -> [a] -nub as = head <$> group as +nub = nubWith id --- | /O(n)/. 'nub' with a Schwartzian transform. +-- | /O(n)/. Online 'nub' with a Schwartzian transform. -- -- @ -- 'nubWith' f as = 'head' 'Control.Applicative.<$>' 'groupWith' f as -- @ nubWith :: Grouping b => (a -> b) -> [a] -> [a] -nubWith f as = head <$> groupWith f as - --------------------------------------------------------------------------------- --- * Collections --------------------------------------------------------------------------------- - --- | Construct an stable unordered discriminator that partitions into equivalence classes based on the equivalence of keys as a multiset. -groupingBag :: Foldable f => Group k -> Group (f k) -groupingBag = groupingColl updateBag - --- | Construct an stable unordered discriminator that partitions into equivalence classes based on the equivalence of keys as a set. -groupingSet :: Foldable f => Group k -> Group (f k) -groupingSet = groupingColl updateSet +nubWith f xs = runLazy (\p0 -> do + rp <- newMutVar p0 + k <- getGroup grouping $ \a -> do + p' <- promise [] + p <- readMutVar rp + p != a : demand p' + writeMutVar rp p' + return $ \ _ -> return () + mapM_ (\x -> k (f x) x) xs + ) [] -groupingColl :: Foldable f => ([Int] -> Int -> [Int]) -> Group k -> Group (f k) -groupingColl update r = Group $ \xss -> let - (kss, vs) = unzip xss - elemKeyNumAssocs = groupNum (toList <$> kss) - keyNumBlocks = runGroup r elemKeyNumAssocs - keyNumElemNumAssocs = groupNum keyNumBlocks - sigs = bdiscNat (length kss) update keyNumElemNumAssocs - yss = zip sigs vs - in filter (not . null) $ grouping1 (groupingNat (length keyNumBlocks)) `runGroup` yss