diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Revision history for Z-IO +## 1.0.0.0 -- 2020-07-08 + +* Clean function names in `Z.IO.BIO` module, now no `BIO` or `Node` suffix anymore. +* `Z.IO.BIO` is not re-exported from `Z.IO` anymore, user are recommended to import it with qualified name, e.g. `import qualified Z.IO.BIO as BIO`. +* Add `foldl'` and `foldIO'` to `Z.IO.BIO` to use with `Fold` and `FoldM` from `foldl` package. +* Add `INLINABLE` pragmas to many functions. +* Add `printStdLnP` to `Z.IO.StdStream`, a `Parser` debug tool. + ## 0.8.1.0 -- 2020-06-12 * Remove `-march=native` flag to improve binary portability. diff --git a/Z-IO.cabal b/Z-IO.cabal --- a/Z-IO.cabal +++ b/Z-IO.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: Z-IO -version: 0.8.1.1 +version: 1.0.0.0 synopsis: Simple and high performance IO toolkit for Haskell description: Simple and high performance IO toolkit for Haskell, including @@ -85,6 +85,7 @@ exposed-modules: Z.IO Z.IO.BIO + Z.IO.BIO.Base Z.IO.BIO.Concurrent Z.IO.BIO.Zlib Z.IO.Buffered @@ -119,12 +120,13 @@ , base >=4.12 && <5.0 , containers ^>=0.6 , exceptions ^>=0.10 + , foldl >= 1.3 && <2.0 , primitive >=0.7.1 && <0.7.2 , stm ^>=2.5 , time >=1.9 && <2.0 , unix-time >=0.4.7 && <0.5 , unordered-containers ^>=0.2 - , Z-Data >=0.8.1 && <0.9 + , Z-Data >=1.0 && <1.1 default-language: Haskell2010 default-extensions: @@ -301,7 +303,7 @@ third_party/libuv/include third_party/libuv/src/unix third_party/libuv/src - cc-options: -Wall + cc-options: -Wall -D_GNU_SOURCE -D_POSIX_C_SOURCE=200112 else if os(osx) @@ -346,7 +348,7 @@ third_party/libuv/include third_party/libuv/src/unix third_party/libuv/src - cc-options: -Wall + cc-options: -Wall -D_DARWIN_UNLIMITED_SELECT=1 -D_DARWIN_USE_64_BIT_INODE=1 else if flag(no-pkg-config) @@ -376,7 +378,7 @@ other-modules: Z.IO.BIO.ConcurrentSpec Z.IO.BIO.ZlibSpec - Z.IO.BIOSpec + Z.IO.BIO.BaseSpec Z.IO.FileSystem.ThreadedSpec Z.IO.FileSystemSpec Z.IO.LowResTimerSpec diff --git a/Z/IO.hs b/Z/IO.hs --- a/Z/IO.hs +++ b/Z/IO.hs @@ -13,19 +13,20 @@ -} module Z.IO - ( module Z.IO.BIO - , module Z.IO.Buffered + ( module Z.IO.Buffered , module Z.IO.Environment , module Z.IO.Exception , module Z.IO.Logger , module Z.IO.Resource , module Z.IO.StdStream + , forkBa ) where -import Z.IO.BIO import Z.IO.Buffered import Z.IO.Environment import Z.IO.Exception import Z.IO.Logger import Z.IO.Resource import Z.IO.StdStream +import Z.IO.UV.Manager (forkBa) + diff --git a/Z/IO/BIO.hs b/Z/IO/BIO.hs --- a/Z/IO/BIO.hs +++ b/Z/IO/BIO.hs @@ -1,5 +1,5 @@ {-| -Module : Z.IO.BIO +Module : Z.IO.BIO.Base Description : Composable IO Loops Copyright : (c) Dong Han, 2017-2020 License : BSD @@ -36,7 +36,7 @@ withResource (initSourceFromFile origin) $ \ src -> withResource (initSinkToFile target) $ \ sink -> - runBIO_ $ src . base64Enc . zlibCompressor . sink + run_ $ src . base64Enc . zlibCompressor . sink > base64AndCompressFile "test" "test.gz" -- run 'zcat "test.gz" | base64 -d' will give you original file @@ -47,6 +47,7 @@ import Z.IO.BIO (BIO, Source, Sink) import qualified Z.IO.BIO as BIO @ + -} module Z.IO.BIO ( -- * The BIO type @@ -56,13 +57,15 @@ , joinSink, fuseSink -- * Run BIO chain , discard - , stepBIO, stepBIO_ - , runBIO, runBIO_ + , step, step_ + , run, run_ , runBlock, runBlock_, unsafeRunBlock , runBlocks, runBlocks_, unsafeRunBlocks -- * Make new BIO - , pureBIO, ioBIO - , filter, filterM + , fromPure, fromIO + , filter, filterIO + -- * Use with fold + , fold', foldIO' -- ** Source , initSourceFromFile , initSourceFromFile' @@ -82,672 +85,31 @@ -- ** Bytes specific , newReChunk , newUTF8Decoder - , newParserNode, newMagicSplitter, newLineSplitter + , newParser, newMagicSplitter, newLineSplitter , newBase64Encoder, newBase64Decoder - , hexEncoder, newHexDecoder + , hexEncode + , newHexDecoder -- ** Generic BIO - , counterNode - , seqNumNode - , newGroupingNode - , ungroupingNode - , consumedNode + , counter + , seqNum + , newGrouping + , ungrouping + , consumed + -- * Concurrent helpers + , zip, newTQueuePair, newTBQueuePair, newBroadcastTChanPair + -- * Zlib BIO + , newCompress, compressReset + , CompressConfig(..) + , defaultCompressConfig + , newDecompress, decompressReset + , DecompressConfig(..) + , defaultDecompressConfig + , MemLevel + , defaultMemLevel + , ZStream ) where -import Prelude hiding (filter) -import Control.Concurrent.MVar -import Control.Monad hiding (filterM) -import Control.Monad.IO.Class -import Data.Bits ((.|.)) -import Data.IORef -import qualified Data.List as List -import Data.Void -import Data.Word -import System.IO.Unsafe (unsafePerformIO) -import qualified Z.Data.Array as A -import qualified Z.Data.Builder as B -import Z.Data.CBytes (CBytes) -import qualified Z.Data.JSON as JSON -import qualified Z.Data.Parser as P -import Z.Data.PrimRef -import qualified Z.Data.Text as T -import qualified Z.Data.Text.UTF8Codec as T -import qualified Z.Data.Vector as V -import qualified Z.Data.Vector.Base as V -import Z.Data.Vector.Base64 -import Z.Data.Vector.Hex -import Z.IO.Buffered -import Z.IO.Exception -import qualified Z.IO.FileSystem.Base as FS -import Z.IO.Resource - --- | A 'BIO'(blocked IO) node. --- --- A 'BIO' node is a push based stream transformer. It can be used to describe different kinds of IO --- devices: --- --- * @BIO inp out@ describe an IO state machine(e.g. z_stream in zlib), --- which takes some input in block, then outputs. --- * @type Source out = BIO Void out@ described an IO source, which never takes input, --- but gives output until EOF by looping. --- * @type Sink inp = BIO inp Void@ described an IO sink, which takes input and perform some IO effects, --- such as writing to terminal or files. --- --- You can connect these 'BIO' nodes with '>|>', which connect left node's output to right node's input, --- and return a new 'BIO' node with left node's input type and right node's output type. --- --- You can run a 'BIO' node in different ways: --- --- * 'stepBIO'\/'stepBIO_' to supply a single chunk of input and step the BIO node. --- * 'runBIO'\/'runBIO_' will supply EOF directly, which will effectively pull all values from source, --- and push to sink until source reaches EOF. --- * 'runBlock'\/'runBlock_' will supply a single block of input as whole input and run the BIO node. --- * 'runBlocks'\/'runBlocks_' will supply a list of blocks as whole input and run the BIO node. --- --- Note 'BIO' usually contains some IO states, you can consider it as an opaque 'IORef': --- --- * You shouldn't use a 'BIO' node across multiple 'BIO' chain unless the state can be reset. --- * You shouldn't use a 'BIO' node across multiple threads unless document states otherwise. --- --- 'BIO' is simply a convenient way to construct single-thread streaming computation, to use 'BIO' --- in multiple threads, check "Z.IO.BIO.Concurrent" module. --- -type BIO inp out = (Maybe out -> IO ()) -- ^ Pass 'EOF' to indicate current node reaches EOF - -> Maybe inp -- ^ 'EOF' indicates upstream reaches EOF - -> IO () - --- | Patterns for more meaningful pattern matching. -pattern EOF :: Maybe a -pattern EOF = Nothing - --- | Type alias for 'BIO' node which never takes input. --- --- Note when implement a 'Source', you should assume 'EOF' argument is supplied only once, and you --- should loop to call downstream continuation with all available chunks, then write a final 'EOF' --- to indicate EOF. -type Source x = BIO Void x - --- | Type alias for 'BIO' node which only takes input and perform effects. --- --- Note when implement a 'Sink', you should assume 'EOF' argument is supplied only once(when upstream --- reaches EOF), you do not need to call downstream continuation before EOF, and --- do a flush(also write a final 'EOF') when upstream reach EOF. -type Sink x = BIO x Void - --- | Connect two 'BIO' source, after first reach EOF, draw elements from second. -appendSource :: HasCallStack => Source a -> Source a -> Source a -{-# INLINE appendSource #-} -b1 `appendSource` b2 = \ k _ -> - b1 (\ y -> - case y of Just _ -> k y - _ -> b2 k EOF) EOF - --- | Fuse two 'BIO' sinks, i.e. everything written to the fused sink will be written to left and right sink. --- --- Flush result 'BIO' will effectively flush both sink. -joinSink :: HasCallStack => Sink out -> Sink out -> Sink out -{-# INLINE joinSink #-} -b1 `joinSink` b2 = \ k mx -> - case mx of - Just _ -> do - b1 discard mx - b2 discard mx - _ -> do - b1 discard EOF - b2 discard EOF - k EOF - --- | Fuse a list of 'BIO' sinks, everything written to the fused sink will be written to every sink in the list. --- --- Flush result 'BIO' will effectively flush every sink in the list. -fuseSink :: HasCallStack => [Sink out] -> Sink out -{-# INLINABLE fuseSink #-} -fuseSink ss = \ k mx -> - case mx of - Just _ -> mapM_ (\ s -> s discard mx) ss - _ -> do - mapM_ (\ s -> s discard mx) ss - k EOF - --- | Connect list of 'BIO' sources, after one reach EOF, draw element from next. -concatSource :: HasCallStack => [Source a] -> Source a -{-# INLINABLE concatSource #-} -concatSource = List.foldl' appendSource emptySource - --- | A 'Source' directly write EOF to downstream. -emptySource :: Source a -{-# INLINABLE emptySource #-} -emptySource = \ k _ -> k EOF - --- | Connect list of 'BIO' sources, after one reach EOF, draw element from next. -concatSource' :: HasCallStack => Source (Source a) -> Source a -{-# INLINABLE concatSource' #-} -concatSource' ssrc = \ k _ -> ssrc (\ msrc -> - case msrc of - Just src -> src (\ mx -> - case mx of Just _ -> k mx - _ -> return ()) EOF - _ -> k EOF) EOF - -------------------------------------------------------------------------------- --- Run BIO - --- | Discards a value. -discard :: a -> IO () -{-# INLINABLE discard #-} -discard _ = return () - --- | Supply a single chunk of input to a 'BIO' and collect result. -stepBIO :: HasCallStack => BIO inp out -> inp -> IO [out] -{-# INLINABLE stepBIO #-} -stepBIO bio inp = do - accRef <- newIORef [] - bio (mapM_ $ \ x -> modifyIORef' accRef (x:)) (Just inp) - reverse <$> readIORef accRef - --- | Supply a single chunk of input to a 'BIO' without collecting result. -stepBIO_ :: HasCallStack => BIO inp out -> inp -> IO () -{-# INLINABLE stepBIO_ #-} -stepBIO_ bio = bio discard . Just - --- | Run a 'BIO' loop without providing input. --- --- When used on 'Source', it starts the streaming loop. --- When used on 'Sink', it performs a flush. -runBIO_ :: HasCallStack => BIO inp out -> IO () -{-# INLINABLE runBIO_ #-} -runBIO_ bio = bio discard EOF - --- | Run a 'BIO' loop without providing input, and collect result. --- --- When used on 'Source', it will collect all input chunks. -runBIO :: HasCallStack => BIO inp out -> IO [out] -{-# INLINABLE runBIO #-} -runBIO bio = do - accRef <- newIORef [] - bio (mapM_ $ \ x -> modifyIORef' accRef (x:)) EOF - reverse <$> readIORef accRef - --- | Run a 'BIO' loop with a single chunk of input and EOF, and collect result. --- -runBlock :: HasCallStack => BIO inp out -> inp -> IO [out] -{-# INLINABLE runBlock #-} -runBlock bio inp = do - accRef <- newIORef [] - bio (mapM_ $ \ x -> modifyIORef' accRef (x:)) (Just inp) - bio (mapM_ $ \ x -> modifyIORef' accRef (x:)) EOF - reverse <$> readIORef accRef - --- | Run a 'BIO' loop with a single chunk of input and EOF, without collecting result. --- -runBlock_ :: HasCallStack => BIO inp out -> inp -> IO () -{-# INLINABLE runBlock_ #-} -runBlock_ bio inp = do - bio discard (Just inp) - bio discard EOF - --- | Wrap 'runBlock' into a pure interface. --- --- You can wrap a stateful BIO computation(including the creation of 'BIO' node), --- when you can guarantee a computation is pure, e.g. compressing, decoding, etc. -unsafeRunBlock :: HasCallStack => IO (BIO inp out) -> inp -> [out] -{-# INLINABLE unsafeRunBlock #-} -unsafeRunBlock new inp = unsafePerformIO (new >>= \ bio -> runBlock bio inp) - --- | Supply blocks of input and EOF to a 'BIO', and collect results. --- --- Note many 'BIO' node will be closed or not be able to take new input after drained. -runBlocks :: HasCallStack => BIO inp out -> [inp] -> IO [out] -{-# INLINABLE runBlocks #-} -runBlocks bio inps = do - accRef <- newIORef [] - forM_ inps $ bio (mapM_ $ \ x -> modifyIORef' accRef (x:)) . Just - bio (mapM_ $ \ x -> modifyIORef' accRef (x:)) EOF - reverse <$> readIORef accRef - --- | Supply blocks of input and EOF to a 'BIO', without collecting results. --- --- Note many 'BIO' node will be closed or not be able to take new input after drained. -runBlocks_ :: HasCallStack => BIO inp out -> [inp] -> IO () -{-# INLINABLE runBlocks_ #-} -runBlocks_ bio inps = do - forM_ inps $ bio discard . Just - bio discard EOF - --- | Wrap 'runBlocks' into a pure interface. --- --- Similar to 'unsafeRunBlock', but with a list of input blocks. -unsafeRunBlocks :: HasCallStack => IO (BIO inp out) -> [inp] -> [out] -{-# INLINABLE unsafeRunBlocks #-} -unsafeRunBlocks new inps = unsafePerformIO (new >>= \ bio -> runBlocks bio inps) - -------------------------------------------------------------------------------- --- Source - --- | Source a list(or any 'Foldable') from memory. --- -sourceFromList :: Foldable f => f a -> Source a -sourceFromList xs0 = \ k _ -> do - mapM_ (k . Just) xs0 - k EOF - --- | Turn a 'BufferedInput' into 'BIO' source, map EOF to EOF. --- -sourceFromBuffered :: HasCallStack => BufferedInput -> Source V.Bytes -{-# INLINABLE sourceFromBuffered #-} -sourceFromBuffered i = \ k _ -> - let loop = readBuffer i >>= \ x -> - if V.null x then k EOF else k (Just x) >> loop - in loop - --- | Turn a `IO` action into 'Source' -sourceFromIO :: HasCallStack => IO (Maybe a) -> Source a -{-# INLINABLE sourceFromIO #-} -sourceFromIO io = \ k _ -> - let loop = io >>= \ x -> - case x of - Just _ -> k x >> loop - _ -> k EOF - in loop - --- | Turn a UTF8 encoded 'BufferedInput' into 'BIO' source, map EOF to EOF. --- -sourceTextFromBuffered :: HasCallStack => BufferedInput -> Source T.Text -{-# INLINABLE sourceTextFromBuffered #-} -sourceTextFromBuffered i = \ k _ -> - let loop = readBufferText i >>= \ x -> - if T.null x then k EOF else k (Just x) >> loop - in loop - --- | Turn a 'JSON' encoded 'BufferedInput' into 'BIO' source, ignoring any --- whitespaces bewteen JSON objects. If EOF reached, then return 'EOF'. --- Throw 'OtherError' with name "EJSON" if JSON value is not parsed or converted. --- -sourceJSONFromBuffered :: forall a. (JSON.JSON a, HasCallStack) => BufferedInput -> Source a -{-# INLINABLE sourceJSONFromBuffered #-} -sourceJSONFromBuffered = sourceParseChunkFromBuffered JSON.decodeChunk - --- | Turn buffered input device into a packet source, throw 'OtherError' with name @EPARSE@ if parsing fail. -sourceParserFromBuffered :: HasCallStack => P.Parser a -> BufferedInput -> Source a -{-# INLINABLE sourceParserFromBuffered #-} -sourceParserFromBuffered p = sourceParseChunkFromBuffered (P.parseChunk p) - --- | Turn buffered input device into a packet source, throw 'OtherError' with name @EPARSE@ if parsing fail. -sourceParseChunkFromBuffered :: (HasCallStack, T.Print e) - => (V.Bytes -> P.Result e a) -> BufferedInput -> Source a -{-# INLINABLE sourceParseChunkFromBuffered #-} -sourceParseChunkFromBuffered pc bi = \ k _ -> - let loopA = do - bs <- readBuffer bi - if V.null bs - then k EOF - else loopB bs - loopB bs = do - (rest, r) <- P.parseChunks pc (readBuffer bi) bs - case r of Right v -> k (Just v) - Left e -> throwOtherError "EPARSE" (T.toText e) - if V.null rest - then loopA - else loopB rest - in loopA - --- | Turn a file into a 'V.Bytes' source. -initSourceFromFile :: HasCallStack => CBytes -> Resource (Source V.Bytes) -{-# INLINABLE initSourceFromFile #-} -initSourceFromFile p = do - f <- FS.initFile p FS.O_RDONLY FS.DEFAULT_FILE_MODE - liftIO (sourceFromBuffered <$> newBufferedInput f) - --- | Turn a file into a 'V.Bytes' source with given chunk size. -initSourceFromFile' :: HasCallStack => CBytes -> Int -> Resource (Source V.Bytes) -{-# INLINABLE initSourceFromFile' #-} -initSourceFromFile' p bufSiz = do - f <- FS.initFile p FS.O_RDONLY FS.DEFAULT_FILE_MODE - liftIO (sourceFromBuffered <$> newBufferedInput' bufSiz f) - --------------------------------------------------------------------------------- --- Sink - --- | Turn a 'BufferedOutput' into a 'V.Bytes' sink. -sinkToBuffered :: HasCallStack => BufferedOutput -> Sink V.Bytes -{-# INLINABLE sinkToBuffered #-} -sinkToBuffered bo = \ k mbs -> - case mbs of - Just bs -> writeBuffer bo bs - _ -> flushBuffer bo >> k EOF - --- | Turn a 'BufferedOutput' into a 'B.Builder' sink. --- -sinkBuilderToBuffered :: HasCallStack => BufferedOutput -> Sink (B.Builder a) -{-# INLINABLE sinkBuilderToBuffered #-} -sinkBuilderToBuffered bo = \ k mbs -> - case mbs of - Just bs -> writeBuilder bo bs - _ -> flushBuffer bo >> k EOF - --- | Turn a file into a 'V.Bytes' sink. --- --- Note the file will be opened in @'FS.O_APPEND' .|. 'FS.O_CREAT' .|. 'FS.O_WRONLY'@ mode, --- bytes will be written after the end of the original file if there'are old bytes. -initSinkToFile :: HasCallStack => CBytes -> Resource (Sink V.Bytes) -{-# INLINABLE initSinkToFile #-} -initSinkToFile p = do - f <- FS.initFile p (FS.O_APPEND .|. FS.O_CREAT .|. FS.O_WRONLY) FS.DEFAULT_FILE_MODE - liftIO (sinkToBuffered <$> newBufferedOutput f) - --- | Turn an `IO` action into 'BIO' sink. --- -sinkToIO :: HasCallStack => (a -> IO ()) -> Sink a -{-# INLINABLE sinkToIO #-} -sinkToIO f = \ k ma -> - case ma of - Just a -> f a - _ -> k EOF - --- | Turn an `IO` action(and a flush action), into 'BIO' sink. --- -sinkToIO' :: HasCallStack => (a -> IO ()) -> IO () -> Sink a -{-# INLINABLE sinkToIO' #-} -sinkToIO' f flush = \ k ma -> - case ma of - Just a -> f a - _ -> flush >> k EOF - --- | Sink to a list in memory. --- --- The 'MVar' will be empty during sinking, and will be filled after sink receives an EOF. -sinkToList :: IO (MVar [a], Sink a) -sinkToList = do - xsRef <- newIORef [] - rRef <- newEmptyMVar - return (rRef, sinkToIO' (\ x -> modifyIORef xsRef (x:)) - (do modifyIORef xsRef reverse - xs <- readIORef xsRef - putMVar rRef xs)) - --------------------------------------------------------------------------------- --- Nodes - --- | BIO node from a pure function. --- --- BIO node made with this funtion are stateless, thus can be reused across chains. -pureBIO :: (a -> b) -> BIO a b -{-# INLINE pureBIO #-} -pureBIO f = \ k x -> k (f <$> x) - --- | BIO node from an IO function. --- --- BIO node made with this funtion may not be stateless, it depends on if the IO function use --- IO state. -ioBIO :: HasCallStack => (a -> IO b) -> BIO a b -{-# INLINE ioBIO #-} -ioBIO f = \ k x -> - case x of Just x' -> f x' >>= k . Just - _ -> k EOF - --- | BIO node from a pure filter. --- --- BIO node made with this funtion are stateless, thus can be reused across chains. -filter :: (a -> Bool) -> BIO a a -filter f k = go - where - go (Just a) = when (f a) $ k (Just a) - go Nothing = k Nothing - --- | BIO node from an impure filter. --- --- BIO node made with this funtion may not be stateless, it depends on if the IO function use -filterM :: (a -> IO Bool) -> BIO a a -filterM f k = go - where - go (Just a) = do - mbool <- f a - when mbool $ k (Just a) - go Nothing = k Nothing - --- | Make a chunk size divider. --- --- A divider size divide each chunk's size to the nearest multiplier to granularity, --- last trailing chunk is directly returned. -newReChunk :: Int -- ^ chunk granularity - -> IO (BIO V.Bytes V.Bytes) -{-# INLINABLE newReChunk #-} -newReChunk n = do - trailingRef <- newIORef V.empty - return $ \ k mbs -> - case mbs of - Just bs -> do - trailing <- readIORef trailingRef - let chunk = trailing `V.append` bs - l = V.length chunk - if l >= n - then do - let l' = l - (l `rem` n) - (chunk', rest) = V.splitAt l' chunk - writeIORef trailingRef rest - k (Just chunk') - else writeIORef trailingRef chunk - _ -> do - trailing <- readIORef trailingRef - unless (V.null trailing) $ do - writeIORef trailingRef V.empty - k (Just trailing) - k EOF - --- | Read buffer and parse with 'Parser'. --- --- This function will turn a 'Parser' into a 'BIO', throw 'OtherError' with name @EPARSE@ if parsing fail. --- -newParserNode :: HasCallStack => P.Parser a -> IO (BIO V.Bytes a) -{-# INLINABLE newParserNode #-} -newParserNode p = do - -- type LastParseState = Maybe (V.Bytes -> P.Result) - resultRef <- newIORef EOF - return $ \ k mbs -> do - let loop f chunk = case f chunk of - P.Success a trailing -> do - k (Just a) - unless (V.null trailing) (loop f trailing) - P.Partial f' -> - writeIORef resultRef (Just f') - P.Failure e _ -> - throwOtherError "EPARSE" (T.toText e) - lastResult <- readIORef resultRef - case mbs of - Just bs -> do - let f = case lastResult of - Just x -> x - _ -> P.parseChunk p - loop f bs - _ -> - case lastResult of - Just f -> loop f V.empty - _ -> k EOF - --- | Make a new UTF8 decoder, which decode bytes streams into text streams. --- --- If there're invalid UTF8 bytes, an 'OtherError' with name 'EINVALIDUTF8' will be thrown.` --- --- Note this node is supposed to be used with preprocess node such as decompressor, parser, etc. --- where bytes boundary cannot be controlled, UTF8 decoder will concat trailing bytes from last block to next one. --- Use this node directly with 'sourceFromBuffered' will not be as efficient as directly use --- 'sourceTextFromBuffered', because 'BufferedInput' provides push back capability, --- trailing bytes can be pushed back to reading buffer then returned with next block input together. --- -newUTF8Decoder :: HasCallStack => IO (BIO V.Bytes T.Text) -{-# INLINABLE newUTF8Decoder #-} -newUTF8Decoder = do - trailingRef <- newIORef V.empty - return $ \ k mbs -> do - case mbs of - Just bs -> do - trailing <- readIORef trailingRef - let chunk = trailing `V.append` bs - (V.PrimVector arr s l) = chunk - if l > 0 && T.decodeCharLen arr s <= l - then do - let (i, _) = V.findR (\ w -> w >= 0b11000000 || w <= 0b01111111) chunk - if (i == -1) - then throwOtherError "EINVALIDUTF8" "invalid UTF8 bytes" - else do - if T.decodeCharLen arr (s + i) > l - i - then do - writeIORef trailingRef (V.fromArr arr (s+i) (l-i)) - k (Just (T.validate (V.fromArr arr s i))) - else do - writeIORef trailingRef V.empty - k (Just (T.validate chunk)) - else writeIORef trailingRef chunk - - _ -> do - trailing <- readIORef trailingRef - if V.null trailing - then k EOF - else throwOtherError "EINVALIDUTF8" "invalid UTF8 bytes" - --- | Make a new stream splitter based on magic byte. --- -newMagicSplitter :: Word8 -> IO (BIO V.Bytes V.Bytes) -{-# INLINABLE newMagicSplitter #-} -newMagicSplitter magic = do - trailingRef <- newIORef V.empty - return $ \ k mx -> - case mx of - Just bs -> do - trailing <- readIORef trailingRef - let loop chunk = case V.elemIndex magic chunk of - Just i -> do - -- TODO: looping - let (line, rest) = V.splitAt (i+1) chunk - k (Just line) - loop rest - _ -> writeIORef trailingRef chunk - loop (trailing `V.append` bs) - _ -> do - chunk <- readIORef trailingRef - unless (V.null chunk) $ do - writeIORef trailingRef V.empty - k (Just chunk) - k EOF - --- | Make a new stream splitter based on linefeed(@\r\n@ or @\n@). --- --- The result bytes doesn't contain linefeed. -newLineSplitter :: IO (BIO V.Bytes V.Bytes) -{-# INLINABLE newLineSplitter #-} -newLineSplitter = do - s <- newMagicSplitter 10 - return (s . pureBIO dropLineEnd) - where - dropLineEnd bs@(V.PrimVector arr s l) = - case bs `V.indexMaybe` (l-2) of - Just r | r == 13 -> V.PrimVector arr s (l-2) - | otherwise -> V.PrimVector arr s (l-1) - _ | V.head bs == 10 -> V.PrimVector arr s (l-1) - | otherwise -> V.PrimVector arr s l - --- | Make a new base64 encoder node. -newBase64Encoder :: IO (BIO V.Bytes V.Bytes) -{-# INLINABLE newBase64Encoder #-} -newBase64Encoder = do - re <- newReChunk 3 - return (re . pureBIO base64Encode) - --- | Make a new base64 decoder node. -newBase64Decoder :: HasCallStack => IO (BIO V.Bytes V.Bytes) -{-# INLINABLE newBase64Decoder #-} -newBase64Decoder = do - re <- newReChunk 4 - return (re . pureBIO base64Decode') - --- | Make a hex encoder node. --- --- Hex encoder is stateless, it can be reused across chains. -hexEncoder :: Bool -- ^ uppercase? - -> BIO V.Bytes V.Bytes -{-# INLINABLE hexEncoder #-} -hexEncoder upper = pureBIO (hexEncode upper) - --- | Make a new hex decoder node. -newHexDecoder :: IO (BIO V.Bytes V.Bytes) -{-# INLINABLE newHexDecoder #-} -newHexDecoder = do - re <- newReChunk 2 - return (re . pureBIO hexDecode') - --- | Make a new BIO node which counts items flow throught it. --- --- 'Counter' is increased atomically, it's safe to read \/ reset the counter from other threads. -counterNode :: Counter -> BIO a a -{-# INLINABLE counterNode #-} -counterNode c = ioBIO inc - where - inc x = do - atomicAddCounter_ c 1 - return x - --- | Make a new BIO node which counts items, and label item with a sequence number. --- --- 'Counter' is increased atomically, it's safe to read \/ reset the counter from other threads. -seqNumNode :: Counter -> BIO a (Int, a) -{-# INLINABLE seqNumNode #-} -seqNumNode c = ioBIO inc - where - inc x = do - i <- atomicAddCounter c 1 - return (i, x) - --- | Make a BIO node grouping items into fixed size arrays. --- --- Trailing items are directly returned. -newGroupingNode :: Int -> IO (BIO a (V.Vector a)) -{-# INLINABLE newGroupingNode #-} -newGroupingNode n - | n < 1 = newGroupingNode 1 - | otherwise = do - c <- newCounter 0 - arrRef <- newIORef =<< A.newArr n - return $ \ k mx -> - case mx of - Just x -> do - i <- readPrimIORef c - if i == n - 1 - then do - marr <- readIORef arrRef - A.writeArr marr i x - writePrimIORef c 0 - writeIORef arrRef =<< A.newArr n - arr <- A.unsafeFreezeArr marr - k . Just $! V.fromArr arr 0 n - else do - marr <- readIORef arrRef - A.writeArr marr i x - writePrimIORef c (i+1) - _ -> do - i <- readPrimIORef c - if i /= 0 - then do - writePrimIORef c 0 - marr <- readIORef arrRef - A.shrinkMutableArr marr i - arr <- A.unsafeFreezeArr marr - k . Just $! V.fromArr arr 0 i - else k EOF - --- | A BIO node flatten items. --- -ungroupingNode :: BIO (V.Vector a) a -{-# INLINABLE ungroupingNode #-} -ungroupingNode = \ k mx -> - case mx of - Just x -> V.traverseVec_ (k . Just) x - _ -> k EOF - --- | A BIO node which write 'True' to 'IORef' when 'EOF' is reached. -consumedNode :: IORef Bool -> BIO a a -{-# INLINABLE consumedNode #-} -consumedNode ref = \ k mx -> case mx of - Just _ -> k mx - _ -> do writeIORef ref True - k EOF - - +import Z.IO.BIO.Base +import Z.IO.BIO.Concurrent +import Z.IO.BIO.Zlib +import Prelude hiding (filter, zip) diff --git a/Z/IO/BIO/Base.hs b/Z/IO/BIO/Base.hs new file mode 100644 --- /dev/null +++ b/Z/IO/BIO/Base.hs @@ -0,0 +1,751 @@ +{-| +Module : Z.IO.BIO.Base +Description : Composable IO Loops +Copyright : (c) Dong Han, 2017-2020 +License : BSD +Maintainer : winterland1989@gmail.com +Stability : experimental +Portability : non-portable + +This module provides 'BIO' (block IO) type to facilitate writing streaming programs. A 'BIO' node usually: + + * Process input in unit of block(or item). + * Running in constant spaces, which means the memory usage won't accumulate. + * Keep some state in IO, which is sealed in 'BIO' closure. + +-} +module Z.IO.BIO.Base ( + -- * The BIO type + BIO, pattern EOF, Source, Sink + -- ** Basic combinators + , appendSource, concatSource, concatSource' + , joinSink, fuseSink + -- * Run BIO chain + , discard + , step, step_ + , run, run_ + , runBlock, runBlock_, unsafeRunBlock + , runBlocks, runBlocks_, unsafeRunBlocks + -- * Make new BIO + , fromPure, fromIO + , filter, filterIO + -- * Use with fold + , fold', foldIO' + -- ** Source + , initSourceFromFile + , initSourceFromFile' + , sourceFromIO + , sourceFromList + , sourceFromBuffered + , sourceTextFromBuffered + , sourceJSONFromBuffered + , sourceParserFromBuffered + , sourceParseChunkFromBuffered + -- ** Sink + , sinkToIO + , sinkToList + , initSinkToFile + , sinkToBuffered + , sinkBuilderToBuffered + -- ** Bytes specific + , newReChunk + , newUTF8Decoder + , newParser, newMagicSplitter, newLineSplitter + , newBase64Encoder, newBase64Decoder + , hexEncode + , newHexDecoder + -- ** Generic BIO + , counter + , seqNum + , newGrouping + , ungrouping + , consumed + ) where + +import Prelude hiding (filter) +import Control.Concurrent.MVar +import Control.Concurrent.STM +import qualified Control.Foldl as L +import Control.Monad +import Control.Monad.IO.Class +import Data.Bits ((.|.)) +import Data.IORef +import qualified Data.List as List +import Data.Void +import Data.Word +import System.IO.Unsafe (unsafePerformIO) +import qualified Z.Data.Array as A +import qualified Z.Data.Builder as B +import Z.Data.CBytes (CBytes) +import qualified Z.Data.JSON as JSON +import qualified Z.Data.Parser as P +import Z.Data.PrimRef +import qualified Z.Data.Text as T +import qualified Z.Data.Text.UTF8Codec as T +import qualified Z.Data.Vector as V +import qualified Z.Data.Vector.Base as V +import Z.Data.Vector.Base64 +import qualified Z.Data.Vector.Hex as Hex +import Z.IO.Buffered +import Z.IO.Exception +import qualified Z.IO.FileSystem.Base as FS +import Z.IO.Resource + +-- | A 'BIO'(blocked IO) node. +-- +-- A 'BIO' node is a push based stream transformer. It can be used to describe different kinds of IO +-- devices: +-- +-- * @BIO inp out@ describe an IO state machine(e.g. z_stream in zlib), +-- which takes some input in block, then outputs. +-- * @type Source out = BIO Void out@ described an IO source, which never takes input, +-- but gives output until EOF by looping. +-- * @type Sink inp = BIO inp Void@ described an IO sink, which takes input and perform some IO effects, +-- such as writing to terminal or files. +-- +-- You can connect these 'BIO' nodes with '>|>', which connect left node's output to right node's input, +-- and return a new 'BIO' node with left node's input type and right node's output type. +-- +-- You can run a 'BIO' node in different ways: +-- +-- * 'step'\/'step_' to supply a single chunk of input and step the BIO node. +-- * 'run'\/'run_' will supply EOF directly, which will effectively pull all values from source, +-- and push to sink until source reaches EOF. +-- * 'runBlock'\/'runBlock_' will supply a single block of input as whole input and run the BIO node. +-- * 'runBlocks'\/'runBlocks_' will supply a list of blocks as whole input and run the BIO node. +-- +-- Note 'BIO' usually contains some IO states, you can consider it as an opaque 'IORef': +-- +-- * You shouldn't use a 'BIO' node across multiple 'BIO' chain unless the state can be reset. +-- * You shouldn't use a 'BIO' node across multiple threads unless document states otherwise. +-- +-- 'BIO' is simply a convenient way to construct single-thread streaming computation, to use 'BIO' +-- in multiple threads, check "Z.IO.BIO.Concurrent" module. +-- +type BIO inp out = (Maybe out -> IO ()) -- ^ Pass 'EOF' to indicate current node reaches EOF + -> Maybe inp -- ^ 'EOF' indicates upstream reaches EOF + -> IO () + +-- | Patterns for more meaningful pattern matching. +pattern EOF :: Maybe a +pattern EOF = Nothing + +-- | Type alias for 'BIO' node which never takes input. +-- +-- Note when implement a 'Source', you should assume 'EOF' argument is supplied only once, and you +-- should loop to call downstream continuation with all available chunks, then write a final 'EOF' +-- to indicate EOF. +type Source x = BIO Void x + +-- | Type alias for 'BIO' node which only takes input and perform effects. +-- +-- Note when implement a 'Sink', you should assume 'EOF' argument is supplied only once(when upstream +-- reaches EOF), you do not need to call downstream continuation before EOF, and +-- do a flush(also write a final 'EOF') when upstream reach EOF. +type Sink x = BIO x () + +-- | Connect two 'BIO' source, after first reach EOF, draw elements from second. +appendSource :: HasCallStack => Source a -> Source a -> Source a +{-# INLINABLE appendSource #-} +b1 `appendSource` b2 = \ k _ -> + b1 (\ y -> + case y of Just _ -> k y + _ -> b2 k EOF) EOF + +-- | Fuse two 'BIO' sinks, i.e. everything written to the fused sink will be written to left and right sink. +-- +-- Flush result 'BIO' will effectively flush both sink. +joinSink :: HasCallStack => Sink out -> Sink out -> Sink out +{-# INLINABLE joinSink #-} +b1 `joinSink` b2 = \ k mx -> + case mx of + Just _ -> do + b1 discard mx + b2 discard mx + _ -> do + b1 discard EOF + b2 discard EOF + k EOF + +-- | Fuse a list of 'BIO' sinks, everything written to the fused sink will be written to every sink in the list. +-- +-- Flush result 'BIO' will effectively flush every sink in the list. +fuseSink :: HasCallStack => [Sink out] -> Sink out +{-# INLINABLE fuseSink #-} +fuseSink ss = \ k mx -> + case mx of + Just _ -> mapM_ (\ s -> s discard mx) ss + _ -> do + mapM_ (\ s -> s discard mx) ss + k EOF + +-- | Connect list of 'BIO' sources, after one reach EOF, draw element from next. +concatSource :: HasCallStack => [Source a] -> Source a +{-# INLINABLE concatSource #-} +concatSource = List.foldl' appendSource emptySource + +-- | A 'Source' directly write EOF to downstream. +emptySource :: Source a +{-# INLINABLE emptySource #-} +emptySource = \ k _ -> k EOF + +-- | Connect list of 'BIO' sources, after one reach EOF, draw element from next. +concatSource' :: HasCallStack => Source (Source a) -> Source a +{-# INLINABLE concatSource' #-} +concatSource' ssrc = \ k _ -> ssrc (\ msrc -> + case msrc of + Just src -> src (\ mx -> + case mx of Just _ -> k mx + _ -> return ()) EOF + _ -> k EOF) EOF + +------------------------------------------------------------------------------- +-- Run BIO + +-- | Discards a value. +discard :: a -> IO () +{-# INLINABLE discard #-} +discard _ = return () + +-- | Supply a single chunk of input to a 'BIO' and collect result. +step :: HasCallStack => BIO inp out -> inp -> IO [out] +{-# INLINABLE step #-} +step bio inp = do + accRef <- newIORef [] + bio (mapM_ $ \ x -> modifyIORef' accRef (x:)) (Just inp) + reverse <$> readIORef accRef + +-- | Supply a single chunk of input to a 'BIO' without collecting result. +step_ :: HasCallStack => BIO inp out -> inp -> IO () +{-# INLINABLE step_ #-} +step_ bio = bio discard . Just + +-- | Run a 'BIO' loop without providing input. +-- +-- When used on 'Source', it starts the streaming loop. +-- When used on 'Sink', it performs a flush. +run_ :: HasCallStack => BIO inp out -> IO () +{-# INLINABLE run_ #-} +run_ bio = bio discard EOF + +-- | Run a 'BIO' loop without providing input, and collect result. +-- +-- When used on 'Source', it will collect all input chunks. +run :: HasCallStack => BIO inp out -> IO [out] +{-# INLINABLE run #-} +run bio = do + accRef <- newIORef [] + bio (mapM_ $ \ x -> modifyIORef' accRef (x:)) EOF + reverse <$> readIORef accRef + +-- | Run a strict fold over a source with 'L.Fold'. +fold' :: L.Fold a b -> Source a -> IO b +{-# INLINABLE fold' #-} +fold' (L.Fold s i e) bio = do + iref <- newIORef i + bio (mapM_ (\ x -> modifyIORef' iref (\ i' -> s i' x))) Nothing + e <$> readIORef iref + +-- | Run a strict fold over a source with 'L.FoldM'. +foldIO' :: L.FoldM IO a b -> Source a -> IO b +{-# INLINABLE foldIO' #-} +foldIO' (L.FoldM s i e) bio = do + iref <- newIORef =<< i + bio (mapM_ (\ x -> do + i' <- readIORef iref + !x' <- s i' x + writeIORef iref x')) Nothing + e =<< readIORef iref + +-- | Run a 'BIO' loop with a single chunk of input and EOF, and collect result. +-- +runBlock :: HasCallStack => BIO inp out -> inp -> IO [out] +{-# INLINABLE runBlock #-} +runBlock bio inp = do + accRef <- newIORef [] + bio (mapM_ $ \ x -> modifyIORef' accRef (x:)) (Just inp) + bio (mapM_ $ \ x -> modifyIORef' accRef (x:)) EOF + reverse <$> readIORef accRef + +-- | Run a 'BIO' loop with a single chunk of input and EOF, without collecting result. +-- +runBlock_ :: HasCallStack => BIO inp out -> inp -> IO () +{-# INLINABLE runBlock_ #-} +runBlock_ bio inp = do + bio discard (Just inp) + bio discard EOF + +-- | Wrap 'runBlock' into a pure interface. +-- +-- You can wrap a stateful BIO computation(including the creation of 'BIO' node), +-- when you can guarantee a computation is pure, e.g. compressing, decoding, etc. +unsafeRunBlock :: HasCallStack => IO (BIO inp out) -> inp -> [out] +{-# INLINABLE unsafeRunBlock #-} +unsafeRunBlock new inp = unsafePerformIO (new >>= \ bio -> runBlock bio inp) + +-- | Supply blocks of input and EOF to a 'BIO', and collect results. +-- +-- Note many 'BIO' node will be closed or not be able to take new input after drained. +runBlocks :: HasCallStack => BIO inp out -> [inp] -> IO [out] +{-# INLINABLE runBlocks #-} +runBlocks bio inps = do + accRef <- newIORef [] + forM_ inps $ bio (mapM_ $ \ x -> modifyIORef' accRef (x:)) . Just + bio (mapM_ $ \ x -> modifyIORef' accRef (x:)) EOF + reverse <$> readIORef accRef + +-- | Supply blocks of input and EOF to a 'BIO', without collecting results. +-- +-- Note many 'BIO' node will be closed or not be able to take new input after drained. +runBlocks_ :: HasCallStack => BIO inp out -> [inp] -> IO () +{-# INLINABLE runBlocks_ #-} +runBlocks_ bio inps = do + forM_ inps $ bio discard . Just + bio discard EOF + +-- | Wrap 'runBlocks' into a pure interface. +-- +-- Similar to 'unsafeRunBlock', but with a list of input blocks. +unsafeRunBlocks :: HasCallStack => IO (BIO inp out) -> [inp] -> [out] +{-# INLINABLE unsafeRunBlocks #-} +unsafeRunBlocks new inps = unsafePerformIO (new >>= \ bio -> runBlocks bio inps) + +------------------------------------------------------------------------------- +-- Source + +-- | Source a list(or any 'Foldable') from memory. +-- +sourceFromList :: Foldable f => f a -> Source a +{-# INLINABLE sourceFromList #-} +sourceFromList xs0 = \ k _ -> do + mapM_ (k . Just) xs0 + k EOF + +-- | Turn a 'BufferedInput' into 'BIO' source, map EOF to EOF. +-- +sourceFromBuffered :: HasCallStack => BufferedInput -> Source V.Bytes +{-# INLINABLE sourceFromBuffered #-} +sourceFromBuffered i = \ k _ -> loop k + where + loop k = do + x <- readBuffer i + if V.null x then k EOF else k (Just x) >> loop k + +-- | Turn a `IO` action into 'Source' +sourceFromIO :: HasCallStack => IO (Maybe a) -> Source a +{-# INLINABLE sourceFromIO #-} +sourceFromIO io = \ k _ -> loop k + where + loop k = do + x <- io + case x of + Just _ -> k x >> loop k + _ -> k EOF + +-- | Turn a UTF8 encoded 'BufferedInput' into 'BIO' source, map EOF to EOF. +-- +sourceTextFromBuffered :: HasCallStack => BufferedInput -> Source T.Text +{-# INLINABLE sourceTextFromBuffered #-} +sourceTextFromBuffered i = \ k _ -> loop k + where + loop k = do + x <- readBufferText i + if T.null x then k EOF else k (Just x) >> loop k + +-- | Turn a 'JSON' encoded 'BufferedInput' into 'BIO' source, ignoring any +-- whitespaces bewteen JSON objects. If EOF reached, then return 'EOF'. +-- Throw 'OtherError' with name "EJSON" if JSON value is not parsed or converted. +-- +sourceJSONFromBuffered :: forall a. (JSON.JSON a, HasCallStack) => BufferedInput -> Source a +{-# INLINABLE sourceJSONFromBuffered #-} +sourceJSONFromBuffered = sourceParseChunkFromBuffered JSON.decodeChunk + +-- | Turn buffered input device into a packet source, throw 'OtherError' with name @EPARSE@ if parsing fail. +sourceParserFromBuffered :: HasCallStack => P.Parser a -> BufferedInput -> Source a +{-# INLINABLE sourceParserFromBuffered #-} +sourceParserFromBuffered p = sourceParseChunkFromBuffered (P.parseChunk p) + +-- | Turn buffered input device into a packet source, throw 'OtherError' with name @EPARSE@ if parsing fail. +sourceParseChunkFromBuffered :: (HasCallStack, T.Print e) + => (V.Bytes -> P.Result e a) -> BufferedInput -> Source a +{-# INLINABLE sourceParseChunkFromBuffered #-} +sourceParseChunkFromBuffered pc bi = \ k _ -> + let loopA = do + bs <- readBuffer bi + if V.null bs + then k EOF + else loopB bs + loopB bs = do + (rest, r) <- P.parseChunks pc (readBuffer bi) bs + case r of Right v -> k (Just v) + Left e -> throwOtherError "EPARSE" (T.toText e) + if V.null rest + then loopA + else loopB rest + in loopA + +-- | Turn a file into a 'V.Bytes' source. +initSourceFromFile :: HasCallStack => CBytes -> Resource (Source V.Bytes) +{-# INLINABLE initSourceFromFile #-} +initSourceFromFile p = do + f <- FS.initFile p FS.O_RDONLY FS.DEFAULT_FILE_MODE + liftIO (sourceFromBuffered <$> newBufferedInput f) + +-- | Turn a file into a 'V.Bytes' source with given chunk size. +initSourceFromFile' :: HasCallStack => CBytes -> Int -> Resource (Source V.Bytes) +{-# INLINABLE initSourceFromFile' #-} +initSourceFromFile' p bufSiz = do + f <- FS.initFile p FS.O_RDONLY FS.DEFAULT_FILE_MODE + liftIO (sourceFromBuffered <$> newBufferedInput' bufSiz f) + +-------------------------------------------------------------------------------- +-- Sink + +-- | Turn a 'BufferedOutput' into a 'V.Bytes' sink. +sinkToBuffered :: HasCallStack => BufferedOutput -> Sink V.Bytes +{-# INLINABLE sinkToBuffered #-} +sinkToBuffered bo = \ k mbs -> + case mbs of + Just bs -> writeBuffer bo bs >> k (Just ()) + _ -> flushBuffer bo >> k EOF + +-- | Turn a 'BufferedOutput' into a 'B.Builder' sink. +-- +sinkBuilderToBuffered :: HasCallStack => BufferedOutput -> Sink (B.Builder a) +{-# INLINABLE sinkBuilderToBuffered #-} +sinkBuilderToBuffered bo = \ k mbs -> + case mbs of + Just bs -> writeBuilder bo bs >> k (Just ()) + _ -> flushBuffer bo >> k EOF + +-- | Turn a file into a 'V.Bytes' sink. +-- +-- Note the file will be opened in @'FS.O_APPEND' .|. 'FS.O_CREAT' .|. 'FS.O_WRONLY'@ mode, +-- bytes will be written after the end of the original file if there'are old bytes. +initSinkToFile :: HasCallStack => CBytes -> Resource (Sink V.Bytes) +{-# INLINABLE initSinkToFile #-} +initSinkToFile p = do + f <- FS.initFile p (FS.O_APPEND .|. FS.O_CREAT .|. FS.O_WRONLY) FS.DEFAULT_FILE_MODE + liftIO (sinkToBuffered <$> newBufferedOutput f) + +-- | Turn an `IO` action into 'BIO' sink. +-- +sinkToIO :: HasCallStack => (a -> IO ()) -> Sink a +{-# INLINABLE sinkToIO #-} +sinkToIO f = \ k ma -> + case ma of + Just a -> f a >> k (Just ()) + _ -> k EOF + +-- | Turn an `IO` action(and a flush action), into 'BIO' sink. +-- +sinkToIO' :: HasCallStack => (a -> IO ()) -> IO () -> Sink a +{-# INLINABLE sinkToIO' #-} +sinkToIO' f flush = \ k ma -> + case ma of + Just a -> f a >> k (Just ()) + _ -> flush >> k EOF + +-- | Sink to a list in memory. +-- +-- The 'MVar' will be empty during sinking, and will be filled after sink receives an EOF. +sinkToList :: IO (MVar [a], Sink a) +sinkToList = do + xsRef <- newIORef [] + rRef <- newEmptyMVar + return (rRef, sinkToIO' (\ x -> modifyIORef xsRef (x:)) + (do modifyIORef xsRef reverse + xs <- readIORef xsRef + putMVar rRef xs)) + +-------------------------------------------------------------------------------- +-- s + +-- | BIO node from a pure function. +-- +-- BIO node made with this funtion are stateless, thus can be reused across chains. +fromPure :: (a -> b) -> BIO a b +{-# INLINABLE fromPure #-} +fromPure f = \ k x -> k (f <$> x) + +-- | BIO node from an IO function. +-- +-- BIO node made with this funtion may not be stateless, it depends on if the IO function use +-- IO state. +fromIO :: HasCallStack => (a -> IO b) -> BIO a b +{-# INLINABLE fromIO #-} +fromIO f = \ k x -> + case x of Just x' -> f x' >>= k . Just + _ -> k EOF + +-- | BIO node from a pure filter. +-- +-- BIO node made with this funtion are stateless, thus can be reused across chains. +filter :: (a -> Bool) -> BIO a a +{-# INLINABLE filter #-} +filter f k = go + where + go (Just a) = when (f a) $ k (Just a) + go Nothing = k Nothing + +-- | BIO node from an impure filter. +-- +-- BIO node made with this funtion may not be stateless, it depends on if the IO function use +filterIO :: (a -> IO Bool) -> BIO a a +{-# INLINABLE filterIO #-} +filterIO f k = go + where + go (Just a) = do + mbool <- f a + when mbool $ k (Just a) + go Nothing = k Nothing + +-- | Make a chunk size divider. +-- +-- A divider size divide each chunk's size to the nearest multiplier to granularity, +-- last trailing chunk is directly returned. +newReChunk :: Int -- ^ chunk granularity + -> IO (BIO V.Bytes V.Bytes) +{-# INLINABLE newReChunk #-} +newReChunk n = do + trailingRef <- newIORef V.empty + return $ \ k mbs -> + case mbs of + Just bs -> do + trailing <- readIORef trailingRef + let chunk = trailing `V.append` bs + l = V.length chunk + if l >= n + then do + let l' = l - (l `rem` n) + (chunk', rest) = V.splitAt l' chunk + writeIORef trailingRef rest + k (Just chunk') + else writeIORef trailingRef chunk + _ -> do + trailing <- readIORef trailingRef + unless (V.null trailing) $ do + writeIORef trailingRef V.empty + k (Just trailing) + k EOF + +-- | Read buffer and parse with 'Parser'. +-- +-- This function will turn a 'Parser' into a 'BIO', throw 'OtherError' with name @EPARSE@ if parsing fail. +-- +newParser :: HasCallStack => P.Parser a -> IO (BIO V.Bytes a) +{-# INLINABLE newParser #-} +newParser p = do + -- type LastParseState = Maybe (V.Bytes -> P.Result) + resultRef <- newIORef EOF + return $ \ k mbs -> do + let loop f chunk = case f chunk of + P.Success a trailing -> do + k (Just a) + unless (V.null trailing) (loop f trailing) + P.Partial f' -> + writeIORef resultRef (Just f') + P.Failure e _ -> + throwOtherError "EPARSE" (T.toText e) + lastResult <- readIORef resultRef + case mbs of + Just bs -> do + let f = case lastResult of + Just x -> x + _ -> P.parseChunk p + loop f bs + _ -> + case lastResult of + Just f -> loop f V.empty + _ -> k EOF + +-- | Make a new UTF8 decoder, which decode bytes streams into text streams. +-- +-- If there're invalid UTF8 bytes, an 'OtherError' with name 'EINVALIDUTF8' will be thrown.` +-- +-- Note this node is supposed to be used with preprocess node such as decompressor, parser, etc. +-- where bytes boundary cannot be controlled, UTF8 decoder will concat trailing bytes from last block to next one. +-- Use this node directly with 'sourceFromBuffered' will not be as efficient as directly use +-- 'sourceTextFromBuffered', because 'BufferedInput' provides push back capability, +-- trailing bytes can be pushed back to reading buffer then returned with next block input together. +-- +newUTF8Decoder :: HasCallStack => IO (BIO V.Bytes T.Text) +{-# INLINABLE newUTF8Decoder #-} +newUTF8Decoder = do + trailingRef <- newIORef V.empty + return $ \ k mbs -> do + case mbs of + Just bs -> do + trailing <- readIORef trailingRef + let chunk = trailing `V.append` bs + (V.PrimVector arr s l) = chunk + if l > 0 && T.decodeCharLen arr s <= l + then do + let (i, _) = V.findR (\ w -> w >= 0b11000000 || w <= 0b01111111) chunk + if (i == -1) + then throwOtherError "EINVALIDUTF8" "invalid UTF8 bytes" + else do + if T.decodeCharLen arr (s + i) > l - i + then do + writeIORef trailingRef (V.fromArr arr (s+i) (l-i)) + k (Just (T.validate (V.fromArr arr s i))) + else do + writeIORef trailingRef V.empty + k (Just (T.validate chunk)) + else writeIORef trailingRef chunk + + _ -> do + trailing <- readIORef trailingRef + if V.null trailing + then k EOF + else throwOtherError "EINVALIDUTF8" "invalid UTF8 bytes" + +-- | Make a new stream splitter based on magic byte. +-- +newMagicSplitter :: Word8 -> IO (BIO V.Bytes V.Bytes) +{-# INLINABLE newMagicSplitter #-} +newMagicSplitter magic = do + trailingRef <- newIORef V.empty + return $ \ k mx -> + case mx of + Just bs -> do + trailing <- readIORef trailingRef + let loop chunk = case V.elemIndex magic chunk of + Just i -> do + -- TODO: looping + let (line, rest) = V.splitAt (i+1) chunk + k (Just line) + loop rest + _ -> writeIORef trailingRef chunk + loop (trailing `V.append` bs) + _ -> do + chunk <- readIORef trailingRef + unless (V.null chunk) $ do + writeIORef trailingRef V.empty + k (Just chunk) + k EOF + +-- | Make a new stream splitter based on linefeed(@\r\n@ or @\n@). +-- +-- The result bytes doesn't contain linefeed. +newLineSplitter :: IO (BIO V.Bytes V.Bytes) +{-# INLINABLE newLineSplitter #-} +newLineSplitter = do + s <- newMagicSplitter 10 + return (s . fromPure dropLineEnd) + where + dropLineEnd bs@(V.PrimVector arr s l) = + case bs `V.indexMaybe` (l-2) of + Just r | r == 13 -> V.PrimVector arr s (l-2) + | otherwise -> V.PrimVector arr s (l-1) + _ | V.head bs == 10 -> V.PrimVector arr s (l-1) + | otherwise -> V.PrimVector arr s l + +-- | Make a new base64 encoder node. +newBase64Encoder :: IO (BIO V.Bytes V.Bytes) +{-# INLINABLE newBase64Encoder #-} +newBase64Encoder = do + re <- newReChunk 3 + return (re . fromPure base64Encode) + +-- | Make a new base64 decoder node. +newBase64Decoder :: HasCallStack => IO (BIO V.Bytes V.Bytes) +{-# INLINABLE newBase64Decoder #-} +newBase64Decoder = do + re <- newReChunk 4 + return (re . fromPure base64Decode') + +-- | Make a hex encoder node. +-- +-- Hex encoder is stateless, it can be reused across chains. +hexEncode :: Bool -- ^ uppercase? + -> BIO V.Bytes V.Bytes +{-# INLINABLE hexEncode #-} +hexEncode upper = fromPure (Hex.hexEncode upper) + +-- | Make a new hex decoder node. +newHexDecoder :: IO (BIO V.Bytes V.Bytes) +{-# INLINABLE newHexDecoder #-} +newHexDecoder = do + re <- newReChunk 2 + return (re . fromPure Hex.hexDecode') + +-- | Make a new BIO node which counts items flow throught it. +-- +-- 'Counter' is increased atomically, it's safe to read \/ reset the counter from other threads. +counter :: Counter -> BIO a a +{-# INLINABLE counter #-} +counter c = fromIO inc + where + inc x = do + atomicAddCounter_ c 1 + return x + +-- | Make a new BIO node which counts items, and label item with a sequence number. +-- +-- 'Counter' is increased atomically, it's safe to read \/ reset the counter from other threads. +seqNum :: Counter -> BIO a (Int, a) +{-# INLINABLE seqNum #-} +seqNum c = fromIO inc + where + inc x = do + i <- atomicAddCounter c 1 + return (i, x) + +-- | Make a BIO node grouping items into fixed size arrays. +-- +-- Trailing items are directly returned. +newGrouping :: V.Vec v a => Int -> IO (BIO a (v a)) +{-# INLINABLE newGrouping #-} +newGrouping n + | n < 1 = newGrouping 1 + | otherwise = do + c <- newCounter 0 + arrRef <- newIORef =<< A.newArr n + return $ \ k mx -> + case mx of + Just x -> do + i <- readPrimRef c + if i == n - 1 + then do + marr <- readIORef arrRef + A.writeArr marr i x + writePrimRef c 0 + writeIORef arrRef =<< A.newArr n + arr <- A.unsafeFreezeArr marr + k . Just $! V.fromArr arr 0 n + else do + marr <- readIORef arrRef + A.writeArr marr i x + writePrimRef c (i+1) + _ -> do + i <- readPrimRef c + if i /= 0 + then do + writePrimRef c 0 + marr <- readIORef arrRef + A.shrinkMutableArr marr i + arr <- A.unsafeFreezeArr marr + k . Just $! V.fromArr arr 0 i + else k EOF + +-- | A BIO node flatten items. +-- +ungrouping :: BIO (V.Vector a) a +{-# INLINABLE ungrouping #-} +ungrouping = \ k mx -> + case mx of + Just x -> V.traverse_ (k . Just) x + _ -> k EOF + +-- | A BIO node which write 'True' to 'IORef' when 'EOF' is reached. +consumed :: TVar Bool -> BIO a a +{-# INLINABLE consumed #-} +consumed ref = \ k mx -> case mx of + Just _ -> k mx + _ -> do atomically (writeTVar ref True) + k EOF + + + + diff --git a/Z/IO/BIO/Concurrent.hs b/Z/IO/BIO/Concurrent.hs --- a/Z/IO/BIO/Concurrent.hs +++ b/Z/IO/BIO/Concurrent.hs @@ -13,9 +13,9 @@ This module provides some concurrent 'BIO' node, to ease the implementation of producer-consumer model. All sources and sinks return by this module are safe to be used in multiple threads. - * Use 'newTQueueNode' for common cases. - * Use 'newTBQueueNode' if you have a fast producer and you don't want input get piled up in memory. - * Use 'newBroadcastTChanNode' if you want messages get broadcasted, i.e. every message written by + * Use 'newTQueuePair' for common cases. + * Use 'newTBQueuePair' if you have a fast producer and you don't want input get piled up in memory. + * Use 'newBroadcastTChanPair' if you want messages get broadcasted, i.e. every message written by producers will be received by every consumers. It's important to correctly set the numebr of producers, internally it keeps a counter on how many producers @@ -23,7 +23,7 @@ exceptions and pull the sink(which indicate EOF) on producer side. @ -(sink, src) <- newTQueueNode 2 -- it's important to correctly set the numebr of producers +(sink, src) <- newTQueuePair 2 -- it's important to correctly set the numebr of producers -------------------------------------------------------------------------------- -- producers @@ -63,7 +63,7 @@ import qualified Data.Sequence as Seq import Data.Sequence (Seq((:<|),(:|>))) import GHC.Natural -import Z.IO.BIO +import Z.IO.BIO.Base import Z.Data.PrimRef import Z.IO.Exception @@ -74,8 +74,9 @@ -- * Two node should output same numebr of results. -- * If the number differs, one node maybe -- -zipBIO :: BIO a b -> BIO a c -> BIO a (b,c) -zipBIO b1 b2 = \ k mx -> do +zip :: BIO a b -> BIO a c -> BIO a (b,c) +{-# INLINABLE zip #-} +zip b1 b2 = \ k mx -> do bEOF <- newTVarIO False cEOF <- newTVarIO False bBuf <- newTVarIO Seq.empty @@ -104,9 +105,10 @@ _ -> if beof then return (k EOF) else retry -- | Make an unbounded queue and a pair of sink and souce connected to it. -newTQueueNode :: Int -- ^ number of producers +newTQueuePair :: Int -- ^ number of producers -> IO (Sink a, Source a) -newTQueueNode n = do +{-# INLINABLE newTQueuePair #-} +newTQueuePair n = do q <- newTQueueIO ec <- newCounter 0 return @@ -127,10 +129,11 @@ in loop) -- | Make an bounded queue and a pair of sink and souce connected to it. -newTBQueueNode :: Int -- ^ number of producers +newTBQueuePair :: Int -- ^ number of producers -> Natural -- ^ queue buffer bound -> IO (Sink a, Source a) -newTBQueueNode n bound = do +{-# INLINABLE newTBQueuePair #-} +newTBQueuePair n bound = do q <- newTBQueueIO bound ec <- newCounter 0 return @@ -151,9 +154,10 @@ in loop) -- | Make a broadcast chan and a sink connected to it, and a function return sources to receive broadcast message. -newBroadcastTChanNode :: Int -- ^ number of producers +newBroadcastTChanPair :: Int -- ^ number of producers -> IO (Sink a, IO (Source a)) -- ^ (Sink, IO Source) -newBroadcastTChanNode n = do +{-# INLINABLE newBroadcastTChanPair #-} +newBroadcastTChanPair n = do b <- newBroadcastTChanIO ec <- newCounter 0 let dupSrc = do diff --git a/Z/IO/BIO/Zlib.hsc b/Z/IO/BIO/Zlib.hsc --- a/Z/IO/BIO/Zlib.hsc +++ b/Z/IO/BIO/Zlib.hsc @@ -65,7 +65,7 @@ import Z.Data.Vector.Base as V import Z.Foreign import Z.Foreign.CPtr -import Z.IO.BIO +import Z.IO.BIO.Base import Z.IO.Exception #include "zlib.h" @@ -120,6 +120,7 @@ deriving anyclass (Print, JSON) defaultCompressConfig :: CompressConfig +{-# INLINABLE defaultCompressConfig #-} defaultCompressConfig = CompressConfig Z_DEFAULT_COMPRESSION defaultWindowBits defaultMemLevel V.empty Z_DEFAULT_STRATEGY V.defaultChunkSize @@ -134,6 +135,7 @@ newCompress :: HasCallStack => CompressConfig -> IO (ZStream, BIO V.Bytes V.Bytes) +{-# INLINABLE newCompress #-} newCompress (CompressConfig level windowBits memLevel dict strategy bufSiz) = do zs <- newCPtr' (do ps <- throwOOMIfNull create_z_stream @@ -189,15 +191,18 @@ -- | Reset compressor's state so that related 'BIO' can be reused. compressReset :: ZStream -> IO () +{-# INLINABLE compressReset #-} compressReset (ZStream fp) = do throwZlibIfMinus_ (withCPtr fp deflateReset) -- | Compress some bytes. compress :: HasCallStack => CompressConfig -> V.Bytes -> V.Bytes +{-# INLINABLE compress #-} compress conf = V.concat . unsafeRunBlock (snd <$> newCompress conf) -- | Compress some bytes in blocks. compressBlocks :: HasCallStack => CompressConfig -> [V.Bytes] -> [V.Bytes] +{-# INLINABLE compressBlocks #-} compressBlocks conf = unsafeRunBlocks (snd <$> newCompress conf) data DecompressConfig = DecompressConfig @@ -208,12 +213,14 @@ deriving anyclass (Print, JSON) defaultDecompressConfig :: DecompressConfig +{-# INLINABLE defaultDecompressConfig #-} defaultDecompressConfig = DecompressConfig defaultWindowBits V.empty V.defaultChunkSize -- | Make a new decompress node. -- -- The returned 'BIO' node can be reused only if you call 'decompressReset' on the 'ZStream'. newDecompress :: DecompressConfig -> IO (ZStream, BIO V.Bytes V.Bytes) +{-# INLINABLE newDecompress #-} newDecompress (DecompressConfig windowBits dict bufSiz) = do zs <- newCPtr' (do ps <- throwOOMIfNull create_z_stream @@ -283,20 +290,24 @@ -- | Reset decompressor's state so that related 'BIO' can be reused. decompressReset :: ZStream -> IO () +{-# INLINABLE decompressReset #-} decompressReset (ZStream fp) = do throwZlibIfMinus_ (withCPtr fp inflateReset) -- | Decompress some bytes. decompress :: HasCallStack => DecompressConfig -> V.Bytes -> V.Bytes +{-# INLINABLE decompress #-} decompress conf = V.concat . unsafeRunBlock (snd <$> newDecompress conf) -- | Decompress some bytes in blocks. decompressBlocks :: HasCallStack => DecompressConfig -> [V.Bytes] -> [V.Bytes] +{-# INLINABLE decompressBlocks #-} decompressBlocks conf = unsafeRunBlocks (snd <$> newDecompress conf) -------------------------------------------------------------------------------- toZErrorMsg :: CInt -> CBytes +{-# INLINABLE toZErrorMsg #-} toZErrorMsg (#const Z_OK ) = "Z_OK" toZErrorMsg (#const Z_STREAM_END ) = "Z_STREAM_END" toZErrorMsg (#const Z_NEED_DICT ) = "Z_NEED_DICT" @@ -315,6 +326,7 @@ fromException = ioExceptionFromException throwZlibIfMinus :: HasCallStack => IO CInt -> IO CInt +{-# INLINABLE throwZlibIfMinus #-} throwZlibIfMinus f = do r <- f if r < 0 && r /= (#const Z_BUF_ERROR) @@ -322,6 +334,7 @@ else return r throwZlibIfMinus_ :: HasCallStack => IO CInt -> IO () +{-# INLINABLE throwZlibIfMinus_ #-} throwZlibIfMinus_ = void . throwZlibIfMinus foreign import ccall unsafe @@ -358,6 +371,7 @@ inflateReset :: Ptr ZStream -> IO CInt set_avail_in :: CPtr ZStream -> V.Bytes -> Int -> IO () +{-# INLINABLE set_avail_in #-} set_avail_in zs buf buflen = do withPrimVectorSafe buf $ \ pbuf _ -> withCPtr zs $ \ ps -> do @@ -365,6 +379,7 @@ (#poke struct z_stream_s, avail_in) ps (fromIntegral buflen :: CUInt) set_avail_out :: CPtr ZStream -> MutablePrimArray RealWorld Word8 -> Int -> IO () +{-# INLINABLE set_avail_out #-} set_avail_out zs buf bufSiz = do withMutablePrimArrayContents buf $ \ pbuf -> withCPtr zs $ \ ps -> do diff --git a/Z/IO/Buffered.hs b/Z/IO/Buffered.hs --- a/Z/IO/Buffered.hs +++ b/Z/IO/Buffered.hs @@ -33,7 +33,7 @@ , newBufferedOutput , newBufferedOutput' , writeBuffer, writeBuffer' - , writeBuilder + , writeBuilder, writeBuilder' , flushBuffer , clearOutputBuffer -- * Buffered Input and Output @@ -51,14 +51,13 @@ import Data.Word import Data.Bits (unsafeShiftR) import Foreign.Ptr -import Z.Data.Array import qualified Z.Data.Builder.Base as B import qualified Z.Data.Parser as P import qualified Z.Data.Vector as V import qualified Z.Data.Text as T import qualified Z.Data.Text.UTF8Codec as T import qualified Z.Data.Vector.Base as V -import Z.Data.PrimRef.PrimIORef +import Z.Data.PrimRef import Z.Foreign import Z.IO.Exception @@ -125,14 +124,16 @@ newBufferedOutput = newBufferedOutput' V.defaultChunkSize -- | Open a new buffered output with given buffer size, e.g. 'V.defaultChunkSize'. +-- +-- Size smaller than 'V.smallChunkSize' will be taken as 'V.smallChunkSize'. newBufferedOutput' :: Output o => Int -- ^ Output buffer size -> o -> IO BufferedOutput {-# INLINABLE newBufferedInput' #-} newBufferedOutput' bufSiz o = do - index <- newPrimIORef 0 - buf <- newPinnedPrimArray (max bufSiz 0) + index <- newPrimRef 0 + buf <- newPinnedPrimArray (max bufSiz V.smallChunkSize) return (BufferedOutput (writeOutput o) index buf) -- | Open a new buffered input with given buffer size, e.g. 'V.defaultChunkSize'. @@ -143,18 +144,18 @@ {-# INLINABLE newBufferedOutput' #-} newBufferedInput' bufSiz i = do pb <- newIORef V.empty - buf <- newPinnedPrimArray (max bufSiz 0) + buf <- newPinnedPrimArray (max bufSiz V.smallChunkSize) inputBuffer <- newIORef buf return (BufferedInput (readInput i) pb inputBuffer) -- | Open a new buffered input and output with 'V.defaultChunkSize' as buffer size. newBufferedIO :: IODev dev => dev -> IO (BufferedInput, BufferedOutput) -{-# INLINE newBufferedIO #-} +{-# INLINABLE newBufferedIO #-} newBufferedIO dev = newBufferedIO' dev V.defaultChunkSize V.defaultChunkSize -- | Open a new buffered input and output with given buffer size, e.g. 'V.defaultChunkSize'. newBufferedIO' :: IODev dev => dev -> Int -> Int -> IO (BufferedInput, BufferedOutput) -{-# INLINE newBufferedIO' #-} +{-# INLINABLE newBufferedIO' #-} newBufferedIO' dev inSize outSize = do i <- newBufferedInput' inSize dev o <- newBufferedOutput' outSize dev @@ -184,9 +185,8 @@ ba <- unsafeFreezePrimArray mba return $! V.fromArr ba 0 l else do -- freeze buf into result - when (bufSiz /= 0) $ do - buf' <- newPinnedPrimArray bufSiz - writeIORef inputBuffer buf' + buf' <- newPinnedPrimArray bufSiz + writeIORef inputBuffer buf' shrinkMutablePrimArray rbuf l ba <- unsafeFreezePrimArray rbuf return $! V.fromArr ba 0 l @@ -196,8 +196,8 @@ -- | Request UTF8 'T.Text' chunk from 'BufferedInput'. -- --- The buffer size must be larger than 4 bytes to guarantee decoding progress. If there're --- trailing bytes before EOF, an 'OtherError' with name 'EINCOMPLETE' will be thrown, if there're +-- The buffer size must be larger than 4 bytes to guarantee decoding progress(which is guaranteed by 'newBufferedInput'). +-- If there're trailing bytes before EOF, an 'OtherError' with name 'EINCOMPLETE' will be thrown, if there're -- invalid UTF8 bytes, an 'OtherError' with name 'EINVALIDUTF8' will be thrown.` readBufferText :: HasCallStack => BufferedInput -> IO T.Text {-# INLINABLE readBufferText #-} @@ -235,9 +235,8 @@ ba <- unsafeFreezePrimArray mba splitLastChar (V.PrimVector ba 0 l) else do -- freeze buf into result - when (bufSiz /= 0) $ do - buf' <- newPinnedPrimArray bufSiz - writeIORef inputBuffer buf' + buf' <- newPinnedPrimArray bufSiz + writeIORef inputBuffer buf' shrinkMutablePrimArray rbuf l ba <- unsafeFreezePrimArray rbuf splitLastChar (V.PrimVector ba 0 l) @@ -257,6 +256,7 @@ -- | Clear already buffered input. clearInputBuffer :: BufferedInput -> IO () +{-# INLINABLE clearInputBuffer #-} clearInputBuffer BufferedInput{..} = writeIORef bufPushBack V.empty -- | Read exactly N bytes. @@ -264,23 +264,31 @@ -- If EOF reached before N bytes read, an 'OtherError' with name 'EINCOMPLETE' will be thrown. readExactly :: HasCallStack => Int -> BufferedInput -> IO V.Bytes {-# INLINABLE readExactly #-} -readExactly n0 h0 = V.concat `fmap` (go h0 n0) +readExactly n0 h = do + chunk <- readBuffer h + let l = V.length chunk + if n0 < l + then do + let (!chunk', !rest) = V.splitAt n0 chunk + unReadBuffer rest h + return chunk' + else if n0 == l + then return chunk + else V.concatR <$> (go (n0 - l) [chunk]) where - go h n = do + go !n acc = do chunk <- readBuffer h let l = V.length chunk if l > n then do - let (chunk', rest) = V.splitAt n chunk + let (!chunk', !rest) = V.splitAt n chunk unReadBuffer rest h - return [chunk'] + return (chunk':acc) else if l == n - then return [chunk] + then return (chunk:acc) else if l == 0 then throwOtherError "EINCOMPLETE" "input is incomplete" - else do - chunks <- go h (n - l) - return (chunk : chunks) + else go (n - l) (chunk:acc) -- | Read all chunks from a 'BufferedInput' until EOF. -- @@ -293,7 +301,7 @@ loop acc = do chunk <- readBuffer h if V.null chunk - then return $! reverse (chunk:acc) + then return $! reverse acc else loop (chunk:acc) -- | Read all chunks from a 'BufferedInput', and concat chunks together. @@ -302,7 +310,13 @@ -- Useful for reading small file into memory. readAll' :: HasCallStack => BufferedInput -> IO V.Bytes {-# INLINABLE readAll' #-} -readAll' i = V.concat <$> readAll i +readAll' h = loop [] + where + loop acc = do + chunk <- readBuffer h + if V.null chunk + then return $! V.concatR acc + else loop (chunk:acc) -- | Push bytes back into buffer(if not empty). -- @@ -403,18 +417,18 @@ writeBuffer :: HasCallStack => BufferedOutput -> V.Bytes -> IO () {-# INLINABLE writeBuffer #-} writeBuffer o@BufferedOutput{..} v@(V.PrimVector ba s l) = do - i <- readPrimIORef bufIndex + i <- readPrimRef bufIndex bufSiz <- getSizeofMutablePrimArray outputBuffer if i /= 0 then if i + l <= bufSiz then do -- current buffer can hold it copyPrimArray outputBuffer i ba s l -- copy to buffer - writePrimIORef bufIndex (i+l) -- update index + writePrimRef bufIndex (i+l) -- update index else do -- flush the buffer first withMutablePrimArrayContents outputBuffer $ \ ptr -> bufOutput ptr i - writePrimIORef bufIndex 0 + writePrimRef bufIndex 0 -- try write to buffer again writeBuffer o v else @@ -422,18 +436,13 @@ then withPrimVectorSafe v bufOutput else do copyPrimArray outputBuffer i ba s l -- copy to buffer - writePrimIORef bufIndex l -- update index + writePrimRef bufIndex l -- update index -- | Write 'V.Bytes' into buffered handle then flush the buffer into output device (if buffer is not empty). -- --- * If buffer is empty and bytes are larger than half of buffer, directly write bytes, --- otherwise copy bytes to buffer. --- --- * If buffer is not empty, then copy bytes to buffer if it can hold, otherwise --- write buffer first, then try again. --- +-- Equivalent to add a 'flushBuffer' after write. writeBuffer' :: HasCallStack => BufferedOutput -> V.Bytes -> IO () -{-# INLINE writeBuffer' #-} +{-# INLINABLE writeBuffer' #-} writeBuffer' bo o = writeBuffer bo o >> flushBuffer bo -- | Directly write 'B.Builder' into buffered handle. @@ -443,21 +452,21 @@ writeBuilder :: HasCallStack => BufferedOutput -> B.Builder a -> IO () {-# INLINABLE writeBuilder #-} writeBuilder BufferedOutput{..} (B.Builder b) = do - i <- readPrimIORef bufIndex + i <- readPrimRef bufIndex originBufSiz <- getSizeofMutablePrimArray outputBuffer loop originBufSiz =<< b (\ _ -> return . B.Done) (B.Buffer outputBuffer i) where loop originBufSiz r = case r of B.Done buffer@(B.Buffer buf' i') -> do if sameMutablePrimArray buf' outputBuffer - then writePrimIORef bufIndex i' + then writePrimRef bufIndex i' else if i' >= originBufSiz then do action =<< freezeBuffer buffer - writePrimIORef bufIndex 0 + writePrimRef bufIndex 0 else do copyMutablePrimArray outputBuffer 0 buf' 0 i' - writePrimIORef bufIndex i' + writePrimRef bufIndex i' B.BufferFull buffer@(B.Buffer _ i') wantSiz k -> do when (i' /= 0) (action =<< freezeBuffer buffer) if wantSiz <= originBufSiz @@ -483,16 +492,24 @@ !arr <- unsafeFreezePrimArray buf return (V.PrimVector arr 0 offset) +-- | Directly write 'B.Builder' into buffered handle then flush the buffer into output device (if buffer is not empty). +-- +-- Equivalent to add a 'flushBuffer' after write. +writeBuilder' :: HasCallStack => BufferedOutput -> B.Builder () -> IO () +{-# INLINABLE writeBuilder' #-} +writeBuilder' bo o = writeBuilder bo o >> flushBuffer bo + -- | Flush the buffer into output device(if buffer is not empty). -- flushBuffer :: HasCallStack => BufferedOutput -> IO () {-# INLINABLE flushBuffer #-} flushBuffer BufferedOutput{..} = do - i <- readPrimIORef bufIndex + i <- readPrimRef bufIndex when (i /= 0) $ do withMutablePrimArrayContents outputBuffer $ \ ptr -> bufOutput ptr i - writePrimIORef bufIndex 0 + writePrimRef bufIndex 0 -- | Clear already buffered output. clearOutputBuffer :: BufferedOutput -> IO () -clearOutputBuffer BufferedOutput{..} = writePrimIORef bufIndex 0 +{-# INLINABLE clearOutputBuffer #-} +clearOutputBuffer BufferedOutput{..} = writePrimRef bufIndex 0 diff --git a/Z/IO/Environment.hs b/Z/IO/Environment.hs --- a/Z/IO/Environment.hs +++ b/Z/IO/Environment.hs @@ -36,7 +36,7 @@ import Control.Monad import Data.Word -import Z.Data.Vector.Base as V +import qualified Z.Data.Vector.Base as V import Z.Data.CBytes import Z.Foreign import Z.IO.Exception @@ -51,6 +51,7 @@ -- This is different from base's 'System.Environment.getArgs' since result -- includes the program path(more like C's *argv). getArgs :: IO [CBytes] +{-# INLINABLE getArgs #-} getArgs = do (argc :: CInt, (p_argv :: Ptr CString, _)) <- allocPrimUnsafe $ \ p_argc -> do allocPrimUnsafe $ \ p_p_argv -> do @@ -62,6 +63,7 @@ -- -- Warning: This function is not thread safe. getAllEnv :: HasCallStack => IO [(CBytes, CBytes)] +{-# INLINABLE getAllEnv #-} getAllEnv = bracket (do (p_env :: Ptr CString, (envc :: CInt, _)) <- allocPrimUnsafe $ \ p_p_env -> do allocPrimUnsafe $ \ p_envc -> @@ -78,6 +80,7 @@ -- -- Warning: This function is not thread safe. getEnv :: HasCallStack => CBytes -> IO (Maybe CBytes) +{-# INLINABLE getEnv #-} getEnv k = go 512 where go siz = do @@ -96,6 +99,7 @@ -- -- Warning: This function is not thread safe. getEnv' :: HasCallStack => CBytes -> IO CBytes +{-# INLINABLE getEnv' #-} getEnv' k = getEnv k >>= \ mv -> case mv of Just v -> return v _ -> throwUVError UV_ENOENT (IOEInfo "ENOENT" "no such environment variable" callStack) @@ -104,6 +108,7 @@ -- -- Warning: This function is not thread safe. setEnv :: HasCallStack => CBytes -> CBytes -> IO () +{-# INLINABLE setEnv #-} setEnv k v = withCBytesUnsafe k $ \ p_k -> withCBytesUnsafe v $ \ p_v -> throwUVIfMinus_ (uv_os_setenv p_k p_v) @@ -112,10 +117,12 @@ -- -- Warning: This function is not thread safe. unsetEnv :: HasCallStack => CBytes -> IO () +{-# INLINABLE unsetEnv #-} unsetEnv k = void . withCBytesUnsafe k $ \ p -> throwUVIfMinus_ (uv_os_unsetenv p) -- | Gets the resident set size (RSS) for the current process. getResidentSetMemory :: HasCallStack => IO CSize +{-# INLINABLE getResidentSetMemory #-} getResidentSetMemory = do (size, r) <- allocPrimUnsafe uv_resident_set_memory throwUVIfMinus_ (return r) @@ -123,6 +130,7 @@ -- | Gets the current system uptime. getUpTime :: HasCallStack => IO Double +{-# INLINABLE getUpTime #-} getUpTime = do (size, r) <- allocPrimUnsafe uv_uptime throwUVIfMinus_ (return r) @@ -134,6 +142,7 @@ -- It is not related to the time of day and therefore not subject to clock drift. -- The primary use is for measuring performance between intervals. getHighResolutionTime :: IO Word64 +{-# INLINABLE getHighResolutionTime #-} getHighResolutionTime = uv_hrtime -- | Gets the resource usage measures for the current process. @@ -141,6 +150,7 @@ -- On Windows not all fields are set, the unsupported fields are filled with zeroes. -- See 'ResUsage' for more details. getResUsage :: HasCallStack => IO ResUsage +{-# INLINABLE getResUsage #-} getResUsage = do (MutableByteArray mba#) <- newByteArray sizeOfResUsage throwUVIfMinus_ (uv_getrusage mba#) @@ -148,15 +158,18 @@ -- | Returns the current process ID. getPID :: IO PID +{-# INLINABLE getPID #-} getPID = uv_os_getpid -- | Returns the parent process ID. getPPID :: IO PID +{-# INLINABLE getPPID #-} getPPID = uv_os_getppid -- | Returns the hostname as a null-terminated string. -- getHostname :: HasCallStack => IO CBytes +{-# INLINABLE getHostname #-} getHostname = do (n, _) <- allocCBytesUnsafe (fromIntegral UV_MAXHOSTNAMESIZE) $ \ p_n -> withPrimUnsafe UV_MAXHOSTNAMESIZE $ \ p_siz -> @@ -168,6 +181,7 @@ -- The function may block indefinitely when not enough entropy is available, don't use it to get -- long random sequences. getRandom :: Int -> IO V.Bytes +{-# INLINABLE getRandom #-} getRandom siz = do (v, _) <- allocPrimVectorUnsafe siz $ \ mba# -> throwUVIfMinus_ (hs_uv_random mba# (fromIntegral siz) 0) @@ -177,6 +191,7 @@ -- -- The function run 'getRandom' in libuv's threadpool, suitable for get long random byte sequences. getRandomT :: Int -> IO V.Bytes +{-# INLINABLE getRandomT #-} getRandomT siz = do (v, _) <- allocPrimVectorSafe siz $ \ p -> do uvm <- getUVManager @@ -186,6 +201,7 @@ -- | Gets the current working directory. -- getCWD :: HasCallStack => IO CBytes +{-# INLINABLE getCWD #-} getCWD = go 512 where go siz = do @@ -201,6 +217,7 @@ -- | Changes the current working directory. -- chDir :: HasCallStack => CBytes -> IO () +{-# INLINABLE chDir #-} chDir p = throwUVIfMinus_ (withCBytesUnsafe p $ \ pp -> uv_chdir pp) -- | Gets the current user’s home directory. @@ -212,6 +229,7 @@ -- -- Warning 'getHomeDir' is not thread safe. getHomeDir :: HasCallStack => IO CBytes +{-# INLINABLE getHomeDir #-} getHomeDir = go 512 where go siz = do @@ -232,6 +250,7 @@ -- -- Warning 'getHomeDir' is not thread safe. getTempDir :: HasCallStack => IO CBytes +{-# INLINABLE getTempDir #-} getTempDir = go 512 where go siz = do @@ -246,10 +265,12 @@ -- | Gets the amount of free memory available in the system, as reported by the kernel (in bytes). getFreeMem :: IO Word64 +{-# INLINABLE getFreeMem #-} getFreeMem = uv_get_free_memory -- | Gets the total amount of physical memory in the system (in bytes). getTotalMem :: IO Word64 +{-# INLINABLE getTotalMem #-} getTotalMem = uv_get_total_memory -- | Gets the amount of memory available to the process (in bytes) based on limits imposed by the OS. @@ -258,6 +279,7 @@ -- Note that it is not unusual for this value to be less than or greater than 'getTotalMem'. -- Note This function currently only returns a non-zero value on Linux, based on cgroups if it is present. getConstrainedMem :: IO Word64 +{-# INLINABLE getConstrainedMem #-} getConstrainedMem = uv_get_constrained_memory -------------------------------------------------------------------------------- diff --git a/Z/IO/Exception.hs b/Z/IO/Exception.hs --- a/Z/IO/Exception.hs +++ b/Z/IO/Exception.hs @@ -103,9 +103,11 @@ instance Exception SomeIOException ioExceptionToException :: Exception e => e -> SomeException +{-# INLINABLE ioExceptionToException #-} ioExceptionToException = toException . SomeIOException ioExceptionFromException :: Exception e => SomeException -> Maybe e +{-# INLINABLE ioExceptionFromException #-} ioExceptionFromException x = do SomeIOException a <- fromException x cast a @@ -211,6 +213,7 @@ -- | Check if the given exception is synchronous -- isSyncException :: Exception e => e -> Bool +{-# INLINABLE isSyncException #-} isSyncException e = case fromException (toException e) of Just (SomeAsyncException _) -> False @@ -219,12 +222,14 @@ -- | Same as upstream 'C.catch', but will not catch asynchronous exceptions -- catchSync :: Exception e => IO a -> (e -> IO a) -> IO a +{-# INLINABLE catchSync #-} catchSync f g = f `catch` \ e -> if isSyncException e then g e else throwIO e -- | Ingore all synchronous exceptions. -- ignoreSync :: IO a -> IO () +{-# INLINABLE ignoreSync #-} ignoreSync f = catchSync (void f) (\ (_ :: SomeException) -> return ()) -------------------------------------------------------------------------------- @@ -240,6 +245,7 @@ instance Show IOEInfo where show = T.toString instance T.Print IOEInfo where + {-# INLINE toUTF8BuilderP #-} toUTF8BuilderP _ (IOEInfo errno desc cstack) = do "{name:" T.text errno diff --git a/Z/IO/FileSystem/Base.hs b/Z/IO/FileSystem/Base.hs --- a/Z/IO/FileSystem/Base.hs +++ b/Z/IO/FileSystem/Base.hs @@ -120,7 +120,7 @@ import qualified Z.Data.Builder as B import Z.Data.CBytes as CBytes import qualified Z.Data.JSON as JSON -import Z.Data.PrimRef.PrimIORef +import Z.Data.PrimRef import qualified Z.Data.Text as T import qualified Z.Data.Text.Print as T import qualified Z.Data.Vector as V @@ -153,12 +153,14 @@ -- | Return File fd. getFileFD :: File -> IO FD +{-# INLINABLE getFileFD #-} getFileFD (File fd closedRef) = do closed <- readIORef closedRef if closed then throwECLOSED else return fd -- | If fd is -1 (closed), throw 'ResourceVanished' ECLOSED. checkFileClosed :: HasCallStack => File -> (FD -> IO a) -> IO a +{-# INLINABLE checkFileClosed #-} checkFileClosed (File fd closedRef) f = do closed <- readIORef closedRef if closed then throwECLOSED else f fd @@ -167,11 +169,13 @@ -- -- Equivalent to . seek :: HasCallStack => File -> Int64 -> Whence -> IO Int64 +{-# INLINABLE seek #-} seek uvf off w = checkFileClosed uvf $ \ fd -> throwUVIfMinus $ hs_seek fd off w instance Input File where -- readInput :: HasCallStack => File -> Ptr Word8 -> Int -> IO Int -- use -1 offset to use fd's default offset + {-# INLINABLE readInput #-} readInput f buf bufSiz = readFileP f buf bufSiz (-1) -- | Read file with given offset @@ -183,10 +187,12 @@ -> Int -- ^ buffer size -> Int64 -- ^ file offset, pass -1 to use default(system) offset -> IO Int -- ^ read length +{-# INLINABLE readFileP #-} readFileP uvf buf bufSiz off = checkFileClosed uvf $ \ fd -> throwUVIfMinus $ hs_uv_fs_read fd buf bufSiz off instance Output File where + {-# INLINABLE writeOutput #-} writeOutput f buf bufSiz = writeFileP f buf bufSiz (-1) -- | Write buffer to file @@ -207,6 +213,7 @@ -> Int -- ^ buffer size -> Int64 -- ^ file offset, pass -1 to use default(system) offset -> IO () +{-# INLINABLE writeFileP #-} writeFileP uvf buf0 bufSiz0 off0 = checkFileClosed uvf $ \fd -> if off0 == -1 then go fd buf0 bufSiz0 else go' fd buf0 bufSiz0 off0 @@ -236,6 +243,7 @@ -> FileMode -- ^ Sets the file mode (permission and sticky bits), -- but only if the file was created, see 'DEFAULT_FILE_MODE'. -> Resource File +{-# INLINABLE initFile #-} initFile path flags mode = initResource (do !fd <- withCBytesUnsafe path $ \ p -> @@ -256,6 +264,7 @@ -- Note mode is currently not implemented on Windows. On unix you should set execute bit -- if you want the directory is accessable, e.g. 0o777. mkdir :: HasCallStack => CBytes -> FileMode -> IO () +{-# INLINABLE mkdir #-} mkdir path mode = throwUVIfMinus_ . withCBytesUnsafe path $ \ p -> hs_uv_fs_mkdir p mode @@ -269,6 +278,7 @@ -- can be created), e.g. 'DEFAULT_DIR_MODE'. -- mkdirp :: HasCallStack => CBytes -> FileMode -> IO () +{-# INLINABLE mkdirp #-} mkdirp path mode = do r <- withCBytesUnsafe path $ \ p -> hs_uv_fs_mkdir p mode case fromIntegral r of @@ -294,6 +304,7 @@ -- | Equivalent to . unlink :: HasCallStack => CBytes -> IO () +{-# INLINABLE unlink #-} unlink path = throwUVIfMinus_ (withCBytesUnsafe path hs_uv_fs_unlink) @@ -309,6 +320,7 @@ -- so no need to add XXXXXX ending. -- mkdtemp :: HasCallStack => CBytes -> IO CBytes +{-# INLINABLE mkdtemp #-} mkdtemp path = do let size = CBytes.length path withCBytesUnsafe path $ \ p -> do @@ -329,6 +341,7 @@ -> CBytes -- ^ A file path prefix template, no "XXXXXX" needed. -> Bool -- ^ Keep file after used? -> Resource (CBytes, File) +{-# INLINABLE mkstemp #-} mkstemp dir template keep = do initResource (do template' <- dir `P.join` template @@ -349,12 +362,14 @@ -- -- Note this function may inherent OS limitations such as argument must be an empty folder. rmdir :: HasCallStack => CBytes -> IO () +{-# INLINABLE rmdir #-} rmdir path = throwUVIfMinus_ (withCBytesUnsafe path hs_uv_fs_rmdir) -- | Removes a file or directory at path together with its contents and -- subdirectories. Symbolic links are removed without affecting their targets. -- If the path does not exist, nothing happens. rmrf :: HasCallStack => CBytes -> IO () +{-# INLINABLE rmrf #-} rmrf path = withCBytesUnsafe path $ \path' -> allocaBytes uvStatSize $ \s -> do @@ -385,6 +400,7 @@ -- systems (btrfs, ext2, ext3 and ext4 at the time of this writing), check the -- man page. scandir :: HasCallStack => CBytes -> IO [(CBytes, DirEntType)] +{-# INLINABLE scandir #-} scandir path = do bracket (withCBytesUnsafe path $ \ p -> @@ -403,6 +419,7 @@ -- | Equivalent to stat :: HasCallStack => CBytes -> IO FStat +{-# INLINABLE stat #-} stat path = withCBytesUnsafe path $ \ p -> allocaBytes uvStatSize $ \ s -> do throwUVIfMinus_ (hs_uv_fs_stat p s) @@ -410,6 +427,7 @@ -- | Equivalent to lstat :: HasCallStack => CBytes -> IO FStat +{-# INLINABLE lstat #-} lstat path = withCBytesUnsafe path $ \ p -> allocaBytes uvStatSize $ \ s -> do throwUVIfMinus_ (hs_uv_fs_lstat p s) @@ -419,6 +437,7 @@ -- -- Return 'Nothing' instead of throwing 'NoSuchThing' if the file doesn't exist. stat' :: HasCallStack => CBytes -> IO (Maybe FStat) +{-# INLINABLE stat' #-} stat' path = withCBytesUnsafe path $ \ p -> allocaBytes uvStatSize $ \ s -> do r <- fromIntegral <$> hs_uv_fs_stat p s @@ -430,6 +449,7 @@ -- -- Return 'Nothing' instead of throwing 'NoSuchThing' if the link doesn't exist. lstat' :: HasCallStack => CBytes -> IO (Maybe FStat) +{-# INLINABLE lstat' #-} lstat' path = withCBytesUnsafe path $ \ p -> allocaBytes uvStatSize $ \ s -> do r <- fromIntegral <$> hs_uv_fs_lstat p s @@ -439,6 +459,7 @@ -- | Equivalent to fstat :: HasCallStack => File -> IO FStat +{-# INLINABLE fstat #-} fstat uvf = checkFileClosed uvf $ \ fd -> allocaBytes uvStatSize $ \ s -> do throwUVIfMinus_ (hs_uv_fs_fstat fd s) @@ -450,25 +471,30 @@ -- -- Note On Windows if this function fails with UV_EBUSY, UV_EPERM or UV_EACCES, it will retry to rename the file up to four times with 250ms wait between attempts before giving up. If both path and new_path are existing directories this function will work only if target directory is empty. rename :: HasCallStack => CBytes -> CBytes -> IO () +{-# INLINABLE rename #-} rename path path' = throwUVIfMinus_ . withCBytesUnsafe path $ \ p -> withCBytesUnsafe path' (hs_uv_fs_rename p) -- | Equivalent to . fsync :: HasCallStack => File -> IO () +{-# INLINABLE fsync #-} fsync uvf = checkFileClosed uvf $ \ fd -> throwUVIfMinus_ $ hs_uv_fs_fsync fd -- | Equivalent to . fdatasync :: HasCallStack => File -> IO () +{-# INLINABLE fdatasync #-} fdatasync uvf = checkFileClosed uvf $ \ fd -> throwUVIfMinus_ $ hs_uv_fs_fdatasync fd -- | Equivalent to . ftruncate :: HasCallStack => File -> Int64 -> IO () +{-# INLINABLE ftruncate #-} ftruncate uvf off = checkFileClosed uvf $ \ fd -> throwUVIfMinus_ $ hs_uv_fs_ftruncate fd off -- | Copies a file from path to new_path. -- -- Warning: If the destination path is created, but an error occurs while copying the data, then the destination path is removed. There is a brief window of time between closing and removing the file where another process could access the file. copyfile :: HasCallStack => CBytes -> CBytes -> CopyFileFlag -> IO () +{-# INLINABLE copyfile #-} copyfile path path' flag = throwUVIfMinus_ . withCBytesUnsafe path $ \ p -> withCBytesUnsafe path' $ \ p' -> hs_uv_fs_copyfile p p' flag @@ -476,6 +502,7 @@ -- -- Windows uses GetFileAttributesW(). access :: HasCallStack => CBytes -> AccessMode -> IO AccessResult +{-# INLINABLE access #-} access path mode = do r <- withCBytesUnsafe path $ \ p -> fromIntegral <$> hs_uv_fs_access p mode if | r == 0 -> return AccessOK @@ -488,10 +515,12 @@ -- | Equivalent to . chmod :: HasCallStack => CBytes -> FileMode -> IO () +{-# INLINABLE chmod #-} chmod path mode = throwUVIfMinus_ . withCBytesUnsafe path $ \ p -> hs_uv_fs_chmod p mode -- | Equivalent to . fchmod :: HasCallStack => File -> FileMode -> IO () +{-# INLINABLE fchmod #-} fchmod uvf mode = checkFileClosed uvf $ \ fd -> throwUVIfMinus_ $ hs_uv_fs_fchmod fd mode -- | Equivalent to . @@ -502,12 +531,14 @@ -> Double -- ^ atime, i.e. access time -> Double -- ^ mtime, i.e. modify time -> IO () +{-# INLINABLE utime #-} utime path atime mtime = throwUVIfMinus_ . withCBytesUnsafe path $ \ p -> hs_uv_fs_utime p atime mtime -- | Equivalent to . -- -- Same precision notes with 'utime'. futime :: HasCallStack => File -> Double -> Double -> IO () +{-# INLINABLE futime #-} futime uvf atime mtime = checkFileClosed uvf $ \ fd -> throwUVIfMinus_ (hs_uv_fs_futime fd atime mtime) @@ -519,10 +550,12 @@ -> Double -- ^ atime, i.e. access time -> Double -- ^ mtime, i.e. modify time -> IO () +{-# INLINABLE lutime #-} lutime path atime mtime = throwUVIfMinus_ . withCBytesUnsafe path $ \ p -> hs_uv_fs_lutime p atime mtime -- | Equivalent to . link :: HasCallStack => CBytes -> CBytes -> IO () +{-# INLINABLE link #-} link path path' = throwUVIfMinus_ . withCBytesUnsafe path $ \ p -> withCBytesUnsafe path' $ hs_uv_fs_link p @@ -535,11 +568,13 @@ -- -- On other platforms these flags are ignored. symlink :: HasCallStack => CBytes -> CBytes -> SymlinkFlag -> IO () +{-# INLINABLE symlink #-} symlink path path' flag = throwUVIfMinus_ . withCBytesUnsafe path $ \ p -> withCBytesUnsafe path' $ \ p' -> hs_uv_fs_symlink p p' flag -- | Equivalent to . readlink :: HasCallStack => CBytes -> IO CBytes +{-# INLINABLE readlink #-} readlink path = do bracket (withCBytesUnsafe path $ \ p -> @@ -567,6 +602,7 @@ -- -- Note This function is not implemented on Windows XP and Windows Server 2003. On these systems, UV_ENOSYS is returned. realpath :: HasCallStack => CBytes -> IO CBytes +{-# INLINABLE realpath #-} realpath path = do bracket (withCBytesUnsafe path $ \ p -> @@ -577,12 +613,15 @@ -- | Equivalent to . chown :: HasCallStack => CBytes -> UID -> GID -> IO () +{-# INLINABLE chown #-} chown path uid gid = throwUVIfMinus_ . withCBytesUnsafe path $ \ p -> hs_uv_fs_chown p uid gid -- | Equivalent to . fchown :: HasCallStack => File -> UID -> GID -> IO () +{-# INLINABLE fchown #-} fchown uvf uid gid = checkFileClosed uvf $ \ fd -> throwUVIfMinus_ $ hs_uv_fs_fchown fd uid gid -- | Equivalent to . lchown :: HasCallStack => CBytes -> UID -> GID -> IO () +{-# INLINABLE lchown #-} lchown path uid gid = throwUVIfMinus_ . withCBytesUnsafe path $ \ p -> hs_uv_fs_lchown p uid gid diff --git a/Z/IO/FileSystem/FilePath.hsc b/Z/IO/FileSystem/FilePath.hsc --- a/Z/IO/FileSystem/FilePath.hsc +++ b/Z/IO/FileSystem/FilePath.hsc @@ -75,10 +75,12 @@ deriving anyclass (T.Print, JSON) enumToPathStyle_ :: CInt -> PathStyle +{-# INLINABLE enumToPathStyle_ #-} enumToPathStyle_ (#const CWK_STYLE_WINDOWS) = WindowsStyle enumToPathStyle_ _ = UnixStyle pathStyleToEnum_ :: PathStyle -> CInt +{-# INLINABLE pathStyleToEnum_ #-} pathStyleToEnum_ WindowsStyle = (#const CWK_STYLE_WINDOWS) pathStyleToEnum_ _ = (#const CWK_STYLE_UNIX) @@ -96,10 +98,12 @@ -- * If nothing was found to determine the style -> UNIX -- pathStyle :: CBytes -> IO PathStyle +{-# INLINABLE pathStyle #-} pathStyle p = enumToPathStyle_ <$> withCBytesUnsafe p cwk_path_guess_style -- | Gets the path style currently using. getPathStyle :: IO PathStyle +{-# INLINABLE getPathStyle #-} getPathStyle = enumToPathStyle_ <$> cwk_path_get_style -- | Configures which path style is used afterwards. @@ -108,10 +112,12 @@ -- call to this function is only required if a non-native behaviour is required. -- The style defaults to 'WindowsStyle' on windows builds and to 'UnixStyle' otherwise. setPathStyle :: PathStyle -> IO () +{-# INLINABLE setPathStyle #-} setPathStyle = cwk_path_set_style . pathStyleToEnum_ -- | Get the default character that separates directories. pathSeparator :: IO Word8 +{-# INLINABLE pathSeparator #-} pathSeparator = do s <- getPathStyle case s of UnixStyle -> return (#const SLASH) @@ -119,6 +125,7 @@ -- | Get characters that separates directories. pathSeparators :: IO [Word8] +{-# INLINABLE pathSeparators #-} pathSeparators = do s <- getPathStyle case s of UnixStyle -> return [(#const SLASH)] @@ -126,6 +133,7 @@ -- | Test if a character is a path separator. isPathSeparator :: Word8 -> IO Bool +{-# INLINABLE isPathSeparator #-} isPathSeparator w = do s <- getPathStyle case s of UnixStyle -> return (w == #const SLASH) @@ -137,6 +145,7 @@ -- * Unix: searchPathSeparator is ASCII @:@ -- searchPathSeparator :: IO Word8 +{-# INLINABLE searchPathSeparator #-} searchPathSeparator = do s <- getPathStyle case s of UnixStyle -> return (#const COLON) @@ -144,6 +153,7 @@ -- | Test if a character is a file separator. isSearchPathSeparator :: Word8 -> IO Bool +{-# INLINABLE isSearchPathSeparator #-} isSearchPathSeparator w = do w' <- searchPathSeparator return (w == w') @@ -152,10 +162,12 @@ -- -- ExtSeparator is ASCII @.@ extensionSeparator :: Word8 +{-# INLINABLE extensionSeparator #-} extensionSeparator = #const DOT -- | Test if a character is a file extension separator. isExtensionSeparator :: Word8 -> Bool +{-# INLINABLE isExtensionSeparator #-} isExtensionSeparator = (== #const DOT) -- | Get the basename of a file path. @@ -205,6 +217,7 @@ changeBaseName :: CBytes -> CBytes -- ^ new base name -> IO CBytes +{-# INLINABLE changeBaseName #-} changeBaseName p b = do let l = CB.length p + CB.length b + (#const BUF_EXT_SIZ) (p', _) <- withCBytesUnsafe p $ \ pp -> @@ -268,6 +281,7 @@ changeRoot :: CBytes -> CBytes -- ^ new base name -> IO CBytes +{-# INLINABLE changeRoot #-} changeRoot p r = do let l = CB.length p + CB.length r + (#const BUF_EXT_SIZ) (p', _) <- withCBytesUnsafe p $ \ pp -> @@ -329,6 +343,7 @@ -- +---------+--------------------------+-----------+ -- isAbsolute :: CBytes -> IO Bool +{-# INLINABLE isAbsolute #-} isAbsolute p = (/=0) <$> withCBytesUnsafe p cwk_path_is_absolute -- | Determine whether the path is relative or not. @@ -365,6 +380,7 @@ -- +---------+--------------------------+-----------+ -- isRelative :: CBytes -> IO Bool +{-# INLINABLE isRelative #-} isRelative p = (/=0) <$> withCBytesUnsafe p cwk_path_is_relative -- | Joins two paths together. @@ -392,6 +408,7 @@ -- +---------+-----------------------+---------------------------+--------------------------------------+ -- join :: CBytes -> CBytes -> IO CBytes +{-# INLINABLE join #-} join p p2 = do let l = CB.length p + CB.length p2 + (#const BUF_EXT_SIZ) (p', _) <- withCBytesUnsafe p $ \ pp -> @@ -406,6 +423,7 @@ -- It will remove double separators, and unlike 'absolute', -- it permits the use of multiple relative paths to combine. concat :: [CBytes] -> IO CBytes +{-# INLINABLE concat #-} concat ps = do (p', _) <- withCBytesListUnsafe ps $ \ pp l -> do let l' = sum (List.map (\ p -> CB.length p + (#const BUF_EXT_SIZ)) ps) @@ -440,6 +458,7 @@ -- +--------------------------------------------------+-------------------+ -- normalize :: CBytes -> IO CBytes +{-# INLINABLE normalize #-} normalize p = do let l = CB.length p + (#const BUF_EXT_SIZ) (p', _) <- withCBytesUnsafe p $ \ pp -> @@ -478,6 +497,7 @@ intersection :: CBytes -- ^ The base path which will be compared with the other path. -> CBytes -- ^ The other path which will compared with the base path. -> IO CBytes +{-# INLINABLE intersection #-} intersection p1 p2 = do len <- withCBytesUnsafe p1 $ \ pp1 -> withCBytesUnsafe p2 $ \ pp2 -> @@ -511,6 +531,7 @@ absolute :: CBytes -- ^ The absolute base path on which the relative path will be applied. -> CBytes -- ^ The relative path which will be applied on the base path. -> IO CBytes +{-# INLINABLE absolute #-} absolute p p2 = do let l = CB.length p + CB.length p2 + (#const BUF_EXT_SIZ) (p', _) <- withCBytesUnsafe p $ \ pp -> @@ -557,6 +578,7 @@ => CBytes -- ^ The base path from which the relative path will start. -> CBytes -- ^ The target path where the relative path will point to. -> IO CBytes +{-# INLINABLE relative #-} relative p p2 = do let l = (CB.length p `unsafeShiftL` 1) + CB.length p2 + (#const BUF_EXT_SIZ) (p', r) <- withCBytesUnsafe p $ \ pp -> @@ -615,7 +637,7 @@ -- dropExtension :: CBytes -- ^ file path -> IO CBytes -{-# INLINE dropExtension #-} +{-# INLINABLE dropExtension #-} dropExtension p = fst <$> splitExtension p -- | Get the extension of a file from a file path, returns @\"\"@ for no @@ -637,12 +659,13 @@ -- takeExtension :: CBytes -- ^ file path -> IO CBytes -{-# INLINE takeExtension #-} +{-# INLINABLE takeExtension #-} takeExtension p = snd <$> splitExtension p -- | Test if a file from a file path has an extension. hasExtension :: CBytes -- ^ file path -> IO Bool +{-# INLINABLE hasExtension #-} hasExtension p = do withCBytesUnsafe p $ \ p' -> cwk_path_has_extension p' @@ -667,6 +690,7 @@ changeExtension :: CBytes -- ^ The path which will be used to make the change. -> CBytes -- ^ The extension which will be placed within the new path. -> IO CBytes +{-# INLINABLE changeExtension #-} changeExtension p p2 = do let l = CB.length p + CB.length p2 + (#const BUF_EXT_SIZ) (p', _) <- withCBytesUnsafe p $ \ pp -> @@ -679,6 +703,7 @@ -- | Get a list of paths in the @$PATH@ variable. getSearchPath :: IO [CBytes] +{-# INLINABLE getSearchPath #-} getSearchPath = do s <- getEnv' "PATH" sp <- searchPathSeparator diff --git a/Z/IO/FileSystem/Threaded.hs b/Z/IO/FileSystem/Threaded.hs --- a/Z/IO/FileSystem/Threaded.hs +++ b/Z/IO/FileSystem/Threaded.hs @@ -132,7 +132,7 @@ import qualified Z.Data.Builder as B import Z.Data.CBytes as CBytes import qualified Z.Data.JSON as JSON -import Z.Data.PrimRef.PrimIORef +import Z.Data.PrimRef import qualified Z.Data.Text as T import qualified Z.Data.Text.Print as T import qualified Z.Data.Vector as V @@ -165,16 +165,19 @@ instance Show File where show = T.toString instance T.Print File where + {-# INLINABLE toUTF8BuilderP #-} toUTF8BuilderP _ (File fd _) = "File " >> T.int fd -- | Return File fd. getFileFD :: File -> IO FD +{-# INLINABLE getFileFD #-} getFileFD (File fd closedRef) = do closed <- readIORef closedRef if closed then throwECLOSED else return fd -- | If fd is -1 (closed), throw 'ResourceVanished' ECLOSED. checkFileClosed :: HasCallStack => File -> (FD -> IO a) -> IO a +{-# INLINABLE checkFileClosed #-} checkFileClosed (File fd closedRef) f = do closed <- readIORef closedRef if closed then throwECLOSED else f fd @@ -183,9 +186,11 @@ -- -- Equivalent to . seek :: HasCallStack => File -> Int64 -> Whence -> IO Int64 +{-# INLINABLE seek #-} seek uvf off w = checkFileClosed uvf $ \ fd -> throwUVIfMinus $ hs_seek fd off w instance Input File where + {-# INLINABLE readInput #-} readInput f buf bufSiz = readFileP f buf bufSiz (-1) -- | Read file with given offset @@ -197,12 +202,14 @@ -> Int -- ^ buffer size -> Int64 -- ^ file offset, pass -1 to use default(system) offset -> IO Int -- ^ read length +{-# INLINABLE readFileP #-} readFileP uvf buf bufSiz off = checkFileClosed uvf $ \ fd -> do uvm <- getUVManager withUVRequest uvm (hs_uv_fs_read_threaded fd buf bufSiz off) instance Output File where + {-# INLINABLE writeOutput #-} writeOutput f buf bufSiz = writeFileP f buf bufSiz (-1) -- | Write buffer to file @@ -223,6 +230,7 @@ -> Int -- ^ buffer size -> Int64 -- ^ file offset, pass -1 to use default(system) offset -> IO () +{-# INLINABLE writeFileP #-} writeFileP uvf buf0 bufSiz0 off0 = checkFileClosed uvf $ \ fd -> do (if off0 == -1 then go fd buf0 bufSiz0 @@ -259,6 +267,7 @@ -> FileMode -- ^ Sets the file mode (permission and sticky bits), -- but only if the file was created, see 'DEFAULT_FILE_MODE'. -> Resource File +{-# INLINABLE initFile #-} initFile path flags mode = initResource (do uvm <- getUVManager @@ -278,6 +287,7 @@ -- Note mode is currently not implemented on Windows. On unix you should set execute bit -- if you want the directory is accessable, e.g. 0o777. mkdir :: HasCallStack => CBytes -> FileMode -> IO () +{-# INLINABLE mkdir #-} mkdir path mode = do uvm <- getUVManager withCBytesUnsafe path $ \ p -> @@ -293,6 +303,7 @@ -- can be created), e.g. 'DEFAULT_DIR_MODE'. -- mkdirp :: HasCallStack => CBytes -> FileMode -> IO () +{-# INLINABLE mkdirp #-} mkdirp path mode = do uvm <- getUVManager r <- withCBytesUnsafe path $ \ p -> @@ -320,6 +331,7 @@ -- | Equivalent to . unlink :: HasCallStack => CBytes -> IO () +{-# INLINABLE unlink #-} unlink path = do uvm <- getUVManager withCBytesUnsafe path $ \ p -> @@ -337,6 +349,7 @@ -- so no need to add XXXXXX ending. -- mkdtemp :: HasCallStack => CBytes -> IO CBytes +{-# INLINABLE mkdtemp #-} mkdtemp path = do let size = CBytes.length path withCBytesUnsafe path $ \ p -> do @@ -358,6 +371,7 @@ -> CBytes -- ^ A file path prefix template, no "XXXXXX" needed. -> Bool -- ^ Keep file after used? -> Resource (CBytes, File) +{-# INLINABLE mkstemp #-} mkstemp dir template keep = do initResource (do template' <- dir `P.join` template @@ -377,6 +391,7 @@ -- -- Note this function may inherent OS limitations such as argument must be an empty folder. rmdir :: HasCallStack => CBytes -> IO () +{-# INLINABLE rmdir #-} rmdir path = do uvm <- getUVManager withCBytesUnsafe path (\ p -> void . withUVRequest uvm $ hs_uv_fs_rmdir_threaded p) @@ -385,6 +400,7 @@ -- subdirectories. Symbolic links are removed without affecting their targets. -- If the path does not exist, nothing happens. rmrf :: HasCallStack => CBytes -> IO () +{-# INLINABLE rmrf #-} rmrf path = withCBytesUnsafe path $ \path' -> allocaBytes uvStatSize $ \s -> do @@ -416,6 +432,7 @@ -- -- Note On Linux, getting the type of an entry is only supported by some file systems (btrfs, ext2, ext3 and ext4 at the time of this writing), check the man page. scandir :: HasCallStack => CBytes -> IO [(CBytes, DirEntType)] +{-# INLINABLE scandir #-} scandir path = do uvm <- getUVManager bracket @@ -436,6 +453,7 @@ -- | Equivalent to stat :: HasCallStack => CBytes -> IO FStat +{-# INLINABLE stat #-} stat path = do withCBytesUnsafe path $ \ p -> allocaBytes uvStatSize $ \ s -> do @@ -445,6 +463,7 @@ -- | Equivalent to lstat :: HasCallStack => CBytes -> IO FStat +{-# INLINABLE lstat #-} lstat path = withCBytesUnsafe path $ \ p -> allocaBytes uvStatSize $ \ s -> do @@ -456,6 +475,7 @@ -- -- Return 'Nothing' instead of throwing 'NoSuchThing' if the file doesn't exist. stat' :: HasCallStack => CBytes -> IO (Maybe FStat) +{-# INLINABLE stat' #-} stat' path = do withCBytesUnsafe path $ \ p -> allocaBytes uvStatSize $ \ s -> do @@ -469,6 +489,7 @@ -- -- Return 'Nothing' instead of throwing 'NoSuchThing' if the link doesn't exist. lstat' :: HasCallStack => CBytes -> IO (Maybe FStat) +{-# INLINABLE lstat' #-} lstat' path = withCBytesUnsafe path $ \ p -> allocaBytes uvStatSize $ \ s -> do @@ -480,6 +501,7 @@ -- | Equivalent to fstat :: HasCallStack => File -> IO FStat +{-# INLINABLE fstat #-} fstat uvf = checkFileClosed uvf $ \ fd -> (allocaBytes uvStatSize $ \ s -> do uvm <- getUVManager @@ -492,6 +514,7 @@ -- -- Note On Windows if this function fails with UV_EBUSY, UV_EPERM or UV_EACCES, it will retry to rename the file up to four times with 250ms wait between attempts before giving up. If both path and new_path are existing directories this function will work only if target directory is empty. rename :: HasCallStack => CBytes -> CBytes -> IO () +{-# INLINABLE rename #-} rename path path' = do uvm <- getUVManager withCBytesUnsafe path $ \ p -> @@ -500,18 +523,21 @@ -- | Equivalent to . fsync :: HasCallStack => File -> IO () +{-# INLINABLE fsync #-} fsync uvf = checkFileClosed uvf $ \ fd -> do uvm <- getUVManager withUVRequest_ uvm (hs_uv_fs_fsync_threaded fd) -- | Equivalent to . fdatasync :: HasCallStack => File -> IO () +{-# INLINABLE fdatasync #-} fdatasync uvf = checkFileClosed uvf $ \ fd -> do uvm <- getUVManager withUVRequest_ uvm (hs_uv_fs_fdatasync_threaded fd) -- | Equivalent to . ftruncate :: HasCallStack => File -> Int64 -> IO () +{-# INLINABLE ftruncate #-} ftruncate uvf off = checkFileClosed uvf $ \ fd -> do uvm <- getUVManager withUVRequest_ uvm (hs_uv_fs_ftruncate_threaded fd off) @@ -520,6 +546,7 @@ -- -- Warning: If the destination path is created, but an error occurs while copying the data, then the destination path is removed. There is a brief window of time between closing and removing the file where another process could access the file. copyfile :: HasCallStack => CBytes -> CBytes -> CopyFileFlag -> IO () +{-# INLINABLE copyfile #-} copyfile path path' flag = do uvm <- getUVManager withCBytesUnsafe path $ \ p -> @@ -529,6 +556,7 @@ -- | Equivalent to on Unix. -- Windows uses GetFileAttributesW(). access :: HasCallStack => CBytes -> AccessMode -> IO AccessResult +{-# INLINABLE access #-} access path mode = do uvm <- getUVManager withCBytesUnsafe path $ \ p -> @@ -545,6 +573,7 @@ -- | Equivalent to . chmod :: HasCallStack => CBytes -> FileMode -> IO () +{-# INLINABLE chmod #-} chmod path mode = do uvm <- getUVManager withCBytesUnsafe path $ \ p -> @@ -552,6 +581,7 @@ -- | Equivalent to . fchmod :: HasCallStack => File -> FileMode -> IO () +{-# INLINABLE fchmod #-} fchmod uvf mode = checkFileClosed uvf $ \ fd -> do uvm <- getUVManager withUVRequest_ uvm (hs_uv_fs_fchmod_threaded fd mode) @@ -565,6 +595,7 @@ -> Double -- ^ atime, i.e. access time -> Double -- ^ mtime, i.e. modify time -> IO () +{-# INLINABLE utime #-} utime path atime mtime = do uvm <- getUVManager withCBytesUnsafe path $ \ p -> @@ -574,6 +605,7 @@ -- -- Same precision notes with 'utime'. futime :: HasCallStack => File -> Double -> Double -> IO () +{-# INLINABLE futime #-} futime uvf atime mtime = checkFileClosed uvf $ \ fd -> do uvm <- getUVManager withUVRequest_ uvm (hs_uv_fs_futime_threaded fd atime mtime) @@ -586,6 +618,7 @@ -> Double -- ^ atime, i.e. access time -> Double -- ^ mtime, i.e. modify time -> IO () +{-# INLINABLE lutime #-} lutime path atime mtime = do uvm <- getUVManager withCBytesUnsafe path $ \ p -> @@ -593,6 +626,7 @@ -- | Equivalent to . link :: HasCallStack => CBytes -> CBytes -> IO () +{-# INLINABLE link #-} link path path' = do uvm <- getUVManager withCBytesUnsafe path $ \ p -> @@ -608,6 +642,7 @@ -- -- On other platforms these flags are ignored. symlink :: HasCallStack => CBytes -> CBytes -> SymlinkFlag -> IO () +{-# INLINABLE symlink #-} symlink path path' flag = do uvm <- getUVManager withCBytesUnsafe path $ \ p -> @@ -616,6 +651,7 @@ -- | Equivalent to . readlink :: HasCallStack => CBytes -> IO CBytes +{-# INLINABLE readlink #-} readlink path = do uvm <- getUVManager bracket @@ -645,6 +681,7 @@ -- -- Note This function is not implemented on Windows XP and Windows Server 2003. On these systems, UV_ENOSYS is returned. realpath :: HasCallStack => CBytes -> IO CBytes +{-# INLINABLE realpath #-} realpath path = do uvm <- getUVManager bracket @@ -658,6 +695,7 @@ -- | Equivalent to . chown :: HasCallStack => CBytes -> UID -> GID -> IO () +{-# INLINABLE chown #-} chown path uid gid = do uvm <- getUVManager withCBytesUnsafe path $ \ p -> @@ -665,12 +703,14 @@ -- | Equivalent to . fchown :: HasCallStack => FD -> UID -> GID -> IO () +{-# INLINABLE fchown #-} fchown fd uid gid = do uvm <- getUVManager withUVRequest_ uvm (hs_uv_fs_fchown_threaded fd uid gid) -- | Equivalent to . lchown :: HasCallStack => CBytes -> UID -> GID -> IO () +{-# INLINABLE lchown #-} lchown path uid gid = do uvm <- getUVManager withCBytesUnsafe path $ \ p -> diff --git a/Z/IO/FileSystem/Watch.hs b/Z/IO/FileSystem/Watch.hs --- a/Z/IO/FileSystem/Watch.hs +++ b/Z/IO/FileSystem/Watch.hs @@ -16,7 +16,7 @@ -- dup a file event source src <- srcf -- print event to stdout - runBIO_ $ src . sinkToIO printStd + BIO.run_ $ src . sinkToIO printStd @ -} @@ -37,7 +37,6 @@ import Data.Primitive.PrimArray import Data.Word import GHC.Generics -import Z.Data.Array import Z.Data.Array.Unaligned import Z.Data.CBytes (CBytes) import qualified Z.Data.CBytes as CBytes @@ -45,8 +44,7 @@ import Z.Data.Text.Print (Print) import Z.Data.Vector (defaultChunkSize) import Z.Foreign -import Z.IO.BIO -import Z.IO.BIO.Concurrent +import Z.IO.BIO as BIO import Z.IO.Exception import Z.IO.FileSystem.Base import qualified Z.IO.FileSystem.FilePath as P @@ -65,15 +63,17 @@ -> Bool -- ^ recursively watch? -> (FileEvent -> IO ()) -- ^ Callback function to handle 'FileEvent' -> IO () +{-# INLINABLE watchDirs #-} watchDirs dirs rec callback = do withResource (initWatchDirs dirs rec) $ \ srcf -> do src <- srcf - runBIO_ $ src . sinkToIO callback + run_ $ src . sinkToIO callback -- | Start watching a list of given directories, stream version. initWatchDirs :: [CBytes] -- ^ watching list -> Bool -- ^ recursively watch? -> Resource (IO (Source FileEvent)) +{-# INLINABLE initWatchDirs #-} initWatchDirs dirs False = do liftIO . forM_ dirs $ \ dir -> do b <- isDir dir @@ -91,11 +91,12 @@ -- Internal function to start watching watch_ :: CUInt -> [CBytes] -> Resource (IO (Source FileEvent)) +{-# INLINABLE watch_ #-} watch_ flag dirs = fst <$> initResource (do -- HashMap to store all watchers mRef <- newMVar HM.empty -- there's only one place to pull the sink, that is cleanUpWatcher - (sink, srcf) <- newBroadcastTChanNode 1 + (sink, srcf) <- newBroadcastTChanPair 1 -- lock UVManager first (forM_ dirs $ \ dir -> do dir' <- P.normalize dir @@ -207,7 +208,7 @@ case me of Just e -> (Nothing, Just e) _ -> (Nothing, Nothing) - forM_ me' (stepBIO_ sink) + forM_ me' (BIO.step_ sink) me' <- atomicModifyIORef' eRef $ \ me -> case me of @@ -215,4 +216,4 @@ then (me, Nothing) else (Just event, Just e) _ -> (Just event, Nothing) - forM_ me' (stepBIO_ sink) + forM_ me' (BIO.step_ sink) diff --git a/Z/IO/Logger.hs b/Z/IO/Logger.hs --- a/Z/IO/Logger.hs +++ b/Z/IO/Logger.hs @@ -94,7 +94,7 @@ import qualified Z.Data.Builder as B import qualified Z.Data.CBytes as CB import qualified Z.Data.JSON.Builder as JB -import Z.Data.Vector.Base as V +import qualified Z.Data.Vector.Base as V import Z.IO.Buffered import Z.IO.Exception import qualified Z.IO.FileSystem as ZF @@ -144,6 +144,7 @@ -- * show everything by default -- * 'defaultFmt' defaultLoggerConfig :: LoggerConfig +{-# INLINABLE defaultLoggerConfig #-} defaultLoggerConfig = LoggerConfig 1 240 NOTSET defaultFmt -- | A default logger config with @@ -153,6 +154,7 @@ -- * show everything by default -- * 'defaultJSONFmt' defaultJSONLoggerConfig :: LoggerConfig +{-# INLINABLE defaultJSONLoggerConfig #-} defaultJSONLoggerConfig = LoggerConfig 5 1000 NOTSET defaultJSONFmt -- | A default timestamp cache with format @%Y-%m-%dT%H:%M:%S%Z@('iso8061DateFormat'). @@ -171,6 +173,7 @@ newLogger :: LoggerConfig -> MVar BufferedOutput -> IO Logger +{-# INLINABLE newLogger #-} newLogger LoggerConfig{..} oLock = do logsRef <- newIORef [] let flush = flushLogIORef oLock logsRef @@ -186,12 +189,14 @@ -- | Make a new logger write to 'stderrBuf'. newStdLogger :: LoggerConfig -> IO Logger +{-# INLINABLE newStdLogger #-} newStdLogger config = newLogger config stderrBuf -- | Make a new file based logger with 'defaultFmt'. -- -- The file will be opened in append mode. newFileLogger :: LoggerConfig -> CB.CBytes -> IO Logger +{-# INLINABLE newFileLogger #-} newFileLogger config path = do let res = ZF.initFile path (ZF.O_CREAT .|. ZF.O_RDWR .|. ZF.O_APPEND) ZF.DEFAULT_FILE_MODE (file, _closeFunc) <- acquire res @@ -215,11 +220,13 @@ -> Int -- ^ buffer size to build each log -> B.Builder () -- ^ formatted log -> IO () +{-# INLINABLE pushLogIORef #-} pushLogIORef logsRef loggerLineBufSize b = do let !bs = B.buildWith loggerLineBufSize b unless (V.null bs) $ atomicModifyIORef' logsRef (\ bss -> (bs:bss, ())) flushLogIORef :: HasCallStack => MVar BufferedOutput -> IORef [V.Bytes] -> IO () +{-# INLINABLE flushLogIORef #-} flushLogIORef oLock logsRef = withMVar oLock $ \ o -> do bss <- atomicModifyIORef' logsRef (\ bss -> ([], bss)) @@ -230,6 +237,7 @@ -- -- @[FATAL][2021-02-01T15:03:30+0800][:31:1][thread#669]...@ defaultFmt :: LogFormatter +{-# INLINABLE defaultFmt #-} defaultFmt ts level content cstack (ThreadId tid#) = do B.square (defaultLevelFmt level) B.square ts @@ -242,6 +250,7 @@ -- -- DEBUG level is 'Cyan', WARNING level is 'Yellow', FATAL and CRITICAL level are 'Red'. defaultColoredFmt :: LogFormatter +{-# INLINABLE defaultColoredFmt #-} defaultColoredFmt ts level content cstack (ThreadId tid#) = do let blevel = defaultLevelFmt level B.square (case level of @@ -260,6 +269,7 @@ -- -- > {"level":"FATAL","time":"2021-02-01T15:02:19+0800","loc":":27:1","theadId":606,"content":"..."}\n defaultJSONFmt :: LogFormatter +{-# INLINABLE defaultJSONFmt #-} defaultJSONFmt ts level content cstack (ThreadId tid#) = do B.curly $ do "level" `JB.kv` B.quotes (defaultLevelFmt level) @@ -275,6 +285,7 @@ -- | Default stack formatter which fetch the logging source and location. defaultFmtCallStack :: CallStack -> B.Builder () +{-# INLINABLE defaultFmtCallStack #-} defaultFmtCallStack cs = case reverse $ getCallStack cs of [] -> "" @@ -294,6 +305,7 @@ -- | Change the global logger. setDefaultLogger :: Logger -> IO () +{-# INLINABLE setDefaultLogger #-} setDefaultLogger !logger = atomicWriteIORef globalLogger logger -- | Get the global logger. @@ -301,16 +313,19 @@ -- This is a logger connected to stderr, if stderr is connect to TTY, -- then use 'defaultColoredFmt', otherwise use 'defaultFmt'. getDefaultLogger :: IO Logger +{-# INLINABLE getDefaultLogger #-} getDefaultLogger = readIORef globalLogger -- | Manually flush global logger. flushDefaultLogger :: IO () +{-# INLINABLE flushDefaultLogger #-} flushDefaultLogger = do (Logger _ flush) <- getDefaultLogger flush -- | Flush global logger when program exits. withDefaultLogger :: IO () -> IO () +{-# INLINABLE withDefaultLogger #-} withDefaultLogger = (`finally` flushDefaultLogger) -------------------------------------------------------------------------------- @@ -361,7 +376,7 @@ -- Level other than built-in ones, are formatted in decimal numeric format, i.e. -- @defaultLevelFmt 60 == "LEVEL60"@ defaultLevelFmt :: Level -> B.Builder () -{-# INLINE defaultLevelFmt #-} +{-# INLINABLE defaultLevelFmt #-} defaultLevelFmt level = case level of CRITICAL -> "CRITICAL" FATAL -> "FATAL" @@ -372,23 +387,23 @@ level' -> "LEVEL" >> B.int level' debug :: HasCallStack => B.Builder () -> IO () -{-# INLINE debug #-} +{-# INLINABLE debug #-} debug = otherLevel_ DEBUG False callStack info :: HasCallStack => B.Builder () -> IO () -{-# INLINE info #-} +{-# INLINABLE info #-} info = otherLevel_ INFO False callStack warning :: HasCallStack => B.Builder () -> IO () -{-# INLINE warning #-} +{-# INLINABLE warning #-} warning = otherLevel_ WARNING False callStack fatal :: HasCallStack => B.Builder () -> IO () -{-# INLINE fatal #-} +{-# INLINABLE fatal #-} fatal = otherLevel_ FATAL True callStack critical :: HasCallStack => B.Builder () -> IO () -{-# INLINE critical #-} +{-# INLINABLE critical #-} critical = otherLevel_ CRITICAL True callStack otherLevel :: HasCallStack @@ -396,11 +411,11 @@ -> Bool -- ^ flush immediately? -> B.Builder () -- ^ log content -> IO () -{-# INLINE otherLevel #-} +{-# INLINABLE otherLevel #-} otherLevel level flushNow bu = otherLevel_ level flushNow callStack bu otherLevel_ :: Level -> Bool -> CallStack -> B.Builder () -> IO () -{-# INLINE otherLevel_ #-} +{-# INLINABLE otherLevel_ #-} otherLevel_ level flushNow cstack bu = do (Logger f _) <- getDefaultLogger f level flushNow cstack bu @@ -408,19 +423,19 @@ -------------------------------------------------------------------------------- debugTo :: HasCallStack => Logger -> B.Builder () -> IO () -{-# INLINE debugTo #-} +{-# INLINABLE debugTo #-} debugTo = otherLevelTo_ DEBUG False callStack infoTo :: HasCallStack => Logger -> B.Builder () -> IO () -{-# INLINE infoTo #-} +{-# INLINABLE infoTo #-} infoTo = otherLevelTo_ INFO False callStack warningTo :: HasCallStack => Logger -> B.Builder () -> IO () -{-# INLINE warningTo #-} +{-# INLINABLE warningTo #-} warningTo = otherLevelTo_ WARNING False callStack fatalTo :: HasCallStack => Logger -> B.Builder () -> IO () -{-# INLINE fatalTo #-} +{-# INLINABLE fatalTo #-} fatalTo = otherLevelTo_ FATAL True callStack otherLevelTo :: HasCallStack @@ -429,11 +444,11 @@ -> Bool -- ^ flush immediately? -> B.Builder () -- ^ log content -> IO () -{-# INLINE otherLevelTo #-} +{-# INLINABLE otherLevelTo #-} otherLevelTo logger level flushNow = otherLevelTo_ level flushNow callStack logger otherLevelTo_ :: Level -> Bool -> CallStack -> Logger -> B.Builder () -> IO () -{-# INLINE otherLevelTo_ #-} +{-# INLINABLE otherLevelTo_ #-} otherLevelTo_ level flushNow cs (Logger f _) = f level flushNow cs foreign import ccall unsafe "rts_getThreadId" getThreadId :: ThreadId# -> CInt diff --git a/Z/IO/LowResTimer.hs b/Z/IO/LowResTimer.hs --- a/Z/IO/LowResTimer.hs +++ b/Z/IO/LowResTimer.hs @@ -49,12 +49,13 @@ import Data.IORef import GHC.Conc import System.IO.Unsafe -import Z.Data.PrimRef.PrimIORef +import Z.Data.PrimRef import Z.IO.Exception import Z.IO.UV.FFI_Env (uv_hrtime) -- queueSize :: Int +{-# INLINABLE queueSize #-} queueSize = 128 -- | A simple timing wheel @@ -72,6 +73,7 @@ -- running lock newLowResTimerManager :: IO LowResTimerManager +{-# INLINABLE newLowResTimerManager #-} newLowResTimerManager = do indexLock <- newMVar 0 regCounter <- newCounter 0 @@ -100,6 +102,7 @@ -- This is not a must though, when we fetch timer manager we always take a modulo. -- lowResTimerManagerCapabilitiesChanged :: IO () +{-# INLINABLE lowResTimerManagerCapabilitiesChanged #-} lowResTimerManagerCapabilitiesChanged = do lrtmArray <- readIORef lowResTimerManager let oldSize = sizeofArr lrtmArray @@ -193,7 +196,7 @@ -- queryLowResTimer :: LowResTimer -> IO Int {-# INLINABLE queryLowResTimer #-} -queryLowResTimer (LowResTimer c) = readPrimIORef c +queryLowResTimer (LowResTimer c) = readPrimRef c -- | Cancel a timer, return the remaining ticks. -- @@ -280,9 +283,10 @@ -- | Start low resolution timer loop, the loop is automatically stopped if there's no more new registrations. -- startLowResTimerManager :: LowResTimerManager -> Word64 -> IO () +{-# INLINABLE startLowResTimerManager #-} startLowResTimerManager lrtm@(LowResTimerManager _ _ regCounter runningLock) !stdT = do modifyMVar_ runningLock $ \ _ -> do -- we shouldn't receive async exception here - c <- readPrimIORef regCounter -- unless something terribly wrong happened, e.g., stackoverflow + c <- readPrimRef regCounter -- unless something terribly wrong happened, e.g., stackoverflow if c > 0 then do t <- uv_hrtime @@ -311,6 +315,7 @@ -- | Scan the timeout queue in current tick index, and move tick index forward by one. -- fireLowResTimerQueue :: LowResTimerManager -> IO () +{-# INLINABLE fireLowResTimerQueue #-} fireLowResTimerQueue (LowResTimerManager queue indexLock regCounter _) = do (tList, tListRef) <- modifyMVar indexLock $ \ index -> do -- get the index lock tListRef <- indexArrM queue index diff --git a/Z/IO/Network/DNS.hsc b/Z/IO/Network/DNS.hsc --- a/Z/IO/Network/DNS.hsc +++ b/Z/IO/Network/DNS.hsc @@ -118,6 +118,7 @@ -- | Indicate whether the given 'AddrInfoFlag' will have any effect on this system. addrInfoFlagImplemented :: AddrInfoFlag -> Bool +{-# INLINABLE addrInfoFlagImplemented #-} addrInfoFlagImplemented f = packBits addrInfoFlagMapping [f] /= 0 -- | Address info @@ -133,9 +134,12 @@ instance Storable AddrInfo where + {-# INLINABLE sizeOf #-} sizeOf _ = #const sizeof(struct addrinfo) + {-# INLINABLE alignment #-} alignment _ = alignment (0 :: CInt) + {-# INLINABLE peek #-} peek p = do ai_flags <- (#peek struct addrinfo, ai_flags) p ai_family <- (#peek struct addrinfo, ai_family) p @@ -154,6 +158,7 @@ , addrCanonName = ai_canonname } + {-# INLINABLE poke #-} poke p (AddrInfo flags family sockType protocol _ _) = do (#poke struct addrinfo, ai_flags) p (packBits addrInfoFlagMapping flags) (#poke struct addrinfo, ai_family) p family @@ -190,7 +195,7 @@ deriving (Eq, Read, Show) nameInfoFlagMapping :: [(NameInfoFlag, CInt)] - +{-# INLINABLE nameInfoFlagMapping #-} nameInfoFlagMapping = [(NI_DGRAM, #const NI_DGRAM), (NI_NAMEREQD, #const NI_NAMEREQD), (NI_NOFQDN, #const NI_NOFQDN), @@ -209,6 +214,7 @@ -- 0 defaultHints :: AddrInfo +{-# INLINABLE defaultHints #-} defaultHints = AddrInfo { addrFlags = [] , addrFamily = AF_UNSPEC @@ -263,6 +269,7 @@ -> HostName -- ^ host name to look up -> ServiceName -- ^ service name to look up -> IO [AddrInfo] -- ^ resolved addresses, with "best" first +{-# INLINABLE getAddrInfo #-} getAddrInfo hints host service = withUVInitDo $ bracket (do withCBytes host $ \ ptr_h -> @@ -286,6 +293,7 @@ -- | Peek @addrinfo@ linked list. -- followAddrInfo :: Ptr AddrInfo -> IO [AddrInfo] +{-# INLINABLE followAddrInfo #-} followAddrInfo ptr_ai | ptr_ai == nullPtr = return [] | otherwise = do @@ -318,6 +326,7 @@ -> Bool -- ^ whether to look up a service name -> SocketAddr -- ^ the address to look up -> IO (HostName, ServiceName) +{-# INLINABLE getNameInfo #-} getNameInfo flags doHost doService addr = withUVInitDo $ do (host, (service, _)) <- allocCBytes (fromIntegral h_len) $ \ ptr_h -> allocCBytes (fromIntegral s_len) $ \ ptr_s -> @@ -338,7 +347,7 @@ -- break if this property is not true. -- packBits :: (Eq a, Num b, Bits b) => [(a, b)] -> [a] -> b -{-# INLINE packBits #-} +{-# INLINABLE packBits #-} packBits mapping xs = List.foldl' go 0 mapping where go acc (k, v) | k `elem` xs = acc .|. v @@ -346,7 +355,7 @@ -- | Unpack a bitmask into a list of values. unpackBits :: (Num b, Bits b) => [(a, b)] -> b -> [a] -{-# INLINE unpackBits #-} +{-# INLINABLE unpackBits #-} -- Be permissive and ignore unknown bit values. At least on OS X, -- getaddrinfo returns an ai_flags field with bits set that have no -- entry in . diff --git a/Z/IO/Network/IPC.hs b/Z/IO/Network/IPC.hs --- a/Z/IO/Network/IPC.hs +++ b/Z/IO/Network/IPC.hs @@ -59,11 +59,13 @@ -- | Default config, connect to ".\/ipc". -- defaultIPCClientConfig :: IPCClientConfig +{-# INLINABLE defaultIPCClientConfig #-} defaultIPCClientConfig = IPCClientConfig Nothing "./ipc" -- | init a IPC client 'Resource', which open a new connect when used. -- initIPCClient :: IPCClientConfig -> Resource UVStream +{-# INLINABLE initIPCClient #-} initIPCClient (IPCClientConfig cname tname) = do uvm <- liftIO getUVManager client <- initIPCStream uvm @@ -92,6 +94,7 @@ -- Test it with @main = startIPCServer defaultIPCServerConfig@ -- defaultIPCServerConfig :: IPCServerConfig +{-# INLINABLE defaultIPCServerConfig #-} defaultIPCServerConfig = IPCServerConfig "./ipc" 256 @@ -106,6 +109,7 @@ -- run in a seperated haskell thread, -- will be closed upon exception or worker finishes. -> IO () +{-# INLINABLE startIPCServer #-} startIPCServer IPCServerConfig{..} = startServerLoop (max ipcListenBacklog 128) initIPCStream @@ -122,5 +126,6 @@ -------------------------------------------------------------------------------- initIPCStream :: HasCallStack => UVManager -> Resource UVStream +{-# INLINABLE initIPCStream #-} initIPCStream = initUVStream (\ loop hdl -> throwUVIfMinus_ (uv_pipe_init loop hdl 0)) diff --git a/Z/IO/Network/SocketAddr.hsc b/Z/IO/Network/SocketAddr.hsc --- a/Z/IO/Network/SocketAddr.hsc +++ b/Z/IO/Network/SocketAddr.hsc @@ -205,6 +205,7 @@ T.toUTF8Builder port sockAddrFamily :: SocketAddr -> SocketFamily +{-# INLINABLE sockAddrFamily #-} sockAddrFamily (SocketAddrIPv4 _ _) = AF_INET sockAddrFamily (SocketAddrIPv6 _ _ _ _) = AF_INET6 @@ -215,6 +216,7 @@ -- -- This is partial function, wrong address will throw 'InvalidArgument' exception. ipv4:: HasCallStack => CBytes -> PortNumber -> SocketAddr +{-# INLINABLE ipv4 #-} ipv4 str (PortNumber port) = unsafeDupablePerformIO . withSocketAddrStorageUnsafe $ \ p -> withCBytesUnsafe str $ \ cstr -> throwUVIfMinus_ $ uv_ip4_addr cstr (fromIntegral port) p @@ -222,6 +224,7 @@ -- -- This is partial function, wrong address will throw 'InvalidArgument' exception. ipv6:: HasCallStack => CBytes -> PortNumber -> SocketAddr +{-# INLINABLE ipv6 #-} ipv6 str (PortNumber port) = unsafeDupablePerformIO . withSocketAddrStorageUnsafe $ \ p -> withCBytesUnsafe str $ \ cstr -> throwUVIfMinus_ $ uv_ip6_addr cstr (fromIntegral port) p @@ -257,54 +260,71 @@ -- | @0.0.0.0@ ipv4Any :: IPv4 +{-# INLINABLE ipv4Any #-} ipv4Any = IPv4 0 -- | @255.255.255.255@ ipv4Broadcast :: IPv4 +{-# INLINABLE ipv4Broadcast #-} ipv4Broadcast = tupleToIPv4Addr (255,255,255,255) -- | @255.255.255.255@ ipv4None :: IPv4 +{-# INLINABLE ipv4None #-} ipv4None = tupleToIPv4Addr (255,255,255,255) -- | @127.0.0.1@ ipv4Loopback :: IPv4 +{-# INLINABLE ipv4Loopback #-} ipv4Loopback = tupleToIPv4Addr (127, 0, 0, 1) -- | @224.0.0.0@ ipv4UnspecificGroup :: IPv4 +{-# INLINABLE ipv4UnspecificGroup #-} ipv4UnspecificGroup = tupleToIPv4Addr (224, 0, 0, 0) -- | @224.0.0.1@ ipv4AllHostsGroup :: IPv4 +{-# INLINABLE ipv4AllHostsGroup #-} ipv4AllHostsGroup = tupleToIPv4Addr (224, 0, 0, 1) -- | @224.0.0.255@ ipv4MaxLocalGroup :: IPv4 +{-# INLINABLE ipv4MaxLocalGroup #-} ipv4MaxLocalGroup = tupleToIPv4Addr (224, 0, 0,255) instance Storable IPv4 where + {-# INLINABLE sizeOf #-} sizeOf _ = 4 + {-# INLINABLE alignment #-} alignment _ = alignment (undefined :: Word32) + {-# INLINABLE peek #-} peek p = (IPv4 . ntohl) `fmap` peekByteOff p 0 + {-# INLINABLE poke #-} poke p (IPv4 ia) = pokeByteOff p 0 (htonl ia) instance Unaligned IPv4 where + {-# INLINABLE unalignedSize #-} unalignedSize = 4 + {-# INLINABLE pokeMBA #-} pokeMBA p off x = pokeMBA p off (htonl (getIPv4Addr x)) + {-# INLINABLE peekMBA #-} peekMBA p off = IPv4 . ntohl <$> peekMBA p off + {-# INLINABLE indexBA #-} indexBA p off = IPv4 (ntohl (indexBA p off)) -- | Converts 'IPv4' to representation-independent IPv4 quadruple. -- For example for @127.0.0.1@ the function will return @(127, 0, 0, 1)@ -- regardless of host endianness. ipv4AddrToTuple :: IPv4 -> (Word8, Word8, Word8, Word8) +{-# INLINE ipv4AddrToTuple #-} ipv4AddrToTuple (IPv4 ia) = let byte i = fromIntegral (ia `shiftR` i) :: Word8 in (byte 24, byte 16, byte 8, byte 0) -- | Converts IPv4 quadruple to 'IPv4'. tupleToIPv4Addr :: (Word8, Word8, Word8, Word8) -> IPv4 +{-# INLINE tupleToIPv4Addr #-} tupleToIPv4Addr (b3, b2, b1, b0) = let x `sl` i = fromIntegral x `shiftL` i :: Word32 in IPv4 $ (b3 `sl` 24) .|. (b2 `sl` 16) .|. (b1 `sl` 8) .|. (b0 `sl` 0) @@ -336,6 +356,7 @@ instance Show IPv6 where show = T.toString instance Print IPv6 where + {-# INLINABLE toUTF8BuilderP #-} toUTF8BuilderP _ ia6@(IPv6 a1 a2 a3 a4) -- IPv4-Mapped IPv6 Address | a1 == 0 && a2 == 0 && a3 == 0xffff = @@ -361,15 +382,18 @@ -- | @::@ ipv6Any :: IPv6 +{-# INLINABLE ipv6Any #-} ipv6Any = IPv6 0 0 0 0 -- | @::1@ ipv6Loopback :: IPv6 +{-# INLINABLE ipv6Loopback #-} ipv6Loopback = IPv6 0 0 0 1 -- | convert 'IPv6' to octets. ipv6AddrToTuple :: IPv6 -> (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16) +{-# INLINABLE ipv6AddrToTuple #-} ipv6AddrToTuple (IPv6 w3 w2 w1 w0) = let high, low :: Word32 -> Word16 high w = fromIntegral (w `shiftR` 16) @@ -379,20 +403,25 @@ -- | convert 'IPv6' from octets. tupleToIPv6Addr :: (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16) -> IPv6 +{-# INLINABLE tupleToIPv6Addr #-} tupleToIPv6Addr (w7, w6, w5, w4, w3, w2, w1, w0) = let add :: Word16 -> Word16 -> Word32 high `add` low = (fromIntegral high `shiftL` 16) .|. (fromIntegral low) in IPv6 (w7 `add` w6) (w5 `add` w4) (w3 `add` w2) (w1 `add` w0) instance Storable IPv6 where + {-# INLINABLE sizeOf #-} sizeOf _ = #size struct in6_addr + {-# INLINABLE alignment #-} alignment _ = #alignment struct in6_addr + {-# INLINABLE peek #-} peek p = do a <- peek32 p 0 b <- peek32 p 1 c <- peek32 p 2 d <- peek32 p 3 return $ IPv6 a b c d + {-# INLINABLE poke #-} poke p (IPv6 a b c d) = do poke32 p 0 a poke32 p 1 b @@ -401,9 +430,11 @@ s6_addr_offset :: Int +{-# INLINABLE s6_addr_offset #-} s6_addr_offset = (#offset struct in6_addr, s6_addr) peek32 :: Ptr a -> Int -> IO Word32 +{-# INLINABLE peek32 #-} peek32 p i0 = do let i' = i0 * 4 peekByte n = peekByteOff p (s6_addr_offset + i' + n) :: IO Word8 @@ -415,6 +446,7 @@ return ((a0 `sl` 24) .|. (a1 `sl` 16) .|. (a2 `sl` 8) .|. (a3 `sl` 0)) poke32 :: Ptr a -> Int -> Word32 -> IO () +{-# INLINABLE poke32 #-} poke32 p i0 a = do let i' = i0 * 4 pokeByte n = pokeByteOff p (s6_addr_offset + i' + n) @@ -425,22 +457,23 @@ pokeByte 3 (a `sr` 0) instance Unaligned IPv6 where + {-# INLINABLE unalignedSize #-} unalignedSize = (#size struct in6_addr) - + {-# INLINABLE indexBA #-} indexBA p off = let a = indexBA p (off + s6_addr_offset + 0) b = indexBA p (off + s6_addr_offset + 4) c = indexBA p (off + s6_addr_offset + 8) d = indexBA p (off + s6_addr_offset + 12) in IPv6 (getBE a) (getBE b) (getBE c) (getBE d) - + {-# INLINABLE peekMBA #-} peekMBA p off = do a <- peekMBA p (off + s6_addr_offset + 0) b <- peekMBA p (off + s6_addr_offset + 4) c <- peekMBA p (off + s6_addr_offset + 8) d <- peekMBA p (off + s6_addr_offset + 12) return $ IPv6 (getBE a) (getBE b) (getBE c) (getBE d) - + {-# INLINABLE pokeMBA #-} pokeMBA p off (IPv6 a b c d) = do pokeMBA p (off + s6_addr_offset) (BE a) pokeMBA p (off + 4 + s6_addr_offset) (BE b) @@ -450,6 +483,7 @@ -------------------------------------------------------------------------------- peekSocketAddr :: HasCallStack => Ptr SocketAddr -> IO SocketAddr +{-# INLINABLE peekSocketAddr #-} peekSocketAddr p = do family <- (#peek struct sockaddr, sa_family) p case family :: CSaFamily of @@ -469,6 +503,7 @@ throwUVError errno (IOEInfo name desc callStack) pokeSocketAddr :: Ptr SocketAddr -> SocketAddr -> IO () +{-# INLINABLE pokeSocketAddr #-} pokeSocketAddr p (SocketAddrIPv4 addr port) = do #if defined(darwin_HOST_OS) clearPtr p (#size struct sockaddr_in) @@ -496,6 +531,7 @@ -- | Pass 'SocketAddr' to FFI as pointer. -- withSocketAddr :: SocketAddr -> (Ptr SocketAddr -> IO a) -> IO a +{-# INLINABLE withSocketAddr #-} withSocketAddr sa@(SocketAddrIPv4 _ _) f = do allocaBytesAligned (#size struct sockaddr_in) @@ -510,6 +546,7 @@ -- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY. -- withSocketAddrUnsafe :: SocketAddr -> (MBA## SocketAddr -> IO a) -> IO a +{-# INLINABLE withSocketAddrUnsafe #-} withSocketAddrUnsafe sa@(SocketAddrIPv4 _ _) f = do (MutableByteArray p) <- newByteArray (#size struct sockaddr_in) pokeSocketAddrMBA p sa @@ -520,11 +557,13 @@ f p sizeOfSocketAddr :: SocketAddr -> CSize +{-# INLINABLE sizeOfSocketAddr #-} sizeOfSocketAddr (SocketAddrIPv4 _ _) = #size struct sockaddr_in sizeOfSocketAddr (SocketAddrIPv6 _ _ _ _) = #size struct sockaddr_in6 -- | Allocate space for 'sockaddr_storage' and pass to FFI. withSocketAddrStorage :: (Ptr SocketAddr -> IO ()) -> IO SocketAddr +{-# INLINABLE withSocketAddrStorage #-} withSocketAddrStorage f = do allocaBytesAligned (#size struct sockaddr_storage) @@ -535,15 +574,18 @@ -- USE THIS FUNCTION WITH UNSAFE FFI CALL ONLY. -- withSocketAddrStorageUnsafe :: (MBA## SocketAddr -> IO ()) -> IO SocketAddr +{-# INLINABLE withSocketAddrStorageUnsafe #-} withSocketAddrStorageUnsafe f = do (MutableByteArray p) <- newByteArray (#size struct sockaddr_storage) f p peekSocketAddrMBA p sizeOfSocketAddrStorage :: CSize +{-# INLINABLE sizeOfSocketAddrStorage #-} sizeOfSocketAddrStorage = (#size struct sockaddr_storage) peekSocketAddrMBA :: HasCallStack => MBA## SocketAddr -> IO SocketAddr +{-# INLINABLE peekSocketAddrMBA #-} peekSocketAddrMBA p = do family <- peekMBA p (#offset struct sockaddr, sa_family) case family :: CSaFamily of @@ -563,6 +605,7 @@ throwUVError errno (IOEInfo name desc callStack) pokeSocketAddrMBA :: MBA## SocketAddr -> SocketAddr -> IO () +{-# INLINABLE pokeSocketAddrMBA #-} pokeSocketAddrMBA p (SocketAddrIPv4 addr port) = do #if defined(darwin_HOST_OS) clearMBA p (#size struct sockaddr_in) @@ -602,6 +645,7 @@ instance Show Interface where show = T.toString peekInterface :: HasCallStack => Ptr Interface -> IO Interface +{-# INLINABLE peekInterface #-} peekInterface p = do name' <- fromCString =<< (#peek struct uv_interface_address_s, name) p phy <- fromPtr (p `plusPtr` (#offset struct uv_interface_address_s, phys_addr)) 6 @@ -649,6 +693,7 @@ -- | Gets address information about the network interfaces on the system. getInterface :: IO [Interface] +{-# INLINABLE getInterface #-} getInterface = bracket (allocPrimUnsafe @(Ptr Interface) $ \ ppiface -> fst <$> allocPrimUnsafe @CInt (uv_interface_addresses ppiface)) @@ -681,37 +726,52 @@ -- | @:0@ portAny :: PortNumber +{-# INLINABLE portAny #-} portAny = PortNumber 0 defaultPortNumberHTTP :: PortNumber +{-# INLINABLE defaultPortNumberHTTP #-} defaultPortNumberHTTP = 80 defaultPortNumberHTTPS :: PortNumber +{-# INLINABLE defaultPortNumberHTTPS #-} defaultPortNumberHTTPS = 443 defaultPortNumberSMTP :: PortNumber +{-# INLINABLE defaultPortNumberSMTP #-} defaultPortNumberSMTP = 25 defaultPortNumberPOP3 :: PortNumber +{-# INLINABLE defaultPortNumberPOP3 #-} defaultPortNumberPOP3 = 110 defaultPortNumberIMAP :: PortNumber +{-# INLINABLE defaultPortNumberIMAP #-} defaultPortNumberIMAP = 143 defaultPortNumberIRC :: PortNumber +{-# INLINABLE defaultPortNumberIRC #-} defaultPortNumberIRC = 194 instance Storable PortNumber where - sizeOf _ = sizeOf (0 :: Word16) - alignment _ = alignment (0 :: Word16) - poke p (PortNumber po) = poke (castPtr p) (htons po) - peek p = PortNumber . ntohs <$> peek (castPtr p) + {-# INLINABLE sizeOf #-} + sizeOf _ = sizeOf (0 :: Word16) + {-# INLINABLE alignment #-} + alignment _ = alignment (0 :: Word16) + {-# INLINABLE poke #-} + poke p (PortNumber po) = poke (castPtr p) (htons po) + {-# INLINABLE peek #-} + peek p = PortNumber . ntohs <$> peek (castPtr p) instance Unaligned PortNumber where - unalignedSize = 2 - indexBA p off = PortNumber . ntohs $ indexBA p off - pokeMBA p off (PortNumber po) = pokeMBA p off (htons po) - peekMBA p off = PortNumber . ntohs <$> peekMBA p off + {-# INLINABLE unalignedSize #-} + unalignedSize = 2 + {-# INLINABLE indexBA #-} + indexBA p off = PortNumber . ntohs $ indexBA p off + {-# INLINABLE pokeMBA #-} + pokeMBA p off (PortNumber po) = pokeMBA p off (htons po) + {-# INLINABLE peekMBA #-} + peekMBA p off = PortNumber . ntohs <$> peekMBA p off -------------------------------------------------------------------------------- diff --git a/Z/IO/Network/TCP.hs b/Z/IO/Network/TCP.hs --- a/Z/IO/Network/TCP.hs +++ b/Z/IO/Network/TCP.hs @@ -64,11 +64,13 @@ -- | Default config, connect to @localhost:8888@. -- defaultTCPClientConfig :: TCPClientConfig +{-# INLINABLE defaultTCPClientConfig #-} defaultTCPClientConfig = TCPClientConfig Nothing (SocketAddrIPv4 ipv4Loopback 8888) True 30 -- | init a TCP client 'Resource', which open a new connect when used. -- initTCPClient :: HasCallStack => TCPClientConfig -> Resource UVStream +{-# INLINABLE initTCPClient #-} initTCPClient TCPClientConfig{..} = do uvm <- liftIO getUVManager client <- initTCPStream uvm @@ -104,6 +106,7 @@ -- @main = startTCPServer defaultTCPServerConfig echoWorker@, now try @nc -v 127.0.0.1 8888@ -- defaultTCPServerConfig :: TCPServerConfig +{-# INLINABLE defaultTCPServerConfig #-} defaultTCPServerConfig = TCPServerConfig (SocketAddrIPv4 ipv4Any 8888) 256 @@ -120,6 +123,7 @@ -- run in a seperated haskell thread, -- will be closed upon exception or worker finishes. -> IO () +{-# INLINABLE startTCPServer #-} startTCPServer TCPServerConfig{..} = startServerLoop (max tcpListenBacklog 128) initTCPStream @@ -224,10 +228,12 @@ -------------------------------------------------------------------------------- initTCPStream :: UVManager -> Resource UVStream +{-# INLINABLE initTCPStream #-} initTCPStream = initUVStream (\ loop hdl -> throwUVIfMinus_ (uv_tcp_init loop hdl)) -- | Enable or disable @TCP_NODELAY@, which enable or disable Nagle’s algorithm. setTCPNoDelay :: HasCallStack => UVStream -> Bool -> IO () +{-# INLINABLE setTCPNoDelay #-} setTCPNoDelay uvs nodelay = throwUVIfMinus_ (uv_tcp_nodelay (uvsHandle uvs) (if nodelay then 1 else 0)) @@ -237,12 +243,14 @@ -- will still happen. If the connection is still lost at the end of this procedure, -- then the connection is closed, pending io thread will throw 'TimeExpired' exception. setTCPKeepAlive :: HasCallStack => UVStream -> CUInt -> IO () +{-# INLINABLE setTCPKeepAlive #-} setTCPKeepAlive uvs delay | delay > 0 = throwUVIfMinus_ (uv_tcp_keepalive (uvsHandle uvs) 1 delay) | otherwise = throwUVIfMinus_ (uv_tcp_keepalive (uvsHandle uvs) 0 0) -- | Get the current address to which the handle is bound. getTCPSockName :: HasCallStack => UVStream -> IO SocketAddr +{-# INLINABLE getTCPSockName #-} getTCPSockName uvs = do withSocketAddrStorageUnsafe $ \ paddr -> void $ withPrimUnsafe (fromIntegral sizeOfSocketAddrStorage :: CInt) $ \ plen -> @@ -250,6 +258,7 @@ -- | Get the address of the peer connected to the handle. getTCPPeerName :: HasCallStack => UVStream -> IO SocketAddr +{-# INLINABLE getTCPPeerName #-} getTCPPeerName uvs = do withSocketAddrStorageUnsafe $ \ paddr -> void $ withPrimUnsafe (fromIntegral sizeOfSocketAddrStorage :: CInt) $ \ plen -> diff --git a/Z/IO/Network/UDP.hs b/Z/IO/Network/UDP.hs --- a/Z/IO/Network/UDP.hs +++ b/Z/IO/Network/UDP.hs @@ -59,7 +59,7 @@ import Control.Concurrent import Control.Monad -import Data.Primitive.PrimArray as A +import qualified Data.Primitive.PrimArray as A import Data.IORef import Data.Word import Data.Int @@ -68,12 +68,11 @@ import Foreign.Ptr (plusPtr) import Foreign.C import GHC.Generics -import Z.Data.Array as A -import Z.Data.Vector.Base as V -import Z.Data.Vector.Extra as V -import Z.Data.CBytes as CBytes -import qualified Z.Data.Text.Print as T -import Z.Data.JSON (JSON) +import Z.Data.CBytes +import qualified Z.Data.Vector.Base as V +import qualified Z.Data.Vector.Extra as V +import qualified Z.Data.Text.Print as T +import Z.Data.JSON (JSON) import Z.IO.Network.SocketAddr import Z.Foreign import Z.IO.UV.FFI @@ -97,6 +96,7 @@ instance Show UDP where show = T.toString instance T.Print UDP where + {-# INLINABLE toUTF8BuilderP #-} toUTF8BuilderP _ (UDP hdl slot uvm _ _) = do "UDP{udpHandle=" >> T.toUTF8Builder hdl ",udpSlot=" >> T.toUTF8Builder slot @@ -117,11 +117,13 @@ -- | @UDPConfig 512 Nothing@ defaultUDPConfig :: UDPConfig +{-# INLINABLE defaultUDPConfig #-} defaultUDPConfig = UDPConfig 512 Nothing -- | Initialize a UDP socket. -- initUDP :: UDPConfig -> Resource UDP +{-# INLINABLE initUDP #-} initUDP (UDPConfig sbsiz maddr) = initResource (do uvm <- getUVManager (hdl, slot) <- withUVManager uvm $ \ loop -> do @@ -146,12 +148,14 @@ unless c $ writeIORef closed True >> hs_uv_handle_close hdl) checkUDPClosed :: HasCallStack => UDP -> IO () +{-# INLINABLE checkUDPClosed #-} checkUDPClosed udp = do c <- readIORef (udpClosed udp) when c throwECLOSED -- | Get the local IP and port of the 'UDP'. getSockName :: HasCallStack => UDP -> IO SocketAddr +{-# INLINABLE getSockName #-} getSockName udp@(UDP hdl _ _ _ _) = do checkUDPClosed udp withSocketAddrStorageUnsafe $ \ paddr -> @@ -172,6 +176,7 @@ -- | Associate the UDP handle to a remote address and port, -- so every message sent by this handle is automatically sent to that destination connectUDP :: HasCallStack => UDP -> SocketAddr -> IO ConnectedUDP +{-# INLINABLE connectUDP #-} connectUDP udp@(UDP hdl _ _ _ _) addr = do checkUDPClosed udp withSocketAddrUnsafe addr $ \ paddr -> @@ -180,6 +185,7 @@ -- | Disconnect the UDP handle from a remote address and port. disconnectUDP :: HasCallStack => ConnectedUDP -> IO UDP +{-# INLINABLE disconnectUDP #-} disconnectUDP (ConnectedUDP udp@(UDP hdl _ _ _ _)) = do checkUDPClosed udp throwUVIfMinus_ (uv_udp_disconnect hdl nullPtr) @@ -187,6 +193,7 @@ -- | Get the remote IP and port on 'ConnectedUDP'. getPeerName :: HasCallStack => ConnectedUDP -> IO SocketAddr +{-# INLINABLE getPeerName #-} getPeerName (ConnectedUDP udp@(UDP hdl _ _ _ _)) = do checkUDPClosed udp withSocketAddrStorageUnsafe $ \ paddr -> @@ -198,6 +205,7 @@ -- WARNING: A 'InvalidArgument' with errno 'UV_EMSGSIZE' will be thrown -- if message is larger than 'sendMsgSize'. sendConnectedUDP :: HasCallStack => ConnectedUDP -> V.Bytes -> IO () +{-# INLINABLE sendConnectedUDP #-} sendConnectedUDP (ConnectedUDP udp@(UDP hdl _ uvm sbuf _)) (V.PrimVector ba s la) = mask_ $ do checkUDPClosed udp -- copy message to pinned buffer @@ -224,6 +232,7 @@ -- WARNING: A 'InvalidArgument' with errno 'UV_EMSGSIZE' will be thrown -- if message is larger than 'sendMsgSize'. sendUDP :: HasCallStack => UDP -> SocketAddr -> V.Bytes -> IO () +{-# INLINABLE sendUDP #-} sendUDP udp@(UDP hdl _ uvm sbuf _) addr (V.PrimVector ba s la) = mask_ $ do checkUDPClosed udp -- copy message to pinned buffer @@ -248,12 +257,14 @@ -- | Set IP multicast loop flag. Makes multicast packets loop back to local sockets. setMulticastLoop :: HasCallStack => UDP -> Bool -> IO () +{-# INLINABLE setMulticastLoop #-} setMulticastLoop udp@(UDP hdl _ _ _ _) loop = do checkUDPClosed udp throwUVIfMinus_ (uv_udp_set_multicast_loop hdl (if loop then 1 else 0)) -- | Set the multicast ttl. setMulticastTTL :: HasCallStack => UDP -> Int -> IO () +{-# INLINABLE setMulticastTTL #-} setMulticastTTL udp@(UDP hdl _ _ _ _) ttl = do checkUDPClosed udp throwUVIfMinus_ (uv_udp_set_multicast_ttl hdl (fromIntegral ttl')) @@ -261,6 +272,7 @@ -- | Set the multicast interface to send or receive data on. setMulticastInterface :: HasCallStack => UDP -> CBytes ->IO () +{-# INLINABLE setMulticastInterface #-} setMulticastInterface udp@(UDP hdl _ _ _ _) iaddr = do checkUDPClosed udp withCBytesUnsafe iaddr $ \ iaddrp -> @@ -268,6 +280,7 @@ -- | Set broadcast on or off. setBroadcast :: HasCallStack => UDP -> Bool -> IO () +{-# INLINABLE setBroadcast #-} setBroadcast udp@(UDP hdl _ _ _ _) b = do checkUDPClosed udp throwUVIfMinus_ (uv_udp_set_broadcast hdl (if b then 1 else 0)) @@ -277,6 +290,7 @@ => UDP -> Int -- ^ 1 ~ 255 -> IO () +{-# INLINABLE setTTL #-} setTTL udp@(UDP hdl _ _ _ _) ttl = do checkUDPClosed udp throwUVIfMinus_ (uv_udp_set_ttl hdl (fromIntegral ttl)) @@ -288,6 +302,7 @@ -> CBytes -- ^ Interface address. -> Membership -- ^ UV_JOIN_GROUP | UV_LEAVE_GROUP -> IO () +{-# INLINABLE setMembership #-} setMembership udp@(UDP hdl _ _ _ _) gaddr iaddr member = do checkUDPClosed udp withCBytesUnsafe gaddr $ \ gaddrp -> @@ -302,6 +317,7 @@ -> CBytes -- ^ Source address. -> Membership -- ^ UV_JOIN_GROUP | UV_LEAVE_GROUP -> IO () +{-# INLINABLE setSourceMembership #-} setSourceMembership udp@(UDP hdl _ _ _ _) gaddr iaddr source member = do checkUDPClosed udp withCBytesUnsafe gaddr $ \ gaddrp -> @@ -324,6 +340,7 @@ -- | @UDPRecvConfig 512 6@ defaultUDPRecvConfig :: UDPRecvConfig +{-# INLINABLE defaultUDPRecvConfig #-} defaultUDPRecvConfig = UDPRecvConfig 512 6 @@ -355,6 +372,7 @@ -- Then we poke those cells out. -- newRecvBuf :: Int32 -> Int -> IO (A.MutablePrimArray RealWorld Word8, A.MutablePrimArray RealWorld (Ptr Word8)) +{-# INLINABLE newRecvBuf #-} newRecvBuf bufSiz bufArrSiz = do rbuf <- A.newPinnedPrimArray (fromIntegral bufsiz' * bufArrSiz') rbufArr <- A.newPinnedPrimArray bufArrSiz' @@ -383,6 +401,7 @@ -> UDP -> ((Maybe SocketAddr, Bool, V.Bytes) -> IO a) -> IO () +{-# INLINABLE recvUDPLoop #-} recvUDPLoop (UDPRecvConfig bufSiz bufArrSiz) udp@(UDP hdl slot uvm _ _) worker = do bracket (do check <- throwOOMIfNull $ hs_uv_check_alloc @@ -404,6 +423,7 @@ -- to indicate if the message is partial (larger than receive buffer size). -- recvUDP :: HasCallStack => UDPRecvConfig -> UDP -> IO [(Maybe SocketAddr, Bool, V.Bytes)] +{-# INLINABLE recvUDP #-} recvUDP (UDPRecvConfig bufSiz bufArrSiz) udp@(UDP hdl slot uvm _ _) = do bracket (do check <- throwOOMIfNull $ hs_uv_check_alloc @@ -423,6 +443,7 @@ -> (A.MutablePrimArray RealWorld Word8, A.MutablePrimArray RealWorld (Ptr Word8)) -> Int32 -> IO [(Maybe SocketAddr, Bool, V.Bytes)] +{-# INLINABLE recvUDPWith #-} recvUDPWith udp@(UDP hdl slot uvm _ _) (rubf, rbufArr) bufSiz = -- It's important to keep recv buffer alive, even if we don't directly use it mask_ . withMutablePrimArrayContents rubf $ \ _ -> do diff --git a/Z/IO/Process.hsc b/Z/IO/Process.hsc --- a/Z/IO/Process.hsc +++ b/Z/IO/Process.hsc @@ -70,7 +70,7 @@ import Z.Data.CBytes import Z.Data.CBytes as CBytes import Z.Data.JSON (JSON) -import Z.Data.Vector as V +import qualified Z.Data.Vector as V import qualified Z.Data.Text as T import qualified Data.List as List import Z.Data.Array.Unaligned @@ -88,6 +88,7 @@ -- | Default process options, start @".\/main"@ with no arguments, redirect all std streams to @\/dev\/null@. defaultProcessOptions :: ProcessOptions +{-# INLINABLE defaultProcessOptions #-} defaultProcessOptions = ProcessOptions { processFile = "./main" , processArgs = [] @@ -106,6 +107,7 @@ -- | Wait until process exit and return the 'ExitCode'. waitProcessExit :: TVar ProcessState -> IO ExitCode +{-# INLINABLE waitProcessExit #-} waitProcessExit svar = atomically $ do s <- readTVar svar case s of ProcessExited e -> return e @@ -113,6 +115,7 @@ -- | Get process 'PID' if process is running. getProcessPID :: TVar ProcessState -> IO (Maybe PID) +{-# INLINABLE getProcessPID #-} getProcessPID svar = atomically $ do s <- readTVar svar case s of ProcessRunning pid -> return (Just pid) @@ -120,6 +123,7 @@ -- | Send signals to process. killPID :: HasCallStack => PID -> Signal -> IO () +{-# INLINABLE killPID #-} killPID (PID pid) sig = throwUVIfMinus_ (uv_kill pid sig) pattern SIGTERM :: Signal @@ -151,6 +155,7 @@ -- waitProcessExit pstate -- wait for process exit on current thread. -- @ initProcess :: ProcessOptions -> Resource (Maybe UVStream, Maybe UVStream, Maybe UVStream, TVar ProcessState) +{-# INLINABLE initProcess #-} initProcess opt = initResource (spawn opt) $ \ (s0,s1,s2, pstate) -> do _ <- waitProcessExit pstate @@ -163,6 +168,7 @@ -- The same as 'initProcess', but the clean action will try to send 'SIGTERM' -- to the process first. initProcess' :: ProcessOptions -> Resource (Maybe UVStream, Maybe UVStream, Maybe UVStream, TVar ProcessState) +{-# INLINABLE initProcess' #-} initProcess' opt = initResource (spawn opt) $ \ (s0, s1, s2, pstate) -> do m_pid <- getProcessPID pstate @@ -179,6 +185,7 @@ => ProcessOptions -- ^ processStdStreams options are ignored -> V.Bytes -- ^ stdin -> IO (V.Bytes, V.Bytes, ExitCode) -- ^ stdout, stderr, exit code +{-# INLINABLE readProcess #-} readProcess opts inp = do withResource (initProcess opts{processStdStreams=(ProcessCreate, ProcessCreate, ProcessCreate)}) $ \ (Just s0, Just s1, Just s2, pstate) -> do @@ -202,6 +209,7 @@ => ProcessOptions -- ^ processStdStreams options are ignored -> T.Text -- ^ stdin -> IO (T.Text, T.Text, ExitCode) -- ^ stdout, stderr, exit code +{-# INLINABLE readProcessText #-} readProcessText opts inp = do (out, err, e) <- readProcess opts (T.getUTF8Bytes inp) return (T.validate out, T.validate err, e) @@ -210,6 +218,7 @@ -- -- Please manually close child process's std stream(if any) after process exits. spawn :: HasCallStack => ProcessOptions -> IO (Maybe UVStream, Maybe UVStream, Maybe UVStream, TVar ProcessState) +{-# INLINABLE spawn #-} spawn ProcessOptions{..} = do (MutableByteArray popts##) <- newByteArray (#size uv_process_options_t) @@ -296,6 +305,7 @@ -- The returned value of priority is between -20 (high priority) and 19 (low priority). -- On Windows, the returned priority will equal one of the PRIORITY constants. getPriority :: HasCallStack => PID -> IO Priority +{-# INLINABLE getPriority #-} getPriority pid = do (p, _) <- allocPrimUnsafe $ \ p_p -> throwUVIfMinus_ (uv_os_getpriority pid p_p) return p @@ -307,4 +317,5 @@ -- 'PRIORITY_ABOVE_NORMAL', 'PRIORITY_HIGH', and 'PRIORITY_HIGHEST' are also provided for convenience. -- setPriority :: HasCallStack => PID -> Priority -> IO () +{-# INLINABLE setPriority #-} setPriority pid p = throwUVIfMinus_ (uv_os_setpriority pid p) diff --git a/Z/IO/Resource.hs b/Z/IO/Resource.hs --- a/Z/IO/Resource.hs +++ b/Z/IO/Resource.hs @@ -39,7 +39,7 @@ import qualified Control.Monad.Catch as MonadCatch import Control.Monad.IO.Class import qualified Data.Map.Strict as M -import Z.Data.PrimRef.PrimIORef +import Z.Data.PrimRef import Z.Data.Array import qualified Z.Data.Vector as V import Data.IORef @@ -81,7 +81,7 @@ -- 'with' \/ 'with''. -- initResource :: IO a -> (a -> IO ()) -> Resource a -{-# INLINE initResource #-} +{-# INLINABLE initResource #-} initResource create release = Resource $ do r <- create return $ (r, release r) @@ -92,7 +92,7 @@ -- inside 'Resource' monad. -- initResource_ :: IO a -> IO () -> Resource a -{-# INLINE initResource_ #-} +{-# INLINABLE initResource_ #-} initResource_ create release = Resource $ do r <- create return $ (r, release) @@ -188,7 +188,8 @@ -- | Dump the status of pool. statPool :: Pool key res -> IO (SmallArray (M.Map key Int)) -statPool (Pool _ _ _ arr) = (`V.traverseVec` arr) $ \ resMapRef -> do +{-# INLINABLE statPool #-} +statPool (Pool _ _ _ arr) = (`V.traverse` arr) $ \ resMapRef -> do mResMap <- readIORef resMapRef case mResMap of Just resMap -> return $ (`fmap` resMap) ( \ es -> @@ -203,6 +204,7 @@ -> Int -- ^ maximum number of resources per local pool per key to be maintained. -> Int -- ^ amount of time after which an unused resource can be released (in seconds). -> Resource (Pool key res) +{-# INLINABLE initPool #-} initPool resf limit itime = initResource createPool closePool where createPool = do @@ -215,7 +217,7 @@ closePool (Pool _ _ _ localPoolArr) = do -- close all existed resource - (`V.traverseVec_` localPoolArr) $ \ resMapRef -> + (`V.traverse_` localPoolArr) $ \ resMapRef -> atomicModifyIORef resMapRef $ \ mResMap -> case mResMap of Just resMap -> (Nothing, mapM_ closeEntry resMap) @@ -231,6 +233,7 @@ -- resource will be closed(not return to pool). withPool :: (MonadCatch.MonadMask m, MonadIO m, Ord key, HasCallStack) => Pool key res -> key -> (res -> m a) -> m a +{-# INLINABLE withPool #-} withPool (Pool resf limitPerKey itime arr) key f = do !resMapRef <- indexArr arr . fst <$> liftIO (threadCapability =<< myThreadId) fst <$> MonadCatch.generalBracket @@ -300,10 +303,12 @@ -> Int -- ^ maximum number of resources per local pool to be maintained. -> Int -- ^ amount of time after which an unused resource can be released (in seconds). -> Resource (SimplePool res) +{-# INLINABLE initSimplePool #-} initSimplePool f = initPool (const f) -- | Open resource with 'SimplePool', see 'withPool' -- withSimplePool :: (MonadCatch.MonadMask m, MonadIO m, HasCallStack) => SimplePool res -> (res -> m a) -> m a +{-# INLINABLE withSimplePool #-} withSimplePool pool = withPool pool () diff --git a/Z/IO/StdStream.hs b/Z/IO/StdStream.hs --- a/Z/IO/StdStream.hs +++ b/Z/IO/StdStream.hs @@ -46,7 +46,7 @@ , stdin, stdout, stderr , stdinBuf, stdoutBuf, stderrBuf -- * utils - , readStd, printStd, putStd, printStdLn, putStdLn + , readStd, printStd, putStd, printStdLn, printStdLnP, putStdLn -- * re-export , withMVar -- * Constant @@ -57,10 +57,12 @@ ) where import Control.Monad +import Control.Monad.Primitive import Control.Concurrent.MVar import Foreign.Ptr import System.IO.Unsafe import qualified Z.Data.Builder as B +import qualified Z.Data.Parser.Base as P import qualified Z.Data.Text.Print as T import qualified Z.Data.Vector as V import Z.IO.UV.FFI @@ -252,13 +254,13 @@ -- | Get terminal's output window size in (width, height) format, -- return (-1, -1) if stdout is not connected to TTY. -getStdoutWinSize :: HasCallStack => IO (CInt, CInt) +getStdoutWinSize :: HasCallStack => IO (Int, Int) getStdoutWinSize = case stdout of StdStream True hdl _ uvm -> withUVManager' uvm $ do - (w, (h, ())) <- allocPrimUnsafe $ \ w -> - allocPrimUnsafe $ \ h -> throwUVIfMinus_ $ uv_tty_get_winsize hdl w h - return (w, h) + (w, (h, ())) <- allocPrimUnsafe @CInt $ \ w -> + allocPrimUnsafe @CInt $ \ h -> throwUVIfMinus_ $ uv_tty_get_winsize hdl w h + return (fromIntegral w, fromIntegral h) _ -> return (-1, -1) -------------------------------------------------------------------------------- @@ -276,6 +278,10 @@ -- | Print a 'Print' and flush to stdout, with a linefeed. printStdLn :: (HasCallStack, T.Print a) => a -> IO () printStdLn s = putStdLn (T.toUTF8Builder s) + +-- | Similar to 'printStdLn', 'P.Parser' debug tool. +printStdLnP :: (HasCallStack, T.Print a) => a -> P.Parser () +printStdLnP s = unsafeIOToPrim $ putStdLn (T.toUTF8Builder s) -- | Print a 'Builder' and flush to stdout, with a linefeed. putStdLn :: HasCallStack => B.Builder a -> IO () diff --git a/Z/IO/StdStream/Ansi.hs b/Z/IO/StdStream/Ansi.hs --- a/Z/IO/StdStream/Ansi.hs +++ b/Z/IO/StdStream/Ansi.hs @@ -6,14 +6,11 @@ Maintainer : winterland1989@gmail.com Stability : experimental Portability : non-portable - Provides utilities to build . - @ > putStd . bold . italicize . color Red $ "hello" hello -- bold, italicize and red @ - -} module Z.IO.StdStream.Ansi @@ -46,6 +43,7 @@ csi, sgr, colorToCode ) where +import Control.Monad import qualified Z.Data.Builder as B import qualified Z.Data.Parser as P import qualified Z.Data.Text as T @@ -58,6 +56,7 @@ csi :: [Int] -- ^ List of parameters for the control sequence -> B.Builder () -- ^ Character(s) that identify the control function -> B.Builder () +{-# INLINABLE csi #-} csi args code = do B.char8 '\ESC' B.char8 '[' @@ -69,31 +68,38 @@ -> B.Builder () cursorDownLine, cursorUpLine :: Int -- ^ Number of lines to move -> B.Builder () -cursorUp n = csi [n] (B.char8 'A') -cursorDown n = csi [n] (B.char8 'B') -cursorForward n = csi [n] (B.char8 'C') -cursorBackward n = csi [n] (B.char8 'D') -cursorDownLine n = csi [n] (B.char8 'E') -cursorUpLine n = csi [n] (B.char8 'F') +{-# INLINABLE cursorUp #-} +cursorUp n = when (n > 0) $ csi [n] (B.char8 'A') +{-# INLINABLE cursorDown #-} +cursorDown n = when (n > 0) $ csi [n] (B.char8 'B') +{-# INLINABLE cursorForward #-} +cursorForward n = when (n > 0) $ csi [n] (B.char8 'C') +{-# INLINABLE cursorBackward #-} +cursorBackward n = when (n > 0) $ csi [n] (B.char8 'D') +{-# INLINABLE cursorDownLine #-} +cursorDownLine n = when (n > 0) $ csi [n] (B.char8 'E') +{-# INLINABLE cursorUpLine #-} +cursorUpLine n = when (n > 0) $ csi [n] (B.char8 'F') -getCursorPosition :: IO (Int, Int) -getCursorPosition = do - withRawStdin . withMVar stdinBuf $ \ i -> do - clearInputBuffer i - putStd (csi [] "6n") - readParser (do - P.word8 ESC - P.word8 BRACKET_LEFT - !n <- P.int - P.word8 SEMICOLON - !m <- P.int - P.word8 LETTER_R - return (m, n)) i +getCursorPosition :: BufferedInput -> IO (Int, Int) +{-# INLINABLE getCursorPosition #-} +getCursorPosition i = do + clearInputBuffer i + putStd (csi [] "6n") + readParser (do + P.word8 ESC + P.word8 BRACKET_LEFT + !n <- P.int + P.word8 SEMICOLON + !m <- P.int + P.word8 LETTER_R + return (m, n)) i -- | Code to move the cursor to the specified column. The column numbering is -- 1-based (that is, the left-most column is numbered 1). setCursorColumn :: Int -- ^ 1-based column to move to -> B.Builder () +{-# INLINABLE setCursorColumn #-} setCursorColumn n = csi [n] (B.char8 'G') -- | Code to move the cursor to the specified position (row and column). The @@ -101,34 +107,48 @@ setCursorPosition :: Int -- ^ 1-based row to move to -> Int -- ^ 1-based column to move to -> B.Builder () +{-# INLINABLE setCursorPosition #-} setCursorPosition n m = csi [n, m] (B.char8 'G') saveCursor, restoreCursor :: B.Builder () +{-# INLINABLE saveCursor #-} saveCursor = B.char8 '\ESC' >> B.char8 '7' +{-# INLINABLE restoreCursor #-} restoreCursor = B.char8 '\ESC' >> B.char8 '8' clearFromCursorToScreenEnd, clearFromCursorToScreenBeginning, clearScreen :: B.Builder () clearFromCursorToLineEnd, clearFromCursorToLineBeginning, clearLine :: B.Builder () +{-# INLINABLE clearFromCursorToScreenEnd #-} clearFromCursorToScreenEnd = csi [0] (B.char8 'J') +{-# INLINABLE clearFromCursorToScreenBeginning #-} clearFromCursorToScreenBeginning = csi [1] (B.char8 'J') +{-# INLINABLE clearScreen #-} clearScreen = csi [2] (B.char8 'J') +{-# INLINABLE clearFromCursorToLineEnd #-} clearFromCursorToLineEnd = csi [0] (B.char8 'K') +{-# INLINABLE clearFromCursorToLineBeginning #-} clearFromCursorToLineBeginning = csi [1] (B.char8 'K') +{-# INLINABLE clearLine #-} clearLine = csi [2] (B.char8 'K') scrollPageUp, scrollPageDown :: Int -- ^ Number of lines to scroll by -> B.Builder() -scrollPageUp n = csi [n] (B.char8 'S') -scrollPageDown n = csi [n] (B.char8 'T') +{-# INLINABLE scrollPageUp #-} +scrollPageUp n = when (n > 0) $ csi [n] (B.char8 'S') +{-# INLINABLE scrollPageDown #-} +scrollPageDown n = when (n > 0) $ csi [n] (B.char8 'T') hideCursor, showCursor :: B.Builder () +{-# INLINABLE hideCursor #-} hideCursor = csi [] "?25l" +{-# INLINABLE showCursor #-} showCursor = csi [] "?25h" -- | XTerm control sequence to set the Icon Name and Window Title. setTitle :: T.Text -- ^ New Icon Name and Window Title -> B.Builder () +{-# INLINABLE setTitle #-} setTitle title = do "\ESC]0;" B.text (T.filter (/= '\007') title) @@ -136,6 +156,7 @@ sgr :: [Word8] -- ^ List of sgr code for the control sequence -> B.Builder () +{-# INLINABLE sgr #-} sgr args = do B.char8 '\ESC' B.char8 '[' @@ -143,52 +164,72 @@ B.char8 'm' reset :: B.Builder () +{-# INLINABLE reset #-} reset = sgr [0] boldIntensity, faintIntensity, resetIntensity :: B.Builder () +{-# INLINABLE boldIntensity #-} boldIntensity = sgr [1] +{-# INLINABLE faintIntensity #-} faintIntensity = sgr [2] +{-# INLINABLE resetIntensity #-} resetIntensity = sgr [22] bold :: B.Builder () -> B.Builder () +{-# INLINABLE bold #-} bold t = boldIntensity >> t >> resetIntensity italicized, noItalicized :: B.Builder () +{-# INLINABLE italicized #-} italicized = sgr [3] +{-# INLINABLE noItalicized #-} noItalicized = sgr [23] -- | Italicize some text italicize :: B.Builder () -> B.Builder () +{-# INLINABLE italicize #-} italicize t = italicized >> t >> noItalicized singleUnderline, doubleUnderline, noUnderline :: B.Builder () +{-# INLINABLE singleUnderline #-} singleUnderline = sgr [4] +{-# INLINABLE doubleUnderline #-} doubleUnderline = sgr [21] +{-# INLINABLE noUnderline #-} noUnderline = sgr [24] -- | Add single underline to some text underline :: B.Builder () -> B.Builder () +{-# INLINABLE underline #-} underline t = singleUnderline >> t >> singleUnderline slowBlink, rapidBlink, blinkOff :: B.Builder () -- | less than 150 per minute +{-# INLINABLE slowBlink #-} slowBlink = sgr [5] -- | MS-DOS ANSI.SYS, 150+ per minute; not widely supported +{-# INLINABLE rapidBlink #-} rapidBlink = sgr [6] +{-# INLINABLE blinkOff #-} blinkOff = sgr [25] conceal, reveal :: B.Builder () -- | Aka Hide, not widely supported. +{-# INLINABLE conceal #-} conceal = sgr [8] +{-# INLINABLE reveal #-} reveal = sgr [28] invert, invertOff :: B.Builder () -- | Swap foreground and background colors, inconsistent emulation +{-# INLINABLE invert #-} invert = sgr [7] +{-# INLINABLE invertOff #-} invertOff = sgr [27] -- | Colorized some text color :: AnsiColor -> B.Builder () -> B.Builder () +{-# INLINABLE color #-} color c t = do setForeground c t @@ -196,6 +237,7 @@ -- | Colorized some text with background color color' :: AnsiColor -> AnsiColor -> B.Builder () -> B.Builder () +{-# INLINABLE color' #-} color' c1 c2 t = do setForeground c1 setBackground c2 @@ -205,6 +247,7 @@ -- | Colorized some text palette :: PaletteColor -> B.Builder () -> B.Builder () +{-# INLINABLE palette #-} palette c t = do setPaletteForeground c t @@ -212,6 +255,7 @@ -- | Colorized some text with background color palette' :: PaletteColor -> PaletteColor -> B.Builder () -> B.Builder () +{-# INLINABLE palette' #-} palette' c1 c2 t = do setPaletteForeground c1 setPaletteBackground c2 @@ -221,6 +265,7 @@ -- | Colorized some text rgb :: RGBColor -> B.Builder () -> B.Builder () +{-# INLINABLE rgb #-} rgb c t = do setRGBForeground c t @@ -228,6 +273,7 @@ -- | Colorized some text with background color rgb' :: RGBColor -> RGBColor -> B.Builder () -> B.Builder () +{-# INLINABLE rgb' #-} rgb' c1 c2 t = do setRGBForeground c1 setRGBBackground c2 @@ -236,21 +282,31 @@ setDefaultBackground setForeground, setBrightForeground, setBackground, setBrightBackground :: AnsiColor -> B.Builder () +{-# INLINABLE setForeground #-} setForeground c = sgr [30 + colorToCode c] +{-# INLINABLE setBrightForeground #-} setBrightForeground c = sgr [90 + colorToCode c] +{-# INLINABLE setBackground #-} setBackground c = sgr [40 + colorToCode c] +{-# INLINABLE setBrightBackground #-} setBrightBackground c = sgr [100 + colorToCode c] setPaletteForeground, setPaletteBackground :: PaletteColor -> B.Builder () +{-# INLINABLE setPaletteForeground #-} setPaletteForeground index = sgr [38, 5, index] +{-# INLINABLE setPaletteBackground #-} setPaletteBackground index = sgr [48, 5, index] setRGBForeground, setRGBBackground :: RGBColor -> B.Builder () +{-# INLINABLE setRGBForeground #-} setRGBForeground (r,g,b) = sgr [38, 2, r, g, b] +{-# INLINABLE setRGBBackground #-} setRGBBackground (r,g,b) = sgr [48, 2, r, g, b] setDefaultForeground, setDefaultBackground :: B.Builder () +{-# INLINABLE setDefaultForeground #-} setDefaultForeground = sgr [39] +{-# INLINABLE setDefaultBackground #-} setDefaultBackground = sgr [49] -- | ANSI's eight standard colors @@ -266,6 +322,7 @@ deriving anyclass T.Print colorToCode :: AnsiColor -> Word8 +{-# INLINABLE colorToCode #-} colorToCode c = case c of Black -> 0 Red -> 1 diff --git a/Z/IO/Time.hs b/Z/IO/Time.hs --- a/Z/IO/Time.hs +++ b/Z/IO/Time.hs @@ -36,6 +36,7 @@ -- | A alternative version of 'getSystemTime'' based on libuv's @uv_gettimeofday@, which also doesn't use pinned allocation. getSystemTime' :: HasCallStack => IO SystemTime +{-# INLINABLE getSystemTime' #-} getSystemTime' = do (TimeVal64 s us) <- getTimeOfDay return (MkSystemTime s (fromIntegral us * 1000)) @@ -48,6 +49,7 @@ -- The value is \"%Y-%m-%d %H:%M:%S\". -- This should be used with 'formatSystemTime' and 'parseSystemTime'. simpleDateFormat :: TimeFormat +{-# INLINABLE simpleDateFormat #-} simpleDateFormat = "%Y-%m-%d %H:%M:%S" -- | Simple format @2020-10-16T03:15:29@. @@ -55,6 +57,7 @@ -- The value is \"%Y-%m-%dT%H:%M:%S%z\". -- This should be used with 'formatSystemTime' and 'parseSystemTime'. iso8061DateFormat :: TimeFormat +{-# INLINABLE iso8061DateFormat #-} iso8061DateFormat = "%Y-%m-%dT%H:%M:%S%z" -- | Format for web (RFC 2616). @@ -62,6 +65,7 @@ -- The value is \"%a, %d %b %Y %H:%M:%S GMT\". -- This should be used with 'formatSystemTimeGMT' and 'parseSystemTimeGMT'. webDateFormat :: TimeFormat +{-# INLINABLE webDateFormat #-} webDateFormat = "%a, %d %b %Y %H:%M:%S GMT" -- | Format for e-mail (RFC 5322). @@ -69,6 +73,7 @@ -- The value is \"%a, %d %b %Y %H:%M:%S %z\". -- This should be used with 'formatSystemTime' and 'parseSystemTime'. mailDateFormat :: TimeFormat +{-# INLINABLE mailDateFormat #-} mailDateFormat = "%a, %d %b %Y %H:%M:%S %z" ---------------------------------------------------------------- @@ -79,7 +84,7 @@ -- formatSystemTime :: TimeFormat -> SystemTime -> IO CBytes formatSystemTime fmt t = formatSystemTimeHelper c_format_unix_time fmt t -{-# INLINE formatSystemTime #-} +{-# INLINABLE formatSystemTime #-} -- | Formatting 'SystemTime' to 'CBytes' in GMT. -- @@ -98,7 +103,7 @@ formatSystemTimeGMT :: TimeFormat -> SystemTime -> CBytes formatSystemTimeGMT fmt t = unsafePerformIO $ formatSystemTimeHelper c_format_unix_time_gmt fmt t -{-# INLINE formatSystemTimeGMT #-} +{-# INLINABLE formatSystemTimeGMT #-} ---------------------------------------------------------------- -- | Parsing 'CBytes' to 'SystemTime' interpreting as localtime. @@ -120,6 +125,7 @@ -- @ -- parseSystemTime :: TimeFormat -> CBytes -> IO SystemTime +{-# INLINABLE parseSystemTime #-} parseSystemTime fmt str = withCBytesUnsafe fmt $ \cfmt -> withCBytesUnsafe str $ \cstr -> do @@ -134,6 +140,7 @@ -- MkSystemTime {systemSeconds = 0, systemNanoseconds = 0} parseSystemTimeGMT :: TimeFormat -> CBytes -> SystemTime +{-# INLINABLE parseSystemTimeGMT #-} parseSystemTimeGMT fmt str = unsafePerformIO $ withCBytesUnsafe fmt $ \cfmt -> withCBytesUnsafe str $ \cstr -> do @@ -160,6 +167,7 @@ -> TimeFormat -> SystemTime -> IO CBytes +{-# INLINABLE formatSystemTimeHelper #-} formatSystemTimeHelper formatFun fmt t = go 80 where MkSystemTime sec _ = t diff --git a/Z/IO/UV/Errno.hsc b/Z/IO/UV/Errno.hsc --- a/Z/IO/UV/Errno.hsc +++ b/Z/IO/UV/Errno.hsc @@ -22,12 +22,14 @@ -- | Returns the error message for the given error code. Leaks a few bytes of memory when you call it with an unknown error code. uvStdError :: CInt -> IO Text +{-# INLINABLE uvStdError #-} uvStdError errno = toText <$> (fromCString =<< uv_strerror errno) foreign import ccall unsafe uv_strerror :: CInt -> IO CString -- | Returns the error name for the given error code. Leaks a few bytes of memory when you call it with an unknown error code. uvErrName :: CInt -> IO Text +{-# INLINABLE uvErrName #-} uvErrName errno = toText <$> (fromCString =<< uv_err_name errno) foreign import ccall unsafe uv_err_name :: CInt -> IO CString diff --git a/Z/IO/UV/FFI.hsc b/Z/IO/UV/FFI.hsc --- a/Z/IO/UV/FFI.hsc +++ b/Z/IO/UV/FFI.hsc @@ -62,15 +62,18 @@ data UVLoopData peekUVEventQueue :: Ptr UVLoopData -> IO (Int, Ptr Int) +{-# INLINABLE peekUVEventQueue #-} peekUVEventQueue p = (,) <$> (#{peek hs_loop_data, event_counter } p) <*> (#{peek hs_loop_data, event_queue } p) clearUVEventCounter :: Ptr UVLoopData -> IO () +{-# INLINABLE clearUVEventCounter #-} clearUVEventCounter p = do #{poke hs_loop_data, event_counter } p $ (0 :: Int) peekUVBufferTable :: Ptr UVLoopData -> IO (Ptr (Ptr Word8), Ptr CSsize) +{-# INLINABLE peekUVBufferTable #-} peekUVBufferTable p = (,) <$> (#{peek hs_loop_data, buffer_table } p) <*> (#{peek hs_loop_data, buffer_size_table } p) @@ -86,6 +89,7 @@ -- | Peek loop data pointer from uv loop pointer. peekUVLoopData :: Ptr UVLoop -> IO (Ptr UVLoopData) +{-# INLINABLE peekUVLoopData #-} peekUVLoopData p = #{peek uv_loop_t, data} p foreign import ccall unsafe hs_uv_loop_init :: Int -> IO (Ptr UVLoop) @@ -110,6 +114,7 @@ data UVHandle peekUVHandleData :: Ptr UVHandle -> IO UVSlotUnsafe +{-# INLINABLE peekUVHandleData #-} peekUVHandleData p = UVSlotUnsafe <$> (#{peek uv_handle_t, data} p :: IO Int) foreign import ccall unsafe hs_uv_fileno :: Ptr UVHandle -> IO FD @@ -155,6 +160,7 @@ foreign import ccall unsafe uv_tcp_getpeername :: Ptr UVHandle -> MBA## SocketAddr -> MBA## CInt -> IO CInt uV_TCP_IPV6ONLY :: CUInt +{-# INLINABLE uV_TCP_IPV6ONLY #-} uV_TCP_IPV6ONLY = #const UV_TCP_IPV6ONLY foreign import ccall unsafe uv_tcp_bind :: Ptr UVHandle -> MBA## SocketAddr -> CUInt -> IO CInt @@ -515,6 +521,7 @@ | otherwise = DirEntUnknown peekUVDirEnt :: Ptr DirEntType -> IO (CString, UVDirEntType) +{-# INLINABLE peekUVDirEnt #-} #ifdef HAVE_DIRENT_TYPES peekUVDirEnt p = (,) (#{ptr hs_uv__dirent_t, d_name } p) <$> (#{peek hs_uv__dirent_t, d_type } p) #else @@ -537,10 +544,14 @@ deriving anyclass (Print, JSON) instance Storable UVTimeSpec where + {-# INLINABLE sizeOf #-} sizeOf _ = #{size uv_timespec_t} + {-# INLINABLE alignment #-} alignment _ = #{alignment uv_timespec_t} + {-# INLINABLE peek #-} peek p = UVTimeSpec <$> (#{peek uv_timespec_t, tv_sec } p) <*> (#{peek uv_timespec_t, tv_nsec } p) + {-# INLINABLE poke #-} poke p (UVTimeSpec sec nsec) = do (#{poke uv_timespec_t, tv_sec } p sec) (#{poke uv_timespec_t, tv_nsec } p nsec) @@ -566,9 +577,11 @@ deriving anyclass (Print, JSON) uvStatSize :: Int +{-# INLINABLE uvStatSize #-} uvStatSize = #{size uv_stat_t} peekUVStat :: Ptr FStat -> IO FStat +{-# INLINABLE peekUVStat #-} peekUVStat p = FStat <$> (#{peek uv_stat_t, st_dev } p) <*> (fromIntegral <$> (#{peek uv_stat_t, st_mode } p :: IO Word64)) @@ -821,6 +834,7 @@ deriving anyclass (Print, JSON) processStdStreamFlag :: ProcessStdStream -> CInt +{-# INLINABLE processStdStreamFlag #-} processStdStreamFlag ProcessIgnore = #const UV_IGNORE processStdStreamFlag ProcessCreate = (#const UV_CREATE_PIPE) .|. (#const UV_READABLE_PIPE) diff --git a/Z/IO/UV/FFI_Env.hsc b/Z/IO/UV/FFI_Env.hsc --- a/Z/IO/UV/FFI_Env.hsc +++ b/Z/IO/UV/FFI_Env.hsc @@ -75,9 +75,11 @@ deriving anyclass (Print, JSON) sizeOfResUsage :: Int +{-# INLINABLE sizeOfResUsage #-} sizeOfResUsage = #size uv_rusage_t peekResUsage :: MBA## a -> IO ResUsage +{-# INLINABLE peekResUsage #-} peekResUsage mba = do utime_sec :: CLong <- peekMBA mba (#offset uv_rusage_t, ru_utime ) utime_usec :: CLong <- peekMBA mba ((#offset uv_rusage_t, ru_utime) + sizeOf (undefined :: CLong)) @@ -147,6 +149,7 @@ deriving anyclass (Print, JSON) getOSName :: HasCallStack => IO OSName +{-# INLINABLE getOSName #-} getOSName = do (MutableByteArray mba##) <- newByteArray (#size uv_utsname_t) throwUVIfMinus_ (uv_os_uname mba##) @@ -180,6 +183,7 @@ -- On non-Windows systems, all data comes from getpwuid_r(3). -- On Windows, uid and gid are set to -1 and have no meaning, and shell is empty. getPassWD :: HasCallStack => IO PassWD +{-# INLINABLE getPassWD #-} getPassWD = bracket (do mpa@(MutableByteArray mba##) <- newByteArray (#size uv_passwd_t) throwUVIfMinus_ (uv_os_get_passwd mba##) @@ -215,6 +219,7 @@ -- | Gets information about the CPUs on the system. getCPUInfo :: HasCallStack => IO [CPUInfo] +{-# INLINABLE getCPUInfo #-} getCPUInfo = bracket (do (p, (len, _)) <- allocPrimUnsafe $ \ pp -> allocPrimUnsafe $ \ plen -> @@ -224,6 +229,7 @@ (\ (p, len) -> forM [0..fromIntegral len-1] (peekCPUInfoOff p)) peekCPUInfoOff :: Ptr CPUInfo -> Int -> IO CPUInfo +{-# INLINABLE peekCPUInfoOff #-} peekCPUInfoOff p off = do let p' = p `plusPtr` (off * (#size uv_cpu_info_t)) model <- fromCString =<< (#peek uv_cpu_info_t, model) p' @@ -239,6 +245,7 @@ -- | Gets the load average. See: getLoadAvg :: IO (Double, Double, Double) +{-# INLINABLE getLoadAvg #-} getLoadAvg = do (arr, _) <- allocPrimArrayUnsafe 3 uv_loadavg return ( indexPrimArray arr 0 @@ -258,6 +265,7 @@ -- | Cross-platform implementation of . -- The timezone argument to gettimeofday() is not supported, as it is considered obsolete. getTimeOfDay :: HasCallStack => IO TimeVal64 +{-# INLINABLE getTimeOfDay #-} getTimeOfDay = do (MutableByteArray mba##) <- newByteArray (#size uv_timeval64_t) throwUVIfMinus_ (uv_gettimeofday mba##) diff --git a/Z/IO/UV/Manager.hs b/Z/IO/UV/Manager.hs --- a/Z/IO/UV/Manager.hs +++ b/Z/IO/UV/Manager.hs @@ -55,7 +55,7 @@ import GHC.Conc.Sync (labelThread) import System.IO.Unsafe import Z.Data.Array -import Z.Data.PrimRef.PrimIORef +import Z.Data.PrimRef import qualified Z.Data.Text.Print as T import Z.IO.Exception import Z.IO.Resource @@ -82,6 +82,7 @@ instance Show UVManager where show = T.toString instance T.Print UVManager where + {-# INLINABLE toUTF8BuilderP #-} toUTF8BuilderP p uvm = T.parenWhen (p > 10) $ "UVManager on capability " >> T.int (uvmCap uvm) @@ -162,6 +163,7 @@ pokeElemOff bufSizTable slot (fromIntegral bufSiz) initUVManager :: HasCallStack => Int -> Int -> Resource UVManager +{-# INLINABLE initUVManager #-} initUVManager siz cap = do loop <- initResource (throwOOMIfNull $ hs_uv_loop_init (fromIntegral siz)) @@ -180,6 +182,7 @@ -- libuv is not thread safe, use this function to perform any action which will mutate uv_loop's state. -- withUVManager :: HasCallStack => UVManager -> (Ptr UVLoop -> IO a) -> IO a +{-# INLINABLE withUVManager #-} withUVManager (UVManager _ loop loopData runningLock _) f = go where go = do @@ -205,11 +208,13 @@ -- In fact most of the libuv's functions are not thread safe, so watch out! -- withUVManager' :: HasCallStack => UVManager -> IO a -> IO a +{-# INLINABLE withUVManager' #-} withUVManager' uvm f = withUVManager uvm (\ _ -> f) -- | Start the uv loop -- startUVManager :: HasCallStack => UVManager -> IO () +{-# INLINABLE startUVManager #-} startUVManager uvm@(UVManager _ _ _ runningLock _) = poll -- use a closure capture uvm in case of stack memory leaking where -- we borrow mio's non-blocking/blocking poll strategy here @@ -267,7 +272,7 @@ -- Always use this function to turn an 'UVSlotUnsafe' into 'UVSlot', so that the block -- table size synchronize with libuv side's slot table. getUVSlot :: HasCallStack => UVManager -> IO UVSlotUnsafe -> IO UVSlot -{-# INLINE getUVSlot #-} +{-# INLINABLE getUVSlot #-} getUVSlot (UVManager blockTableRef _ _ _ _) f = do slot <- throwUVIfMinus (unsafeGetSlot <$> f) blockTable <- readIORef blockTableRef @@ -287,6 +292,7 @@ -- | Cancel uv async function (actions which can be cancelled with 'uv_cancel') with -- best effort, if the action is already performed, run an extra clean up action. cancelUVReq :: UVManager -> UVSlot -> (Int -> IO ()) -> IO () +{-# INLINABLE cancelUVReq #-} cancelUVReq uvm slot extra_cleanup = withUVManager uvm $ \ loop -> do m <- getBlockMVar uvm slot r <- tryTakeMVar m @@ -306,6 +312,7 @@ -- async function with best efforts, withUVRequest :: HasCallStack => UVManager -> (Ptr UVLoop -> IO UVSlotUnsafe) -> IO Int +{-# INLINABLE withUVRequest #-} withUVRequest uvm f = do (slot, m) <- withUVManager uvm $ \ loop -> mask_ $ do slot <- getUVSlot uvm (f loop) @@ -318,6 +325,7 @@ -- | Same with 'withUVRequest' but disgard the result. withUVRequest_ :: HasCallStack => UVManager -> (Ptr UVLoop -> IO UVSlotUnsafe) -> IO () +{-# INLINABLE withUVRequest_ #-} withUVRequest_ uvm f = void (withUVRequest uvm f) -- | Same with 'withUVRequest' but apply an convert function to result. @@ -330,6 +338,7 @@ -> (Ptr UVLoop -> IO UVSlotUnsafe) -> (Int -> IO b) -- ^ convert function -> IO b +{-# INLINABLE withUVRequest' #-} withUVRequest' uvm f g = do (slot, m) <- withUVManager uvm $ \ loop -> mask_ $ do slot <- getUVSlot uvm (f loop) @@ -345,6 +354,7 @@ -- e.g. release result memory. withUVRequestEx :: HasCallStack => UVManager -> (Ptr UVLoop -> IO UVSlotUnsafe) -> (Int -> IO ()) -> IO Int +{-# INLINABLE withUVRequestEx #-} withUVRequestEx uvm f extra_cleanup = do (slot, m) <- withUVManager uvm $ \ loop -> mask_ $ do slot <- getUVSlot uvm (f loop) @@ -364,6 +374,7 @@ -- we solve this problem with simple round-robin load-balancing: forkBa will automatically -- distribute new threads to all capabilities in round-robin manner. Thus its name forkBa(lance). forkBa :: IO () -> IO ThreadId +{-# INLINABLE forkBa #-} forkBa io = do i <- atomicAddCounter counter 1 forkOn i io diff --git a/Z/IO/UV/UVStream.hs b/Z/IO/UV/UVStream.hs --- a/Z/IO/UV/UVStream.hs +++ b/Z/IO/UV/UVStream.hs @@ -51,6 +51,7 @@ instance Show UVStream where show = T.toString instance T.Print UVStream where + {-# INLINABLE toUTF8BuilderP #-} toUTF8BuilderP _ (UVStream hdl slot uvm _) = do "UVStream{uvsHandle=" >> T.toUTF8Builder hdl ",uvsSlot=" >> T.toUTF8Builder slot @@ -72,6 +73,7 @@ => (Ptr UVLoop -> Ptr UVHandle -> IO ()) -> UVManager -> Resource UVStream +{-# INLINABLE initUVStream #-} initUVStream f uvm = initResource (withUVManager uvm $ \ loop -> do hdl <- hs_uv_handle_alloc loop @@ -85,6 +87,7 @@ -- | Manually close a uv stream. closeUVStream :: UVStream -> IO () +{-# INLINABLE closeUVStream #-} closeUVStream (UVStream hdl _ uvm closed) = withUVManager' uvm $ do c <- readIORef closed -- hs_uv_handle_close won't return error @@ -94,6 +97,7 @@ -- -- Futher writing will throw 'ResourceVanished'(EPIPE). shutdownUVStream :: HasCallStack => UVStream -> IO () +{-# INLINABLE shutdownUVStream #-} shutdownUVStream (UVStream hdl _ uvm closed) = do c <- readIORef closed when c throwECLOSED @@ -106,6 +110,7 @@ -- | Get stream fd getUVStreamFD :: HasCallStack => UVStream -> IO FD +{-# INLINABLE getUVStreamFD #-} getUVStreamFD (UVStream hdl _ _ closed) = do c <- readIORef closed when c throwECLOSED @@ -187,10 +192,12 @@ -- | Write "hello world" to a 'UVStream'. helloWorld :: UVStream -> IO () +{-# INLINABLE helloWorld #-} helloWorld uvs = writeOutput uvs (Ptr "hello world"#) 11 -- | Echo whatever received bytes. echo :: UVStream -> IO () +{-# INLINABLE echo #-} echo uvs = do i <- newBufferedInput uvs o <- newBufferedOutput uvs diff --git a/Z/IO/UV/Win.hs b/Z/IO/UV/Win.hs --- a/Z/IO/UV/Win.hs +++ b/Z/IO/UV/Win.hs @@ -20,7 +20,7 @@ -- This functions will run 'uv__once_init' once if not run before, -- withUVInitDo :: IO a -> IO a -{-# INLINE withUVInitDo #-} +{-# INLINABLE withUVInitDo #-} #if defined(mingw32_HOST_OS) diff --git a/include/fs_shared.hs b/include/fs_shared.hs --- a/include/fs_shared.hs +++ b/include/fs_shared.hs @@ -7,63 +7,74 @@ -- -- The notes on linux 'writeFileP' applied to 'FilePtr' too. data FilePtr = FilePtr {-# UNPACK #-} !File - {-# UNPACK #-} !(PrimIORef Int64) + {-# UNPACK #-} !(PrimRef RealWorld Int64) -- | Create a file offset bundle from an 'File'. -- newFilePtr :: File -- ^ the file we're reading -> Int64 -- ^ initial offset -> IO FilePtr -newFilePtr uvf off = FilePtr uvf <$> newPrimIORef off +{-# INLINABLE newFilePtr #-} +newFilePtr uvf off = FilePtr uvf <$> newPrimRef off -- | Get current offset. getFilePtrOffset :: FilePtr -> IO Int64 -getFilePtrOffset (FilePtr _ offsetRef) = readPrimIORef offsetRef +{-# INLINABLE getFilePtrOffset #-} +getFilePtrOffset (FilePtr _ offsetRef) = readPrimRef offsetRef -- | Change current offset. setFilePtrOffset :: FilePtr -> Int64 -> IO () -setFilePtrOffset (FilePtr _ offsetRef) = writePrimIORef offsetRef +{-# INLINABLE setFilePtrOffset #-} +setFilePtrOffset (FilePtr _ offsetRef) = writePrimRef offsetRef instance Input FilePtr where + {-# INLINABLE readInput #-} readInput (FilePtr file offsetRef) buf bufSiz = - readPrimIORef offsetRef >>= \ off -> do + readPrimRef offsetRef >>= \ off -> do l <- readFileP file buf bufSiz off - writePrimIORef offsetRef (off + fromIntegral l) + writePrimRef offsetRef (off + fromIntegral l) return l instance Output FilePtr where + {-# INLINABLE writeOutput #-} writeOutput (FilePtr file offsetRef) buf bufSiz = - readPrimIORef offsetRef >>= \ off -> do + readPrimRef offsetRef >>= \ off -> do writeFileP file buf bufSiz off - writePrimIORef offsetRef (off + fromIntegral bufSiz) + writePrimRef offsetRef (off + fromIntegral bufSiz) -- | Quickly open a file and read its content. readFile :: HasCallStack => CBytes -> IO V.Bytes +{-# INLINABLE readFile #-} readFile filename = do withResource (initFile filename O_RDONLY DEFAULT_FILE_MODE) $ \ file -> do readAll' =<< newBufferedInput file -- | Quickly open a file and read its content as UTF8 text. readTextFile :: HasCallStack => CBytes -> IO T.Text +{-# INLINABLE readTextFile #-} readTextFile filename = T.validate <$> readFile filename -- | Quickly open a file and write some content. writeFile :: HasCallStack => CBytes -> V.Bytes -> IO () +{-# INLINABLE writeFile #-} writeFile filename content = do withResource (initFile filename (O_WRONLY .|. O_CREAT) DEFAULT_FILE_MODE) $ \ file -> do withPrimVectorSafe content (writeOutput file) -- | Quickly open a file and write some content as UTF8 text. writeTextFile :: HasCallStack => CBytes -> T.Text -> IO () +{-# INLINABLE writeTextFile #-} writeTextFile filename content = writeFile filename (T.getUTF8Bytes content) -- | Quickly open a file and read its content as a JSON value. -- Throw 'OtherError' with name @EPARSE@ if JSON value is not parsed. readJSONFile :: (HasCallStack, JSON.JSON a) => CBytes -> IO a +{-# INLINABLE readJSONFile #-} readJSONFile filename = unwrap "EPARSE" . JSON.decode' =<< readFile filename -- | Quickly open a file and write a JSON Value. writeJSONFile :: (HasCallStack, JSON.JSON a) => CBytes -> a -> IO () +{-# INLINABLE writeJSONFile #-} writeJSONFile filename x = writeFile filename (JSON.encode x) -------------------------------------------------------------------------------- @@ -76,6 +87,7 @@ -- scandirRecursively "." (\\ p _ -> (== ".hs") . snd \<$\> splitExtension p) -- @ scandirRecursively :: HasCallStack => CBytes -> (CBytes -> DirEntType -> IO Bool) -> IO [CBytes] +{-# INLINABLE scandirRecursively #-} scandirRecursively dir p = loop [] =<< P.normalize dir where loop acc0 pdir = @@ -93,44 +105,53 @@ -- | Does given path exist? -- doesPathExist :: CBytes -> IO Bool +{-# INLINABLE doesPathExist #-} doesPathExist path = maybe False (const True) <$> stat' path -- | Returns 'True' if the argument file exists and is either a file or a -- symbolic link to a file, and 'False' otherwise. doesFileExist :: CBytes -> IO Bool +{-# INLINABLE doesFileExist #-} doesFileExist path = maybe False isFileSt <$> stat' path -- | Returns 'True' if the argument directory exists and is either a directory or a -- symbolic link to a directory, and 'False' otherwise. doesDirExist :: CBytes -> IO Bool +{-# INLINABLE doesDirExist #-} doesDirExist path = maybe False isDirSt <$> stat' path -------------------------------------------------------------------------------- -- | If given path is a symbolic link? isLink :: HasCallStack => CBytes -> IO Bool +{-# INLINABLE isLink #-} isLink = fmap isLinkSt . lstat -- | If given path is a directory or a symbolic link to a directory? isDir :: HasCallStack => CBytes -> IO Bool +{-# INLINABLE isDir #-} isDir = fmap isDirSt . stat -- | If given path is a file or a symbolic link to a file? isFile :: HasCallStack => CBytes -> IO Bool +{-# INLINABLE isFile #-} isFile = fmap isFileSt . stat -- | Shortcut to @\\ st -> stMode st .&. S_IFMT == S_IFLNK@ -- -- Note you should use 'lstat' to get the link's stat. isLinkSt :: FStat -> Bool +{-# INLINABLE isLinkSt #-} isLinkSt st = stMode st .&. S_IFMT == S_IFLNK -- | Shortcut to @\\ st -> stMode st .&. S_IFMT == S_IFDIR@ isDirSt :: FStat -> Bool +{-# INLINABLE isDirSt #-} isDirSt st = stMode st .&. S_IFMT == S_IFDIR -- | Shortcut to @\\ st -> stMode st .&. S_IFMT == S_IFREG@ isFileSt :: FStat -> Bool +{-# INLINABLE isFileSt #-} isFileSt st = stMode st .&. S_IFMT == S_IFREG ------------------------------------------------------------------------------- @@ -143,6 +164,7 @@ -- ("/var/folders/3l/cfdy03vd1gvd1x75gg_js7280000gn/T/Z-IO-bYgZDX",File 13) -- initTempFile :: HasCallStack => Resource (CBytes, File) +{-# INLINABLE initTempFile #-} initTempFile = do d <- liftIO $ Env.getTempDir mkstemp d "Z-IO-" False @@ -155,4 +177,5 @@ -- "/tmp/Z-IO-xfWR0L" -- initTempDir :: HasCallStack => Resource CBytes +{-# INLINABLE initTempDir #-} initTempDir = initResource (Env.getTempDir >>= (`P.join` "Z-IO-") >>= mkdtemp) rmrf diff --git a/test/Z/IO/BIO/BaseSpec.hs b/test/Z/IO/BIO/BaseSpec.hs new file mode 100644 --- /dev/null +++ b/test/Z/IO/BIO/BaseSpec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Z.IO.BIO.BaseSpec where + +import Control.Concurrent +import Control.Monad +import qualified Codec.Compression.Zlib as TheZlib +import Data.IORef +import qualified Z.Data.Vector as V +import Z.IO.BIO.Zlib +import Z.IO.BIO.Base +import Z.IO +import Test.QuickCheck +import Test.QuickCheck.Function +import Test.QuickCheck.Property +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.HUnit +import System.IO.Unsafe + + +spec :: Spec +spec = describe "BIO" . modifyMaxSize (*10) $ do + + describe "decode . encode === id(Base64)" $ + prop "Base64" $ \ xs -> + let r = unsafePerformIO $ do + let src = sourceFromList xs + (rRef, sink) <- sinkToList + enc <- newBase64Encoder + dec <- newBase64Decoder + run_ $ src . enc . dec . sink + takeMVar rRef + in V.concat r === V.concat xs + + describe "decode . encode === id(Hex)" $ do + prop "Hex" $ \ xs upper -> + let r = unsafePerformIO $ do + let src = sourceFromList xs + (rRef, sink) <- sinkToList + dec <- newHexDecoder + run_ $ src . hexEncode upper . dec . sink + takeMVar rRef + in V.concat r === V.concat xs + diff --git a/test/Z/IO/BIO/ConcurrentSpec.hs b/test/Z/IO/BIO/ConcurrentSpec.hs --- a/test/Z/IO/BIO/ConcurrentSpec.hs +++ b/test/Z/IO/BIO/ConcurrentSpec.hs @@ -7,8 +7,7 @@ import Control.Monad import Control.Monad.IO.Class import Data.IORef -import Z.IO.BIO.Concurrent -import Z.IO.BIO +import qualified Z.IO.BIO as BIO import Test.QuickCheck import Test.QuickCheck.Function import Test.QuickCheck.Property @@ -22,23 +21,23 @@ spec :: Spec spec = describe "BIO.Concurrent" $ do - prop "zipBIO works like zip on Sources" $ \ xs ys -> monadicIO $ do - (zs :: [(Int, Int)]) <- liftIO . runBIO $ zipBIO (sourceFromList xs) (sourceFromList ys) + prop "zip works like zip on Sources" $ \ xs ys -> monadicIO $ do + (zs :: [(Int, Int)]) <- liftIO . BIO.run $ BIO.zip (BIO.sourceFromList xs) (BIO.sourceFromList ys) QM.assert (zs == zip xs ys) it "TQueueNode works as expected" $ do let content = [1..1000] - (sink, src) <- newTQueueNode 2 + (sink, src) <- BIO.newTQueuePair 2 sumRef <- newIORef 0 let producter = do src' <- sourceListWithDelay content - runBIO_ (src' . sink) + BIO.run_ (src' . sink) let consumer = do - (rRef, sink') <- sinkToList - runBIO_ (src . sink') + (rRef, sink') <- BIO.sinkToList + BIO.run_ (src . sink') r <- takeMVar rRef atomicModifyIORef' sumRef $ \ x -> (x + sum r, ()) @@ -56,16 +55,16 @@ it "TBQueueNode works as expected" $ do let content = [1..1000] - (sink, src) <- newTBQueueNode 2 10 + (sink, src) <- BIO.newTBQueuePair 2 10 sumRef <- newIORef 0 let producter = do src' <- sourceListWithDelay content - runBIO_ (src' . sink) + BIO.run_ (src' . sink) let consumer = do - (rRef, sink') <- sinkToList - runBIO_ (src . sink') + (rRef, sink') <- BIO.sinkToList + BIO.run_ (src . sink') r <- takeMVar rRef atomicModifyIORef' sumRef $ \ x -> (x + sum r, ()) @@ -83,17 +82,17 @@ it "TChanNode works as expected" $ do let content = [1..1000] - (sink, srcf) <- newBroadcastTChanNode 2 + (sink, srcf) <- BIO.newBroadcastTChanPair 2 sumRef <- newIORef 0 let producter = do src' <- sourceListWithDelay content - runBIO_ (src' . sink) + BIO.run_ (src' . sink) let consumer = do - (rRef, sink') <- sinkToList + (rRef, sink') <- BIO.sinkToList src <- srcf - runBIO_ (src . sink') + BIO.run_ (src . sink') r <- takeMVar rRef atomicModifyIORef' sumRef $ \ x -> (x + sum r, ()) @@ -109,7 +108,7 @@ s @?= (sum content * 2 * 3) -sourceListWithDelay :: [Int] -> IO (Source Int) +sourceListWithDelay :: [Int] -> IO (BIO.Source Int) sourceListWithDelay xs = do return $ \ k _ -> do forM_ xs $ \ x -> do diff --git a/test/Z/IO/BIO/ZlibSpec.hs b/test/Z/IO/BIO/ZlibSpec.hs --- a/test/Z/IO/BIO/ZlibSpec.hs +++ b/test/Z/IO/BIO/ZlibSpec.hs @@ -9,6 +9,7 @@ import Data.ByteString.Lazy as BL import Z.Data.Vector as V import Z.IO.BIO.Zlib +import Z.IO.BIO import Z.IO import Test.QuickCheck import Test.QuickCheck.Function diff --git a/test/Z/IO/BIOSpec.hs b/test/Z/IO/BIOSpec.hs deleted file mode 100644 --- a/test/Z/IO/BIOSpec.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Z.IO.BIOSpec where - -import Control.Concurrent -import Control.Monad -import qualified Codec.Compression.Zlib as TheZlib -import Data.IORef -import qualified Z.Data.Vector as V -import Z.IO.BIO.Zlib -import Z.IO -import Test.QuickCheck -import Test.QuickCheck.Function -import Test.QuickCheck.Property -import Test.Hspec -import Test.Hspec.QuickCheck -import Test.HUnit -import System.IO.Unsafe - - -spec :: Spec -spec = describe "BIO" . modifyMaxSize (*10) $ do - - describe "decode . encode === id(Base64)" $ - prop "Base64" $ \ xs -> - let r = unsafePerformIO $ do - let src = sourceFromList xs - (rRef, sink) <- sinkToList - enc <- newBase64Encoder - dec <- newBase64Decoder - runBIO $ src . enc . dec . sink - takeMVar rRef - in V.concat r === V.concat xs - - describe "decode . encode === id(Hex)" $ do - prop "Hex" $ \ xs upper -> - let r = unsafePerformIO $ do - let src = sourceFromList xs - (rRef, sink) <- sinkToList - let enc = hexEncoder upper - dec <- newHexDecoder - runBIO $ src . enc . dec . sink - takeMVar rRef - in V.concat r === V.concat xs - diff --git a/test/Z/IO/LowResTimerSpec.hs b/test/Z/IO/LowResTimerSpec.hs --- a/test/Z/IO/LowResTimerSpec.hs +++ b/test/Z/IO/LowResTimerSpec.hs @@ -3,7 +3,7 @@ import Control.Concurrent import Control.Monad import Control.Monad.IO.Class -import Z.Data.PrimRef.PrimIORef +import Z.Data.PrimRef import Z.IO.LowResTimer import Test.Hspec import Test.HUnit @@ -22,7 +22,7 @@ assertEqual "timer manager should start" True running threadDelay 2000000 -- make sure all timers are fired - c' <- readPrimIORef c + c' <- readPrimRef c assertEqual "timers registration counter" 100000 c' threadDelay 100000 -- another 0.1s @@ -38,7 +38,7 @@ throttledAdd threadDelay 100000 threadDelay 10000000 -- wait 10s here - c' <- readPrimIORef c + c' <- readPrimRef c assertBool ("throttled add " ++ show c') (5 <= c' && c' <= 8) -- on osx CI threadDelay drift too much it "throttleTrailing" $ do @@ -48,5 +48,5 @@ throttledAdd threadDelay 100000 threadDelay 10000000 -- wait 10s here - c' <- readPrimIORef c + c' <- readPrimRef c assertBool ("throttled add " ++ show c') (5 <= c' && c' <= 8) -- on osx CI threadDelay drift too muc diff --git a/test/Z/IO/Network/UDPSpec.hs b/test/Z/IO/Network/UDPSpec.hs --- a/test/Z/IO/Network/UDPSpec.hs +++ b/test/Z/IO/Network/UDPSpec.hs @@ -6,8 +6,8 @@ import Control.Monad import Data.Bits import Data.IORef -import Z.Data.Vector as V -import Z.Data.Vector.Base as V +import qualified Z.Data.Vector as V +import qualified Z.Data.Vector.Base as V import Data.List as List import Foreign.Marshal.Array import Foreign.Ptr diff --git a/test/Z/IO/ResourceSpec.hs b/test/Z/IO/ResourceSpec.hs --- a/test/Z/IO/ResourceSpec.hs +++ b/test/Z/IO/ResourceSpec.hs @@ -5,7 +5,7 @@ import Control.Concurrent import Control.Exception import Control.Monad -import Z.Data.PrimRef.PrimIORef +import Z.Data.PrimRef import Z.IO.Resource as R import Test.Hspec import Test.HUnit @@ -30,20 +30,20 @@ threadDelay 1000000 - r <- readPrimIORef resCounter + r <- readPrimRef resCounter assertEqual "pool should keep returned resources alive" 100 r threadDelay 5000000 -- after 5s, 200 thread should release all resources - w <- readPrimIORef workerCounter + w <- readPrimRef workerCounter assertEqual "worker should be able to get resource" 200 w - r <- readPrimIORef resCounter + r <- readPrimRef resCounter assertEqual "pool should reap unused resources" 0 r -- Let's test again - writePrimIORef workerCounter 0 + writePrimRef workerCounter 0 forM_ [1..200] $ \ k -> forkIO. R.withSimplePool pool $ \ i -> do atomicAddCounter_ workerCounter 1 @@ -51,15 +51,15 @@ threadDelay 1000000 - r <- readPrimIORef resCounter + r <- readPrimRef resCounter assertEqual "pool should keep returned resources alive" 100 r threadDelay 5000000 - w <- readPrimIORef workerCounter + w <- readPrimRef workerCounter assertEqual "worker should be able to get resource" 200 w - r <- readPrimIORef resCounter + r <- readPrimRef resCounter assertEqual "pool should reap unused resources" 0 r it "resource pool under exceptions" $ do @@ -77,5 +77,5 @@ threadDelay 5000000 - r <- readPrimIORef resCounter + r <- readPrimRef resCounter assertEqual "pool should reap unused resources" 0 r