diff options
author | Joe Crayne <joe@jerkface.net> | 2018-10-23 19:40:28 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2018-10-23 21:33:36 -0400 |
commit | 185c1f9e85fd0a2d3bb5f0531a652fa4787fba25 (patch) | |
tree | 013d06b642758762d37607c0c4fd1be9b0ac2f66 | |
parent | 97162c77d17d832b301c1384d8fce114f34002c9 (diff) |
Converted ST use to generic PrimMonad instead.
-rw-r--r-- | haskell/Data/BA.hs | 17 | ||||
-rw-r--r-- | haskell/Data/XDelta.hsc | 32 |
2 files changed, 34 insertions, 15 deletions
diff --git a/haskell/Data/BA.hs b/haskell/Data/BA.hs new file mode 100644 index 0000000..60b1136 --- /dev/null +++ b/haskell/Data/BA.hs | |||
@@ -0,0 +1,17 @@ | |||
1 | {-# LANGUAGE MagicHash #-} | ||
2 | {-# LANGUAGE ScopedTypeVariables #-} | ||
3 | module Data.BA where | ||
4 | |||
5 | import GHC.Exts | ||
6 | import Control.Monad.Primitive | ||
7 | import Data.Primitive.Types | ||
8 | import Data.Primitive.ByteArray | ||
9 | |||
10 | -- | WARNING: Unsafe to use this on packed C structs. | ||
11 | writeAtByte :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> a -> m () | ||
12 | writeAtByte buf offset a = writeByteArray buf (div offset $ I# (sizeOf# a)) a | ||
13 | {-# INLINE writeAtByte #-} | ||
14 | |||
15 | readAtByte :: forall a m. (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> m a | ||
16 | readAtByte buf offset = readByteArray buf (div offset $ I# (sizeOf# (undefined :: a))) | ||
17 | {-# INLINE readAtByte #-} | ||
diff --git a/haskell/Data/XDelta.hsc b/haskell/Data/XDelta.hsc index 11a8579..09f5523 100644 --- a/haskell/Data/XDelta.hsc +++ b/haskell/Data/XDelta.hsc | |||
@@ -17,6 +17,7 @@ import qualified Data.ByteString.Internal as B | |||
17 | import Data.Coerce | 17 | import Data.Coerce |
18 | import Data.Primitive.Addr | 18 | import Data.Primitive.Addr |
19 | import Data.Primitive.ByteArray | 19 | import Data.Primitive.ByteArray |
20 | import Data.Primitive.MutVar | ||
20 | import Data.STRef | 21 | import Data.STRef |
21 | import qualified Data.Text as T | 22 | import qualified Data.Text as T |
22 | import Data.Text.Encoding | 23 | import Data.Text.Encoding |
@@ -39,10 +40,10 @@ import XDelta.Types | |||
39 | #endif | 40 | #endif |
40 | #include <xdelta3.h> | 41 | #include <xdelta3.h> |
41 | 42 | ||
42 | data Stream s = Stream | 43 | data Stream m = Stream |
43 | { streamArray :: MutableByteArray (PrimState (ST s)) | 44 | { streamArray :: MutableByteArray (PrimState m) |
44 | , streamPtr :: ForeignPtr Xd3Stream | 45 | , streamPtr :: ForeignPtr Xd3Stream |
45 | , streamSource :: STRef s (Maybe (MutableByteArray (PrimState (ST s)))) | 46 | , streamSource :: MutVar (PrimState m) (Maybe (MutableByteArray (PrimState m))) |
46 | } | 47 | } |
47 | 48 | ||
48 | foreign import ccall "xdelta3.h xd3_config_stream" xd3_config_stream :: Ptr Xd3Stream -> Ptr Config -> IO ErrorCode | 49 | foreign import ccall "xdelta3.h xd3_config_stream" xd3_config_stream :: Ptr Xd3Stream -> Ptr Config -> IO ErrorCode |
@@ -76,7 +77,7 @@ adr (Ptr a) = Addr a | |||
76 | -- The xd3_config structure is used to initialize a stream - all data | 77 | -- The xd3_config structure is used to initialize a stream - all data |
77 | -- is copied into stream so config may be a temporary variable. See | 78 | -- is copied into stream so config may be a temporary variable. See |
78 | -- the [documentation] or comments on the xd3_config structure. | 79 | -- the [documentation] or comments on the xd3_config structure. |
79 | config_stream :: Config -> ST s (Either ErrorCode (Stream s)) | 80 | config_stream :: PrimMonad m => Config -> m (Either ErrorCode (Stream m)) |
80 | config_stream cfg = do | 81 | config_stream cfg = do |
81 | let (len,n) = case smatch_cfg cfg of | 82 | let (len,n) = case smatch_cfg cfg of |
82 | Left m -> let n = encodeUtf8 $ T.pack $ smName m | 83 | Left m -> let n = encodeUtf8 $ T.pack $ smName m |
@@ -112,8 +113,8 @@ config_stream cfg = do | |||
112 | writeMatcher c o matcher | 113 | writeMatcher c o matcher |
113 | unsafeFreezeByteArray c | 114 | unsafeFreezeByteArray c |
114 | let cptr = ptr (byteArrayContents c) :: Ptr Config | 115 | let cptr = ptr (byteArrayContents c) :: Ptr Config |
115 | srcvar <- newSTRef Nothing | 116 | srcvar <- newMutVar Nothing |
116 | stream <- unsafeIOToST $ do | 117 | stream <- unsafeIOToPrim $ do |
117 | let finalize = do | 118 | let finalize = do |
118 | -- freeHaskellFunPtr: aloc,free,getblk | 119 | -- freeHaskellFunPtr: aloc,free,getblk |
119 | xd3_abort_stream sptr | 120 | xd3_abort_stream sptr |
@@ -125,12 +126,12 @@ config_stream cfg = do | |||
125 | , streamPtr = fp | 126 | , streamPtr = fp |
126 | , streamSource = srcvar | 127 | , streamSource = srcvar |
127 | } | 128 | } |
128 | unsafeIOToST (xd3_config_stream sptr cptr) >>= \case | 129 | unsafeIOToPrim (xd3_config_stream sptr cptr) >>= \case |
129 | XD3_SUCCESS -> return $ c `seq` Right stream | 130 | XD3_SUCCESS -> return $ c `seq` Right stream |
130 | ecode -> return $ Left ecode | 131 | ecode -> return $ Left ecode |
131 | 132 | ||
132 | writeStringAt src o bsname = do | 133 | writeStringAt src o bsname = do |
133 | (p,cnt) <- unsafeIOToST $ B.unsafeUseAsCStringLen bsname return | 134 | (p,cnt) <- unsafeIOToPrim $ B.unsafeUseAsCStringLen bsname return |
134 | let nptr = ptr (mutableByteArrayContents src) `plusPtr` o | 135 | let nptr = ptr (mutableByteArrayContents src) `plusPtr` o |
135 | copyAddr (adr nptr) (adr p) cnt | 136 | copyAddr (adr nptr) (adr p) cnt |
136 | writeOffAddr (adr nptr) cnt (0 :: Word8) | 137 | writeOffAddr (adr nptr) cnt (0 :: Word8) |
@@ -140,10 +141,11 @@ data Xd3Source | |||
140 | 141 | ||
141 | foreign import ccall "xdelta3.h xd3_set_source" xd3_set_source :: Ptr Xd3Stream -> Ptr Xd3Source -> IO ErrorCode | 142 | foreign import ccall "xdelta3.h xd3_set_source" xd3_set_source :: Ptr Xd3Stream -> Ptr Xd3Source -> IO ErrorCode |
142 | 143 | ||
143 | set_source :: Stream s -> String -- ^ name for debug/print purposes. | 144 | set_source :: PrimMonad m => |
145 | Stream m -> String -- ^ name for debug/print purposes. | ||
144 | -> Usize_t -- ^ block size | 146 | -> Usize_t -- ^ block size |
145 | -> Xoff_t -- ^ maximum visible buffer | 147 | -> Xoff_t -- ^ maximum visible buffer |
146 | -> ST s () | 148 | -> m () |
147 | set_source stream nm blksz maxwinsz = do | 149 | set_source stream nm blksz maxwinsz = do |
148 | let bsname = encodeUtf8 $ T.pack nm | 150 | let bsname = encodeUtf8 $ T.pack nm |
149 | src <- newPinnedByteArray $ 1 + B.length bsname + #{const sizeof(xd3_source)} | 151 | src <- newPinnedByteArray $ 1 + B.length bsname + #{const sizeof(xd3_source)} |
@@ -159,8 +161,8 @@ set_source stream nm blksz maxwinsz = do | |||
159 | -} | 161 | -} |
160 | let strm = ptr (mutableByteArrayContents $ streamArray stream) | 162 | let strm = ptr (mutableByteArrayContents $ streamArray stream) |
161 | srcptr = ptr (mutableByteArrayContents src) | 163 | srcptr = ptr (mutableByteArrayContents src) |
162 | unsafeIOToST (xd3_set_source strm srcptr) | 164 | unsafeIOToPrim (xd3_set_source strm srcptr) |
163 | writeSTRef (streamSource stream) (Just src) | 165 | writeMutVar (streamSource stream) (Just src) |
164 | 166 | ||
165 | data XDeltaMethods m = XDeltaMethods | 167 | data XDeltaMethods m = XDeltaMethods |
166 | { xConfig :: Config | 168 | { xConfig :: Config |
@@ -173,10 +175,10 @@ data XDeltaMethods m = XDeltaMethods | |||
173 | -- | Checks for legal flag changes. | 175 | -- | Checks for legal flag changes. |
174 | foreign import ccall "xdelta3.h xd3_set_flags" xd3_set_flags :: Ptr Xd3Stream -> Flags -> IO () | 176 | foreign import ccall "xdelta3.h xd3_set_flags" xd3_set_flags :: Ptr Xd3Stream -> Flags -> IO () |
175 | 177 | ||
176 | setFlush :: Stream s -> Bool -> ST s () | 178 | setFlush :: PrimMonad m => Stream m -> Bool -> m () |
177 | setFlush stream wantFlush = return () -- todo | 179 | setFlush stream wantFlush = return () -- todo |
178 | 180 | ||
179 | setSkipWindow :: Stream s -> Bool -> ST s () | 181 | setSkipWindow :: PrimMonad m => Stream m -> Bool -> m () |
180 | setSkipWindow stream wantSkipWin = return () -- todo | 182 | setSkipWindow stream wantSkipWin = return () -- todo |
181 | 183 | ||
182 | {- | 184 | {- |