Bryan O'Sullivan avatar Bryan O'Sullivan committed ed3a60e

Switch to native code for copying and comparison.

Comments (0)

Files changed (7)

Data/Text/Array.hs

-{-# LANGUAGE BangPatterns, CPP, MagicHash, Rank2Types, RecordWildCards,
-    UnboxedTuples #-}
+{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, MagicHash, Rank2Types,
+    RecordWildCards, UnboxedTuples, UnliftedFFITypes #-}
 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
 -- |
 -- Module      : Data.Text.Array
--- Copyright   : (c) 2009, 2010 Bryan O'Sullivan
+-- Copyright   : (c) 2009, 2010, 2011 Bryan O'Sullivan
 --
 -- License     : BSD-style
 -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,
 #if defined(ASSERTS)
 import Control.Exception (assert)
 #endif
+import Control.Monad.ST (unsafeIOToST)
 import Data.Bits ((.&.), xor)
+import Data.Text.Unsafe.Base (inlinePerformIO)
 import Data.Text.UnsafeShift (shiftL, shiftR)
+import Foreign.C.Types (CInt, CSize)
 import GHC.Base (ByteArray#, MutableByteArray#, Int(..),
-                 indexWord16Array#, indexWordArray#, newByteArray#,
-                 readWord16Array#, readWordArray#, unsafeCoerce#,
-                 writeWord16Array#, writeWordArray#)
+                 indexWord16Array#, newByteArray#,
+                 unsafeCoerce#, writeWord16Array#)
 import GHC.ST (ST(..), runST)
-import GHC.Word (Word16(..), Word(..))
+import GHC.Word (Word16(..))
 import Prelude hiding (length, read)
 
 -- | Immutable array type.
     case indexWord16Array# aBA i# of r# -> (W16# r#)
 {-# INLINE unsafeIndex #-}
 
--- | Unchecked read of an immutable array.  May return garbage or
--- crash on an out-of-bounds access.
-unsafeIndexWord :: Array -> Int -> Word
-unsafeIndexWord Array{..} i@(I# i#) =
-  CHECK_BOUNDS("unsafeIndexWord",aLen`div`wordFactor,i)
-    case indexWordArray# aBA i# of r# -> (W# r#)
-{-# INLINE unsafeIndexWord #-}
-
--- | Unchecked read of a mutable array.  May return garbage or
--- crash on an out-of-bounds access.
-unsafeRead :: MArray s -> Int -> ST s Word16
-unsafeRead MArray{..} i@(I# i#) = ST $ \s# ->
-  CHECK_BOUNDS("unsafeRead",maLen,i)
-  case readWord16Array# maBA i# s# of
-    (# s2#, r# #) -> (# s2#, W16# r# #)
-{-# INLINE unsafeRead #-}
-
 -- | Unchecked write of a mutable array.  May return garbage or crash
 -- on an out-of-bounds access.
 unsafeWrite :: MArray s -> Int -> Word16 -> ST s ()
     s2# -> (# s2#, () #)
 {-# INLINE unsafeWrite #-}
 
--- | Unchecked read of a mutable array.  May return garbage or
--- crash on an out-of-bounds access.
-unsafeReadWord :: MArray s -> Int -> ST s Word
-unsafeReadWord MArray{..} i@(I# i#) = ST $ \s# ->
-  CHECK_BOUNDS("unsafeRead64",maLen`div`wordFactor,i)
-  case readWordArray# maBA i# s# of
-    (# s2#, r# #) -> (# s2#, W# r# #)
-{-# INLINE unsafeReadWord #-}
-
--- | Unchecked write of a mutable array.  May return garbage or crash
--- on an out-of-bounds access.
-unsafeWriteWord :: MArray s -> Int -> Word -> ST s ()
-unsafeWriteWord MArray{..} i@(I# i#) (W# e#) = ST $ \s1# ->
-  CHECK_BOUNDS("unsafeWriteWord",maLen`div`wordFactor,i)
-  case writeWordArray# maBA i# e# s1# of
-    s2# -> (# s2#, () #)
-{-# INLINE unsafeWriteWord #-}
-
 -- | Convert an immutable array to a list.
 toList :: Array -> Int -> Int -> [Word16]
 toList ary off len = loop 0
                  arr <- unsafeFreeze marr
                  return (arr,b))
 
--- | The amount to divide or multiply by to switch between units of
--- 'Word16' and units of 'Word'.
-wordFactor :: Int
-wordFactor = SIZEOF_HSWORD `shiftR` 1
-
--- | Indicate whether an offset is word-aligned.
-wordAligned :: Int -> Bool
-wordAligned i = i .&. (wordFactor - 1) == 0
-
 -- | Copy some elements of a mutable array.
 copyM :: MArray s               -- ^ Destination
       -> Int                    -- ^ Destination offset
       -> Int                    -- ^ Source offset
       -> Int                    -- ^ Count
       -> ST s ()
-copyM dest didx src sidx count =
+copyM dest didx src sidx count
+    | count <= 0 = return ()
+    | otherwise =
 #if defined(ASSERTS)
     assert (sidx + count <= length src) .
-    assert (didx + count <= length dest) $
+    assert (didx + count <= length dest) .
 #endif
-    if srem == 0 && drem == 0
-    then fast_loop 0
-    else slow_loop 0
-    where
-      (swidx,srem) = sidx `divMod` wordFactor
-      (dwidx,drem) = didx `divMod` wordFactor
-      nwds         = count `div` wordFactor
-      fast_loop !i
-          | i >= nwds = slow_loop (i * wordFactor)
-          | otherwise = do w <- unsafeReadWord src (swidx+i)
-                           unsafeWriteWord dest (dwidx+i) w
-                           fast_loop (i+1)
-      slow_loop !i
-          | i >= count= return ()
-          | otherwise = do unsafeRead src (sidx+i) >>= unsafeWrite dest (didx+i)
-                           slow_loop (i+1)
+    unsafeIOToST $ memcpyM (maBA dest) (fromIntegral didx)
+                           (maBA src) (fromIntegral sidx)
+                           (fromIntegral count)
+{-# INLINE copyM #-}
 
 -- | Copy some elements of an immutable array.
 copyI :: MArray s               -- ^ Destination
       -> Int                    -- ^ Destination offset
       -> Array                  -- ^ Source
       -> Int                    -- ^ Source offset
-      -> Int                    -- ^ First offset in source /not/ to
+      -> Int                    -- ^ First offset in destination /not/ to
                                 -- copy (i.e. /not/ length)
       -> ST s ()
 copyI dest i0 src j0 top
-    | wordAligned i0 && wordAligned j0 = fast (i0 `div` wordFactor) (j0 `div` wordFactor)
-    | otherwise = slow i0 j0
-  where
-    topwds = top `div` wordFactor
-    fast !i !j
-        | i >= topwds = slow (i * wordFactor) (j * wordFactor)
-        | otherwise   = do unsafeWriteWord dest i (src `unsafeIndexWord` j)
-                           fast (i+1) (j+1)
-    slow !i !j
-        | i >= top  = return ()
-        | otherwise = do unsafeWrite dest i (src `unsafeIndex` j)
-                         slow (i+1) (j+1)
+    | i0 >= top = return ()
+    | otherwise = unsafeIOToST $
+                  memcpyI (maBA dest) (fromIntegral i0)
+                          (aBA src) (fromIntegral j0)
+                          (fromIntegral (top-i0))
+{-# INLINE copyI #-}
 
 -- | Compare portions of two arrays for equality.  No bounds checking
 -- is performed.
       -> Int                    -- ^ Offset into second
       -> Int                    -- ^ Count
       -> Bool
-equal arrA offA arrB offB count
-    | wordAligned offA && wordAligned offB = fast 0
-    | otherwise                            = slow 0
-  where
-    countWords = count `div` wordFactor
-    fast !i
-        | i >= countWords = slow (i * wordFactor)
-        | a /= b          = False
-        | otherwise       = fast (i+1)
-        where a     = unsafeIndexWord arrA (offAW+i)
-              b     = unsafeIndexWord arrB (offBW+i)
-              offAW = offA `div` wordFactor
-              offBW = offB `div` wordFactor
-    slow !i
-        | i >= count = True
-        | a /= b     = False
-        | otherwise  = slow (i+1)
-        where a = unsafeIndex arrA (offA+i)
-              b = unsafeIndex arrB (offB+i)
+equal arrA offA arrB offB count = inlinePerformIO $ do
+  i <- memcmp (aBA arrA) (fromIntegral offA)
+                     (aBA arrB) (fromIntegral offB) (fromIntegral count)
+  return $! i == 0
+{-# INLINE equal #-}
+
+foreign import ccall unsafe "_hs_text_memcpy" memcpyI
+    :: MutableByteArray# s -> CSize -> ByteArray# -> CSize -> CSize -> IO ()
+
+foreign import ccall unsafe "_hs_text_memcmp" memcmp
+    :: ByteArray# -> CSize -> ByteArray# -> CSize -> CSize -> IO CInt
+
+foreign import ccall unsafe "_hs_text_memcpy" memcpyM
+    :: MutableByteArray# s -> CSize -> MutableByteArray# s -> CSize -> CSize
+    -> IO ()

Data/Text/Unsafe.hs

 {-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
 -- |
 -- Module      : Data.Text.Unsafe
--- Copyright   : (c) 2009, 2010 Bryan O'Sullivan
+-- Copyright   : (c) 2009, 2010, 2011 Bryan O'Sullivan
 -- License     : BSD-style
 -- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,
 --               duncan@haskell.org
 #endif
 import Data.Text.Encoding.Utf16 (chr2)
 import Data.Text.Internal (Text(..))
+import Data.Text.Unsafe.Base (inlineInterleaveST, inlinePerformIO)
 import Data.Text.UnsafeChar (unsafeChr)
-import GHC.ST (ST(..))
 import qualified Data.Text.Array as A
-#if defined(__GLASGOW_HASKELL__)
-# if __GLASGOW_HASKELL__ >= 611
-import GHC.IO (IO(IO))
-# else
-import GHC.IOBase (IO(IO))
-# endif
-import GHC.Base (realWorld#)
-#endif
 
 -- | /O(1)/ A variant of 'head' for non-empty 'Text'. 'unsafeHead'
 -- omits the check for the empty case, so there is an obligation on
         k = j - 1
 {-# INLINE reverseIter #-}
 
--- | Just like unsafePerformIO, but we inline it. Big performance gains as
--- it exposes lots of things to further inlining. /Very unsafe/. In
--- particular, you should do no memory allocation inside an
--- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.
---
-{-# INLINE inlinePerformIO #-}
-inlinePerformIO :: IO a -> a
-#if defined(__GLASGOW_HASKELL__)
-inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
-#else
-inlinePerformIO = unsafePerformIO
-#endif
-
--- | Allow an 'ST' computation to be deferred lazily. When passed an
--- action of type 'ST' @s@ @a@, the action will only be performed when
--- the value of @a@ is demanded.
---
--- This function is identical to the normal unsafeInterleaveST, but is
--- inlined and hence faster.
---
--- /Note/: This operation is highly unsafe, as it can introduce
--- externally visible non-determinism into an 'ST' action.
-inlineInterleaveST :: ST s a -> ST s a
-inlineInterleaveST (ST m) = ST $ \ s ->
-    let r = case m s of (# _, res #) -> res in (# s, r #)
-{-# INLINE inlineInterleaveST #-}
-
 -- | /O(1)/ Return the length of a 'Text' in units of 'Word16'.  This
 -- is useful for sizing a target array appropriately before using
 -- 'unsafeCopyToPtr'.

Data/Text/Unsafe/Base.hs

+{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-}
+-- |
+-- Module      : Data.Text.Unsafe.Base
+-- Copyright   : (c) 2009, 2010, 2011 Bryan O'Sullivan
+-- License     : BSD-style
+-- Maintainer  : bos@serpentine.com, rtomharper@googlemail.com,
+--               duncan@haskell.org
+-- Stability   : experimental
+-- Portability : portable
+--
+-- A module containing unsafe operations, for very very careful use in
+-- heavily tested code.
+module Data.Text.Unsafe.Base
+    (
+      inlineInterleaveST
+    , inlinePerformIO
+    ) where
+     
+import GHC.ST (ST(..))
+#if defined(__GLASGOW_HASKELL__)
+# if __GLASGOW_HASKELL__ >= 611
+import GHC.IO (IO(IO))
+# else
+import GHC.IOBase (IO(IO))
+# endif
+import GHC.Base (realWorld#)
+#endif
+
+
+-- | Just like unsafePerformIO, but we inline it. Big performance gains as
+-- it exposes lots of things to further inlining. /Very unsafe/. In
+-- particular, you should do no memory allocation inside an
+-- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.
+--
+{-# INLINE inlinePerformIO #-}
+inlinePerformIO :: IO a -> a
+#if defined(__GLASGOW_HASKELL__)
+inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
+#else
+inlinePerformIO = unsafePerformIO
+#endif
+
+-- | Allow an 'ST' computation to be deferred lazily. When passed an
+-- action of type 'ST' @s@ @a@, the action will only be performed when
+-- the value of @a@ is demanded.
+--
+-- This function is identical to the normal unsafeInterleaveST, but is
+-- inlined and hence faster.
+--
+-- /Note/: This operation is highly unsafe, as it can introduce
+-- externally visible non-determinism into an 'ST' action.
+inlineInterleaveST :: ST s a -> ST s a
+inlineInterleaveST (ST m) = ST $ \ s ->
+    let r = case m s of (# _, res #) -> res in (# s, r #)
+{-# INLINE inlineInterleaveST #-}
+#include <string.h>
+
+void _hs_text_memcpy(void *dest, size_t doff, const void *src, size_t soff,
+		     size_t n)
+{
+  memcpy(dest + (doff<<1), src + (soff<<1), n<<1);
+}
+
+int _hs_text_memcmp(const void *a, size_t aoff, const void *b, size_t boff,
+		    size_t n)
+{
+  return memcmp(a + (aoff<<1), b + (boff<<1), n<<1);
+}

tests/benchmarks/text-benchmarks.cabal

 
 executable text-benchmarks
   hs-source-dirs: src ../..
+  c-sources:      ../../cbits/cbits.c
   main-is:        Data/Text/Benchmarks.hs
   ghc-options:    -Wall -O2
   cpp-options:    -DHAVE_DEEPSEQ

tests/tests/text-tests.cabal

   main-is:        Data/Text/Tests.hs
 
   ghc-options:
-    -Wall
-    -threaded
-    -O0
+    -Wall -threaded -O0 -rtsopts
 
   if flag(hpc)
     ghc-options:
   main-is:        Data/Text/Tests/IO.hs
 
   ghc-options:
-    -Wall
-    -threaded
+    -Wall -threaded -rtsopts
 
   -- Optional HPC support
   if flag(hpc)
 
 library
   hs-source-dirs: ../..
+  c-sources: ../../cbits/cbits.c
   exposed-modules:
     Data.Text
     Data.Text.Array
     Data.Text.Lazy.Search
     Data.Text.Search
     Data.Text.Unsafe
+    Data.Text.Unsafe.Base
     Data.Text.UnsafeChar
     Data.Text.UnsafeShift
     Data.Text.Util
 name:           text
-version:        0.11.1.1
+version:        0.11.1.2
 homepage:       https://bitbucket.org/bos/text
 bug-reports:    https://bitbucket.org/bos/text/issues
 synopsis:       An efficient packed Unicode text type.
 maintainer:     Bryan O'Sullivan <bos@serpentine.com>
                 Tom Harper <rtomharper@googlemail.com>
                 Duncan Coutts <duncan@haskell.org>
-copyright:      2008-2009 Tom Harper, 2009-2010 Bryan O'Sullivan
+copyright:      2009-2011 Bryan O'Sullivan, 2008-2009 Tom Harper
 category:       Data, Text
 build-type:     Simple
 cabal-version:  >= 1.6
     -- scripts/CaseFolding.txt
     -- scripts/SpecialCasing.txt
     scripts/*.hs
-    tests/*.hs
-    tests/Makefile
     tests/README.markdown
     tests/benchmarks/Setup.hs
     tests/benchmarks/python/*.py
     tests/benchmarks/src/Data/Text/*.hs
     tests/benchmarks/src/Data/Text/Benchmarks/*.hs
     tests/benchmarks/text-benchmarks.cabal
-    tests/cover-stdio.sh
+    tests/tests/.ghci
+    tests/tests/Makefile
+    tests/tests/scripts/*.sh
+    tests/tests/src/Data/Text/*.hs
+    tests/tests/src/Data/Text/Tests/*.hs
+    tests/tests/text-tests.cabal
 
 flag developer
   description: operate in developer mode
   default: False
 
 library
+  c-sources: cbits/cbits.c
+
   exposed-modules:
     Data.Text
     Data.Text.Array
     Data.Text.Lazy.Search
     Data.Text.Search
     Data.Text.Unsafe
+    Data.Text.Unsafe.Base
     Data.Text.UnsafeChar
     Data.Text.UnsafeShift
     Data.Text.Util
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.