diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2015, Kei HIBINO + +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 Kei HIBINO 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,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bytestring-short.cabal b/bytestring-short.cabal new file mode 100644 --- /dev/null +++ b/bytestring-short.cabal @@ -0,0 +1,68 @@ +name: bytestring-short +version: 0.0.1.0 +synopsis: Backport copy of ShortByteString +description: Backport copy of ShortByteString +license: BSD3 +license-file: LICENSE +author: Kei Hibino +maintainer: Kei Hibino +copyright: Copyright (c) Don Stewart 2005-2009, + (c) Duncan Coutts 2006-2013, + (c) David Roundy 2003-2005, + (c) Kei Hibino 2015. +category: Text +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: + Data.ByteString.Short + Data.ByteString.Short.Internal + -- other-modules: + + other-extensions: + DeriveDataTypeable + CPP + BangPatterns + RankNTypes + ForeignFunctionInterface + MagicHash + UnboxedTuples + UnliftedFFITypes + Unsafe + + build-depends: base >=4.2 && <5 + , bytestring >=0.9.1 && <0.10.4 + , deepseq >=1.1 + hs-source-dirs: src + default-language: Haskell2010 + + ghc-options: + -Wall + + default-language: Haskell98 + + c-sources: cbits/short_fpstring.c + include-dirs: include + includes: short_fpstring.h + install-includes: short_fpstring.h + +test-suite prop-compiled + type: exitcode-stdio-1.0 + main-is: Properties.hs + hs-source-dirs: tests + build-depends: base <5, bytestring-short, bytestring, + QuickCheck >=2 + default-language: Haskell98 + c-sources: cbits/short_fpstring.c + include-dirs: include + + +source-repository head + type: git + location: https://github.com/khibino/haskell-bytestring-short + +source-repository head + type: mercurial + location: https://bitbucket.org/khibino/haskell-bytestring-short diff --git a/cbits/short_fpstring.c b/cbits/short_fpstring.c new file mode 100644 --- /dev/null +++ b/cbits/short_fpstring.c @@ -0,0 +1,40 @@ +/* + * Copyright (c) 2003 David Roundy + * Copyright (c) 2005-6 Don Stewart + * + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. 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. + * 3. Neither the names of the authors or the names of any contributors + * may be used to endorse or promote products derived from this software + * without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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. + */ + +#include "short_fpstring.h" + +/* This wrapper is here so that we can copy a sub-range of a ByteArray#. + We cannot construct a pointer to the interior of an unpinned ByteArray#, + except by doing an unsafe ffi call, and adjusting the pointer C-side. */ +void * short_fps_memcpy_offsets(void *dst, unsigned long dst_off, + const void *src, unsigned long src_off, size_t n) { + return memcpy(dst + dst_off, src + src_off, n); +} diff --git a/include/short_fpstring.h b/include/short_fpstring.h new file mode 100644 --- /dev/null +++ b/include/short_fpstring.h @@ -0,0 +1,5 @@ + +#include + +void * short_fps_memcpy_offsets(void *dst, unsigned long dst_off, + const void *src, unsigned long src_off, size_t n); diff --git a/src/Data/ByteString/Short.hs b/src/Data/ByteString/Short.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Short.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +-- | +-- Module : Data.ByteString.Short +-- Copyright : (c) Duncan Coutts 2012-2013 +-- License : BSD-style +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : stable +-- Portability : ghc only +-- +-- A compact representation suitable for storing short byte strings in memory. +-- +-- In typical use cases it can be imported alongside "Data.ByteString", e.g. +-- +-- > import qualified Data.ByteString as B +-- > import qualified Data.ByteString.Short as B +-- > (ShortByteString, toShort, fromShort) +-- +-- Other 'ShortByteString' operations clash with "Data.ByteString" or "Prelude" +-- functions however, so they should be imported @qualified@ with a different +-- alias e.g. +-- +-- > import qualified Data.ByteString.Short as B.Short +-- +module Data.ByteString.Short ( + + -- * The @ShortByteString@ type + + ShortByteString, + + -- ** Memory overhead + -- | With GHC, the memory overheads are as follows, expressed in words and + -- in bytes (words are 4 and 8 bytes on 32 or 64bit machines respectively). + -- + -- * 'ByteString' unshared: 9 words; 36 or 72 bytes. + -- + -- * 'ByteString' shared substring: 5 words; 20 or 40 bytes. + -- + -- * 'ShortByteString': 4 words; 16 or 32 bytes. + -- + -- For the string data itself, both 'ShortByteString' and 'ByteString' use + -- one byte per element, rounded up to the nearest word. For example, + -- including the overheads, a length 10 'ShortByteString' would take + -- @16 + 12 = 28@ bytes on a 32bit platform and @32 + 16 = 48@ bytes on a + -- 64bit platform. + -- + -- These overheads can all be reduced by 1 word (4 or 8 bytes) when the + -- 'ShortByteString' or 'ByteString' is unpacked into another constructor. + -- + -- For example: + -- + -- > data ThingId = ThingId {-# UNPACK #-} !Int + -- > {-# UNPACK #-} !ShortByteString + -- + -- This will take @1 + 1 + 3@ words (the @ThingId@ constructor + + -- unpacked @Int@ + unpacked @ShortByteString@), plus the words for the + -- string data. + + -- ** Heap fragmentation + -- | With GHC, the 'ByteString' representation uses /pinned/ memory, + -- meaning it cannot be moved by the GC. This is usually the right thing to + -- do for larger strings, but for small strings using pinned memory can + -- lead to heap fragmentation which wastes space. The 'ShortByteString' + -- type (and the @Text@ type from the @text@ package) use /unpinned/ memory + -- so they do not contribute to heap fragmentation. In addition, with GHC, + -- small unpinned strings are allocated in the same way as normal heap + -- allocations, rather than in a separate pinned area. + + -- * Conversions + toShort, + fromShort, + pack, + unpack, + + -- * Other operations + empty, null, length, index, + ) where + +import Data.ByteString.Short.Internal +import Prelude () + diff --git a/src/Data/ByteString/Short/Internal.hs b/src/Data/ByteString/Short/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Short/Internal.hs @@ -0,0 +1,589 @@ +{-# LANGUAGE DeriveDataTypeable, CPP, BangPatterns, RankNTypes, + ForeignFunctionInterface, MagicHash, UnboxedTuples, + UnliftedFFITypes #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +#if __GLASGOW_HASKELL__ >= 703 +{-# LANGUAGE Unsafe #-} +#endif +{-# OPTIONS_HADDOCK hide #-} + +-- | +-- Module : Data.ByteString.Short.Internal +-- Copyright : (c) Duncan Coutts 2012-2013 +-- License : BSD-style +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : stable +-- Portability : ghc only +-- +-- Internal representation of ShortByteString +-- +module Data.ByteString.Short.Internal ( + + -- * The @ShortByteString@ type and representation + ShortByteString(..), + + -- * Conversions + toShort, + fromShort, + pack, + unpack, + + -- * Other operations + empty, null, length, index, unsafeIndex, + + -- * Low level operations + createFromPtr, copyToPtr + ) where + +import Data.ByteString.Internal (ByteString(..), inlinePerformIO) + +import Data.Typeable (Typeable) +import Data.Data (Data(..), mkNoRepType) +import Data.Monoid (Monoid(..)) +import Data.String (IsString(..)) +import Control.DeepSeq (NFData(..)) +import qualified Data.List as List (length) +#if MIN_VERSION_base(4,7,0) +import Foreign.C.Types (CSize(..), CInt(..)) +#elif MIN_VERSION_base(4,4,0) +import Foreign.C.Types (CSize(..), CInt(..), CLong(..)) +#else +import Foreign.C.Types (CSize, CInt, CLong) +#endif +import Foreign.Ptr +import Foreign.ForeignPtr (touchForeignPtr) +#if MIN_VERSION_base(4,5,0) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +#else +import Foreign.ForeignPtr (unsafeForeignPtrToPtr) +#endif + +#if MIN_VERSION_base(4,5,0) +import qualified GHC.Exts +#endif +import GHC.Exts ( Int(I#), Int#, Ptr(Ptr), Addr#, Char(C#) + , State#, RealWorld + , ByteArray#, MutableByteArray# + , newByteArray# +#if MIN_VERSION_base(4,6,0) + , newPinnedByteArray# + , byteArrayContents# + , unsafeCoerce# +#endif +#if MIN_VERSION_base(4,3,0) + , sizeofByteArray# +#endif + , indexWord8Array#, indexCharArray# + , writeWord8Array#, writeCharArray# + , unsafeFreezeByteArray# ) +import GHC.IO +#if MIN_VERSION_base(4,6,0) +import GHC.ForeignPtr (ForeignPtr(ForeignPtr), ForeignPtrContents(PlainPtr)) +#else +import GHC.ForeignPtr (mallocPlainForeignPtrBytes) +#endif +import GHC.ST (ST(ST), runST) +import GHC.Word + +import Prelude ( Eq(..), Ord(..), Ordering(..), Read(..), Show(..) + , ($), error, (++) + , Bool(..), (&&), otherwise + , (+), (-), fromIntegral + , return ) + + +-- | A compact representation of a 'Word8' vector. +-- +-- It has a lower memory overhead than a 'ByteString' and and does not +-- contribute to heap fragmentation. It can be converted to or from a +-- 'ByteString' (at the cost of copying the string data). It supports very few +-- other operations. +-- +-- It is suitable for use as an internal representation for code that needs +-- to keep many short strings in memory, but it /should not/ be used as an +-- interchange type. That is, it should not generally be used in public APIs. +-- The 'ByteString' type is usually more suitable for use in interfaces; it is +-- more flexible and it supports a wide range of operations. +-- +data ShortByteString = SBS ByteArray# +#if !(MIN_VERSION_base(4,3,0)) + Int -- ^ Prior to ghc-7.0.x, 'ByteArray#'s reported + -- their length rounded up to the nearest word. + -- This means we have to store the true length + -- separately, wasting a word. +#define LEN(x) (x) +#else +#define _len /* empty */ +#define LEN(x) /* empty */ +#endif + deriving Typeable + +-- The ByteArray# representation is always word sized and aligned but with a +-- known byte length. Our representation choice for ShortByteString is to leave +-- the 0--3 trailing bytes undefined. This means we can use word-sized writes, +-- but we have to be careful with reads, see equateBytes and compareBytes below. + + +instance Eq ShortByteString where + (==) = equateBytes + +instance Ord ShortByteString where + compare = compareBytes + +instance Monoid ShortByteString where + mempty = empty + mappend = append + mconcat = concat + +instance NFData ShortByteString + +instance Show ShortByteString where + showsPrec p ps r = showsPrec p (unpackChars ps) r + +instance Read ShortByteString where + readsPrec p str = [ (packChars x, y) | (x, y) <- readsPrec p str ] + +instance IsString ShortByteString where + fromString = packChars + +instance Data ShortByteString where + gfoldl f z txt = z packBytes `f` (unpackBytes txt) + toConstr _ = error "Data.ByteString.Short.ShortByteString.toConstr" + gunfold _ _ = error "Data.ByteString.Short.ShortByteString.gunfold" +#if MIN_VERSION_base(4,2,0) + dataTypeOf _ = mkNoRepType "Data.ByteString.Short.ShortByteString" +#else + dataTypeOf _ = mkNorepType "Data.ByteString.Short.ShortByteString" +#endif + +------------------------------------------------------------------------ +-- Simple operations + +-- | /O(1)/. The empty 'ShortByteString'. +empty :: ShortByteString +empty = create 0 (\_ -> return ()) + +-- | /O(1)/ The length of a 'ShortByteString'. +length :: ShortByteString -> Int +#if MIN_VERSION_base(4,3,0) +length (SBS barr#) = I# (sizeofByteArray# barr#) +#else +length (SBS _ len) = len +#endif + +-- | /O(1)/ Test whether a 'ShortByteString' is empty. +null :: ShortByteString -> Bool +null sbs = length sbs == 0 + +-- | /O(1)/ 'ShortByteString' index (subscript) operator, starting from 0. +index :: ShortByteString -> Int -> Word8 +index sbs i + | i >= 0 && i < length sbs = unsafeIndex sbs i + | otherwise = indexError sbs i + +unsafeIndex :: ShortByteString -> Int -> Word8 +unsafeIndex sbs = indexWord8Array (asBA sbs) + +indexError :: ShortByteString -> Int -> a +indexError sbs i = + error $ "Data.ByteString.Short.index: error in array index; " ++ show i + ++ " not in range [0.." ++ show (length sbs) ++ ")" + + +------------------------------------------------------------------------ +-- Internal utils + +asBA :: ShortByteString -> BA +asBA (SBS ba# _len) = BA# ba# + +create :: Int -> (forall s. MBA s -> ST s ()) -> ShortByteString +create len fill = + runST (do + mba <- newByteArray len + fill mba + BA# ba# <- unsafeFreezeByteArray mba + return (SBS ba# LEN(len))) +{-# INLINE create #-} + +------------------------------------------------------------------------ +-- Conversion to and from ByteString + +-- | /O(n)/. Convert a 'ByteString' into a 'ShortByteString'. +-- +-- This makes a copy, so does not retain the input string. +-- +toShort :: ByteString -> ShortByteString +toShort !bs = unsafeDupablePerformIO (toShortIO bs) + +toShortIO :: ByteString -> IO ShortByteString +toShortIO (PS fptr off len) = do + mba <- stToIO (newByteArray len) + let ptr = unsafeForeignPtrToPtr fptr + stToIO (copyAddrToByteArray (ptr `plusPtr` off) mba 0 len) + touchForeignPtr fptr + BA# ba# <- stToIO (unsafeFreezeByteArray mba) + return (SBS ba# LEN(len)) + + +-- | /O(n)/. Convert a 'ShortByteString' into a 'ByteString'. +-- +fromShort :: ShortByteString -> ByteString +fromShort !sbs = unsafeDupablePerformIO (fromShortIO sbs) + +fromShortIO :: ShortByteString -> IO ByteString +fromShortIO sbs = do +#if MIN_VERSION_base(4,6,0) + let len = length sbs + mba@(MBA# mba#) <- stToIO (newPinnedByteArray len) + stToIO (copyByteArray (asBA sbs) 0 mba 0 len) + let fp = ForeignPtr (byteArrayContents# (unsafeCoerce# mba#)) + (PlainPtr mba#) + return (PS fp 0 len) +#else + -- Before base 4.6 ForeignPtrContents is not exported from GHC.ForeignPtr + -- so we cannot get direct access to the mbarr# + let len = length sbs + fptr <- mallocPlainForeignPtrBytes len + let ptr = unsafeForeignPtrToPtr fptr + stToIO (copyByteArrayToAddr (asBA sbs) 0 ptr len) + touchForeignPtr fptr + return (PS fptr 0 len) +#endif + + +------------------------------------------------------------------------ +-- Packing and unpacking from lists + +-- | /O(n)/. Convert a list into a 'ShortByteString' +pack :: [Word8] -> ShortByteString +pack = packBytes + +-- | /O(n)/. Convert a 'ShortByteString' into a list. +unpack :: ShortByteString -> [Word8] +unpack = unpackBytes + +packChars :: [Char] -> ShortByteString +packChars cs = packLenChars (List.length cs) cs + +packBytes :: [Word8] -> ShortByteString +packBytes cs = packLenBytes (List.length cs) cs + +packLenChars :: Int -> [Char] -> ShortByteString +packLenChars len cs0 = + create len (\mba -> go mba 0 cs0) + where + go :: MBA s -> Int -> [Char] -> ST s () + go !_ !_ [] = return () + go !mba !i (c:cs) = do + writeCharArray mba i c + go mba (i+1) cs + +packLenBytes :: Int -> [Word8] -> ShortByteString +packLenBytes len ws0 = + create len (\mba -> go mba 0 ws0) + where + go :: MBA s -> Int -> [Word8] -> ST s () + go !_ !_ [] = return () + go !mba !i (w:ws) = do + writeWord8Array mba i w + go mba (i+1) ws + +-- Unpacking bytestrings into lists effeciently is a tradeoff: on the one hand +-- we would like to write a tight loop that just blats the list into memory, on +-- the other hand we want it to be unpacked lazily so we don't end up with a +-- massive list data structure in memory. +-- +-- Our strategy is to combine both: we will unpack lazily in reasonable sized +-- chunks, where each chunk is unpacked strictly. +-- +-- unpackChars does the lazy loop, while unpackAppendBytes and +-- unpackAppendChars do the chunks strictly. + +unpackChars :: ShortByteString -> [Char] +unpackChars bs = unpackAppendCharsLazy bs [] + +unpackBytes :: ShortByteString -> [Word8] +unpackBytes bs = unpackAppendBytesLazy bs [] + +-- Why 100 bytes you ask? Because on a 64bit machine the list we allocate +-- takes just shy of 4k which seems like a reasonable amount. +-- (5 words per list element, 8 bytes per word, 100 elements = 4000 bytes) + +unpackAppendCharsLazy :: ShortByteString -> [Char] -> [Char] +unpackAppendCharsLazy sbs cs0 = + go 0 (length sbs) cs0 + where + sz = 100 + + go off len cs + | len <= sz = unpackAppendCharsStrict sbs off len cs + | otherwise = unpackAppendCharsStrict sbs off sz remainder + where remainder = go (off+sz) (len-sz) cs + +unpackAppendBytesLazy :: ShortByteString -> [Word8] -> [Word8] +unpackAppendBytesLazy sbs ws0 = + go 0 (length sbs) ws0 + where + sz = 100 + + go off len ws + | len <= sz = unpackAppendBytesStrict sbs off len ws + | otherwise = unpackAppendBytesStrict sbs off sz remainder + where remainder = go (off+sz) (len-sz) ws + +-- For these unpack functions, since we're unpacking the whole list strictly we +-- build up the result list in an accumulator. This means we have to build up +-- the list starting at the end. So our traversal starts at the end of the +-- buffer and loops down until we hit the sentinal: + +unpackAppendCharsStrict :: ShortByteString -> Int -> Int -> [Char] -> [Char] +unpackAppendCharsStrict !sbs off len cs = + go (off-1) (off-1 + len) cs + where + go !sentinal !i !acc + | i == sentinal = acc + | otherwise = let !c = indexCharArray (asBA sbs) i + in go sentinal (i-1) (c:acc) + +unpackAppendBytesStrict :: ShortByteString -> Int -> Int -> [Word8] -> [Word8] +unpackAppendBytesStrict !sbs off len ws = + go (off-1) (off-1 + len) ws + where + go !sentinal !i !acc + | i == sentinal = acc + | otherwise = let !w = indexWord8Array (asBA sbs) i + in go sentinal (i-1) (w:acc) + + +------------------------------------------------------------------------ +-- Eq and Ord implementations + +equateBytes :: ShortByteString -> ShortByteString -> Bool +equateBytes sbs1 sbs2 = + let !len1 = length sbs1 + !len2 = length sbs2 + in len1 == len2 + && 0 == inlinePerformIO (memcmp_ByteArray (asBA sbs1) (asBA sbs2) len1) + +compareBytes :: ShortByteString -> ShortByteString -> Ordering +compareBytes sbs1 sbs2 = + let !len1 = length sbs1 + !len2 = length sbs2 + !len = min len1 len2 + in case inlinePerformIO (memcmp_ByteArray (asBA sbs1) (asBA sbs2) len) of + i | i < 0 -> LT + | i > 0 -> GT + | len2 > len1 -> LT + | len2 < len1 -> GT + | otherwise -> EQ + + +------------------------------------------------------------------------ +-- Appending and concatenation + +append :: ShortByteString -> ShortByteString -> ShortByteString +append src1 src2 = + let !len1 = length src1 + !len2 = length src2 + in create (len1 + len2) $ \dst -> do + copyByteArray (asBA src1) 0 dst 0 len1 + copyByteArray (asBA src2) 0 dst len1 len2 + +concat :: [ShortByteString] -> ShortByteString +concat sbss = + create (totalLen 0 sbss) (\dst -> copy dst 0 sbss) + where + totalLen !acc [] = acc + totalLen !acc (sbs: sbss) = totalLen (acc + length sbs) sbss + + copy :: MBA s -> Int -> [ShortByteString] -> ST s () + copy !_ !_ [] = return () + copy !dst !off (src : sbss) = do + let !len = length src + copyByteArray (asBA src) 0 dst off len + copy dst (off + len) sbss + + +------------------------------------------------------------------------ +-- Exported low level operations + +copyToPtr :: ShortByteString -- ^ source data + -> Int -- ^ offset into source + -> Ptr a -- ^ destination + -> Int -- ^ number of bytes to copy + -> IO () +copyToPtr src off dst len = + stToIO $ + copyByteArrayToAddr (asBA src) off dst len + +createFromPtr :: Ptr a -- ^ source data + -> Int -- ^ number of bytes to copy + -> IO ShortByteString +createFromPtr !ptr len = + stToIO $ do + mba <- newByteArray len + copyAddrToByteArray ptr mba 0 len + BA# ba# <- unsafeFreezeByteArray mba + return (SBS ba# LEN(len)) + + +------------------------------------------------------------------------ +-- Primop wrappers + +data BA = BA# ByteArray# +data MBA s = MBA# (MutableByteArray# s) + +indexCharArray :: BA -> Int -> Char +indexCharArray (BA# ba#) (I# i#) = C# (indexCharArray# ba# i#) + +indexWord8Array :: BA -> Int -> Word8 +indexWord8Array (BA# ba#) (I# i#) = W8# (indexWord8Array# ba# i#) + +newByteArray :: Int -> ST s (MBA s) +newByteArray (I# len#) = + ST $ \s -> case newByteArray# len# s of + (# s, mba# #) -> (# s, MBA# mba# #) + +#if MIN_VERSION_base(4,6,0) +newPinnedByteArray :: Int -> ST s (MBA s) +newPinnedByteArray (I# len#) = + ST $ \s -> case newPinnedByteArray# len# s of + (# s, mba# #) -> (# s, MBA# mba# #) +#endif + +unsafeFreezeByteArray :: MBA s -> ST s BA +unsafeFreezeByteArray (MBA# mba#) = + ST $ \s -> case unsafeFreezeByteArray# mba# s of + (# s, ba# #) -> (# s, BA# ba# #) + +writeCharArray :: MBA s -> Int -> Char -> ST s () +writeCharArray (MBA# mba#) (I# i#) (C# c#) = + ST $ \s -> case writeCharArray# mba# i# c# s of + s -> (# s, () #) + +writeWord8Array :: MBA s -> Int -> Word8 -> ST s () +writeWord8Array (MBA# mba#) (I# i#) (W8# w#) = + ST $ \s -> case writeWord8Array# mba# i# w# s of + s -> (# s, () #) + +copyAddrToByteArray :: Ptr a -> MBA RealWorld -> Int -> Int -> ST RealWorld () +copyAddrToByteArray (Ptr src#) (MBA# dst#) (I# dst_off#) (I# len#) = + ST $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of + s -> (# s, () #) + +copyByteArrayToAddr :: BA -> Int -> Ptr a -> Int -> ST RealWorld () +copyByteArrayToAddr (BA# src#) (I# src_off#) (Ptr dst#) (I# len#) = + ST $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of + s -> (# s, () #) + +copyByteArray :: BA -> Int -> MBA s -> Int -> Int -> ST s () +copyByteArray (BA# src#) (I# src_off#) (MBA# dst#) (I# dst_off#) (I# len#) = + ST $ \s -> case copyByteArray# src# src_off# dst# dst_off# len# s of + s -> (# s, () #) + + +------------------------------------------------------------------------ +-- FFI imports + +memcmp_ByteArray :: BA -> BA -> Int -> IO CInt +memcmp_ByteArray (BA# ba1#) (BA# ba2#) len = + c_memcmp_ByteArray ba1# ba2# (fromIntegral len) + +foreign import ccall unsafe "string.h memcmp" + c_memcmp_ByteArray :: ByteArray# -> ByteArray# -> CSize -> IO CInt + + +------------------------------------------------------------------------ +-- Primop replacements + +copyAddrToByteArray# :: Addr# + -> MutableByteArray# RealWorld -> Int# + -> Int# + -> State# RealWorld -> State# RealWorld + +copyByteArrayToAddr# :: ByteArray# -> Int# + -> Addr# + -> Int# + -> State# RealWorld -> State# RealWorld + +copyByteArray# :: ByteArray# -> Int# + -> MutableByteArray# s -> Int# + -> Int# + -> State# s -> State# s + +#if MIN_VERSION_base(4,7,0) + +-- These exist as real primops in ghc-7.8, and for before that we use +-- FFI to C memcpy. +copyAddrToByteArray# = GHC.Exts.copyAddrToByteArray# +copyByteArrayToAddr# = GHC.Exts.copyByteArrayToAddr# + +#else + +copyAddrToByteArray# src dst dst_off len s = + unIO_ (memcpy_AddrToByteArray dst (clong dst_off) src 0 (csize len)) s + +copyAddrToByteArray0 :: Addr# -> MutableByteArray# s -> Int# + -> State# RealWorld -> State# RealWorld +copyAddrToByteArray0 src dst len s = + unIO_ (memcpy_AddrToByteArray0 dst src (csize len)) s + +{-# INLINE [0] copyAddrToByteArray# #-} +{-# RULES "copyAddrToByteArray# dst_off=0" + forall src dst len s. + copyAddrToByteArray# src dst 0# len s + = copyAddrToByteArray0 src dst len s #-} + +foreign import ccall unsafe "short_fpstring.h short_fps_memcpy_offsets" + memcpy_AddrToByteArray :: MutableByteArray# s -> CLong -> Addr# -> CLong -> CSize -> IO () + +foreign import ccall unsafe "string.h memcpy" + memcpy_AddrToByteArray0 :: MutableByteArray# s -> Addr# -> CSize -> IO () + + +copyByteArrayToAddr# src src_off dst len s = + unIO_ (memcpy_ByteArrayToAddr dst 0 src (clong src_off) (csize len)) s + +copyByteArrayToAddr0 :: ByteArray# -> Addr# -> Int# + -> State# RealWorld -> State# RealWorld +copyByteArrayToAddr0 src dst len s = + unIO_ (memcpy_ByteArrayToAddr0 dst src (csize len)) s + +{-# INLINE [0] copyByteArrayToAddr# #-} +{-# RULES "copyByteArrayToAddr# src_off=0" + forall src dst len s. + copyByteArrayToAddr# src 0# dst len s + = copyByteArrayToAddr0 src dst len s #-} + +foreign import ccall unsafe "short_fpstring.h short_fps_memcpy_offsets" + memcpy_ByteArrayToAddr :: Addr# -> CLong -> ByteArray# -> CLong -> CSize -> IO () + +foreign import ccall unsafe "string.h memcpy" + memcpy_ByteArrayToAddr0 :: Addr# -> ByteArray# -> CSize -> IO () + + +unIO_ :: IO () -> State# RealWorld -> State# RealWorld +unIO_ io s = case unIO io s of (# s, _ #) -> s + +clong :: Int# -> CLong +clong i# = fromIntegral (I# i#) + +csize :: Int# -> CSize +csize i# = fromIntegral (I# i#) +#endif + +#if MIN_VERSION_base(4,5,0) +copyByteArray# = GHC.Exts.copyByteArray# +#else +copyByteArray# src src_off dst dst_off len s = + unST_ (unsafeIOToST + (memcpy_ByteArray dst (clong dst_off) src (clong src_off) (csize len))) s + where + unST (ST st) = st + unST_ st s = case unST st s of (# s, _ #) -> s + +foreign import ccall unsafe "short_fpstring.h short_fps_memcpy_offsets" + memcpy_ByteArray :: MutableByteArray# s -> CLong + -> ByteArray# -> CLong -> CSize -> IO () +#endif diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -0,0 +1,130 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +import Data.ByteString.Char8 () +import qualified Data.ByteString as P +import qualified Data.ByteString.Internal as P +import qualified Data.ByteString.Short as Short + +import Control.Applicative ((<$>)) +import Control.Monad (unless) +import Data.Monoid (mappend, mconcat) +import Data.Maybe (catMaybes) +import Data.String (fromString) +import System.IO (stderr, hPutStrLn) +import Test.QuickCheck + (Testable, Property, Result (..), quickCheckResult, label, + Arbitrary (..), choose) + + +type Test = (String, Property) + +testProperty :: Testable prop => String -> prop -> Test +testProperty m = (,) m . label m + +runMayError :: Testable prop => (a, prop) -> IO (Maybe (a, Result)) +runMayError (m, prop) = fmap ((,) m) . err <$> quickCheckResult prop where + err :: Result -> Maybe Result + err (Success {}) = Nothing + err x = Just x + +defaultMain :: [Test] -> IO () +defaultMain xs = do + es <- catMaybes <$> mapM runMayError xs + mapM_ (\(m, r) -> hPutStrLn stderr $ m ++ ":\n" ++ show r) es + unless (null es) $ fail "Found some failures." + +main :: IO () +main = defaultMain tests + + +-- Arbitrary instance for only test. +instance Arbitrary P.ByteString where + arbitrary = do + bs <- P.pack `fmap` arbitrary + n <- choose (0, 2) + return (P.drop n bs) -- to give us some with non-0 offset + +prop_short_pack_unpack xs = + (Short.unpack . Short.pack) xs == xs +prop_short_toShort_fromShort bs = + (Short.fromShort . Short.toShort) bs == bs + +prop_short_toShort_unpack bs = + (Short.unpack . Short.toShort) bs == P.unpack bs +prop_short_pack_fromShort xs = + (Short.fromShort . Short.pack) xs == P.pack xs + +prop_short_empty = + Short.empty == Short.toShort P.empty + && Short.empty == Short.pack [] + && Short.null (Short.toShort P.empty) + && Short.null (Short.pack []) + && Short.null Short.empty + +prop_short_null_toShort bs = + P.null bs == Short.null (Short.toShort bs) +prop_short_null_pack xs = + null xs == Short.null (Short.pack xs) + +prop_short_length_toShort bs = + P.length bs == Short.length (Short.toShort bs) +prop_short_length_pack xs = + length xs == Short.length (Short.pack xs) + +prop_short_index_pack xs = + all (\i -> Short.pack xs `Short.index` i == xs !! i) + [0 .. length xs - 1] +prop_short_index_toShort bs = + all (\i -> Short.toShort bs `Short.index` i == bs `P.index` i) + [0 .. P.length bs - 1] + +prop_short_eq xs ys = + (xs == ys) == (Short.pack xs == Short.pack ys) +prop_short_ord xs ys = + (xs `compare` ys) == (Short.pack xs `compare` Short.pack ys) + +prop_short_mappend_empty_empty = + Short.empty `mappend` Short.empty == Short.empty +prop_short_mappend_empty xs = + Short.empty `mappend` Short.pack xs == Short.pack xs + && Short.pack xs `mappend` Short.empty == Short.pack xs +prop_short_mappend xs ys = + (xs `mappend` ys) == Short.unpack (Short.pack xs `mappend` Short.pack ys) +prop_short_mconcat xss = + mconcat xss == Short.unpack (mconcat (map Short.pack xss)) + +prop_short_fromString s = + fromString s == Short.fromShort (fromString s) + +prop_short_show xs = + show (Short.pack xs) == show (map P.w2c xs) +prop_short_show' xs = + show (Short.pack xs) == show (P.pack xs) + +prop_short_read xs = + read (show (Short.pack xs)) == Short.pack xs + +tests :: [Test] +tests = + [ testProperty "pack/unpack" prop_short_pack_unpack + , testProperty "toShort/fromShort" prop_short_toShort_fromShort + , testProperty "toShort/unpack" prop_short_toShort_unpack + , testProperty "pack/fromShort" prop_short_pack_fromShort + , testProperty "empty" prop_short_empty + , testProperty "null/toShort" prop_short_null_toShort + , testProperty "null/pack" prop_short_null_pack + , testProperty "length/toShort" prop_short_length_toShort + , testProperty "length/pack" prop_short_length_pack + , testProperty "index/pack" prop_short_index_pack + , testProperty "index/toShort" prop_short_index_toShort + , testProperty "Eq" prop_short_eq + , testProperty "Ord" prop_short_ord + , testProperty "mappend/empty/empty" prop_short_mappend_empty_empty + , testProperty "mappend/empty" prop_short_mappend_empty + , testProperty "mappend" prop_short_mappend + , testProperty "mconcat" prop_short_mconcat + , testProperty "fromString" prop_short_fromString + , testProperty "show" prop_short_show + , testProperty "show'" prop_short_show' + , testProperty "read" prop_short_read + ]