diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for byte-containers + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2019, Andrew Martin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Andrew Martin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/byte-containers.cabal b/byte-containers.cabal new file mode 100644 --- /dev/null +++ b/byte-containers.cabal @@ -0,0 +1,63 @@ +cabal-version: 2.2 +name: byte-containers +version: 0.1.0.0 +synopsis: Sets and maps with 8-bit words for keys +description: + This library provides variant of @Data.Map@ and @Data.Set@ from + the @containers@ library where the key is specialized to @Word8@. + Internally, this uses a 256-bit bitmask for the presence of keys + and a @SmallArray@ of values of keys that were present. For example, + the map @{2 => Z, 3 => B, 5 => X, 9 => A}@ would be repsented in + memory as: + . + > Bitmask: 0011010001000000... (240 more zero bits) + > Value Array: Z,B,X,A + . + This is optimized for reads. Lookup is @O(1)@. Union is technically + @O(1)@ but only because the universe of keys is finite. The current + implementation always scans through all 256 bits of key space. + +homepage: https://github.com/byteverse/byte-containers +bug-reports: https://github.com/byteverse/byte-containers/issues +license: BSD-3-Clause +license-file: LICENSE +author: Andrew Martin +maintainer: amartin@layer3com.com +copyright: 2020 Andrew Martin +category: Data +build-type: Simple +extra-doc-files: CHANGELOG.md + +library + build-depends: + , base >=4.12 && <5 + , primitive >=0.7 && <0.10 + , run-st >=0.1 && <0.2 + , wide-word >=0.1.1 && <0.2 + + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: + Data.Map.Word8 + Data.Set.Word8 + + ghc-options: -Wall -O2 + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + ghc-options: -Wall -O2 + build-depends: + , base >=4.12 && <5 + , byte-containers + , byteslice >=0.2.9 && <0.3 + , primitive >=0.7 && <0.10 + , quickcheck-classes >=0.6.4 + , tasty + , tasty-quickcheck + +source-repository head + type: git + location: git://github.com/byteverse/byte-containers.git diff --git a/src/Data/Map/Word8.hs b/src/Data/Map/Word8.hs new file mode 100644 --- /dev/null +++ b/src/Data/Map/Word8.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Map.Word8 + ( Map + , lookup + , null + , size + , empty + , singleton + , union + , unionWith + , insert + , insertWith + , foldrWithKeys + , foldl' + , traverse_ + , toList + , fromList + ) where + +import Prelude hiding (lookup, null) + +import Control.Monad.ST.Run (runSmallArrayST) +import Data.Bits (bit, popCount, testBit, unsafeShiftR, (.&.), (.|.)) +import Data.Primitive (SmallArray) +import Data.WideWord (Word256) +import Data.Word (Word8) + +import qualified Data.Foldable as F +import qualified Data.Primitive as PM + +-- | A map whose keys are 8-bit words. +data Map a + = Map + -- Invariant: len(values) = popcnt keys + {-# UNPACK #-} !Word256 + {-# UNPACK #-} !(SmallArray a) + +deriving stock instance (Eq a) => Eq (Map a) +deriving stock instance Functor Map + +instance (Show a) => Show (Map a) where + showsPrec p m = showsPrec p (toList m) + +instance (Semigroup a) => Semigroup (Map a) where + (<>) = unionWith (<>) + +instance (Semigroup a) => Monoid (Map a) where + mempty = empty + +singleton :: Word8 -> a -> Map a +singleton !k v = + Map + (bit (fromIntegral @Word8 @Int k)) + (runSmallArrayST (PM.newSmallArray 1 v >>= PM.unsafeFreezeSmallArray)) + +-- | Is the passed map empty? +null :: Map a -> Bool +null m = size m == 0 + +-- | The number of elements the passed map contains. +size :: Map a -> Int +size (Map keys _) = popCount keys + +-- | The empty map. +empty :: Map a +empty = Map 0 mempty + +-- | Lookup the value at a key in the map. +lookup :: Word8 -> Map a -> Maybe a +lookup kw (Map keys vals) = case testBit keys k of + False -> Nothing + True -> case k of + 0 -> Just (PM.indexSmallArray vals 0) + _ -> + let ix = popCount (unsafeShiftR maxBound (256 - k) .&. keys) + in Just (PM.indexSmallArray vals ix) + where + k = fromIntegral @Word8 @Int kw + +{- | The expression @'union' t1 t2@ takes the left-biased union +of @t1@ and @t2@. It prefers @t1@ when duplicate keys are +encountered (i.e. @'union' == 'unionWith' const@). +-} +union :: Map a -> Map a -> Map a +union !ma@(Map ksA vsA) !mb@(Map ksB vsB) + | ksA == 0 = mb + | ksB == 0 = ma + | otherwise = Map ks $ runSmallArrayST do + let sz = popCount ks + dst <- PM.newSmallArray sz =<< PM.indexSmallArrayM vsA 0 + foldlZipBits256 + ( \(!ix, !ixA, !ixB) a b -> case a of + True -> do + PM.writeSmallArray dst ix =<< PM.indexSmallArrayM vsA ixA + pure (ix + 1, ixA + 1, if b then ixB + 1 else ixB) + False -> case b of + True -> do + PM.writeSmallArray dst ix =<< PM.indexSmallArrayM vsB ixB + pure (ix + 1, ixA, ixB + 1) + False -> pure (ix, ixA, ixB) + ) + (0, 0, 0) + ksA + ksB + PM.unsafeFreezeSmallArray dst + where + ks = ksA .|. ksB + +-- | Union with a combining function. +unionWith :: (a -> a -> a) -> Map a -> Map a -> Map a +unionWith g !ma@(Map ksA vsA) !mb@(Map ksB vsB) + | ksA == 0 = mb + | ksB == 0 = ma + | otherwise = Map ks $ runSmallArrayST do + let sz = popCount ks + dst <- PM.newSmallArray sz =<< PM.indexSmallArrayM vsA 0 + foldlZipBits256 + ( \(!ix, !ixA, !ixB) a b -> case a of + True -> case b of + True -> do + a <- PM.indexSmallArrayM vsA ixA + b <- PM.indexSmallArrayM vsB ixB + let !c = g a b + PM.writeSmallArray dst ix c + pure (ix + 1, ixA + 1, ixB + 1) + False -> do + PM.writeSmallArray dst ix =<< PM.indexSmallArrayM vsA ixA + pure (ix + 1, ixA + 1, ixB) + False -> case b of + True -> do + PM.writeSmallArray dst ix =<< PM.indexSmallArrayM vsB ixB + pure (ix + 1, ixA, ixB + 1) + False -> pure (ix, ixA, ixB) + ) + (0, 0, 0) + ksA + ksB + PM.unsafeFreezeSmallArray dst + where + ks = ksA .|. ksB + +insert :: Word8 -> a -> Map a -> Map a +insert = insertWith const + +{- | Insert with a function, combining new value and old value. +@'insertWith' f key value mp@ will insert the pair @(key, value)@ into @mp@ +if @key@ does not exist in the map. +If the key does exist, the function will insert the pair +@(key, f new_value old_value)@. +-} +insertWith :: (a -> a -> a) -> Word8 -> a -> Map a -> Map a +insertWith f k v m = unionWith f (singleton k v) m + +-- Internal function. This is strict in the accumulator. +foldlZipBits256 :: + (Monad m) => + (a -> Bool -> Bool -> m a) -> + a -> + Word256 -> + Word256 -> + m () +foldlZipBits256 g !a0 !x !y = go 0 a0 + where + go !ix !a = case ix of + 256 -> pure () + _ -> do + let xval = testBit x ix + let yval = testBit y ix + a' <- g a xval yval + go (ix + 1) a' + +foldrBits256 :: (Word8 -> b -> b) -> b -> Word256 -> b +foldrBits256 g b0 w = go 0 + where + go ix = case ix of + 256 -> b0 + _ -> case testBit w ix of + True -> g (fromIntegral @Int @Word8 ix) (go (ix + 1)) + False -> go (ix + 1) + +foldrWithKeys :: (Word8 -> a -> b -> b) -> b -> Map a -> b +foldrWithKeys g b0 (Map ks vs) = go 0 0 + where + go !ix !ixVal = case ix of + 256 -> b0 + _ -> case testBit ks ix of + True -> + g + (fromIntegral @Int @Word8 ix) + (PM.indexSmallArray vs ixVal) + (go (ix + 1) (ixVal + 1)) + False -> go (ix + 1) ixVal + +foldl' :: (b -> a -> b) -> b -> Map a -> b +{-# INLINE foldl' #-} +foldl' f b0 (Map _ vs) = F.foldl' f b0 vs + +traverse_ :: (Applicative m) => (a -> m b) -> Map a -> m () +{-# INLINE traverse_ #-} +traverse_ f (Map _ vs) = F.traverse_ f vs + +toList :: Map a -> [(Word8, a)] +toList = foldrWithKeys (\k v b -> (k, v) : b) [] + +fromList :: [(Word8, a)] -> Map a +fromList = F.foldl' (\acc (k, v) -> union acc (singleton k v)) empty diff --git a/src/Data/Set/Word8.hs b/src/Data/Set/Word8.hs new file mode 100644 --- /dev/null +++ b/src/Data/Set/Word8.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeApplications #-} + +module Data.Set.Word8 + ( Set + , member + , null + , size + , empty + , singleton + , union + , insert + ) where + +import Prelude hiding (lookup, null) + +import Data.Bits (bit, popCount, testBit, (.|.)) +import Data.WideWord (Word256) +import Data.Word (Word8) + +-- | A map whose keys are 8-bit words. +newtype Set = Set Word256 + +-- | Is the passed map empty? +null :: Set -> Bool +null m = size m == 0 + +-- | The number of elements the passed map contains. +size :: Set -> Int +size (Set keys) = popCount keys + +empty :: Set +empty = Set 0 + +singleton :: Word8 -> Set +singleton !k = Set (bit (fromIntegral @Word8 @Int k)) + +member :: Word8 -> Set -> Bool +member k (Set keys) = + testBit keys (fromIntegral @Word8 @Int k) + +union :: Set -> Set -> Set +union (Set x) (Set y) = Set (x .|. y) + +insert :: Word8 -> Set -> Set +insert k s = union (singleton k) s diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +import Data.Map.Word8 (Map) +import Data.Proxy (Proxy (..)) +import Data.Semigroup (Sum) +import Data.Word (Word8) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.QuickCheck (Arbitrary, Discard (Discard), property, testProperty, (===)) + +import qualified Data.List as List +import qualified Data.Map.Word8 as Map +import qualified Test.QuickCheck.Classes as QCC +import qualified Test.Tasty.QuickCheck as TQC + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "byte-containers" + [ testGroup + "append" + [ testProperty "doubleton" $ \ka (va :: Word) kb vb -> + Map.toList + (Map.union (Map.singleton ka va) (Map.singleton kb vb)) + === ( case compare ka kb of + EQ -> [(ka, va)] + LT -> [(ka, va), (kb, vb)] + GT -> [(kb, vb), (ka, va)] + ) + , testProperty "lookup" lookupProp + , testProperty "associative" $ \alist blist clist -> + let a = Map.fromList alist :: Map Word + b = Map.fromList blist + c = Map.fromList clist + in Map.union a (Map.union b c) + === Map.union (Map.union a b) c + , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (Map [Integer]))) + , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (Map [Integer]))) + , lawsToTest (QCC.commutativeMonoidLaws (Proxy :: Proxy (Map (Sum Integer)))) + , lawsToTest (QCC.functorLaws (Proxy :: Proxy Map)) + ] + , testGroup + "insert" + [ testProperty "replaces" $ \k v v' alist -> + let a = Map.insert k v (Map.fromList alist) :: Map Word + a' = Map.insert k v' a + in if + | v /= v' -> + Map.lookup k a' === Just v' + | otherwise -> property Discard + ] + ] + +instance (Arbitrary a) => Arbitrary (Map a) where + arbitrary = Map.fromList <$> TQC.arbitrary + +lookupProp :: TQC.Property +lookupProp = TQC.property $ \(xs :: [(Word8, Integer)]) -> + let ys = Map.fromList xs + in foldr + ( \x r -> case List.lookup x xs == Map.lookup x ys of + True -> r + False -> TQC.counterexample ("key " ++ show x) False + ) + (TQC.property True) + [0 .. 255 :: Word8] + +lawsToTest :: QCC.Laws -> TestTree +lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs)