@@ -1,4 +1,4 @@
1−{-# LANGUAGE MagicHash, RankNTypes, RecordWildCards, UnboxedTuples #-}
1+{-# LANGUAGE CPP, MagicHash, RankNTypes, RecordWildCards, UnboxedTuples #-}
22
33-- |
44-- Module : Data.Attoparsec.Text.Buffer
@@ -34,7 +34,10 @@ module Data.Attoparsec.Text.Buffer
3434 , dropWord16
3535 ) where
3636
37+import Control.Applicative ((<$>))
3738import Control.Exception (assert)
39+import Data.Attoparsec.Internal.Fhthagn (inlinePerformIO)
40+import Data.IORef (IORef, atomicModifyIORef, newIORef)
3841import Data.List (foldl1')
3942import Data.Monoid (Monoid(..))
4043import Data.Text ()
@@ -45,13 +48,22 @@ import Data.Text.Unsafe (Iter(..))
4548import GHC.Base (unsafeCoerce#)
4649import GHC.ST (ST(..), runST)
4750import Prelude hiding (length)
51+import System.IO.Unsafe (unsafePerformIO)
4852import qualified Data.Text.Array as A
4953
54+#if __GLASGOW_HASKELL__ >= 702
55+import Control.Monad.ST.Unsafe (unsafeIOToST)
56+#else
57+import Control.Monad.ST (unsafeIOToST)
58+#endif
59+
5060data Buffer = Buf {
5161 _arr :: {-# UNPACK #-} !A.Array
5262 , _off :: {-# UNPACK #-} !Int
5363 , _len :: {-# UNPACK #-} !Int
5464 , _cap :: {-# UNPACK #-} !Int
65+ , _gen :: {-# UNPACK #-} !Int
66+ , _ref :: {-# UNPACK #-} !(IORef Int)
5567 }
5668
5769instance Show Buffer where
@@ -61,48 +73,53 @@ instance Show Buffer where
6173-- copies in the (hopefully) common case of no further input being fed
6274-- to us.
6375buffer :: Text -> Buffer
64−buffer (Text arr off len) = Buf arr off len len
76+buffer (Text arr off len) = inlinePerformIO $
77+ Buf arr off len len 0 <$> newIORef 0
6578
6679unbuffer :: Buffer -> Text
67−unbuffer (Buf arr off len _cap) = Text arr off len
80+unbuffer (Buf arr off len _ _ _) = Text arr off len
6881
6982instance Monoid Buffer where
70− mempty = Buf A.empty 0 0 0
71−
72− mappend (Buf _ _ _ 0) b = b
73− mappend a (Buf _ _ _ 0) = a
74− mappend (Buf arr0 off0 len0 cap0) (Buf arr1 off1 len1 _cap1) = runST $ do
83+ mempty = unsafePerformIO $ Buf A.empty 0 0 0 0 <$> newIORef 0
84+ {-# NOINLINE mempty #-}
85+
86+ mappend (Buf _ _ _ 0 _ _) b = b
87+ mappend a (Buf _ _ _ 0 _ _) = a
88+ mappend (Buf arr0 off0 len0 cap0 gen ref)
89+ (Buf arr1 off1 len1 _ _ _) = runST $ do
90+ gen' <- unsafeIOToST $
91+ atomicModifyIORef ref (\a -> let a' = a+1 in (a',a'))
7592 let newlen = len0 + len1
76− if newlen <= cap0
93+ if gen' == gen+1 && newlen <= cap0
7794 then do
7895 marr <- unsafeThaw arr0
7996 A.copyI marr (off0+len0) arr1 off1 (off0+newlen)
8097 arr2 <- A.unsafeFreeze marr
81− return (Buf arr2 off0 newlen cap0)
98+ return (Buf arr2 off0 newlen cap0 gen' ref)
8299 else do
83100 let newcap = newlen * 2
84101 marr <- A.new newcap
85102 A.copyI marr 0 arr0 off0 len0
86103 A.copyI marr len0 arr1 off1 newlen
87104 arr2 <- A.unsafeFreeze marr
88− return (Buf arr2 0 newlen newcap)
105+ return (Buf arr2 0 newlen newcap gen' ref)
89106
90107 mconcat [] = mempty
91108 mconcat xs = foldl1' mappend xs
92109
93110length :: Buffer -> Int
94−length (Buf _ _ len _) = len
111+length (Buf _ _ len _ _ _) = len
95112{-# INLINE length #-}
96113
97114substring :: Int -> Int -> Buffer -> Text
98−substring s l (Buf arr off len _cap) =
115+substring s l (Buf arr off len _ _ _) =
99116 assert (s >= 0 && s <= len) .
100117 assert (l >= 0 && l <= len-s) $
101118 Text arr (off+s) l
102119{-# INLINE substring #-}
103120
104121dropWord16 :: Int -> Buffer -> Text
105−dropWord16 s (Buf arr off len _cap) =
122+dropWord16 s (Buf arr off len _ _ _) =
106123 assert (s >= 0 && s <= len) $
107124 Text arr (off+s) (len-s)
108125{-# INLINE dropWord16 #-}
@@ -111,7 +128,7 @@ dropWord16 s (Buf arr off len _cap) =
111128-- array, returning the current character and the delta to add to give
112129-- the next offset to iterate at.
113130iter :: Buffer -> Int -> Iter
114−iter (Buf arr off _len _cap) i
131+iter (Buf arr off _len _ _ _) i
115132 | m < 0xD800 || m > 0xDBFF = Iter (unsafeChr m) 1
116133 | otherwise = Iter (chr2 m n) 2
117134 where m = A.unsafeIndex arr j
@@ -123,7 +140,7 @@ iter (Buf arr off _len _cap) i
123140-- | /O(1)/ Iterate one step through a UTF-16 array, returning the
124141-- delta to add to give the next offset to iterate at.
125142iter_ :: Buffer -> Int -> Int
126−iter_ (Buf arr off _len _cap) i | m < 0xD800 || m > 0xDBFF = 1
143+iter_ (Buf arr off _len _ _ _) i | m < 0xD800 || m > 0xDBFF = 1
127144 | otherwise = 2
128145 where m = A.unsafeIndex arr (off+i)
129146{-# INLINE iter_ #-}