discrimination 0 → 0.1

raw patch · 4 files changed

+118/−157 lines, 4 filesdep +primitivedep +promisesdep ~deepseqPVP ok

version bump matches the API change (PVP)

Dependencies added: primitive, promises

Dependency ranges changed: deepseq

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +9/−2
• discrimination.cabal +6/−4
• src/Data/Discrimination.hs +3/−2
• src/Data/Discrimination/Grouping.hs +100/−149

@@ -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

@@ -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

@@ -10,8 +10,9 @@   , nubWith   , group   , groupWith-  , groupingBag-  , groupingSet+  , runGroup+  -- , groupingBag+  -- , groupingSet   , groupingEq   -- * Ordered   , Sort(..)

@@ -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