diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,539 @@ +# Changelog + + + +## 0.8.2 (Mar 2022) + +* Fix performance issues for GHC-9. These changes coupled with GHC changes + expected to land in 9.2.2 will bring the performance back to the same levels + as before. + +## 0.8.1.1 (Dec 2021) + +* Disable building FileSystem.Events where FS Events isn't supported. + +## 0.8.1 (Nov 2021) + +See API-changelog.txt for new APIs introduced. + +### Bug Fixes + +* Several bug fixes in the Array module: + * Fix writeN fold eating away one element when applied multiple times + [#1258](https://github.com/composewell/streamly/issues/1258). + * Fix potentially writing beyond allocated memory when shrinking. Likely + cause of [#944](https://github.com/composewell/streamly/issues/944). + * Fix potentially writing beyond allocated memory when writing the last + element. Likely cause of + [#944](https://github.com/composewell/streamly/issues/944). + * Fix missing pointer touch could potentially cause use of freed memory. + * Fix unnecessary additional allocation due to a bug +* Fix a bug in classifySessionsBy, see + [PR #1311](https://github.com/composewell/streamly/pull/1311). The bug + could cause premature ejection of a session when input events with the + same key are split into multiple sessions. + +### Notable Internal API Changes + +* `tapAsync` from `Streamly.Internal.Data.Stream.Parallel` has been moved to + `Streamly.Internal.Data.Stream.IsStream` and renamed to `tapAsyncK`. +* `Fold2` has now been renamed to `Refold` and the corresponding `Fold2` + combinators have been either renamed or removed. + +## 0.8.0 (Jun 2021) + +See [API Changelog](/docs/API-changelog.txt) for a complete list of signature +changes and new APIs introduced. + +### Breaking changes + +* `Streamly.Prelude` + * `fold`: this function may now terminate early without consuming + the entire stream. For example, `fold Fold.head stream` would + now terminate immediately after consuming the head element from + `stream`. This may result in change of behavior in existing programs + if the program relies on the evaluation of the full stream. +* `Streamly.Data.Unicode.Stream` + * The following APIs no longer throw errors on invalid input, use new + APIs suffixed with a prime for strict behavior: + * decodeUtf8 + * encodeLatin1 + * encodeUtf8 +* `Streamly.Data.Fold`: + * Several instances have been moved to the `Streamly.Data.Fold.Tee` + module, please use the `Tee` type to adapt to the changes. + +### Bug Fixes + +* Concurrent Streams: The monadic state for the stream is now propagated across + threads. Please refer to + [#369](https://github.com/composewell/streamly/issues/369) for more info. +* `Streamly.Prelude`: + * `bracket`, `handle`, and `finally` now also work correctly on streams + that aren't fully drained. Also, the resource acquisition and release is + atomic with respect to async exceptions. + * `iterate`, `iterateM` now consume O(1) space instead of O(n). + * `fromFoldableM` is fixed to be concurrent. +* `Streamly.Network.Inet.TCP`: `accept` and `connect` APIs now close the socket + if an exception is thrown. +* `Streamly.Network.Socket`: `accept` now closes the socket if an exception is + thrown. + +### Enhancements + +* See [API Changelog](/docs/API-changelog.txt) for a complete list of new + modules and APIs introduced. +* The Fold type is now more powerful, the new termination behavior allows + to express basic parsing of streams using folds. +* Many new Fold and Unfold APIs are added. +* A new module for console IO APIs is added. +* Experimental modules for the following are added: + * Parsing + * Deserialization + * File system event handling (fsnotify/inotify) + * Folds for streams of arrays +* Experimental `use-c-malloc` build flag to use the c library `malloc` for + array allocations. This could be useful to avoid pinned memory fragmentation. + + +### Notable Internal/Pre-release API Changes + +Breaking changes: + +* The `Fold` type has changed to accommodate terminating folds. +* Rename: `Streamly.Internal.Prelude` => `Streamly.Internal.Data.Stream.IsStream` +* Several other internal modules have been renamed and re-factored. + +Bug fixes: + +* A bug was fixed in the conversion of `MicroSecond64` and `MilliSecond64` + (commit e5119626) +* Bug fix: `classifySessionsBy` now flushes sessions at the end and terminates. + +### Miscellaneous + +* Drop support for GHC 7.10.3. +* The examples in this package are moved to a new github repo + [streamly-examples](https://github.com/composewell/streamly-examples) + +## 0.7.3 (February 2021) + +### Build Issues + +* Fix build issues with primitive package version >= 0.7.1. +* Fix build issues on armv7. + +## 0.7.2 (April 2020) + +### Bug Fixes + +* Fix a bug in the `Applicative` and `Functor` instances of the `Fold` + data type. + +### Build Issues + +* Fix a bug that occasionally caused a build failure on windows when + used with `stack` or `stack ghci`. +* Now builds on 32-bit machines. +* Now builds with `primitive` package version >= 0.5.4 && <= 0.6.4.0 +* Now builds with newer `QuickCheck` package version >= 2.14 && < 2.15. +* Now builds with GHC 8.10. + +## 0.7.1 (February 2020) + +### Bug Fixes + +* Fix a bug that caused `findIndices` to return wrong indices in some + cases. +* Fix a bug in `tap`, `chunksOf` that caused memory consumption to + increase in some cases. +* Fix a space leak in concurrent streams (`async`, `wAsync`, and `ahead`) that + caused memory consumption to increase with the number of elements in the + stream, especially when built with `-threaded` and used with `-N` RTS option. + The issue occurs only in cases when a worker thread happens to be used + continuously for a long time. +* Fix scheduling of WAsyncT stream style to be in round-robin fashion. +* Now builds with `containers` package version < 0.5.8. +* Now builds with `network` package version >= 3.0.0.0 && < 3.1.0.0. + +### Behavior change + +* Combinators in `Streamly.Network.Inet.TCP` no longer use TCP `NoDelay` and + `ReuseAddr` socket options by default. These options can now be specified + using appropriate combinators. + +### Performance + +* Now uses `fusion-plugin` package for predictable stream fusion optimizations +* Significant improvement in performance of concurrent stream operations. +* Improved space and time performance of `Foldable` instance. + +## 0.7.0 (November 2019) + +### Breaking changes + +* Change the signature of `foldrM` to ensure that it is lazy +* Change the signature of `iterateM` to ensure that it is lazy. +* `scanx` would now require an additional `Monad m` constraint. + +### Behavior change + +* Earlier `ParallelT` was unaffected by `maxBuffer` directive, now `maxBuffer` + can limit the buffer of a `ParallelT` stream as well. When the buffer becomes + full, the producer threads block. +* `ParallelT` streams no longer have an unlimited buffer by default. Now the + buffer for parallel streams is limited to 1500 by default, the same as other + concurrent stream types. + +### Deprecations + +* In `Streamly.Prelude`: + * `runStream` has been replaced by `drain` + * `runN` has been replaced by `drainN` + * `runWhile` has been replaced by `drainWhile` + * `fromHandle` has been deprecated. Please use + `Streamly.FileSystem.Handle.read`, `Streamly.Data.Unicode.Stream.decodeUtf8` and + `splitOnSuffix` with `Streamly.Data.Fold.toList` to split the + stream to a stream of `String` separated by a newline. + * `toHandle` has been deprecated. Please use `intersperse` and `concatUnfold` to + add newlines to a stream, `Streamly.Data.Unicode.Stream.encodeUtf8` for encoding and + `Streamly.FileSystem.Handle.write` for writing to a file handle. + * Deprecate `scanx`, `foldx`, `foldxM`, `foldr1` + * Remove deprecated APIs `foldl`, `foldlM` + * Replace deprecated API `scan` with a new signature, to scan using Fold. + +* In `Streamly` module: + * `runStream` has been deprecated, please use `Streamly.Prelude.drain` + +* Remove deprecated module `Streamly.Time` (moved to Streamly.Internal.Data.Time) +* Remove module `Streamly.Internal` (functionality moved to the Internal hierarchy) + +### Bug Fixes + +* Fix a bug that caused `uniq` function to yield the same element twice. +* Fix a bug that caused "thread blocked indefinitely in an MVar operation" + exception in a parallel stream. +* Fix unbounded memory usage (leak) in `parallel` combinator. The bug manifests + when large streams are combined using `parallel`. + +### Major Enhancements + +This release contains a lot of new features and major enhancements. For more +details on the new features described below please see the haddock docs of the +modules on hackage. + +#### Exception Handling + +See `Streamly.Prelude` for new exception handling combinators like `before`, +`after`, `bracket`, `onException`, `finally`, `handle` etc. + +#### Composable Folds + +`Streamly.Data.Fold` module provides composable folds (stream consumers). Folds +allow splitting, grouping, partitioning, unzipping and nesting a stream onto +multiple folds without breaking the stream. Combinators are provided for +temporal and spatial window based fold operations, for example, to support +folding and aggregating data for timeout or inactivity based sessions. + +#### Composable Unfolds + +`Streamly.Data.Unfold` module provides composable stream generators. Unfolds allow +high performance merging/flattening/combining of stream generators. + +#### Streaming File IO + +`Streamly.FileSystem.Handle` provides handle based streaming file IO +operations. + +#### Streaming Network IO + +* `Streamly.Network.Socket` provides socket based streaming network IO +operations. + +* `Streamly.Network.Inet.TCP` provides combinators to build Inet/TCP +clients and servers. + +#### Concurrent concatMap + +The new `concatMapWith` in `Streamly.Prelude` combinator performs a +`concatMap` using a supplied merge/concat strategy. This is a very +powerful combinator as you can, for example, concat streams +concurrently using this. + +### Other Enhancements + +* Add the following new features/modules: + * _Unicode Strings_: `Streamly.Data.Unicode.Stream` module provides + encoding/decoding of character streams and other character stream + operations. + * _Arrays_: `Streamly.Memory.Array` module provides arrays for efficient + in-memory buffering and efficient interfacing with IO. + +* Add the following to `Streamly.Prelude`: + * `unfold`, `fold`, `scan` and `postscan` + * `concatUnfold` to concat a stream after unfolding each element + * `intervalsOf` and `chunksOf` + * `splitOn`, `splitOnSuffix`, `splitWithSuffix`, and `wordsBy` + * `groups`, `groupsBy` and `groupsByRolling` + * `postscanl'` and `postscanlM'` + * `intersperse` intersperse an element in between consecutive elements in + stream + * `trace` combinator maps a monadic function on a stream just for side + effects + * `tap` redirects a copy of the stream to a `Fold` + +## 0.6.1 (March 2019) + +### Bug Fixes + +* Fix a bug that caused `maxThreads` directive to be ignored when rate control + was not used. + +### Enhancements + +* Add GHCJS support +* Remove dependency on "clock" package + +## 0.6.0 (December 2018) + +### Breaking changes + +* `Monad` constraint may be needed on some of the existing APIs (`findIndices` + and `elemIndices`). + +### Enhancements + +* Add the following functions to Streamly.Prelude: + * Generation: `replicate`, `fromIndices`, `fromIndicesM` + * Enumeration: `Enumerable` type class, `enumerateFrom`, `enumerateFromTo`, + `enumerateFromThen`, `enumerateFromThenTo`, `enumerate`, `enumerateTo` + * Running: `runN`, `runWhile` + * Folds: `(!!)`, `maximumBy`, `minimumBy`, `the` + * Scans: `scanl1'`, `scanl1M' + * Filters: `uniq`, `insertBy`, `deleteBy`, `findM` + * Multi-stream: `eqBy`, `cmpBy`, `mergeBy`, `mergeByM`, `mergeAsyncBy`, + `mergeAsyncByM`, `isPrefixOf`, `isSubsequenceOf`, `stripPrefix`, + `concatMap`, `concatMapM`, `indexed`, `indexedR` +* Following instances were added for `SerialT m`, `WSerialT m` and + `ZipSerialM m`: + * When `m` ~ `Identity`: IsList, Eq, Ord, Show, Read, IsString, NFData, + NFData1, Traversable + * When `m` is `Foldable`: Foldable +* Performance improvements +* Add benchmarks to measure composed and iterated operations + +## 0.5.2 (October 2018) + +### Bug Fixes + +* Cleanup any pending threads when an exception occurs. +* Fixed a livelock in ahead style streams. The problem manifests sometimes when + multiple streams are merged together in ahead style and one of them is a nil + stream. +* As per expected concurrency semantics each forked concurrent task must run + with the monadic state captured at the fork point. This release fixes a bug, + which, in some cases caused an incorrect monadic state to be used for a + concurrent action, leading to unexpected behavior when concurrent streams are + used in a stateful monad e.g. `StateT`. Particularly, this bug cannot affect + `ReaderT`. + +## 0.5.1 (September 2018) + +* Performance improvements, especially space consumption, for concurrent + streams + +## 0.5.0 (September 2018) + +### Bug Fixes + +* Leftover threads are now cleaned up as soon as the consumer is garbage + collected. +* Fix a bug in concurrent function application that in certain cases would + unnecessarily share the concurrency state resulting in incorrect output + stream. +* Fix passing of state across `parallel`, `async`, `wAsync`, `ahead`, `serial`, + `wSerial` combinators. Without this fix combinators that rely on state + passing e.g. `maxThreads` and `maxBuffer` won't work across these + combinators. + +### Enhancements + +* Added rate limiting combinators `rate`, `avgRate`, `minRate`, `maxRate` and + `constRate` to control the yield rate of a stream. +* Add `foldl1'`, `foldr1`, `intersperseM`, `find`, `lookup`, `and`, `or`, + `findIndices`, `findIndex`, `elemIndices`, `elemIndex`, `init` to Prelude + +### Deprecations + +* The `Streamly.Time` module is now deprecated, its functionality is subsumed + by the new rate limiting combinators. + +## 0.4.1 (July 2018) + +### Bug Fixes + +* foldxM was not fully strict, fixed. + +## 0.4.0 (July 2018) + +### Breaking changes + +* Signatures of `zipWithM` and `zipAsyncWithM` have changed +* Some functions in prelude now require an additional `Monad` constraint on + the underlying type of the stream. + +### Deprecations + +* `once` has been deprecated and renamed to `yieldM` + +### Enhancements + +* Add concurrency control primitives `maxThreads` and `maxBuffer`. +* Concurrency of a stream with bounded concurrency when used with `take` is now + limited by the number of elements demanded by `take`. +* Significant performance improvements utilizing stream fusion optimizations. +* Add `yield` to construct a singleton stream from a pure value +* Add `repeat` to generate an infinite stream by repeating a pure value +* Add `fromList` and `fromListM` to generate streams from lists, faster than + `fromFoldable` and `fromFoldableM` +* Add `map` as a synonym of fmap +* Add `scanlM'`, the monadic version of scanl' +* Add `takeWhileM` and `dropWhileM` +* Add `filterM` + +## 0.3.0 (June 2018) + +### Breaking changes + +* Some prelude functions, to whom concurrency capability has been added, will + now require a `MonadAsync` constraint. + +### Bug Fixes + +* Fixed a race due to which, in a rare case, we might block indefinitely on + an MVar due to a lost wakeup. +* Fixed an issue in adaptive concurrency. The issue caused us to stop creating + more worker threads in some cases due to a race. This bug would not cause any + functional issue but may reduce concurrency in some cases. + +### Enhancements +* Added a concurrent lookahead stream type `Ahead` +* Added `fromFoldableM` API that creates a stream from a container of monadic + actions +* Monadic stream generation functions `consM`, `|:`, `unfoldrM`, `replicateM`, + `repeatM`, `iterateM` and `fromFoldableM` can now generate streams + concurrently when used with concurrent stream types. +* Monad transformation functions `mapM` and `sequence` can now map actions + concurrently when used at appropriate stream types. +* Added concurrent function application operators to run stages of a + stream processing function application pipeline concurrently. +* Added `mapMaybe` and `mapMaybeM`. + +## 0.2.1 (June 2018) + +### Bug Fixes +* Fixed a bug that caused some transformation ops to return incorrect results + when used with concurrent streams. The affected ops are `take`, `filter`, + `takeWhile`, `drop`, `dropWhile`, and `reverse`. + +## 0.2.0 (May 2018) + +### Breaking changes +* Changed the semantics of the Semigroup instance for `InterleavedT`, `AsyncT` + and `ParallelT`. The new semantics are as follows: + * For `InterleavedT`, `<>` operation interleaves two streams + * For `AsyncT`, `<>` now concurrently merges two streams in a left biased + manner using demand based concurrency. + * For `ParallelT`, the `<>` operation now concurrently meges the two streams + in a fairly parallel manner. + + To adapt to the new changes, replace `<>` with `serial` wherever it is used + for stream types other than `StreamT`. + +* Remove the `Alternative` instance. To adapt to this change replace any usage + of `<|>` with `parallel` and `empty` with `nil`. +* Stream type now defaults to the `SerialT` type unless explicitly specified + using a type combinator or a monomorphic type. This change reduces puzzling + type errors for beginners. It includes the following two changes: + * Change the type of all stream elimination functions to use `SerialT` + instead of a polymorphic type. This makes sure that the stream type is + always fixed at all exits. + * Change the type combinators (e.g. `parallely`) to only fix the argument + stream type and the output stream type remains polymorphic. + + Stream types may have to be changed or type combinators may have to be added + or removed to adapt to this change. +* Change the type of `foldrM` to make it consistent with `foldrM` in base. +* `async` is renamed to `mkAsync` and `async` is now a new API with a different + meaning. +* `ZipAsync` is renamed to `ZipAsyncM` and `ZipAsync` is now ZipAsyncM + specialized to the IO Monad. +* Remove the `MonadError` instance as it was not working correctly for + parallel compositions. Use `MonadThrow` instead for error propagation. +* Remove Num/Fractional/Floating instances as they are not very useful. Use + `fmap` and `liftA2` instead. + +### Deprecations +* Deprecate and rename the following symbols: + * `Streaming` to `IsStream` + * `runStreaming` to `runStream` + * `StreamT` to `SerialT` + * `InterleavedT` to `WSerialT` + * `ZipStream` to `ZipSerialM` + * `ZipAsync` to `ZipAsyncM` + * `interleaving` to `wSerially` + * `zipping` to `zipSerially` + * `zippingAsync` to `zipAsyncly` + * `<=>` to `wSerial` + * `<|` to `async` + * `each` to `fromFoldable` + * `scan` to `scanx` + * `foldl` to `foldx` + * `foldlM` to `foldxM` +* Deprecate the following symbols for future removal: + * `runStreamT` + * `runInterleavedT` + * `runAsyncT` + * `runParallelT` + * `runZipStream` + * `runZipAsync` + +### Enhancements +* Add the following functions: + * `consM` and `|:` operator to construct streams from monadic actions + * `once` to create a singleton stream from a monadic action + * `repeatM` to construct a stream by repeating a monadic action + * `scanl'` strict left scan + * `foldl'` strict left fold + * `foldlM'` strict left fold with a monadic fold function + * `serial` run two streams serially one after the other + * `async` run two streams asynchronously + * `parallel` run two streams in parallel (replaces `<|>`) + * `WAsyncT` stream type for BFS version of `AsyncT` composition +* Add simpler stream types that are specialized to the IO monad +* Put a bound (1500) on the output buffer used for asynchronous tasks +* Put a limit (1500) on the number of threads used for Async and WAsync types + +## 0.1.2 (March 2018) + +### Enhancements +* Add `iterate`, `iterateM` stream operations + +### Bug Fixes +* Fixed a bug that caused unexpected behavior when `pure` was used to inject + values in Applicative composition of `ZipStream` and `ZipAsync` types. + +## 0.1.1 (March 2018) + +### Enhancements +* Make `cons` right associative and provide an operator form `.:` for it +* Add `null`, `tail`, `reverse`, `replicateM`, `scan` stream operations +* Improve performance of some stream operations (`foldl`, `dropWhile`) + +### Bug Fixes +* Fix the `product` operation. Earlier, it always returned 0 due to a bug +* Fix the `last` operation, which returned `Nothing` for singleton streams + +## 0.1.0 (December 2017) + +* Initial release diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -34,8 +34,8 @@ and benchmarking tasks conveniently. They support running a group of tests or benchmarks, coverage, using correct optimization flags for benchmarking, benchmark comparison reports etc. Use the `--help` option -to see how to use these. See [benchmark/README.md](benchmark/README.md) -and [test/README.md](test/README.md) for more details. +to see how to use these. See [benchmark/README.md](/benchmark/README.md) +and [test/README.md](/test/README.md) for more details. You can also run tests or benchmarks directly for example: @@ -86,13 +86,13 @@ * Compiler warnings are fixed * Reasonable hlint suggestions are accepted * Tests are added to cover the changed parts -* All [tests](test) pass -* [Performance benchmarks](benchmark) are added, where applicable -* No significant regressions are reported by [performance benchmarks](benchmark/README.md) +* All [tests](/test) pass +* [Performance benchmarks](/benchmark) are added, where applicable +* No significant regressions are reported by [performance benchmarks](/benchmark/README.md) * Haddock documentation is added to user visible APIs and data types -* Tutorial module, [README](README.md), and [guides](docs) are updated if - necessary. -* [Changelog](Changelog.md) is updated if needed +* Tutorial module, [Introduction](/docs/Introduction.md), and [guides](/docs) are + updated if necessary. +* [Changelog](/docs/Changelog.md) is updated if needed * The code conforms to the license, it is not stolen, credit is given, copyright notices are retained, original license is included if needed. @@ -145,8 +145,8 @@ ### Testing It is a good idea to include tests for the changes where applicable. See -the existing tests in the [test](test) directory. Also see the -[test/README](test/README) for more details on how to run the tests. +the existing tests in the [test](/test) directory. Also see the +[test/README.md](/test/README.md) for more details on how to run the tests. ### Documentation @@ -154,7 +154,7 @@ is easily understood by the end programmer and does not sound highfalutin, and preferably with examples. If your change affects the tutorial or needs to be mentioned in the tutorial then please update the tutorial. Check if the -additional [guides](docs) are affected or need to updated. +additional [guides](/docs) are affected or need to updated. ### Performance Benchmarks @@ -163,13 +163,13 @@ then you may want to add benchmarks to check if it performs as well as expected by the programmers to deem it usable. -See the [README](benchmark/README) file in the `benchmark` directory for more +See the [README](/benchmark/README.md) file in the `benchmark` directory for more details on how to run the benchmarks. The first level of check is the regression in "allocations", this is the most stable measure of regression. "bytesCopied" is another stable measure, it gives an idea of the amount of long lived data being copied -across generations of GC. +across generations of GC. The next measure to look at is "cpuTime" this may have some variance from run to run because of factors like cpu frequency scaling, load on @@ -222,7 +222,7 @@ * Use https://streamly.composewell.com/ for searching in reference docs * Build haddock docs for latest reference docs -* See [the dev directory](dev) for design guidelines and dev documents. +* See [the dev directory](/dev) for design guidelines and dev documents. ## Coding Guidelines diff --git a/Changelog.md b/Changelog.md deleted file mode 100644 --- a/Changelog.md +++ /dev/null @@ -1,533 +0,0 @@ -# Changelog - - - -## 0.8.1.1 (Dec 2021) - -* Disable building FileSystem.Events where FS Events isn't supported. - -## 0.8.1 (Nov 2021) - -See docs/API-changelog.txt for new APIs introduced. - -### Bug Fixes - -* Several bug fixes in the Array module: - * Fix writeN fold eating away one element when applied multiple times - [#1258](https://github.com/composewell/streamly/issues/1258). - * Fix potentially writing beyond allocated memory when shrinking. Likely - cause of [#944](https://github.com/composewell/streamly/issues/944). - * Fix potentially writing beyond allocated memory when writing the last - element. Likely cause of - [#944](https://github.com/composewell/streamly/issues/944). - * Fix missing pointer touch could potentially cause use of freed memory. - * Fix unnecessary additional allocation due to a bug -* Fix a bug in classifySessionsBy, see - [PR #1311](https://github.com/composewell/streamly/pull/1311). The bug - could cause premature ejection of a session when input events with the - same key are split into multiple sessions. - -### Notable Internal API Changes - -* `tapAsync` from `Streamly.Internal.Data.Stream.Parallel` has been moved to - `Streamly.Internal.Data.Stream.IsStream` and renamed to `tapAsyncK`. -* `Fold2` has now been renamed to `Refold` and the corresponding `Fold2` - combinators have been either renamed or removed. - -## 0.8.0 (Jun 2021) - -See [API Changelog](docs/API-changelog.txt) for a complete list of signature -changes and new APIs introduced. - -### Breaking changes - -* `Streamly.Prelude` - * `fold`: this function may now terminate early without consuming - the entire stream. For example, `fold Fold.head stream` would - now terminate immediately after consuming the head element from - `stream`. This may result in change of behavior in existing programs - if the program relies on the evaluation of the full stream. -* `Streamly.Data.Unicode.Stream` - * The following APIs no longer throw errors on invalid input, use new - APIs suffixed with a prime for strict behavior: - * decodeUtf8 - * encodeLatin1 - * encodeUtf8 -* `Streamly.Data.Fold`: - * Several instances have been moved to the `Streamly.Data.Fold.Tee` - module, please use the `Tee` type to adapt to the changes. - -### Bug Fixes - -* Concurrent Streams: The monadic state for the stream is now propagated across - threads. Please refer to - [#369](https://github.com/composewell/streamly/issues/369) for more info. -* `Streamly.Prelude`: - * `bracket`, `handle`, and `finally` now also work correctly on streams - that aren't fully drained. Also, the resource acquisition and release is - atomic with respect to async exceptions. - * `iterate`, `iterateM` now consume O(1) space instead of O(n). - * `fromFoldableM` is fixed to be concurrent. -* `Streamly.Network.Inet.TCP`: `accept` and `connect` APIs now close the socket - if an exception is thrown. -* `Streamly.Network.Socket`: `accept` now closes the socket if an exception is - thrown. - -### Enhancements - -* See [API Changelog](docs/API-changelog.txt) for a complete list of new - modules and APIs introduced. -* The Fold type is now more powerful, the new termination behavior allows - to express basic parsing of streams using folds. -* Many new Fold and Unfold APIs are added. -* A new module for console IO APIs is added. -* Experimental modules for the following are added: - * Parsing - * Deserialization - * File system event handling (fsnotify/inotify) - * Folds for streams of arrays -* Experimental `use-c-malloc` build flag to use the c library `malloc` for - array allocations. This could be useful to avoid pinned memory fragmentation. - - -### Notable Internal/Pre-release API Changes - -Breaking changes: - -* The `Fold` type has changed to accommodate terminating folds. -* Rename: `Streamly.Internal.Prelude` => `Streamly.Internal.Data.Stream.IsStream` -* Several other internal modules have been renamed and re-factored. - -Bug fixes: - -* A bug was fixed in the conversion of `MicroSecond64` and `MilliSecond64` - (commit e5119626) -* Bug fix: `classifySessionsBy` now flushes sessions at the end and terminates. - -### Miscellaneous - -* Drop support for GHC 7.10.3. -* The examples in this package are moved to a new github repo - [streamly-examples](https://github.com/composewell/streamly-examples) - -## 0.7.3 (February 2021) - -### Build Issues - -* Fix build issues with primitive package version >= 0.7.1. -* Fix build issues on armv7. - -## 0.7.2 (April 2020) - -### Bug Fixes - -* Fix a bug in the `Applicative` and `Functor` instances of the `Fold` - data type. - -### Build Issues - -* Fix a bug that occasionally caused a build failure on windows when - used with `stack` or `stack ghci`. -* Now builds on 32-bit machines. -* Now builds with `primitive` package version >= 0.5.4 && <= 0.6.4.0 -* Now builds with newer `QuickCheck` package version >= 2.14 && < 2.15. -* Now builds with GHC 8.10. - -## 0.7.1 (February 2020) - -### Bug Fixes - -* Fix a bug that caused `findIndices` to return wrong indices in some - cases. -* Fix a bug in `tap`, `chunksOf` that caused memory consumption to - increase in some cases. -* Fix a space leak in concurrent streams (`async`, `wAsync`, and `ahead`) that - caused memory consumption to increase with the number of elements in the - stream, especially when built with `-threaded` and used with `-N` RTS option. - The issue occurs only in cases when a worker thread happens to be used - continuously for a long time. -* Fix scheduling of WAsyncT stream style to be in round-robin fashion. -* Now builds with `containers` package version < 0.5.8. -* Now builds with `network` package version >= 3.0.0.0 && < 3.1.0.0. - -### Behavior change - -* Combinators in `Streamly.Network.Inet.TCP` no longer use TCP `NoDelay` and - `ReuseAddr` socket options by default. These options can now be specified - using appropriate combinators. - -### Performance - -* Now uses `fusion-plugin` package for predictable stream fusion optimizations -* Significant improvement in performance of concurrent stream operations. -* Improved space and time performance of `Foldable` instance. - -## 0.7.0 (November 2019) - -### Breaking changes - -* Change the signature of `foldrM` to ensure that it is lazy -* Change the signature of `iterateM` to ensure that it is lazy. -* `scanx` would now require an additional `Monad m` constraint. - -### Behavior change - -* Earlier `ParallelT` was unaffected by `maxBuffer` directive, now `maxBuffer` - can limit the buffer of a `ParallelT` stream as well. When the buffer becomes - full, the producer threads block. -* `ParallelT` streams no longer have an unlimited buffer by default. Now the - buffer for parallel streams is limited to 1500 by default, the same as other - concurrent stream types. - -### Deprecations - -* In `Streamly.Prelude`: - * `runStream` has been replaced by `drain` - * `runN` has been replaced by `drainN` - * `runWhile` has been replaced by `drainWhile` - * `fromHandle` has been deprecated. Please use - `Streamly.FileSystem.Handle.read`, `Streamly.Data.Unicode.Stream.decodeUtf8` and - `splitOnSuffix` with `Streamly.Data.Fold.toList` to split the - stream to a stream of `String` separated by a newline. - * `toHandle` has been deprecated. Please use `intersperse` and `concatUnfold` to - add newlines to a stream, `Streamly.Data.Unicode.Stream.encodeUtf8` for encoding and - `Streamly.FileSystem.Handle.write` for writing to a file handle. - * Deprecate `scanx`, `foldx`, `foldxM`, `foldr1` - * Remove deprecated APIs `foldl`, `foldlM` - * Replace deprecated API `scan` with a new signature, to scan using Fold. - -* In `Streamly` module: - * `runStream` has been deprecated, please use `Streamly.Prelude.drain` - -* Remove deprecated module `Streamly.Time` (moved to Streamly.Internal.Data.Time) -* Remove module `Streamly.Internal` (functionality moved to the Internal hierarchy) - -### Bug Fixes - -* Fix a bug that caused `uniq` function to yield the same element twice. -* Fix a bug that caused "thread blocked indefinitely in an MVar operation" - exception in a parallel stream. -* Fix unbounded memory usage (leak) in `parallel` combinator. The bug manifests - when large streams are combined using `parallel`. - -### Major Enhancements - -This release contains a lot of new features and major enhancements. For more -details on the new features described below please see the haddock docs of the -modules on hackage. - -#### Exception Handling - -See `Streamly.Prelude` for new exception handling combinators like `before`, -`after`, `bracket`, `onException`, `finally`, `handle` etc. - -#### Composable Folds - -`Streamly.Data.Fold` module provides composable folds (stream consumers). Folds -allow splitting, grouping, partitioning, unzipping and nesting a stream onto -multiple folds without breaking the stream. Combinators are provided for -temporal and spatial window based fold operations, for example, to support -folding and aggregating data for timeout or inactivity based sessions. - -#### Composable Unfolds - -`Streamly.Data.Unfold` module provides composable stream generators. Unfolds allow -high performance merging/flattening/combining of stream generators. - -#### Streaming File IO - -`Streamly.FileSystem.Handle` provides handle based streaming file IO -operations. - -#### Streaming Network IO - -* `Streamly.Network.Socket` provides socket based streaming network IO -operations. - -* `Streamly.Network.Inet.TCP` provides combinators to build Inet/TCP -clients and servers. - -#### Concurrent concatMap - -The new `concatMapWith` in `Streamly.Prelude` combinator performs a -`concatMap` using a supplied merge/concat strategy. This is a very -powerful combinator as you can, for example, concat streams -concurrently using this. - -### Other Enhancements - -* Add the following new features/modules: - * _Unicode Strings_: `Streamly.Data.Unicode.Stream` module provides - encoding/decoding of character streams and other character stream - operations. - * _Arrays_: `Streamly.Memory.Array` module provides arrays for efficient - in-memory buffering and efficient interfacing with IO. - -* Add the following to `Streamly.Prelude`: - * `unfold`, `fold`, `scan` and `postscan` - * `concatUnfold` to concat a stream after unfolding each element - * `intervalsOf` and `chunksOf` - * `splitOn`, `splitOnSuffix`, `splitWithSuffix`, and `wordsBy` - * `groups`, `groupsBy` and `groupsByRolling` - * `postscanl'` and `postscanlM'` - * `intersperse` intersperse an element in between consecutive elements in - stream - * `trace` combinator maps a monadic function on a stream just for side - effects - * `tap` redirects a copy of the stream to a `Fold` - -## 0.6.1 (March 2019) - -### Bug Fixes - -* Fix a bug that caused `maxThreads` directive to be ignored when rate control - was not used. - -### Enhancements - -* Add GHCJS support -* Remove dependency on "clock" package - -## 0.6.0 (December 2018) - -### Breaking changes - -* `Monad` constraint may be needed on some of the existing APIs (`findIndices` - and `elemIndices`). - -### Enhancements - -* Add the following functions to Streamly.Prelude: - * Generation: `replicate`, `fromIndices`, `fromIndicesM` - * Enumeration: `Enumerable` type class, `enumerateFrom`, `enumerateFromTo`, - `enumerateFromThen`, `enumerateFromThenTo`, `enumerate`, `enumerateTo` - * Running: `runN`, `runWhile` - * Folds: `(!!)`, `maximumBy`, `minimumBy`, `the` - * Scans: `scanl1'`, `scanl1M' - * Filters: `uniq`, `insertBy`, `deleteBy`, `findM` - * Multi-stream: `eqBy`, `cmpBy`, `mergeBy`, `mergeByM`, `mergeAsyncBy`, - `mergeAsyncByM`, `isPrefixOf`, `isSubsequenceOf`, `stripPrefix`, - `concatMap`, `concatMapM`, `indexed`, `indexedR` -* Following instances were added for `SerialT m`, `WSerialT m` and - `ZipSerialM m`: - * When `m` ~ `Identity`: IsList, Eq, Ord, Show, Read, IsString, NFData, - NFData1, Traversable - * When `m` is `Foldable`: Foldable -* Performance improvements -* Add benchmarks to measure composed and iterated operations - -## 0.5.2 (October 2018) - -### Bug Fixes - -* Cleanup any pending threads when an exception occurs. -* Fixed a livelock in ahead style streams. The problem manifests sometimes when - multiple streams are merged together in ahead style and one of them is a nil - stream. -* As per expected concurrency semantics each forked concurrent task must run - with the monadic state captured at the fork point. This release fixes a bug, - which, in some cases caused an incorrect monadic state to be used for a - concurrent action, leading to unexpected behavior when concurrent streams are - used in a stateful monad e.g. `StateT`. Particularly, this bug cannot affect - `ReaderT`. - -## 0.5.1 (September 2018) - -* Performance improvements, especially space consumption, for concurrent - streams - -## 0.5.0 (September 2018) - -### Bug Fixes - -* Leftover threads are now cleaned up as soon as the consumer is garbage - collected. -* Fix a bug in concurrent function application that in certain cases would - unnecessarily share the concurrency state resulting in incorrect output - stream. -* Fix passing of state across `parallel`, `async`, `wAsync`, `ahead`, `serial`, - `wSerial` combinators. Without this fix combinators that rely on state - passing e.g. `maxThreads` and `maxBuffer` won't work across these - combinators. - -### Enhancements - -* Added rate limiting combinators `rate`, `avgRate`, `minRate`, `maxRate` and - `constRate` to control the yield rate of a stream. -* Add `foldl1'`, `foldr1`, `intersperseM`, `find`, `lookup`, `and`, `or`, - `findIndices`, `findIndex`, `elemIndices`, `elemIndex`, `init` to Prelude - -### Deprecations - -* The `Streamly.Time` module is now deprecated, its functionality is subsumed - by the new rate limiting combinators. - -## 0.4.1 (July 2018) - -### Bug Fixes - -* foldxM was not fully strict, fixed. - -## 0.4.0 (July 2018) - -### Breaking changes - -* Signatures of `zipWithM` and `zipAsyncWithM` have changed -* Some functions in prelude now require an additional `Monad` constraint on - the underlying type of the stream. - -### Deprecations - -* `once` has been deprecated and renamed to `yieldM` - -### Enhancements - -* Add concurrency control primitives `maxThreads` and `maxBuffer`. -* Concurrency of a stream with bounded concurrency when used with `take` is now - limited by the number of elements demanded by `take`. -* Significant performance improvements utilizing stream fusion optimizations. -* Add `yield` to construct a singleton stream from a pure value -* Add `repeat` to generate an infinite stream by repeating a pure value -* Add `fromList` and `fromListM` to generate streams from lists, faster than - `fromFoldable` and `fromFoldableM` -* Add `map` as a synonym of fmap -* Add `scanlM'`, the monadic version of scanl' -* Add `takeWhileM` and `dropWhileM` -* Add `filterM` - -## 0.3.0 (June 2018) - -### Breaking changes - -* Some prelude functions, to whom concurrency capability has been added, will - now require a `MonadAsync` constraint. - -### Bug Fixes - -* Fixed a race due to which, in a rare case, we might block indefinitely on - an MVar due to a lost wakeup. -* Fixed an issue in adaptive concurrency. The issue caused us to stop creating - more worker threads in some cases due to a race. This bug would not cause any - functional issue but may reduce concurrency in some cases. - -### Enhancements -* Added a concurrent lookahead stream type `Ahead` -* Added `fromFoldableM` API that creates a stream from a container of monadic - actions -* Monadic stream generation functions `consM`, `|:`, `unfoldrM`, `replicateM`, - `repeatM`, `iterateM` and `fromFoldableM` can now generate streams - concurrently when used with concurrent stream types. -* Monad transformation functions `mapM` and `sequence` can now map actions - concurrently when used at appropriate stream types. -* Added concurrent function application operators to run stages of a - stream processing function application pipeline concurrently. -* Added `mapMaybe` and `mapMaybeM`. - -## 0.2.1 (June 2018) - -### Bug Fixes -* Fixed a bug that caused some transformation ops to return incorrect results - when used with concurrent streams. The affected ops are `take`, `filter`, - `takeWhile`, `drop`, `dropWhile`, and `reverse`. - -## 0.2.0 (May 2018) - -### Breaking changes -* Changed the semantics of the Semigroup instance for `InterleavedT`, `AsyncT` - and `ParallelT`. The new semantics are as follows: - * For `InterleavedT`, `<>` operation interleaves two streams - * For `AsyncT`, `<>` now concurrently merges two streams in a left biased - manner using demand based concurrency. - * For `ParallelT`, the `<>` operation now concurrently meges the two streams - in a fairly parallel manner. - - To adapt to the new changes, replace `<>` with `serial` wherever it is used - for stream types other than `StreamT`. - -* Remove the `Alternative` instance. To adapt to this change replace any usage - of `<|>` with `parallel` and `empty` with `nil`. -* Stream type now defaults to the `SerialT` type unless explicitly specified - using a type combinator or a monomorphic type. This change reduces puzzling - type errors for beginners. It includes the following two changes: - * Change the type of all stream elimination functions to use `SerialT` - instead of a polymorphic type. This makes sure that the stream type is - always fixed at all exits. - * Change the type combinators (e.g. `parallely`) to only fix the argument - stream type and the output stream type remains polymorphic. - - Stream types may have to be changed or type combinators may have to be added - or removed to adapt to this change. -* Change the type of `foldrM` to make it consistent with `foldrM` in base. -* `async` is renamed to `mkAsync` and `async` is now a new API with a different - meaning. -* `ZipAsync` is renamed to `ZipAsyncM` and `ZipAsync` is now ZipAsyncM - specialized to the IO Monad. -* Remove the `MonadError` instance as it was not working correctly for - parallel compositions. Use `MonadThrow` instead for error propagation. -* Remove Num/Fractional/Floating instances as they are not very useful. Use - `fmap` and `liftA2` instead. - -### Deprecations -* Deprecate and rename the following symbols: - * `Streaming` to `IsStream` - * `runStreaming` to `runStream` - * `StreamT` to `SerialT` - * `InterleavedT` to `WSerialT` - * `ZipStream` to `ZipSerialM` - * `ZipAsync` to `ZipAsyncM` - * `interleaving` to `wSerially` - * `zipping` to `zipSerially` - * `zippingAsync` to `zipAsyncly` - * `<=>` to `wSerial` - * `<|` to `async` - * `each` to `fromFoldable` - * `scan` to `scanx` - * `foldl` to `foldx` - * `foldlM` to `foldxM` -* Deprecate the following symbols for future removal: - * `runStreamT` - * `runInterleavedT` - * `runAsyncT` - * `runParallelT` - * `runZipStream` - * `runZipAsync` - -### Enhancements -* Add the following functions: - * `consM` and `|:` operator to construct streams from monadic actions - * `once` to create a singleton stream from a monadic action - * `repeatM` to construct a stream by repeating a monadic action - * `scanl'` strict left scan - * `foldl'` strict left fold - * `foldlM'` strict left fold with a monadic fold function - * `serial` run two streams serially one after the other - * `async` run two streams asynchronously - * `parallel` run two streams in parallel (replaces `<|>`) - * `WAsyncT` stream type for BFS version of `AsyncT` composition -* Add simpler stream types that are specialized to the IO monad -* Put a bound (1500) on the output buffer used for asynchronous tasks -* Put a limit (1500) on the number of threads used for Async and WAsync types - -## 0.1.2 (March 2018) - -### Enhancements -* Add `iterate`, `iterateM` stream operations - -### Bug Fixes -* Fixed a bug that caused unexpected behavior when `pure` was used to inject - values in Applicative composition of `ZipStream` and `ZipAsync` types. - -## 0.1.1 (March 2018) - -### Enhancements -* Make `cons` right associative and provide an operator form `.:` for it -* Add `null`, `tail`, `reverse`, `replicateM`, `scan` stream operations -* Improve performance of some stream operations (`foldl`, `dropWhile`) - -### Bug Fixes -* Fix the `product` operation. Earlier, it always returned 0 due to a bug -* Fix the `last` operation, which returned `Nothing` for singleton streams - -## 0.1.0 (December 2017) - -* Initial release diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -43,11 +43,11 @@ If you wish to follow along with this guide, you will need to have [Streamly][] installed. -Please see the [Getting Started With The Streamly Package](docs/getting-started.md) +Please see the [Getting Started With The Streamly Package](/docs/getting-started.md) guide for instructions on how to install [Streamly][]. If you wish to run benchmarks, please be sure to build your -application using the instructions in the [Build Guide](docs/building.md). +application using the instructions in the [Build Guide](/docs/Compiling.md). ### An overview of the types used in these examples @@ -296,7 +296,7 @@ ``` These example programs have assumed ASCII encoded input data. For UTF-8 -streams, we have a [concurrent wc implementation][WordCountUTF8.hs] +streams, we have a [concurrent wc implementation][WordCountParallelUTF8.hs] with UTF-8 decoding. This concurrent implementation performs as well as the standard `wc` program in serial benchmarks. In concurrent mode [Streamly][]'s implementation can utilise multiple processing cores if @@ -490,7 +490,7 @@ * [Streaming Benchmarks][streaming-benchmarks] * [Concurrency Benchmarks][concurrency-benchmarks] * Functional Conf 2019 [Video](https://www.youtube.com/watch?v=uzsqgdMMgtk) | [Slides](https://www.slideshare.net/HarendraKumar10/streamly-concurrent-data-flow-programming) -* [Other Guides](docs/) +* [Other Guides](/) * [Streamly Homepage][Streamly] ## Performance @@ -595,7 +595,7 @@ * Gabriella Gonzalez ([foldl](https://hackage.haskell.org/package/foldl)) * Alberto G. Corona ([transient](https://hackage.haskell.org/package/transient)) -Please see the [`credits`](./credits/README.md) directory for a full +Please see the [`credits`](/docs/Credits.md) directory for a full list of contributors, credits and licenses. ## Licensing @@ -637,7 +637,7 @@ [WordCount.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCount.hs [WordCount.c]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCount.c [WordCountParallel.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCountParallel.hs -[WordCountUTF8.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCountUTF8.hs +[WordCountParallelUTF8.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCountParallelUTF8.hs [WordServer.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordServer.hs [MergeServer.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/MergeServer.hs [ListDir.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/ListDir.hs @@ -646,6 +646,6 @@ [CirclingSquare.hs]: https://github.com/composewell/streamly-examples/tree/master/examples/CirclingSquare.hs -[LICENSE]: LICENSE -[CONTRIBUTING.md]: CONTRIBUTING.md +[LICENSE]: /LICENSE +[CONTRIBUTING.md]: /CONTRIBUTING.md [docs]: docs/ diff --git a/benchmark/README.md b/benchmark/README.md --- a/benchmark/README.md +++ b/benchmark/README.md @@ -129,6 +129,14 @@ The automatic tests do not test unicode input, this option is useful to specify a unicode text file manually. +## Running benchmarks on valid UTF8 input + +To run the unicode benchmarks on valid utf8 input, you can do the following, + +``` +$ Benchmark_FileSystem_Handle_InputFile= bin/bench.sh --benchmarks Unicode.Stream --cabal-build-options "-f include-strict-utf8" +``` + ## Benchmarking notes We run each benchmark in an isolated process to minimize interference @@ -302,7 +310,7 @@ ### Resolving the problem Review the problematic code, see [the optimization -guide](dev/optimization-guidelines.md) for common problems and how to +guide](/dev/optimization-guidelines.md) for common problems and how to solve those. If no obvious issues are found on review, then generate and examine the core. diff --git a/benchmark/Streamly/Benchmark/Data/Array.hs b/benchmark/Streamly/Benchmark/Data/Array.hs --- a/benchmark/Streamly/Benchmark/Data/Array.hs +++ b/benchmark/Streamly/Benchmark/Data/Array.hs @@ -1,139 +1,84 @@ --- | --- Module : Main --- Copyright : (c) 2020 Composewell Technologies --- --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com - {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -import Control.DeepSeq (NFData(..)) -import System.Random (randomRIO) +#include "Streamly/Benchmark/Data/Array/CommonImports.hs" -import qualified Streamly.Benchmark.Data.ArrayOps as Ops -import qualified Streamly.Data.Array.Foreign as A +import Control.DeepSeq (deepseq) -#ifdef DATA_ARRAY import qualified Streamly.Internal.Data.Array as IA -#else -import qualified Streamly.Internal.Data.Array.Foreign as IA -#endif -import qualified Streamly.Prelude as S +import qualified Streamly.Internal.Data.Array as A +type Stream = A.Array -import Gauge -import Streamly.Benchmark.Common hiding (benchPureSrc) -import qualified Streamly.Benchmark.Prelude as P +#include "Streamly/Benchmark/Data/Array/Common.hs" -#ifdef MEMORY_ARRAY -import qualified GHC.Exts as GHC -#endif +------------------------------------------------------------------------------- +-- Benchmark helpers +------------------------------------------------------------------------------- -#if !defined(DATA_ARRAY_PRIM) && !defined(DATA_ARRAY_PRIM_PINNED) -import Control.DeepSeq (deepseq) -#endif +-- Drain a source that generates an array in the IO monad +{-# INLINE benchIOSrc #-} +benchIOSrc :: NFData a => String -> (Int -> IO (Stream a)) -> Benchmark +benchIOSrc name src = benchIO name src id ------------------------------------------------------------------------------- --- +-- Bench Ops ------------------------------------------------------------------------------- -#ifdef MEMORY_ARRAY --- Drain a source that generates a pure array -{-# INLINE benchPureSrc #-} -benchPureSrc :: String -> (Int -> Ops.Stream a) -> Benchmark -benchPureSrc name src = benchPure name src id -#endif +{-# INLINE sourceIntFromToFromList #-} +sourceIntFromToFromList :: MonadIO m => Int -> Int -> m (Stream Int) +sourceIntFromToFromList value n = P.return $ A.fromListN value [n..n + value] -{-# INLINE benchIO #-} -benchIO :: NFData b => String -> (Int -> IO a) -> (a -> b) -> Benchmark -benchIO name src f = bench name $ nfIO $ - randomRIO (1,1) >>= src >>= return . f --- Drain a source that generates an array in the IO monad -{-# INLINE benchIOSrc #-} -benchIOSrc :: -#if !defined(DATA_ARRAY_PRIM) \ - && !defined(DATA_ARRAY_PRIM_PINNED) \ - && !defined(MEMORY_ARRAY) - NFData a => -#endif - String -> (Int -> IO (Ops.Stream a)) -> Benchmark -benchIOSrc name src = benchIO name src id +{-# INLINE readInstance #-} +readInstance :: P.String -> Stream Int +readInstance str = + let r = P.reads str + in case r of + [(x,"")] -> x + _ -> P.error "readInstance: no parse" -{-# INLINE benchPureSink #-} -benchPureSink :: NFData b => Int -> String -> (Ops.Stream Int -> b) -> Benchmark -benchPureSink value name f = benchIO name (Ops.sourceIntFromTo value) f +#ifdef DEVBUILD +{- +{-# INLINE foldableFoldl' #-} +foldableFoldl' :: Stream Int -> Int +foldableFoldl' = F.foldl' (+) 0 -{-# INLINE benchIO' #-} -benchIO' :: NFData b => String -> (Int -> IO a) -> (a -> IO b) -> Benchmark -benchIO' name src f = bench name $ nfIO $ - randomRIO (1,1) >>= src >>= f +{-# INLINE foldableSum #-} +foldableSum :: Stream Int -> Int +foldableSum = P.sum +-} +#endif -{-# INLINE benchIOSink #-} -benchIOSink :: NFData b => Int -> String -> (Ops.Stream Int -> IO b) -> Benchmark -benchIOSink value name f = benchIO' name (Ops.sourceIntFromTo value) f +{-# INLINE sourceIntFromToFromStream #-} +sourceIntFromToFromStream :: MonadIO m => Int -> Int -> m (Stream Int) +sourceIntFromToFromStream value n = S.fold A.write $ S.enumerateFromTo n (n + value) +------------------------------------------------------------------------------- +-- Bench groups +------------------------------------------------------------------------------- + o_1_space_generation :: Int -> [Benchmark] o_1_space_generation value = [ bgroup "generation" - [ benchIOSrc "writeN . intFromTo" (Ops.sourceIntFromTo value) -#ifndef DATA_SMALLARRAY - , benchIOSrc "write . intFromTo" (Ops.sourceIntFromToFromStream value) -#endif - , benchIOSrc - "fromList . intFromTo" - (Ops.sourceIntFromToFromList value) - , benchIOSrc "writeN . unfoldr" (Ops.sourceUnfoldr value) - , benchIOSrc "writeN . fromList" (Ops.sourceFromList value) -#ifdef MEMORY_ARRAY - , benchPureSrc "writeN . IsList.fromList" (Ops.sourceIsList value) - , benchPureSrc - "writeN . IsString.fromString" - (Ops.sourceIsString value) -#endif -#if !defined(DATA_ARRAY_PRIM) && !defined(DATA_ARRAY_PRIM_PINNED) -#ifdef DATA_SMALLARRAY - , let testStr = - "fromListN " ++ - show (value + 1) ++ - "[1" ++ concat (replicate value ",1") ++ "]" -#else + [ benchIOSrc "write . intFromTo" (sourceIntFromToFromStream value) , let testStr = mkListString value -#endif - in testStr `deepseq` (bench "read" $ nf Ops.readInstance testStr) -#endif - , benchPureSink value "show" Ops.showInstance + in testStr `deepseq` bench "read" (nf readInstance testStr) ] ] o_1_space_elimination :: Int -> [Benchmark] o_1_space_elimination value = [ bgroup "elimination" - [ benchPureSink value "id" id - , benchPureSink value "==" Ops.eqInstance - , benchPureSink value "/=" Ops.eqInstanceNotEq - , benchPureSink value "<" Ops.ordInstance - , benchPureSink value "min" Ops.ordInstanceMin -#ifdef MEMORY_ARRAY - -- length is used to check for foldr/build fusion - , benchPureSink value "length . IsList.toList" (length . GHC.toList) -#endif - , benchIOSink value "foldl'" Ops.pureFoldl' - , benchIOSink value "read" Ops.unfoldReadDrain - , benchIOSink value "toStreamRev" Ops.toStreamRevDrain - , benchFold "writeLastN.1" + [ benchFold "writeLastN.1" (S.fold (IA.writeLastN 1)) (P.sourceUnfoldrM value) , benchFold "writeLastN.10" (S.fold (IA.writeLastN 10)) (P.sourceUnfoldrM value) -#if !defined(DATA_ARRAY_PRIM) && !defined(DATA_ARRAY_PRIM_PINNED) #ifdef DEVBUILD {- - , benchPureSink value "foldable/foldl'" Ops.foldableFoldl' - , benchPureSink value "foldable/sum" Ops.foldableSum + benchPureSink value "foldable/foldl'" foldableFoldl' + , benchPureSink value "foldable/sum" foldableSum -} #endif -#endif ] ] @@ -144,49 +89,14 @@ -- Converting the stream to an array benchFold "writeLastN.Max" (S.fold (IA.writeLastN (value + 1))) (P.sourceUnfoldrM value) - , benchFold "writeN" (S.fold (A.writeN value)) - (P.sourceUnfoldrM value) ] ] -o_1_space_transformation :: Int -> [Benchmark] -o_1_space_transformation value = - [ bgroup "transformation" - [ benchIOSink value "scanl'" (Ops.scanl' value 1) - , benchIOSink value "scanl1'" (Ops.scanl1' value 1) - , benchIOSink value "map" (Ops.map value 1) - ] - ] - -o_1_space_transformationX4 :: Int -> [Benchmark] -o_1_space_transformationX4 value = - [ bgroup "transformationX4" - [ benchIOSink value "scanl'" (Ops.scanl' value 4) - , benchIOSink value "scanl1'" (Ops.scanl1' value 4) - , benchIOSink value "map" (Ops.map value 4) - ] - ] - moduleName :: String -#ifdef DATA_SMALLARRAY -moduleName = "Data.SmallArray" -#elif defined(MEMORY_ARRAY) -moduleName = "Data.Array.Foreign" -#elif defined(DATA_ARRAY_PRIM) -moduleName = "Data.Array.Prim" -#elif defined(DATA_ARRAY_PRIM_PINNED) -moduleName = "Data.Array.Prim.Pinned" -#else moduleName = "Data.Array" -#endif -#ifdef DATA_SMALLARRAY defStreamSize :: Int -defStreamSize = 128 -#else -defStreamSize :: Int defStreamSize = defaultStreamSize -#endif main :: IO () main = runWithCLIOpts defStreamSize allBenchmarks @@ -194,12 +104,8 @@ where allBenchmarks size = - [ bgroup (o_1_space_prefix moduleName) $ concat - [ o_1_space_generation size - , o_1_space_elimination size - , o_1_space_transformation size - , o_1_space_transformationX4 size - ] + [ bgroup (o_1_space_prefix moduleName) $ + o_1_space_generation size ++ o_1_space_elimination size , bgroup (o_n_space_prefix moduleName) $ o_n_heap_serial size - ] + ] ++ commonBenchmarks size diff --git a/benchmark/Streamly/Benchmark/Data/Array/Common.hs b/benchmark/Streamly/Benchmark/Data/Array/Common.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Array/Common.hs @@ -0,0 +1,188 @@ + + +------------------------------------------------------------------------------- +-- Benchmark helpers +------------------------------------------------------------------------------- + +{-# INLINE benchIO #-} +benchIO :: NFData b => String -> (Int -> IO a) -> (a -> b) -> Benchmark +benchIO name src f = bench name $ nfIO $ + (randomRIO (1,1) >>= src) <&> f + +{-# INLINE benchPureSink #-} +benchPureSink :: NFData b => Int -> String -> (Stream Int -> b) -> Benchmark +benchPureSink value name = benchIO name (sourceIntFromTo value) + +{-# INLINE benchIO' #-} +benchIO' :: NFData b => String -> (Int -> IO a) -> (a -> IO b) -> Benchmark +benchIO' name src f = bench name $ nfIO $ + randomRIO (1,1) >>= src >>= f + +{-# INLINE benchIOSink #-} +benchIOSink :: NFData b => Int -> String -> (Stream Int -> IO b) -> Benchmark +benchIOSink value name = benchIO' name (sourceIntFromTo value) + +------------------------------------------------------------------------------- +-- Bench Ops +------------------------------------------------------------------------------- + +{-# INLINE sourceUnfoldr #-} +sourceUnfoldr :: MonadIO m => Int -> Int -> m (Stream Int) +sourceUnfoldr value n = S.fold (A.writeN value) $ S.unfoldr step n + where + step cnt = + if cnt > n + value + then Nothing + else Just (cnt, cnt + 1) + +{-# INLINE sourceIntFromTo #-} +sourceIntFromTo :: MonadIO m => Int -> Int -> m (Stream Int) +sourceIntFromTo value n = S.fold (A.writeN value) $ S.enumerateFromTo n (n + value) + +{-# INLINE sourceFromList #-} +sourceFromList :: MonadIO m => Int -> Int -> m (Stream Int) +sourceFromList value n = S.fold (A.writeN value) $ S.fromList [n..n+value] + +------------------------------------------------------------------------------- +-- Transformation +------------------------------------------------------------------------------- + +{-# INLINE composeN #-} +composeN :: P.Monad m + => Int -> (Stream Int -> m (Stream Int)) -> Stream Int -> m (Stream Int) +composeN n f x = + case n of + 1 -> f x + 2 -> f x P.>>= f + 3 -> f x P.>>= f P.>>= f + 4 -> f x P.>>= f P.>>= f P.>>= f + _ -> undefined + +{-# INLINE scanl' #-} +{-# INLINE scanl1' #-} +{-# INLINE map #-} + +scanl' , scanl1', map + :: MonadIO m => Int -> Int -> Stream Int -> m (Stream Int) + + +{-# INLINE onArray #-} +onArray + :: MonadIO m => Int -> (S.SerialT m Int -> S.SerialT m Int) + -> Stream Int + -> m (Stream Int) +onArray value f arr = S.fold (A.writeN value) $ f $ S.unfold A.read arr + +scanl' value n = composeN n $ onArray value $ S.scanl' (+) 0 +scanl1' value n = composeN n $ onArray value $ S.scanl1' (+) +map value n = composeN n $ onArray value $ S.map (+1) +-- map n = composeN n $ A.map (+1) + +{-# INLINE eqInstance #-} +eqInstance :: Stream Int -> Bool +eqInstance src = src == src + +{-# INLINE eqInstanceNotEq #-} +eqInstanceNotEq :: Stream Int -> Bool +eqInstanceNotEq src = src P./= src + +{-# INLINE ordInstance #-} +ordInstance :: Stream Int -> Bool +ordInstance src = src P.< src + +{-# INLINE ordInstanceMin #-} +ordInstanceMin :: Stream Int -> Stream Int +ordInstanceMin src = P.min src src + +{-# INLINE showInstance #-} +showInstance :: Stream Int -> P.String +showInstance = P.show + +{-# INLINE pureFoldl' #-} +pureFoldl' :: MonadIO m => Stream Int -> m Int +pureFoldl' = S.foldl' (+) 0 . S.unfold A.read + + +------------------------------------------------------------------------------- +-- Elimination +------------------------------------------------------------------------------- + +{-# INLINE unfoldReadDrain #-} +unfoldReadDrain :: MonadIO m => Stream Int -> m () +unfoldReadDrain = S.drain . S.unfold A.read + +{-# INLINE toStreamRevDrain #-} +toStreamRevDrain :: MonadIO m => Stream Int -> m () +toStreamRevDrain = S.drain . A.toStreamRev + +------------------------------------------------------------------------------- +-- Bench groups +------------------------------------------------------------------------------- + +common_o_1_space_generation :: Int -> [Benchmark] +common_o_1_space_generation value = + [ bgroup + "generation" + [ benchIOSrc "writeN . intFromTo" (sourceIntFromTo value) + , benchIOSrc + "fromList . intFromTo" + (sourceIntFromToFromList value) + , benchIOSrc "writeN . unfoldr" (sourceUnfoldr value) + , benchIOSrc "writeN . fromList" (sourceFromList value) + , benchPureSink value "show" showInstance + ] + ] + +common_o_1_space_elimination :: Int -> [Benchmark] +common_o_1_space_elimination value = + [ bgroup "elimination" + [ benchPureSink value "id" id + , benchPureSink value "==" eqInstance + , benchPureSink value "/=" eqInstanceNotEq + , benchPureSink value "<" ordInstance + , benchPureSink value "min" ordInstanceMin + , benchIOSink value "foldl'" pureFoldl' + , benchIOSink value "read" unfoldReadDrain + , benchIOSink value "toStreamRev" toStreamRevDrain + ] + ] + +common_o_n_heap_serial :: Int -> [Benchmark] +common_o_n_heap_serial value = + [ bgroup "elimination" + [ + -- Converting the stream to an array + benchFold "writeN" (S.fold (A.writeN value)) + (P.sourceUnfoldrM value) + ] + ] + +common_o_1_space_transformation :: Int -> [Benchmark] +common_o_1_space_transformation value = + [ bgroup "transformation" + [ benchIOSink value "scanl'" (scanl' value 1) + , benchIOSink value "scanl1'" (scanl1' value 1) + , benchIOSink value "map" (map value 1) + ] + ] + +common_o_1_space_transformationX4 :: Int -> [Benchmark] +common_o_1_space_transformationX4 value = + [ bgroup "transformationX4" + [ benchIOSink value "scanl'" (scanl' value 4) + , benchIOSink value "scanl1'" (scanl1' value 4) + , benchIOSink value "map" (map value 4) + ] + ] + +commonBenchmarks :: Int -> [Benchmark] +commonBenchmarks size = + [ bgroup (o_1_space_prefix moduleName) $ concat + [ common_o_1_space_generation size + , common_o_1_space_elimination size + , common_o_1_space_transformation size + , common_o_1_space_transformationX4 size + ] + , bgroup (o_n_space_prefix moduleName) $ + common_o_n_heap_serial size + ] diff --git a/benchmark/Streamly/Benchmark/Data/Array/CommonImports.hs b/benchmark/Streamly/Benchmark/Data/Array/CommonImports.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Array/CommonImports.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE FlexibleContexts #-} + +import Control.DeepSeq (NFData(..)) +import System.Random (randomRIO) + +import qualified Streamly.Prelude as S + +import Gauge +import Streamly.Benchmark.Common hiding (benchPureSrc) +import qualified Streamly.Benchmark.Prelude as P + + +import Control.Monad.IO.Class (MonadIO) + +import Prelude as P hiding (map) + +import Data.Functor ((<&>)) diff --git a/benchmark/Streamly/Benchmark/Data/Array/Foreign.hs b/benchmark/Streamly/Benchmark/Data/Array/Foreign.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Array/Foreign.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE CPP #-} + +#include "Streamly/Benchmark/Data/Array/CommonImports.hs" + +import Control.DeepSeq (deepseq) + +import qualified Streamly.Internal.Data.Array.Foreign as IA +import qualified GHC.Exts as GHC + +import qualified Streamly.Data.Array.Foreign as A +import qualified Streamly.Internal.Data.Array.Foreign as A +type Stream = A.Array + +#include "Streamly/Benchmark/Data/Array/Common.hs" + +------------------------------------------------------------------------------- +-- Benchmark helpers +------------------------------------------------------------------------------- + +-- Drain a source that generates a pure array +{-# INLINE benchPureSrc #-} +benchPureSrc :: String -> (Int -> Stream a) -> Benchmark +benchPureSrc name src = benchPure name src id + +-- Drain a source that generates an array in the IO monad +{-# INLINE benchIOSrc #-} +benchIOSrc :: String -> (Int -> IO (Stream a)) -> Benchmark +benchIOSrc name src = benchIO name src id + +------------------------------------------------------------------------------- +-- Bench Ops +------------------------------------------------------------------------------- + +{-# INLINE sourceIntFromToFromList #-} +sourceIntFromToFromList :: MonadIO m => Int -> Int -> m (Stream Int) +sourceIntFromToFromList value n = P.return $ A.fromListN value [n..n + value] + +{-# INLINE readInstance #-} +readInstance :: P.String -> Stream Int +readInstance str = + let r = P.reads str + in case r of + [(x,"")] -> x + _ -> P.error "readInstance: no parse" + +#ifdef DEVBUILD +{- +{-# INLINE foldableFoldl' #-} +foldableFoldl' :: Stream Int -> Int +foldableFoldl' = F.foldl' (+) 0 + +{-# INLINE foldableSum #-} +foldableSum :: Stream Int -> Int +foldableSum = P.sum +-} +#endif + +{-# INLINE sourceIsList #-} +sourceIsList :: Int -> Int -> Stream Int +sourceIsList value n = GHC.fromList [n..n+value] + +{-# INLINE sourceIsString #-} +sourceIsString :: Int -> Int -> Stream P.Char +sourceIsString value n = GHC.fromString (P.replicate (n + value) 'a') + +{-# INLINE sourceIntFromToFromStream #-} +sourceIntFromToFromStream :: MonadIO m => Int -> Int -> m (Stream Int) +sourceIntFromToFromStream value n = S.fold A.write $ S.enumerateFromTo n (n + value) + +------------------------------------------------------------------------------- +-- Bench groups +------------------------------------------------------------------------------- + +o_1_space_generation :: Int -> [Benchmark] +o_1_space_generation value = + [ bgroup + "generation" + [ benchIOSrc "write . intFromTo" (sourceIntFromToFromStream value) + , let testStr = mkListString value + in testStr `deepseq` bench "read" (nf readInstance testStr) + , benchPureSrc "writeN . IsList.fromList" (sourceIsList value) + , benchPureSrc + "writeN . IsString.fromString" + (sourceIsString value) + + ] + ] + +o_1_space_elimination :: Int -> [Benchmark] +o_1_space_elimination value = + [ bgroup "elimination" + [ benchPureSink value "length . IsList.toList" (length . GHC.toList) + , benchFold "writeLastN.1" + (S.fold (IA.writeLastN 1)) (P.sourceUnfoldrM value) + , benchFold "writeLastN.10" + (S.fold (IA.writeLastN 10)) (P.sourceUnfoldrM value) +#ifdef DEVBUILD +{- + benchPureSink value "foldable/foldl'" foldableFoldl' + , benchPureSink value "foldable/sum" foldableSum +-} +#endif + ] + ] + +o_n_heap_serial :: Int -> [Benchmark] +o_n_heap_serial value = + [ bgroup "elimination" + [ + -- Converting the stream to an array + benchFold "writeLastN.Max" (S.fold (IA.writeLastN (value + 1))) + (P.sourceUnfoldrM value) + ] + ] + +moduleName :: String +moduleName = "Data.Array.Foreign" + +defStreamSize :: Int +defStreamSize = defaultStreamSize + +main :: IO () +main = runWithCLIOpts defStreamSize allBenchmarks + + where + + allBenchmarks size = + [ bgroup (o_1_space_prefix moduleName) $ + o_1_space_generation size ++ o_1_space_elimination size + , bgroup (o_n_space_prefix moduleName) $ + o_n_heap_serial size + ] ++ commonBenchmarks size diff --git a/benchmark/Streamly/Benchmark/Data/Array/Foreign/Mut.hs b/benchmark/Streamly/Benchmark/Data/Array/Foreign/Mut.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Array/Foreign/Mut.hs @@ -0,0 +1,82 @@ +-- | +-- Module : Streamly.Benchmark.Data.Array.Foreign.Mut +-- Copyright : (c) 2021 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +#ifdef __HADDOCK_VERSION__ +#undef INSPECTION +#endif + +#ifdef INSPECTION +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fplugin Test.Inspection.Plugin #-} +#endif + +module Main (main) where + +import Control.DeepSeq (NFData(..)) +import Streamly.Prelude (MonadAsync, SerialT, IsStream) +import System.Random (randomRIO) + +import qualified Streamly.Prelude as Stream +import qualified Streamly.Internal.Data.Array.Foreign.Mut as MArray + +import Gauge hiding (env) +import Streamly.Benchmark.Common + +------------------------------------------------------------------------------- +-- Utilities +------------------------------------------------------------------------------- + +{-# INLINE sourceUnfoldrM #-} +sourceUnfoldrM :: (IsStream t, MonadAsync m) => Int -> Int -> t m Int +sourceUnfoldrM value n = Stream.unfoldrM step n + where + step cnt = + if cnt > n + value + then return Nothing + else return (Just (cnt, cnt + 1)) + +{-# INLINE benchIO #-} +benchIO + :: NFData b + => String -> (Int -> a) -> (a -> IO b) -> Benchmark +benchIO name src sink = + bench name $ nfIO $ randomRIO (1,1) >>= sink . src + +o_n_space_serial_marray :: Int -> MArray.Array Int -> [Benchmark] +o_n_space_serial_marray value array = + [ benchIO "partitionBy (< 0)" (const array) + $ MArray.partitionBy (< 0) + , benchIO "partitionBy (> 0)" (const array) + $ MArray.partitionBy (> 0) + , benchIO "partitionBy (< value/2)" (const array) + $ MArray.partitionBy (< (value `div` 2)) + , benchIO "partitionBy (> value/2)" (const array) + $ MArray.partitionBy (> (value `div` 2)) + ] + +------------------------------------------------------------------------------- +-- Driver +------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "Data.Array.Foreign.Mut" + +main :: IO () +main = do + runWithCLIOptsEnv defaultStreamSize alloc allBenchmarks + + where + + alloc value = MArray.fromStream (sourceUnfoldrM value 0 :: SerialT IO Int) + + allBenchmarks array value = + [ bgroup (o_1_space_prefix moduleName) $ + o_n_space_serial_marray value array + ] diff --git a/benchmark/Streamly/Benchmark/Data/Array/Prim.hs b/benchmark/Streamly/Benchmark/Data/Array/Prim.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Array/Prim.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE CPP #-} + +#include "Streamly/Benchmark/Data/Array/CommonImports.hs" + +import qualified Streamly.Internal.Data.Array.Prim as A +type Stream = A.Array + +#include "Streamly/Benchmark/Data/Array/Common.hs" + +------------------------------------------------------------------------------- +-- Benchmark helpers +------------------------------------------------------------------------------- + +-- Drain a source that generates an array in the IO monad +{-# INLINE benchIOSrc #-} +benchIOSrc :: String -> (Int -> IO (Stream a)) -> Benchmark +benchIOSrc name src = benchIO name src id + +------------------------------------------------------------------------------- +-- Bench Ops +------------------------------------------------------------------------------- + +{-# INLINE sourceIntFromToFromList #-} +sourceIntFromToFromList :: MonadIO m => Int -> Int -> m (Stream Int) +sourceIntFromToFromList value n = P.return $ A.fromListN value [n..n + value] + +-- CPP: +{-# INLINE sourceIntFromToFromStream #-} +sourceIntFromToFromStream :: MonadIO m => Int -> Int -> m (Stream Int) +sourceIntFromToFromStream value n = S.fold A.write $ S.enumerateFromTo n (n + value) + +------------------------------------------------------------------------------- +-- Bench groups +------------------------------------------------------------------------------- + +o_1_space_generation :: Int -> [Benchmark] +o_1_space_generation value = + [ bgroup + "generation" + [ benchIOSrc "write . intFromTo" (sourceIntFromToFromStream value) + ] + ] + +moduleName :: String +moduleName = "Data.Array.Prim" + +defStreamSize :: Int +defStreamSize = defaultStreamSize + +main :: IO () +main = runWithCLIOpts defStreamSize allBenchmarks + + where + + allBenchmarks size = + bgroup (o_1_space_prefix moduleName) (o_1_space_generation size) + : commonBenchmarks size diff --git a/benchmark/Streamly/Benchmark/Data/Array/Prim/Pinned.hs b/benchmark/Streamly/Benchmark/Data/Array/Prim/Pinned.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Array/Prim/Pinned.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE CPP #-} + +#include "Streamly/Benchmark/Data/Array/CommonImports.hs" + +import qualified Streamly.Internal.Data.Array.Prim.Pinned as A +type Stream = A.Array + +#include "Streamly/Benchmark/Data/Array/Common.hs" + +------------------------------------------------------------------------------- +-- Benchmark helpers +------------------------------------------------------------------------------- + +-- Drain a source that generates an array in the IO monad +{-# INLINE benchIOSrc #-} +benchIOSrc :: String -> (Int -> IO (Stream a)) -> Benchmark +benchIOSrc name src = benchIO name src id + +------------------------------------------------------------------------------- +-- Bench Ops +------------------------------------------------------------------------------- + +{-# INLINE sourceIntFromToFromList #-} +sourceIntFromToFromList :: MonadIO m => Int -> Int -> m (Stream Int) +sourceIntFromToFromList value n = P.return $ A.fromListN value [n..n + value] + +-- CPP: +{-# INLINE sourceIntFromToFromStream #-} +sourceIntFromToFromStream :: MonadIO m => Int -> Int -> m (Stream Int) +sourceIntFromToFromStream value n = S.fold A.write $ S.enumerateFromTo n (n + value) + +------------------------------------------------------------------------------- +-- Bench groups +------------------------------------------------------------------------------- + +o_1_space_generation :: Int -> [Benchmark] +o_1_space_generation value = + [ bgroup + "generation" + [ benchIOSrc "write . intFromTo" (sourceIntFromToFromStream value) + ] + ] + +moduleName :: String +moduleName = "Data.Array.Prim.Pinned" + +defStreamSize :: Int +defStreamSize = defaultStreamSize + +main :: IO () +main = runWithCLIOpts defStreamSize allBenchmarks + + where + + allBenchmarks size = + bgroup (o_1_space_prefix moduleName) (o_1_space_generation size) + : commonBenchmarks size diff --git a/benchmark/Streamly/Benchmark/Data/Array/SmallArray.hs b/benchmark/Streamly/Benchmark/Data/Array/SmallArray.hs new file mode 100644 --- /dev/null +++ b/benchmark/Streamly/Benchmark/Data/Array/SmallArray.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE CPP #-} + +#include "Streamly/Benchmark/Data/Array/CommonImports.hs" + +import Control.DeepSeq (deepseq) + +import qualified Streamly.Internal.Data.SmallArray as A +type Stream = A.SmallArray + +#include "Streamly/Benchmark/Data/Array/Common.hs" + +------------------------------------------------------------------------------- +-- Benchmark helpers +------------------------------------------------------------------------------- + +-- Drain a source that generates an array in the IO monad +{-# INLINE benchIOSrc #-} +benchIOSrc :: NFData a => String -> (Int -> IO (Stream a)) -> Benchmark +benchIOSrc name src = benchIO name src id + +------------------------------------------------------------------------------- +-- Bench Ops +------------------------------------------------------------------------------- + +{-# INLINE sourceIntFromToFromList #-} +sourceIntFromToFromList :: MonadIO m => Int -> Int -> m (Stream Int) +sourceIntFromToFromList value n = P.return $ A.fromListN value [n..n + value] + +{-# INLINE readInstance #-} +readInstance :: P.String -> Stream Int +readInstance str = + let r = P.reads str + in case r of + [(x,"")] -> x + _ -> P.error "readInstance: no parse" + +#ifdef DEVBUILD +{- +{-# INLINE foldableFoldl' #-} +foldableFoldl' :: Stream Int -> Int +foldableFoldl' = F.foldl' (+) 0 + +{-# INLINE foldableSum #-} +foldableSum :: Stream Int -> Int +foldableSum = P.sum +-} +#endif + +------------------------------------------------------------------------------- +-- Bench groups +------------------------------------------------------------------------------- + +o_1_space_generation :: Int -> [Benchmark] +o_1_space_generation value = + [ bgroup + "generation" + [ let testStr = + "fromListN " ++ + show (value + 1) ++ + "[1" ++ concat (replicate value ",1") ++ "]" + in testStr `deepseq` bench "read" (nf readInstance testStr) + ] + ] + +{- +o_1_space_elimination :: Int -> [Benchmark] +o_1_space_elimination value = + [ bgroup "elimination" + [ +#ifdef DEVBUILD +{- + benchPureSink value "foldable/foldl'" foldableFoldl' + , benchPureSink value "foldable/sum" foldableSum +-} +#endif + ] + ] +-} + +moduleName :: String +moduleName = "Data.SmallArray" + +defStreamSize :: Int +defStreamSize = 128 + +main :: IO () +main = runWithCLIOpts defStreamSize allBenchmarks + + where + + allBenchmarks size = + bgroup (o_1_space_prefix moduleName) (o_1_space_generation size) + : commonBenchmarks size diff --git a/benchmark/Streamly/Benchmark/Data/ArrayOps.hs b/benchmark/Streamly/Benchmark/Data/ArrayOps.hs deleted file mode 100644 --- a/benchmark/Streamly/Benchmark/Data/ArrayOps.hs +++ /dev/null @@ -1,246 +0,0 @@ --- | --- Module : Streamly.Benchmark.Data.ArrayOps --- Copyright : (c) 2020 Composewell Technologies --- --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- CPP: --- MEMORY_ARRAY --- DATA_ARRAY --- DATA_ARRAY_PRIM --- DATA_ARRAY_PRIM_PINNED --- DATA_SMALLARRAY - -module Streamly.Benchmark.Data.ArrayOps where - -import Control.Monad.IO.Class (MonadIO) -import Prelude (Bool, Int, Maybe(..), ($), (+), (.), (==), (>), undefined) - -import qualified Prelude as P -import qualified Streamly.Prelude as S - -#if !defined(DATA_ARRAY_PRIM) && !defined(DATA_ARRAY_PRIM_PINNED) -#ifdef DEVBUILD -{- -import qualified Data.Foldable as F --} -#endif -#endif - -#ifdef DATA_SMALLARRAY -import qualified Streamly.Internal.Data.SmallArray as A -type Stream = A.SmallArray -#elif defined(MEMORY_ARRAY) -import qualified GHC.Exts as GHC -import qualified Streamly.Data.Array.Foreign as A -import qualified Streamly.Internal.Data.Array.Foreign as A -type Stream = A.Array -#elif defined(DATA_ARRAY_PRIM) -import qualified Streamly.Internal.Data.Array.Prim as A -type Stream = A.Array -#elif defined(DATA_ARRAY_PRIM_PINNED) -import qualified Streamly.Internal.Data.Array.Prim.Pinned as A -type Stream = A.Array -#elif defined(DATA_ARRAY) -import qualified Streamly.Internal.Data.Array as A -type Stream = A.Array -#endif - -------------------------------------------------------------------------------- --- Benchmark ops -------------------------------------------------------------------------------- - -------------------------------------------------------------------------------- --- Stream generation and elimination -------------------------------------------------------------------------------- - -------------------------------------------------------------------------------- --- CPP Common to: --- MEMORY_ARRAY --- DATA_ARRAY --- DATA_ARRAY_PRIM --- DATA_ARRAY_PRIM_PINNED --- DATA_SMALLARRAY -------------------------------------------------------------------------------- - -{-# INLINE sourceUnfoldr #-} -sourceUnfoldr :: MonadIO m => Int -> Int -> m (Stream Int) -sourceUnfoldr value n = S.fold (A.writeN value) $ S.unfoldr step n - where - step cnt = - if cnt > n + value - then Nothing - else (Just (cnt, cnt + 1)) - -{-# INLINE sourceIntFromTo #-} -sourceIntFromTo :: MonadIO m => Int -> Int -> m (Stream Int) -sourceIntFromTo value n = S.fold (A.writeN value) $ S.enumerateFromTo n (n + value) - -{-# INLINE sourceFromList #-} -sourceFromList :: MonadIO m => Int -> Int -> m (Stream Int) -sourceFromList value n = S.fold (A.writeN value) $ S.fromList [n..n+value] - --- Different defination of sourceIntFromToFromList for DATA_SMALLARRAY --- CPP: -{-# INLINE sourceIntFromToFromList #-} -sourceIntFromToFromList :: MonadIO m => Int -> Int -> m (Stream Int) -#ifndef DATA_SMALLARRAY -sourceIntFromToFromList value n = P.return $ A.fromList $ [n..n + value] -#else -sourceIntFromToFromList value n = P.return $ A.fromListN value $ [n..n + value] -#endif - -------------------------------------------------------------------------------- --- CPP Common to: --- MEMORY_ARRAY --- DATA_ARRAY --- DATA_ARRAY_PRIM --- DATA_ARRAY_PRIM_PINNED -------------------------------------------------------------------------------- - --- CPP: -#ifndef DATA_SMALLARRAY -{-# INLINE sourceIntFromToFromStream #-} -sourceIntFromToFromStream :: MonadIO m => Int -> Int -> m (Stream Int) -sourceIntFromToFromStream value n = S.fold A.write $ S.enumerateFromTo n (n + value) -#endif - -------------------------------------------------------------------------------- --- CPP Common to: --- MEMORY_ARRAY -------------------------------------------------------------------------------- - --- CPP: -#ifdef MEMORY_ARRAY -{-# INLINE sourceIsList #-} -sourceIsList :: Int -> Int -> Stream Int -sourceIsList value n = GHC.fromList [n..n+value] - -{-# INLINE sourceIsString #-} -sourceIsString :: Int -> Int -> Stream P.Char -sourceIsString value n = GHC.fromString (P.replicate (n + value) 'a') -#endif - -------------------------------------------------------------------------------- --- Transformation -------------------------------------------------------------------------------- - -------------------------------------------------------------------------------- --- CPP Common to: --- MEMORY_ARRAY --- DATA_ARRAY --- DATA_ARRAY_PRIM --- DATA_ARRAY_PRIM_PINNED --- DATA_SMALLARRAY -------------------------------------------------------------------------------- - -{-# INLINE composeN #-} -composeN :: P.Monad m - => Int -> (Stream Int -> m (Stream Int)) -> Stream Int -> m (Stream Int) -composeN n f x = - case n of - 1 -> f x - 2 -> f x P.>>= f - 3 -> f x P.>>= f P.>>= f - 4 -> f x P.>>= f P.>>= f P.>>= f - _ -> undefined - -{-# INLINE scanl' #-} -{-# INLINE scanl1' #-} -{-# INLINE map #-} - -scanl' , scanl1', map - :: MonadIO m => Int -> Int -> Stream Int -> m (Stream Int) - - -{-# INLINE onArray #-} -onArray - :: MonadIO m => Int -> (S.SerialT m Int -> S.SerialT m Int) - -> Stream Int - -> m (Stream Int) -onArray value f arr = S.fold (A.writeN value) $ f $ (S.unfold A.read arr) - -scanl' value n = composeN n $ onArray value $ S.scanl' (+) 0 -scanl1' value n = composeN n $ onArray value $ S.scanl1' (+) -map value n = composeN n $ onArray value $ S.map (+1) --- map n = composeN n $ A.map (+1) - -{-# INLINE eqInstance #-} -eqInstance :: Stream Int -> Bool -eqInstance src = src == src - -{-# INLINE eqInstanceNotEq #-} -eqInstanceNotEq :: Stream Int -> Bool -eqInstanceNotEq src = src P./= src - -{-# INLINE ordInstance #-} -ordInstance :: Stream Int -> Bool -ordInstance src = src P.< src - -{-# INLINE ordInstanceMin #-} -ordInstanceMin :: Stream Int -> Stream Int -ordInstanceMin src = P.min src src - -{-# INLINE showInstance #-} -showInstance :: Stream Int -> P.String -showInstance src = P.show src - -{-# INLINE pureFoldl' #-} -pureFoldl' :: MonadIO m => Stream Int -> m Int -pureFoldl' = S.foldl' (+) 0 . S.unfold A.read - -------------------------------------------------------------------------------- --- CPP Common to: --- MEMORY_ARRAY --- DATA_ARRAY --- DATA_SMALLARRAY -------------------------------------------------------------------------------- - --- CPP: -#if !defined(DATA_ARRAY_PRIM) && !defined(DATA_ARRAY_PRIM_PINNED) -{-# INLINE readInstance #-} -readInstance :: P.String -> Stream Int -readInstance str = - let r = P.reads str - in case r of - [(x,"")] -> x - _ -> P.error "readInstance: no parse" - -#ifdef DEVBUILD -{- -{-# INLINE foldableFoldl' #-} -foldableFoldl' :: Stream Int -> Int -foldableFoldl' = F.foldl' (+) 0 - -{-# INLINE foldableSum #-} -foldableSum :: Stream Int -> Int -foldableSum = P.sum --} -#endif -#endif - -------------------------------------------------------------------------------- --- Elimination -------------------------------------------------------------------------------- - -------------------------------------------------------------------------------- --- CPP Common to: --- MEMORY_ARRAY --- DATA_ARRAY --- DATA_ARRAY_PRIM --- DATA_ARRAY_PRIM_PINNED --- DATA_SMALLARRAY -------------------------------------------------------------------------------- - -{-# INLINE unfoldReadDrain #-} -unfoldReadDrain :: MonadIO m => Stream Int -> m () -unfoldReadDrain = S.drain . S.unfold A.read - -{-# INLINE toStreamRevDrain #-} -toStreamRevDrain :: MonadIO m => Stream Int -> m () -toStreamRevDrain = S.drain . A.toStreamRev diff --git a/benchmark/Streamly/Benchmark/Data/Fold.hs b/benchmark/Streamly/Benchmark/Data/Fold.hs --- a/benchmark/Streamly/Benchmark/Data/Fold.hs +++ b/benchmark/Streamly/Benchmark/Data/Fold.hs @@ -303,6 +303,14 @@ (FL.transform (Pipe.mapM (\x -> return $ x + 1)) FL.drain)) + , benchIOSink + value + "fold-scan" + (S.fold $ FL.scan FL.sum FL.drain) + , benchIOSink + value + "fold-postscan" + (S.fold $ FL.postscan FL.sum FL.drain) ] ] diff --git a/benchmark/Streamly/Benchmark/Data/Parser/ParserD.hs b/benchmark/Streamly/Benchmark/Data/Parser/ParserD.hs --- a/benchmark/Streamly/Benchmark/Data/Parser/ParserD.hs +++ b/benchmark/Streamly/Benchmark/Data/Parser/ParserD.hs @@ -94,6 +94,10 @@ takeP :: MonadThrow m => Int -> SerialT m a -> m () takeP value = IP.parseD (PR.takeP value (PR.fromFold FL.drain)) +{-# INLINE takeBetween #-} +takeBetween :: MonadCatch m => Int -> SerialT m a -> m () +takeBetween value = IP.parseD (PR.takeBetween 0 value FL.drain) + {-# INLINE groupBy #-} groupBy :: MonadThrow m => SerialT m Int -> m () groupBy = IP.parseD (PR.groupBy (<=) FL.drain) @@ -318,6 +322,7 @@ o_1_space_serial value = [ benchIOSink value "takeWhile" $ takeWhile value , benchIOSink value "takeP" $ takeP value + , benchIOSink value "takeBetween" $ takeBetween value , benchIOSink value "sliceBeginWith" $ sliceBeginWith value , benchIOSink value "groupBy" $ groupBy , benchIOSink value "groupByRolling" $ groupByRolling diff --git a/benchmark/Streamly/Benchmark/FileSystem/Handle/ReadWrite.hs b/benchmark/Streamly/Benchmark/FileSystem/Handle/ReadWrite.hs --- a/benchmark/Streamly/Benchmark/FileSystem/Handle/ReadWrite.hs +++ b/benchmark/Streamly/Benchmark/FileSystem/Handle/ReadWrite.hs @@ -159,7 +159,6 @@ ] -- | Send the file contents ('defaultChunkSize') to /dev/null -{-# NOINLINE writeReadWithBufferOf #-} writeReadWithBufferOf :: Handle -> Handle -> IO () writeReadWithBufferOf inh devNull = IUF.fold fld unf (defaultChunkSize, inh) @@ -177,7 +176,6 @@ #endif -- | Send the file contents ('AT.defaultChunkSize') to /dev/null -{-# NOINLINE writeRead #-} writeRead :: Handle -> Handle -> IO () writeRead inh devNull = IUF.fold fld unf inh diff --git a/benchmark/Streamly/Benchmark/Prelude/Serial/NestedStream.hs b/benchmark/Streamly/Benchmark/Prelude/Serial/NestedStream.hs --- a/benchmark/Streamly/Benchmark/Prelude/Serial/NestedStream.hs +++ b/benchmark/Streamly/Benchmark/Prelude/Serial/NestedStream.hs @@ -414,6 +414,62 @@ ] ------------------------------------------------------------------------------- +-- Joining +------------------------------------------------------------------------------- + +toKv :: Int -> (Int, Int) +toKv p = (p, p) + +{-# INLINE joinWith #-} +joinWith :: (S.MonadAsync m) => + ((Int -> Int -> Bool) -> SerialT m Int -> SerialT m Int -> SerialT m b) + -> Int + -> Int + -> m () +joinWith j val i = + S.drain $ j (==) (sourceUnfoldrM val i) (sourceUnfoldrM val (val `div` 2)) + +{-# INLINE joinMapWith #-} +joinMapWith :: (S.MonadAsync m) => + (SerialT m (Int, Int) -> SerialT m (Int, Int) -> SerialT m b) + -> Int + -> Int + -> m () +joinMapWith j val i = + S.drain + $ j + (fmap toKv (sourceUnfoldrM val i)) + (fmap toKv (sourceUnfoldrM val (val `div` 2))) + +o_n_heap_buffering :: Int -> [Benchmark] +o_n_heap_buffering value = + [ bgroup "buffered" + [ + benchIOSrc1 "joinInner (sqrtVal)" + $ joinWith Internal.joinInner sqrtVal + , benchIOSrc1 "joinInnerMap" + $ joinMapWith Internal.joinInnerMap halfVal + , benchIOSrc1 "joinLeft (sqrtVal)" + $ joinWith Internal.joinLeft sqrtVal + , benchIOSrc1 "joinLeftMap " + $ joinMapWith Internal.joinLeftMap halfVal + , benchIOSrc1 "joinOuter (sqrtVal)" + $ joinWith Internal.joinOuter sqrtVal + , benchIOSrc1 "joinOuterMap" + $ joinMapWith Internal.joinOuterMap halfVal + , benchIOSrc1 "intersectBy (sqrtVal)" + $ joinWith Internal.intersectBy sqrtVal + , benchIOSrc1 "intersectBySorted" + $ joinMapWith (Internal.intersectBySorted compare) halfVal + ] + ] + + where + + halfVal = value `div` 2 + sqrtVal = round $ sqrt (fromIntegral value :: Double) + +------------------------------------------------------------------------------- -- Main ------------------------------------------------------------------------------- @@ -440,4 +496,7 @@ , o_n_space_monad size , o_n_space_concat size ] + , bgroup (o_n_heap_prefix moduleName) $ + -- multi-stream + o_n_heap_buffering size ] diff --git a/benchmark/Streamly/Benchmark/Prelude/ZipAsync.hs b/benchmark/Streamly/Benchmark/Prelude/ZipAsync.hs --- a/benchmark/Streamly/Benchmark/Prelude/ZipAsync.hs +++ b/benchmark/Streamly/Benchmark/Prelude/ZipAsync.hs @@ -41,6 +41,12 @@ S.fromZipAsync $ (,) <$> sourceUnfoldrM count n <*> sourceUnfoldrM count (n + 1) +fromZipAsyncTraverse :: String -> Int -> Benchmark +fromZipAsyncTraverse name count = + bench name + $ nfIO + $ S.drain $ S.fromZipAsync $ traverse S.fromPure [0 :: Int .. count] + o_1_space_joining :: Int -> [Benchmark] o_1_space_joining value = [ bgroup "joining" @@ -50,6 +56,7 @@ (value `div` 2)) , benchIOSrc fromSerial "zipAsyncAp (2,x/2)" (zipAsyncAp (value `div` 2)) , benchIOSink value "fmap zipAsyncly" $ fmapN S.fromZipAsync 1 + , fromZipAsyncTraverse "ZipAsync Applicative (x/100)" (value `div` 100) ] ] diff --git a/benchmark/Streamly/Benchmark/Unicode/Stream.hs b/benchmark/Streamly/Benchmark/Unicode/Stream.hs --- a/benchmark/Streamly/Benchmark/Unicode/Stream.hs +++ b/benchmark/Streamly/Benchmark/Unicode/Stream.hs @@ -267,6 +267,23 @@ -- inspect $ 'copyStreamUtf8Lax `hasNoType` ''D.ConcatMapUState #endif +{-# NOINLINE _copyStreamUtf8'Fold #-} +_copyStreamUtf8'Fold :: Handle -> Handle -> IO () +_copyStreamUtf8'Fold inh outh = + Stream.fold (Handle.write outh) + $ Unicode.encodeUtf8 + $ Stream.foldMany Unicode.writeCharUtf8' + $ Stream.unfold Handle.read inh + +{-# NOINLINE _copyStreamUtf8Parser #-} +_copyStreamUtf8Parser :: Handle -> Handle -> IO () +_copyStreamUtf8Parser inh outh = + Stream.fold (Handle.write outh) + $ Unicode.encodeUtf8 + $ Stream.parseMany + (Unicode.parseCharUtf8With Unicode.TransliterateCodingFailure) + $ Stream.unfold Handle.read inh + o_1_space_decode_encode_read :: BenchEnv -> [Benchmark] o_1_space_decode_encode_read env = [ bgroup "decode-encode" @@ -280,7 +297,11 @@ -- Requires valid unicode input , mkBench "encodeUtf8' . decodeUtf8'" env $ \inh outh -> _copyStreamUtf8' inh outh + , mkBench "encodeUtf8' . foldMany writeCharUtf8'" env $ \inh outh -> + _copyStreamUtf8'Fold inh outh #endif + , mkBenchSmall "encodeUtf8 . parseMany parseCharUtf8" env + $ \inh outh -> _copyStreamUtf8Parser inh outh , mkBenchSmall "encodeUtf8 . decodeUtf8" env $ \inh outh -> copyStreamUtf8 inh outh ] diff --git a/benchmark/bench-report/BenchReport.hs b/benchmark/bench-report/BenchReport.hs --- a/benchmark/bench-report/BenchReport.hs +++ b/benchmark/bench-report/BenchReport.hs @@ -10,7 +10,6 @@ import Control.Monad.Trans.State import Data.Char (toLower) import Data.List -import GHC.Real (infinity) import System.Environment (getArgs) import Text.Read (readMaybe) @@ -165,7 +164,7 @@ ------------------------------------------------------------------------------ makeGraphs :: String -> Config -> String -> IO () -makeGraphs name cfg@Config{..} inputFile = +makeGraphs name cfg inputFile = ignoringErr $ graph inputFile name cfg ------------------------------------------------------------------------------ @@ -209,25 +208,25 @@ -> (SortColumn -> Maybe GroupStyle -> Either String [(String, Double)]) -> [String] selectBench Options{..} f = - reverse - $ fmap fst - $ filter (\(_,y) -> filterPred y) - $ either - (const $ either error sortFunc $ f (ColumnIndex 0) (Just PercentDiff)) - sortFunc - $ f (ColumnIndex 1) (Just PercentDiff) + -- Apply filterPred only if at least 2 columns exist + let colVals = + case f (ColumnIndex 1) (Just PercentDiff) of + Left _ -> either error id $ f (ColumnIndex 0) (Just PercentDiff) + Right xs -> filter (filterPred . snd) xs + in reverse + $ fmap fst + $ sortFunc colVals where sortFunc = if sortByName then sortOn fst else sortOn snd - cutOffMultiples = 1 + cutOffPercent / 100 - - filterPred x = - case benchType of - Just (Compare _) -> - x <= negate cutOffPercent || x >= cutOffPercent - _ -> True + filterPred x + | isInfinite x = False + | isNaN x = False + | cutOffPercent > 0 = x >= cutOffPercent + | cutOffPercent < 0 = x <= cutOffPercent + | otherwise = True benchShow :: Options diff --git a/benchmark/bench-report/bench-report.cabal b/benchmark/bench-report/bench-report.cabal --- a/benchmark/bench-report/bench-report.cabal +++ b/benchmark/bench-report/bench-report.cabal @@ -18,6 +18,6 @@ main-is: BenchReport.hs buildable: True build-Depends: - base >= 4.9 && < 5 - , bench-show >= 0.3 && < 0.4 + base >= 4.9 && < 4.17 + , bench-show >= 0.3.2 && < 0.4 , transformers >= 0.4 && < 0.6 diff --git a/benchmark/bench-report/bin/bench-runner.sh b/benchmark/bench-report/bin/bench-runner.sh --- a/benchmark/bench-report/bin/bench-runner.sh +++ b/benchmark/bench-report/bin/bench-runner.sh @@ -21,8 +21,9 @@ echo " [--sort-by-name]" echo " [--compare]" echo " [--diff-style ]" - echo " [--cutoff-percent ]" + echo " [--diff-cutoff-percent ]" echo " [--graphs]" + echo " [--silent]" echo " [--no-measure]" echo " [--append]" echo " [--long]" @@ -39,6 +40,13 @@ echo echo "--benchmarks: benchmarks to run, use 'help' for list of benchmarks" echo "--compare: compare the specified benchmarks with each other" + + echo "--diff-cutoff-percent: Diff percentage used for benchmark selection." + echo "This applies only to the second column of the report and makes sense" + echo "only while comparing benchmarks." + echo "A positive cutoff value selects only regressions, whereas, a negative" + echo "cutoff value selects only improvements." + echo "--fields: measurement fields to report, use 'help' for a list" echo "--graphs: Generate graphical reports" echo "--no-measure: Don't run benchmarks, run reports from previous results" @@ -432,11 +440,11 @@ local prog prog=$BENCH_REPORT_DIR/bin/bench-report test -x $prog || die "Cannot find bench-report executable" - echo + test -z "$SILENT" && echo for i in $1 do - echo "Generating reports for ${i}..." + test -z "$SILENT" && echo "Generating reports for ${i}..." $prog \ --benchmark $i \ $(test "$USE_GAUGE" = 1 && echo "--use-gauge") \ @@ -497,6 +505,7 @@ --diff-cutoff-percent) shift; BENCH_CUTOFF_PERCENT=$1; shift ;; # flags --slow) SLOW=1; shift ;; + --silent) SILENT=1; shift ;; --quick) QUICK_MODE=1; shift ;; --compare) COMPARE=1; shift ;; --commit-compare) COMMIT_COMPARE=1; shift ;; @@ -598,7 +607,7 @@ TARGETS_ORIG=$TARGETS TARGETS=$(only_real_benchmarks) -echo "Using benchmark suites [$TARGETS]" +test -z "$SILENT" && echo "Using benchmark suites [$TARGETS]" #----------------------------------------------------------------------------- # Build reporting utility @@ -606,7 +615,10 @@ # We need to build the report progs first at the current (latest) commit before # checking out any other commit for benchmarking. -build_report_progs +if test -z "$SILENT" +then build_report_progs +else silently build_report_progs +fi #----------------------------------------------------------------------------- # Build and run targets diff --git a/benchmark/bench-report/bin/build-lib.sh b/benchmark/bench-report/bin/build-lib.sh --- a/benchmark/bench-report/bin/build-lib.sh +++ b/benchmark/bench-report/bin/build-lib.sh @@ -25,6 +25,11 @@ done } +# $1: command +silently () { + eval "$1 &> /dev/null" +} + #------------------------------------------------------------------------------ # target groups #------------------------------------------------------------------------------ diff --git a/benchmark/lib/Streamly/Benchmark/Common/Handle.hs b/benchmark/lib/Streamly/Benchmark/Common/Handle.hs --- a/benchmark/lib/Streamly/Benchmark/Common/Handle.hs +++ b/benchmark/lib/Streamly/Benchmark/Common/Handle.hs @@ -39,7 +39,7 @@ import System.Directory (getFileSize) import System.Environment (lookupEnv) import System.IO (openFile, IOMode(..), Handle, hClose, stderr, hPutStrLn) -import System.Process.Typed (shell, runProcess_) +import System.Process (callCommand) import Data.IORef import Prelude hiding (last, length) @@ -183,8 +183,8 @@ ++ "\" && head -c " ++ show size ++ " " ++ infile ++ ";}" - runProcess_ (shell (cmd inFileSmall smallFileSize)) - runProcess_ (shell (cmd inFileBig bigFileSize)) + callCommand (cmd inFileSmall smallFileSize) + callCommand (cmd inFileBig bigFileSize) return (inFileSmall, inFileBig) hPutStrLn stderr $ "Using small input file: " ++ small diff --git a/benchmark/lib/Streamly/Benchmark/Prelude.hs b/benchmark/lib/Streamly/Benchmark/Prelude.hs --- a/benchmark/lib/Streamly/Benchmark/Prelude.hs +++ b/benchmark/lib/Streamly/Benchmark/Prelude.hs @@ -10,7 +10,59 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} -module Streamly.Benchmark.Prelude where +module Streamly.Benchmark.Prelude + ( absTimes + , apDiscardFst + , apDiscardSnd + , apLiftA2 + , benchIO + , benchIOSink + , benchIOSrc + , breakAfterSome + , composeN + , concatFoldableWith + , concatForFoldableWith + , concatPairsWith + , concatStreamsWith + , filterAllInM + , filterAllOutM + , filterSome + , fmapN + , mapM + , mapN + , mkAsync + , monadThen + , runToList + , sourceConcatMapId + , sourceFoldMapM + , sourceFoldMapWith + , sourceFoldMapWithM + , sourceFoldMapWithStream + , sourceFracFromThenTo + , sourceFracFromTo + , sourceFromFoldable + , sourceFromFoldableM + , sourceFromList + , sourceFromListM + , sourceIntegerFromStep + , sourceIntFromThenTo + , sourceIntFromTo + , sourceUnfoldr + , sourceUnfoldrAction + , sourceUnfoldrM + , sourceUnfoldrMSerial + , toListM + , toListSome + , toNull + , toNullAp + , toNullM + , toNullM3 + , transformComposeMapM + , transformMapM + , transformTeeMapM + , transformZipMapM + ) +where import Control.Applicative (liftA2) import Control.DeepSeq (NFData(..)) @@ -20,6 +72,7 @@ import Data.Semigroup (Semigroup((<>))) #endif import GHC.Exception (ErrorCall) +import Prelude hiding (mapM) import System.Random (randomRIO) import qualified Data.Foldable as F diff --git a/benchmark/streamly-benchmarks.cabal b/benchmark/streamly-benchmarks.cabal --- a/benchmark/streamly-benchmarks.cabal +++ b/benchmark/streamly-benchmarks.cabal @@ -84,6 +84,7 @@ -Wredundant-constraints -Wnoncanonical-monad-instances -Rghc-timing + -Wmissing-export-lists if flag(has-llvm) ghc-options: -fllvm @@ -114,16 +115,16 @@ -- Core libraries shipped with ghc, the min and max -- constraints of these libraries should match with -- the GHC versions we support - base >= 4.9 && < 5 + base >= 4.9 && < 4.17 , deepseq >= 1.4.1 && < 1.5 - , mtl >= 2.2 && < 3 + , mtl >= 2.2 && < 2.3 -- other libraries - , streamly >= 0.7.0 + , streamly , random >= 1.0 && < 2.0 , transformers >= 0.4 && < 0.7 , containers >= 0.5 && < 0.7 - , typed-process >= 0.2.3 && < 0.3 + , process >= 1.4 && < 1.7 , directory >= 1.2.2 && < 1.4 , filepath >= 1.4.1 && < 1.5 , ghc-prim >= 0.4 && < 0.9 @@ -167,6 +168,7 @@ common bench-options import: compile-options, optimization-options, bench-depends + include-dirs: . ghc-options: -rtsopts if flag(limit-build-mem) ghc-options: +RTS -M512M -RTS @@ -220,6 +222,8 @@ buildable: False else buildable: True + if flag(limit-build-mem) + ghc-options: +RTS -M750M -RTS benchmark Prelude.Merge import: bench-options @@ -458,43 +462,34 @@ type: exitcode-stdio-1.0 hs-source-dirs: . main-is: Streamly/Benchmark/Data/Array.hs - other-modules: Streamly.Benchmark.Data.ArrayOps - cpp-options: -DDATA_ARRAY benchmark Data.Array.Prim import: bench-options type: exitcode-stdio-1.0 - hs-source-dirs: . - main-is: Streamly/Benchmark/Data/Array.hs - other-modules: Streamly.Benchmark.Data.ArrayOps - cpp-options: -DDATA_ARRAY_PRIM + main-is: Streamly/Benchmark/Data/Array/Prim.hs build-depends: primitive benchmark Data.SmallArray import: bench-options type: exitcode-stdio-1.0 - hs-source-dirs: . - main-is: Streamly/Benchmark/Data/Array.hs - other-modules: Streamly.Benchmark.Data.ArrayOps - cpp-options: -DDATA_SMALLARRAY + main-is: Streamly/Benchmark/Data/Array/SmallArray.hs benchmark Data.Array.Prim.Pinned import: bench-options type: exitcode-stdio-1.0 - hs-source-dirs: . - main-is: Streamly/Benchmark/Data/Array.hs - other-modules: Streamly.Benchmark.Data.ArrayOps - cpp-options: -DDATA_ARRAY_PRIM_PINNED + main-is: Streamly/Benchmark/Data/Array/Prim/Pinned.hs benchmark Data.Array.Foreign import: bench-options type: exitcode-stdio-1.0 - hs-source-dirs: . - main-is: Streamly/Benchmark/Data/Array.hs - other-modules: Streamly.Benchmark.Data.ArrayOps - cpp-options: -DMEMORY_ARRAY + main-is: Streamly/Benchmark/Data/Array/Foreign.hs if flag(limit-build-mem) ghc-options: +RTS -M1000M -RTS + +benchmark Data.Array.Foreign.Mut + import: bench-options + type: exitcode-stdio-1.0 + main-is: Streamly/Benchmark/Data/Array/Foreign/Mut.hs ------------------------------------------------------------------------------- -- Array Stream Benchmarks diff --git a/bin/mk-hscope.sh b/bin/mk-hscope.sh --- a/bin/mk-hscope.sh +++ b/bin/mk-hscope.sh @@ -1,7 +1,7 @@ #!/usr/bin/env bash GHC_VERSION=8.10.4 -STREAMLY_VERSION=0.8.1.1 +STREAMLY_VERSION=0.8.2 case `uname` in Darwin) SYSTEM=x86_64-osx;; diff --git a/bin/test.sh b/bin/test.sh --- a/bin/test.sh +++ b/bin/test.sh @@ -2,7 +2,7 @@ SCRIPT_DIR=$(dirname $0) -STREAMLY_VERSION=0.8.1.1 +STREAMLY_VERSION=0.8.2 BENCH_REPORT_DIR=benchmark/bench-report source $SCRIPT_DIR/targets.sh diff --git a/configure b/configure --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.71 for streamly 0.8.1.1. +# Generated by GNU Autoconf 2.71 for streamly 0.8.2. # # Report bugs to . # @@ -610,8 +610,8 @@ # Identity of this package. PACKAGE_NAME='streamly' PACKAGE_TARNAME='streamly' -PACKAGE_VERSION='0.8.1.1' -PACKAGE_STRING='streamly 0.8.1.1' +PACKAGE_VERSION='0.8.2' +PACKAGE_STRING='streamly 0.8.2' PACKAGE_BUGREPORT='streamly@composewell.com' PACKAGE_URL='https://streamly.composewell.com' @@ -1256,7 +1256,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures streamly 0.8.1.1 to adapt to many kinds of systems. +\`configure' configures streamly 0.8.2 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1318,7 +1318,7 @@ if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of streamly 0.8.1.1:";; + short | recursive ) echo "Configuration of streamly 0.8.2:";; esac cat <<\_ACEOF @@ -1404,7 +1404,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -streamly configure 0.8.1.1 +streamly configure 0.8.2 generated by GNU Autoconf 2.71 Copyright (C) 2021 Free Software Foundation, Inc. @@ -1674,7 +1674,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by streamly $as_me 0.8.1.1, which was +It was created by streamly $as_me 0.8.2, which was generated by GNU Autoconf 2.71. Invocation command line was $ $0$ac_configure_args_raw @@ -4028,7 +4028,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by streamly $as_me 0.8.1.1, which was +This file was extended by streamly $as_me 0.8.2, which was generated by GNU Autoconf 2.71. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -4084,7 +4084,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ -streamly config.status 0.8.1.1 +streamly config.status 0.8.2 configured by $0, generated by GNU Autoconf 2.71, with options \\"\$ac_cs_config\\" diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -3,7 +3,7 @@ # See https://www.gnu.org/software/autoconf/manual/autoconf.html for help on # the macros used in this file. -AC_INIT([streamly], [0.8.1.1], [streamly@composewell.com], [streamly], [https://streamly.composewell.com]) +AC_INIT([streamly], [0.8.2], [streamly@composewell.com], [streamly], [https://streamly.composewell.com]) # To suppress "WARNING: unrecognized options: --with-compiler" AC_ARG_WITH([compiler], [GHC]) diff --git a/dev/MAINTAINING.md b/dev/MAINTAINING.md --- a/dev/MAINTAINING.md +++ b/dev/MAINTAINING.md @@ -31,11 +31,21 @@ * _Documentation_: - * README is updated, links in README are stable. Run `rg '/blob/'` - and `rg '/tree/'` to search for github links, replace `master` ref - with release tag where possible (e.g. streamly-examples). Ideally, - the distribution process should automatically replace these with - current stable references. + * Documentation is updated. + * Check if all the links in the docs are stable. + * External links might point to the `master` branch of a few + repositories. Pin them to a specific version that works with the current + release. + * You can run `rg '/blob/'` and `rg '/tree/'` to search for github links. + * For example, links that point to `streamly-examples` point to its + `master` branch. Instead, while making the release we need to pin the + links to a specific revision that works with the latest commit of the + current release. + * Ideally, the distribution process should automatically replace these + with current stable references. + * The markdown documentation files have no broken links. See the section + about [checking for broken + links](#checking-for-broken-links-in-the-markdown-files) for more info. * Haddock docs are consistent with the changes in the release * Tutorial has been updated for new changes * Documents in the `docs` directory are consistent with new changes @@ -88,10 +98,10 @@ * _Update Package Metadata:_ - * Make sure the description in cabal file is in sync with README and other docs + * Make sure the description in cabal file is in sync with the docs * Make sure CI configs include last three major releases of GHC in CI testing. * Update GHC `tested-with` field - * Update `docs/building.md` with the distributions tested with + * Update `docs/Compiling.md` with the distributions tested with * Any docs linked inside haddock/cabal/changelog or any other such file should go in the extra-doc-files section instead of extra-source-files. Otherwise hackage shows the links as broken. @@ -107,11 +117,10 @@ * Bump the release version in `docs/CONTRIBUTORS.md`. * Make sure any third party code included in the release has been listed in `docs/Credits.md` and the license is added to the repo. - * Bump the release version in `docs/Credits.md`. * _Update changelog & Version_: - * Find API changes using `cabal-diff streamly 0.8.1 .` and record + * Find API changes using `cabal-diff streamly 0.8.2 .` and record them in docs/API-changelog.txt. * Make sure all the bug fixes being included in this release are marked with a target release on github. So that users can search by release if @@ -128,9 +137,8 @@ * Wait for final CI tests to pass: - * Create a git tag corresponding to the release where X.Y.Z is the new - package version (`git tag vX.Y.Z && git push -f origin vX.Y.Z`). - * Mask out the build status lines from the README + * Mask out the build status lines from the + [docs/Introduction.md](/docs/Introduction.md) * Upload to hackage * Use a clean workspace to create source distribution by freshly cloning the git repository. The reason for @@ -138,8 +146,16 @@ `extra-source-files`, these wild-cards may match additional files lying around in the workspace and unintentionally ship them as well. - * `cabal v2-sdist`; `cabal upload --publish ` - * `stack upload .` + * Upload and verify the candidate + * `cabal v2-sdist; cabal upload ` + * `cabal v2-haddock --haddock-for-hackage --enable-doc; cabal upload -d ` + * Publish the package + * `cabal v2-sdist`; `cabal upload --publish ` + * Run packcheck on the uploaded package. To get the latest uploaded + version from hackage, run `cabal unpack `. You might + have to run `cabal update`. + * Create a git tag corresponding to the release where X.Y.Z is the new + package version (`git tag vX.Y.Z && git push -f origin vX.Y.Z`). * Add to stackage (`build-constraints.yaml` in Stackage repo) if needed * Optionally upload `package-X.Y.Z-sdist.tar.gz` to github release page * Update release contributors on github release page @@ -315,4 +331,66 @@ ``` $ nix-shell --run "ghc-pkg dot | dot -Tpdf > streamly.pdf" +``` + +## Checking for broken links in the markdown files + +You can use [markdown-link-check](https://github.com/tcort/markdown-link-check) +for finding broken links. + +You can run it using `npx` like so: +``` +npx markdown-link-check +``` + +The following command - when run from the repository root - finds all the +markdown files that we need to consider: + +``` +find . -type f -name "*.md" \ + -not -path "./dist*" \ + -not -path "./.stack*" \ + -not -path "./benchmark/bench-report/dist*" +``` + +The following executes the markdown link checking with proper configuration on +the results. This also checks all the links are absolute to the root of the +repo. + +``` +find . -type f -name "*.md" \ + -not -path "./dist*" \ + -not -path "./.stack*" \ + -not -path "./benchmark/bench-report/dist*" \ + -exec npx markdown-link-check -c /dev/stdin --quiet {} \; <&1 | grep -e "http" -e "ftp" -e "mailto" ``` diff --git a/dev/utf8-decoder.md b/dev/utf8-decoder.md --- a/dev/utf8-decoder.md +++ b/dev/utf8-decoder.md @@ -263,7 +263,7 @@ the graph are disallowed; they all lead to state one, which has been omitted for readability. -![DFA with range transitions](/design/dfa-bytes.png) +![DFA with range transitions](/dev/dfa-bytes.png) ### Automaton with character class transitions @@ -273,7 +273,7 @@ belongs to exactly one character class. Then the transitions go over these character classes. -![DFA with class transitions](/design/dfa-classes.png) +![DFA with class transitions](/dev/dfa-classes.png) ### Mapping bytes to character classes @@ -404,7 +404,7 @@ I have experimented with various rearrangements of states and character classes. A seemingly promising one is the following: -![Re-arranged DFA with class transitions](/design/dfa-rearr.png) +![Re-arranged DFA with class transitions](/dev/dfa-rearr.png) One of the continuation ranges has been split into two, the other changes are just renamings. This arrangement allows, when a continuation diff --git a/docs/CONTRIBUTORS.md b/docs/CONTRIBUTORS.md --- a/docs/CONTRIBUTORS.md +++ b/docs/CONTRIBUTORS.md @@ -4,6 +4,14 @@ Use `git shortlog -sn tag1...tag2` on the git repository to get a list of contributors between two repository tags. +## 0.8.2 + +* Adithya Kumar +* Harendra Kumar +* Ranjeet Kumar Ranjan +* Anurag Hooda +* andremarianiello + ## 0.8.1.1 * Harendra Kumar diff --git a/docs/Changelog.md b/docs/Changelog.md new file mode 100644 --- /dev/null +++ b/docs/Changelog.md @@ -0,0 +1,539 @@ +# Changelog + + + +## 0.8.2 (Mar 2022) + +* Fix performance issues for GHC-9. These changes coupled with GHC changes + expected to land in 9.2.2 will bring the performance back to the same levels + as before. + +## 0.8.1.1 (Dec 2021) + +* Disable building FileSystem.Events where FS Events isn't supported. + +## 0.8.1 (Nov 2021) + +See API-changelog.txt for new APIs introduced. + +### Bug Fixes + +* Several bug fixes in the Array module: + * Fix writeN fold eating away one element when applied multiple times + [#1258](https://github.com/composewell/streamly/issues/1258). + * Fix potentially writing beyond allocated memory when shrinking. Likely + cause of [#944](https://github.com/composewell/streamly/issues/944). + * Fix potentially writing beyond allocated memory when writing the last + element. Likely cause of + [#944](https://github.com/composewell/streamly/issues/944). + * Fix missing pointer touch could potentially cause use of freed memory. + * Fix unnecessary additional allocation due to a bug +* Fix a bug in classifySessionsBy, see + [PR #1311](https://github.com/composewell/streamly/pull/1311). The bug + could cause premature ejection of a session when input events with the + same key are split into multiple sessions. + +### Notable Internal API Changes + +* `tapAsync` from `Streamly.Internal.Data.Stream.Parallel` has been moved to + `Streamly.Internal.Data.Stream.IsStream` and renamed to `tapAsyncK`. +* `Fold2` has now been renamed to `Refold` and the corresponding `Fold2` + combinators have been either renamed or removed. + +## 0.8.0 (Jun 2021) + +See [API Changelog](/docs/API-changelog.txt) for a complete list of signature +changes and new APIs introduced. + +### Breaking changes + +* `Streamly.Prelude` + * `fold`: this function may now terminate early without consuming + the entire stream. For example, `fold Fold.head stream` would + now terminate immediately after consuming the head element from + `stream`. This may result in change of behavior in existing programs + if the program relies on the evaluation of the full stream. +* `Streamly.Data.Unicode.Stream` + * The following APIs no longer throw errors on invalid input, use new + APIs suffixed with a prime for strict behavior: + * decodeUtf8 + * encodeLatin1 + * encodeUtf8 +* `Streamly.Data.Fold`: + * Several instances have been moved to the `Streamly.Data.Fold.Tee` + module, please use the `Tee` type to adapt to the changes. + +### Bug Fixes + +* Concurrent Streams: The monadic state for the stream is now propagated across + threads. Please refer to + [#369](https://github.com/composewell/streamly/issues/369) for more info. +* `Streamly.Prelude`: + * `bracket`, `handle`, and `finally` now also work correctly on streams + that aren't fully drained. Also, the resource acquisition and release is + atomic with respect to async exceptions. + * `iterate`, `iterateM` now consume O(1) space instead of O(n). + * `fromFoldableM` is fixed to be concurrent. +* `Streamly.Network.Inet.TCP`: `accept` and `connect` APIs now close the socket + if an exception is thrown. +* `Streamly.Network.Socket`: `accept` now closes the socket if an exception is + thrown. + +### Enhancements + +* See [API Changelog](/docs/API-changelog.txt) for a complete list of new + modules and APIs introduced. +* The Fold type is now more powerful, the new termination behavior allows + to express basic parsing of streams using folds. +* Many new Fold and Unfold APIs are added. +* A new module for console IO APIs is added. +* Experimental modules for the following are added: + * Parsing + * Deserialization + * File system event handling (fsnotify/inotify) + * Folds for streams of arrays +* Experimental `use-c-malloc` build flag to use the c library `malloc` for + array allocations. This could be useful to avoid pinned memory fragmentation. + + +### Notable Internal/Pre-release API Changes + +Breaking changes: + +* The `Fold` type has changed to accommodate terminating folds. +* Rename: `Streamly.Internal.Prelude` => `Streamly.Internal.Data.Stream.IsStream` +* Several other internal modules have been renamed and re-factored. + +Bug fixes: + +* A bug was fixed in the conversion of `MicroSecond64` and `MilliSecond64` + (commit e5119626) +* Bug fix: `classifySessionsBy` now flushes sessions at the end and terminates. + +### Miscellaneous + +* Drop support for GHC 7.10.3. +* The examples in this package are moved to a new github repo + [streamly-examples](https://github.com/composewell/streamly-examples) + +## 0.7.3 (February 2021) + +### Build Issues + +* Fix build issues with primitive package version >= 0.7.1. +* Fix build issues on armv7. + +## 0.7.2 (April 2020) + +### Bug Fixes + +* Fix a bug in the `Applicative` and `Functor` instances of the `Fold` + data type. + +### Build Issues + +* Fix a bug that occasionally caused a build failure on windows when + used with `stack` or `stack ghci`. +* Now builds on 32-bit machines. +* Now builds with `primitive` package version >= 0.5.4 && <= 0.6.4.0 +* Now builds with newer `QuickCheck` package version >= 2.14 && < 2.15. +* Now builds with GHC 8.10. + +## 0.7.1 (February 2020) + +### Bug Fixes + +* Fix a bug that caused `findIndices` to return wrong indices in some + cases. +* Fix a bug in `tap`, `chunksOf` that caused memory consumption to + increase in some cases. +* Fix a space leak in concurrent streams (`async`, `wAsync`, and `ahead`) that + caused memory consumption to increase with the number of elements in the + stream, especially when built with `-threaded` and used with `-N` RTS option. + The issue occurs only in cases when a worker thread happens to be used + continuously for a long time. +* Fix scheduling of WAsyncT stream style to be in round-robin fashion. +* Now builds with `containers` package version < 0.5.8. +* Now builds with `network` package version >= 3.0.0.0 && < 3.1.0.0. + +### Behavior change + +* Combinators in `Streamly.Network.Inet.TCP` no longer use TCP `NoDelay` and + `ReuseAddr` socket options by default. These options can now be specified + using appropriate combinators. + +### Performance + +* Now uses `fusion-plugin` package for predictable stream fusion optimizations +* Significant improvement in performance of concurrent stream operations. +* Improved space and time performance of `Foldable` instance. + +## 0.7.0 (November 2019) + +### Breaking changes + +* Change the signature of `foldrM` to ensure that it is lazy +* Change the signature of `iterateM` to ensure that it is lazy. +* `scanx` would now require an additional `Monad m` constraint. + +### Behavior change + +* Earlier `ParallelT` was unaffected by `maxBuffer` directive, now `maxBuffer` + can limit the buffer of a `ParallelT` stream as well. When the buffer becomes + full, the producer threads block. +* `ParallelT` streams no longer have an unlimited buffer by default. Now the + buffer for parallel streams is limited to 1500 by default, the same as other + concurrent stream types. + +### Deprecations + +* In `Streamly.Prelude`: + * `runStream` has been replaced by `drain` + * `runN` has been replaced by `drainN` + * `runWhile` has been replaced by `drainWhile` + * `fromHandle` has been deprecated. Please use + `Streamly.FileSystem.Handle.read`, `Streamly.Data.Unicode.Stream.decodeUtf8` and + `splitOnSuffix` with `Streamly.Data.Fold.toList` to split the + stream to a stream of `String` separated by a newline. + * `toHandle` has been deprecated. Please use `intersperse` and `concatUnfold` to + add newlines to a stream, `Streamly.Data.Unicode.Stream.encodeUtf8` for encoding and + `Streamly.FileSystem.Handle.write` for writing to a file handle. + * Deprecate `scanx`, `foldx`, `foldxM`, `foldr1` + * Remove deprecated APIs `foldl`, `foldlM` + * Replace deprecated API `scan` with a new signature, to scan using Fold. + +* In `Streamly` module: + * `runStream` has been deprecated, please use `Streamly.Prelude.drain` + +* Remove deprecated module `Streamly.Time` (moved to Streamly.Internal.Data.Time) +* Remove module `Streamly.Internal` (functionality moved to the Internal hierarchy) + +### Bug Fixes + +* Fix a bug that caused `uniq` function to yield the same element twice. +* Fix a bug that caused "thread blocked indefinitely in an MVar operation" + exception in a parallel stream. +* Fix unbounded memory usage (leak) in `parallel` combinator. The bug manifests + when large streams are combined using `parallel`. + +### Major Enhancements + +This release contains a lot of new features and major enhancements. For more +details on the new features described below please see the haddock docs of the +modules on hackage. + +#### Exception Handling + +See `Streamly.Prelude` for new exception handling combinators like `before`, +`after`, `bracket`, `onException`, `finally`, `handle` etc. + +#### Composable Folds + +`Streamly.Data.Fold` module provides composable folds (stream consumers). Folds +allow splitting, grouping, partitioning, unzipping and nesting a stream onto +multiple folds without breaking the stream. Combinators are provided for +temporal and spatial window based fold operations, for example, to support +folding and aggregating data for timeout or inactivity based sessions. + +#### Composable Unfolds + +`Streamly.Data.Unfold` module provides composable stream generators. Unfolds allow +high performance merging/flattening/combining of stream generators. + +#### Streaming File IO + +`Streamly.FileSystem.Handle` provides handle based streaming file IO +operations. + +#### Streaming Network IO + +* `Streamly.Network.Socket` provides socket based streaming network IO +operations. + +* `Streamly.Network.Inet.TCP` provides combinators to build Inet/TCP +clients and servers. + +#### Concurrent concatMap + +The new `concatMapWith` in `Streamly.Prelude` combinator performs a +`concatMap` using a supplied merge/concat strategy. This is a very +powerful combinator as you can, for example, concat streams +concurrently using this. + +### Other Enhancements + +* Add the following new features/modules: + * _Unicode Strings_: `Streamly.Data.Unicode.Stream` module provides + encoding/decoding of character streams and other character stream + operations. + * _Arrays_: `Streamly.Memory.Array` module provides arrays for efficient + in-memory buffering and efficient interfacing with IO. + +* Add the following to `Streamly.Prelude`: + * `unfold`, `fold`, `scan` and `postscan` + * `concatUnfold` to concat a stream after unfolding each element + * `intervalsOf` and `chunksOf` + * `splitOn`, `splitOnSuffix`, `splitWithSuffix`, and `wordsBy` + * `groups`, `groupsBy` and `groupsByRolling` + * `postscanl'` and `postscanlM'` + * `intersperse` intersperse an element in between consecutive elements in + stream + * `trace` combinator maps a monadic function on a stream just for side + effects + * `tap` redirects a copy of the stream to a `Fold` + +## 0.6.1 (March 2019) + +### Bug Fixes + +* Fix a bug that caused `maxThreads` directive to be ignored when rate control + was not used. + +### Enhancements + +* Add GHCJS support +* Remove dependency on "clock" package + +## 0.6.0 (December 2018) + +### Breaking changes + +* `Monad` constraint may be needed on some of the existing APIs (`findIndices` + and `elemIndices`). + +### Enhancements + +* Add the following functions to Streamly.Prelude: + * Generation: `replicate`, `fromIndices`, `fromIndicesM` + * Enumeration: `Enumerable` type class, `enumerateFrom`, `enumerateFromTo`, + `enumerateFromThen`, `enumerateFromThenTo`, `enumerate`, `enumerateTo` + * Running: `runN`, `runWhile` + * Folds: `(!!)`, `maximumBy`, `minimumBy`, `the` + * Scans: `scanl1'`, `scanl1M' + * Filters: `uniq`, `insertBy`, `deleteBy`, `findM` + * Multi-stream: `eqBy`, `cmpBy`, `mergeBy`, `mergeByM`, `mergeAsyncBy`, + `mergeAsyncByM`, `isPrefixOf`, `isSubsequenceOf`, `stripPrefix`, + `concatMap`, `concatMapM`, `indexed`, `indexedR` +* Following instances were added for `SerialT m`, `WSerialT m` and + `ZipSerialM m`: + * When `m` ~ `Identity`: IsList, Eq, Ord, Show, Read, IsString, NFData, + NFData1, Traversable + * When `m` is `Foldable`: Foldable +* Performance improvements +* Add benchmarks to measure composed and iterated operations + +## 0.5.2 (October 2018) + +### Bug Fixes + +* Cleanup any pending threads when an exception occurs. +* Fixed a livelock in ahead style streams. The problem manifests sometimes when + multiple streams are merged together in ahead style and one of them is a nil + stream. +* As per expected concurrency semantics each forked concurrent task must run + with the monadic state captured at the fork point. This release fixes a bug, + which, in some cases caused an incorrect monadic state to be used for a + concurrent action, leading to unexpected behavior when concurrent streams are + used in a stateful monad e.g. `StateT`. Particularly, this bug cannot affect + `ReaderT`. + +## 0.5.1 (September 2018) + +* Performance improvements, especially space consumption, for concurrent + streams + +## 0.5.0 (September 2018) + +### Bug Fixes + +* Leftover threads are now cleaned up as soon as the consumer is garbage + collected. +* Fix a bug in concurrent function application that in certain cases would + unnecessarily share the concurrency state resulting in incorrect output + stream. +* Fix passing of state across `parallel`, `async`, `wAsync`, `ahead`, `serial`, + `wSerial` combinators. Without this fix combinators that rely on state + passing e.g. `maxThreads` and `maxBuffer` won't work across these + combinators. + +### Enhancements + +* Added rate limiting combinators `rate`, `avgRate`, `minRate`, `maxRate` and + `constRate` to control the yield rate of a stream. +* Add `foldl1'`, `foldr1`, `intersperseM`, `find`, `lookup`, `and`, `or`, + `findIndices`, `findIndex`, `elemIndices`, `elemIndex`, `init` to Prelude + +### Deprecations + +* The `Streamly.Time` module is now deprecated, its functionality is subsumed + by the new rate limiting combinators. + +## 0.4.1 (July 2018) + +### Bug Fixes + +* foldxM was not fully strict, fixed. + +## 0.4.0 (July 2018) + +### Breaking changes + +* Signatures of `zipWithM` and `zipAsyncWithM` have changed +* Some functions in prelude now require an additional `Monad` constraint on + the underlying type of the stream. + +### Deprecations + +* `once` has been deprecated and renamed to `yieldM` + +### Enhancements + +* Add concurrency control primitives `maxThreads` and `maxBuffer`. +* Concurrency of a stream with bounded concurrency when used with `take` is now + limited by the number of elements demanded by `take`. +* Significant performance improvements utilizing stream fusion optimizations. +* Add `yield` to construct a singleton stream from a pure value +* Add `repeat` to generate an infinite stream by repeating a pure value +* Add `fromList` and `fromListM` to generate streams from lists, faster than + `fromFoldable` and `fromFoldableM` +* Add `map` as a synonym of fmap +* Add `scanlM'`, the monadic version of scanl' +* Add `takeWhileM` and `dropWhileM` +* Add `filterM` + +## 0.3.0 (June 2018) + +### Breaking changes + +* Some prelude functions, to whom concurrency capability has been added, will + now require a `MonadAsync` constraint. + +### Bug Fixes + +* Fixed a race due to which, in a rare case, we might block indefinitely on + an MVar due to a lost wakeup. +* Fixed an issue in adaptive concurrency. The issue caused us to stop creating + more worker threads in some cases due to a race. This bug would not cause any + functional issue but may reduce concurrency in some cases. + +### Enhancements +* Added a concurrent lookahead stream type `Ahead` +* Added `fromFoldableM` API that creates a stream from a container of monadic + actions +* Monadic stream generation functions `consM`, `|:`, `unfoldrM`, `replicateM`, + `repeatM`, `iterateM` and `fromFoldableM` can now generate streams + concurrently when used with concurrent stream types. +* Monad transformation functions `mapM` and `sequence` can now map actions + concurrently when used at appropriate stream types. +* Added concurrent function application operators to run stages of a + stream processing function application pipeline concurrently. +* Added `mapMaybe` and `mapMaybeM`. + +## 0.2.1 (June 2018) + +### Bug Fixes +* Fixed a bug that caused some transformation ops to return incorrect results + when used with concurrent streams. The affected ops are `take`, `filter`, + `takeWhile`, `drop`, `dropWhile`, and `reverse`. + +## 0.2.0 (May 2018) + +### Breaking changes +* Changed the semantics of the Semigroup instance for `InterleavedT`, `AsyncT` + and `ParallelT`. The new semantics are as follows: + * For `InterleavedT`, `<>` operation interleaves two streams + * For `AsyncT`, `<>` now concurrently merges two streams in a left biased + manner using demand based concurrency. + * For `ParallelT`, the `<>` operation now concurrently meges the two streams + in a fairly parallel manner. + + To adapt to the new changes, replace `<>` with `serial` wherever it is used + for stream types other than `StreamT`. + +* Remove the `Alternative` instance. To adapt to this change replace any usage + of `<|>` with `parallel` and `empty` with `nil`. +* Stream type now defaults to the `SerialT` type unless explicitly specified + using a type combinator or a monomorphic type. This change reduces puzzling + type errors for beginners. It includes the following two changes: + * Change the type of all stream elimination functions to use `SerialT` + instead of a polymorphic type. This makes sure that the stream type is + always fixed at all exits. + * Change the type combinators (e.g. `parallely`) to only fix the argument + stream type and the output stream type remains polymorphic. + + Stream types may have to be changed or type combinators may have to be added + or removed to adapt to this change. +* Change the type of `foldrM` to make it consistent with `foldrM` in base. +* `async` is renamed to `mkAsync` and `async` is now a new API with a different + meaning. +* `ZipAsync` is renamed to `ZipAsyncM` and `ZipAsync` is now ZipAsyncM + specialized to the IO Monad. +* Remove the `MonadError` instance as it was not working correctly for + parallel compositions. Use `MonadThrow` instead for error propagation. +* Remove Num/Fractional/Floating instances as they are not very useful. Use + `fmap` and `liftA2` instead. + +### Deprecations +* Deprecate and rename the following symbols: + * `Streaming` to `IsStream` + * `runStreaming` to `runStream` + * `StreamT` to `SerialT` + * `InterleavedT` to `WSerialT` + * `ZipStream` to `ZipSerialM` + * `ZipAsync` to `ZipAsyncM` + * `interleaving` to `wSerially` + * `zipping` to `zipSerially` + * `zippingAsync` to `zipAsyncly` + * `<=>` to `wSerial` + * `<|` to `async` + * `each` to `fromFoldable` + * `scan` to `scanx` + * `foldl` to `foldx` + * `foldlM` to `foldxM` +* Deprecate the following symbols for future removal: + * `runStreamT` + * `runInterleavedT` + * `runAsyncT` + * `runParallelT` + * `runZipStream` + * `runZipAsync` + +### Enhancements +* Add the following functions: + * `consM` and `|:` operator to construct streams from monadic actions + * `once` to create a singleton stream from a monadic action + * `repeatM` to construct a stream by repeating a monadic action + * `scanl'` strict left scan + * `foldl'` strict left fold + * `foldlM'` strict left fold with a monadic fold function + * `serial` run two streams serially one after the other + * `async` run two streams asynchronously + * `parallel` run two streams in parallel (replaces `<|>`) + * `WAsyncT` stream type for BFS version of `AsyncT` composition +* Add simpler stream types that are specialized to the IO monad +* Put a bound (1500) on the output buffer used for asynchronous tasks +* Put a limit (1500) on the number of threads used for Async and WAsync types + +## 0.1.2 (March 2018) + +### Enhancements +* Add `iterate`, `iterateM` stream operations + +### Bug Fixes +* Fixed a bug that caused unexpected behavior when `pure` was used to inject + values in Applicative composition of `ZipStream` and `ZipAsync` types. + +## 0.1.1 (March 2018) + +### Enhancements +* Make `cons` right associative and provide an operator form `.:` for it +* Add `null`, `tail`, `reverse`, `replicateM`, `scan` stream operations +* Improve performance of some stream operations (`foldl`, `dropWhile`) + +### Bug Fixes +* Fix the `product` operation. Earlier, it always returned 0 due to a bug +* Fix the `last` operation, which returned `Nothing` for singleton streams + +## 0.1.0 (December 2017) + +* Initial release diff --git a/docs/Compiling.md b/docs/Compiling.md new file mode 100644 --- /dev/null +++ b/docs/Compiling.md @@ -0,0 +1,137 @@ +# Build Guide + +## Building + +### Compiler (GHC) Versions + +GHC 8.6 and above are recommended. For best performance use GHC 8.8 or +8.10 along with `fusion-plugin` (see below). Benchmarks show that GHC +8.8 has significantly better performance than GHC 8.6 in many cases. + +GHC 9.0 and GHC 9.2.1 have some performance issues, please see [this +issue](https://github.com/composewell/streamly/issues/1061) for details. +GHC 9.2.2 is expected to have the fixes that will bring the performance on par +with previous versions. + +### Distributions + +Tested with stackage `lts-18.27` and `nix 21.05`. + +### Memory requirements + +Building streamly itself may require upto 4GB memory. Depending on the +size of the application you may require 1-16GB memory to build. For most +applications up to 8GB of memory should be sufficient. + +To reduce the memory footprint you may want to break big modules into +smaller ones and reduce unnecessary inlining on large functions. You can +also use the `-Rghc-timing` GHC option to report the memory usage during +compilation. + +See the "Build times and space considerations" section below for more +details. + +### Compilation Options + +#### Recommended Options + +Add `fusion-plugin` to the `build-depends` section of your program in +the cabal file and use the following GHC options: + +``` + -O2 + -fdicts-strict + -fmax-worker-args=16 + -fspec-constr-recursive=16 + -fplugin Fusion.Plugin +``` + +Important Notes: + +1. [fusion-plugin](https://hackage.haskell.org/package/fusion-plugin) can + improve performance significantly by better stream fusion, many + cases. If the perform regresses due to fusion-plugin please open + an issue. You may remove the `-fplugin` option for regular builds + but it is recommended for deployment builds and performance + benchmarking. Note, for GHC 8.4 or lower fusion-plugin cannot be used. +2. In certain cases it is possible that GHC takes too long to compile + with `-fspec-constr-recursive=16`, if that happens please reduce the + value or remove that option. +3. At the very least `-O -fdicts-strict` compilation options are + absolutely required to avoid issues in some cases. For example, the + program `main = S.drain $ S.concatMap S.fromList $ S.repeat []` may + hog memory without these options. + +See [Explanation](#explanation) for details about these flags. + +#### Explanation + +* `-fdicts-strict` is needed to avoid [a GHC +issue](https://gitlab.haskell.org/ghc/ghc/issues/17745) leading to +memory leak in some cases. + +* `-fspec-constr-recursive` is needed for better stream fusion by enabling +the `SpecConstr` optimization in more cases. Large values used with this flag +may lead to huge compilation times and code bloat, if that happens please avoid +it or use a lower value (e.g. 3 or 4). + +* `-fmax-worker-args` is needed for better stream fusion by enabling the +`SpecConstr` optimization in some important cases. + +* `-fplugin=Fusion.Plugin` enables predictable stream fusion +optimization in certain cases by helping the compiler inline internal +bindings and therefore enabling case-of-case optimization. In some +cases, especially in some file IO benchmarks, it can make a difference of +5-10x better performance. + +### Multi-core Parallelism + +Concurrency without a threaded runtime may be a bit more efficient. Do not use +threaded runtime unless you really need multi-core parallelism. To get +multi-core parallelism use the following GHC options: + + `-threaded -with-rtsopts "-N"` + +## Platform Specific Features + +Streamly supports Linux, macOS and Windows operating systems. Some +modules and functionality may depend on specific OS kernel features. +Features/modules may get disabled if the kernel/OS does not support it. + +### Linux + +File system events notification module is supported only for kernel versions +2.6.36 onwards. + +### macOS + +File system events notification module supports macOS 10.7+ . You must +have the ``Cocoa`` framework installed which is supplied by the macOS +SDK. If ``Cocoa`` is not installed, you may see an error like this: + +``` +error: ld: framework not found Cocoa +``` + +### Native build + +Usually, if you have a working GHC you would already have the SDK +installed. See the documentation of `Xcode` or `xcode-select` tool for +more details. + +### Nix build + +Please note that cabal2nix may not always be able to generate a complete nix +expression on `macOS`. See [this +issue](https://github.com/NixOS/cabal2nix/issues/470). + +You may need to add ``nixpkgs.darwin.apple_sdk.frameworks.Cocoa`` to +your ``buildInputs`` or ``executableFrameworkDepends``. Something like +this: + +``` +executableFrameworkDepends = + if builtins.currentSystem == "x86_64-darwin" + then [nixpkgs.darwin.apple_sdk.frameworks.Cocoa] + else []; +``` diff --git a/docs/ConcurrentStreams.hs b/docs/ConcurrentStreams.hs --- a/docs/ConcurrentStreams.hs +++ b/docs/ConcurrentStreams.hs @@ -723,19 +723,20 @@ -- 'fromZipAsync' type combinator can be used to switch to parallel applicative -- zip composition: -- --- This takes 7 seconds to zip, which is max (1,3) + max (2,4) because 1 and 3 --- are produced concurrently, and 2 and 4 are produced concurrently: --- -- >>> d n = delay n >> return n --- >>> s1 = Stream.fromSerial $ d 1 <> d 2 --- >>> s2 = Stream.fromSerial $ d 3 <> d 4 +-- >>> s1 = Stream.fromSerial $ d 2 <> d 4 +-- >>> s2 = Stream.fromSerial $ d 3 <> d 1 -- >>> (Stream.toList $ Stream.fromZipAsync $ (,) <$> s1 <*> s2) >>= print --- ThreadId ...: Delay 1 -- ThreadId ...: Delay 2 -- ThreadId ...: Delay 3 +-- ThreadId ...: Delay 1 -- ThreadId ...: Delay 4 --- [(1,3),(2,4)] +-- [(2,3),(4,1)] -- +-- The actions within each stream are executed serially, however, the two +-- streams are run concurrently with respect to each other. Therefore, it takes +-- 6 seconds to zip the two streams, which is the maximum of the time to +-- evaluate stream s1 (2 + 4 = 6 seconds) and stream s2 (3 + 1 = 4 seconds). -- $concurrent -- diff --git a/docs/Introduction.md b/docs/Introduction.md new file mode 100644 --- /dev/null +++ b/docs/Introduction.md @@ -0,0 +1,651 @@ +# [Streamly][]: Idiomatic Haskell with the Performance of C + +[![Gitter chat](https://badges.gitter.im/composewell/gitter.svg)](https://gitter.im/composewell/streamly) +[![Hackage](https://img.shields.io/hackage/v/streamly.svg?style=flat)](https://hackage.haskell.org/package/streamly) + +Streamly is a Haskell library that provides the building blocks to build +safe, scalable, modular and high performance software. Streamly offers: + +* The type safety of Haskell. +* The performance of C programs. +* Powerful abstractions for structuring your code. +* Idiomatic functional programming. +* Declarative concurrency for the seamless use of multiprocessing hardware. + +## About This Document + +This guide introduces programming with [Streamly][] using a few practical +examples: + +* We will start with a simple program that [counts the number of words + in a text](#modular-word-counting). We will then transform this program + into a [concurrent](#concurrent-word-counting) program that can efficiently + use multiprocessing hardware. +* Next, we will create a [concurrent network + server](#a-concurrent-network-server). We then show + how to write a network server that [merges multiple + streams](#merging-incoming-streams) concurrently. +* Our third example shows how to list a directory tree concurrently, + by reading [multiple directories in + parallel](#listing-directories-recursivelyconcurrently). +* Finally, we will look at how to [rate limit](#rate-limiting) stream + processing. + +The guide then looks at how Streamly achieves its +[performance](#performance). It [concludes](#notes) with a brief +discussion about Streamly's design philosophy, and with suggestions for +further reading. + +## Getting Started + +### Installing Streamly + +If you wish to follow along with this guide, you will need to have +[Streamly][] installed. + +Please see the [Getting Started With The Streamly Package](/docs/getting-started.md) +guide for instructions on how to install [Streamly][]. + +If you wish to run benchmarks, please be sure to build your +application using the instructions in the [Build Guide](/docs/Compiling.md). + +### An overview of the types used in these examples + +As an expository device, we have indicated the types at the intermediate +stages of stream computations as comments in the examples below. +The meaning of these types are: + +* A `SerialT IO a` is a serial stream of values of type `a` in the IO Monad. +* An `AsyncT IO a` is a concurrent (asynchronous) stream of values of type + `a` in the IO Monad. +* An `Unfold IO a b` is a representation of a function that converts a seed + value of type `a` into a stream of values of type `b` in the IO Monad. +* A `Fold IO a b` is a representation of a function that converts a stream of + type `a` to a final accumulator of type `b` in the IO Monad. + +### A Note on Module Naming + +Some of the examples below use modules from the `Internal` Streamly package +hierarchy. These are not really internal to the library. We classify +`Streamly` modules into two categories: + +* _Released modules and APIs_: These modules and APIs are + stable. Significant changes to these modules and APIs will cause + Streamly's version number to change according to the package versioning + policy. +* _Pre-release modules and APIs_: These modules and APIs have not been + formally released yet. They may change in the near future, and such + changes will not necessarily be reflected in Streamly's package + version number. As yet unreleased modules and APIs reside in the + `Internal` namespace. + +Please use a minor release upper bound to adhere to the Haskell PVP when +using the pre-release (internal) modules. + +## The Examples + +### Modular Word Counting + +A `Fold` in Streamly is a composable stream consumer. For our first +example, we will use `Fold`s to count the number of bytes, words and lines +present in a file. We will then compose individual `Fold`s together to +count words, bytes and lines at the same time. + +Please see the file [WordCountModular.hs][] for the complete example +program, including the imports that we have omitted here. + +#### Count Bytes (wc -c) + +We start with a code fragment that counts the number of bytes in a file: + +```haskell +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Internal.FileSystem.File as File +import qualified Streamly.Prelude as Stream + +wcb :: String -> IO Int +wcb file = + File.toBytes file -- SerialT IO Word8 + & Stream.fold Fold.length -- IO Int +``` + +### Count Lines (wc -l) + +The next code fragment shows how to count the number of lines in a file: + +```haskell +-- ASCII character 10 is a newline. +countl :: Int -> Word8 -> Int +countl n ch = if ch == 10 then n + 1 else n + +-- The fold accepts a stream of `Word8` and returns a line count (`Int`). +nlines :: Monad m => Fold m Word8 Int +nlines = Fold.foldl' countl 0 + +wcl :: String -> IO Int +wcl file = + File.toBytes file -- SerialT IO Word8 + & Stream.fold nlines -- IO Int +``` + +### Count Words (wc -w) + +Our final code fragment counts the number of whitespace-separated words +in a stream: + +```haskell +countw :: (Int, Bool) -> Word8 -> (Int, Bool) +countw (n, wasSpace) ch = + if isSpace $ chr $ fromIntegral ch + then (n, True) + else (if wasSpace then n + 1 else n, False) + +-- The fold accepts a stream of `Word8` and returns a word count (`Int`). +nwords :: Monad m => Fold m Word8 Int +nwords = fst <$> Fold.foldl' countw (0, True) + +wcw :: String -> IO Int +wcw file = + File.toBytes file -- SerialT IO Word8 + & Stream.fold nwords -- IO Int +``` + +### Counting Bytes, Words and Lines Together + +By using the `Tee` combinator we can compose the three folds that count +bytes, lines and words individually into a single fold that counts all +three at once. The applicative instance of `Tee` distributes its input +to all the supplied folds (`Fold.length`, `nlines`, and `nwords`) and +then combines the outputs from the folds using the supplied combiner +function (`(,,)`). + +```haskell +import qualified Streamly.Internal.Data.Fold.Tee as Tee + +-- The fold accepts a stream of `Word8` and returns the three counts. +countAll :: Fold IO Word8 (Int, Int, Int) +countAll = Tee.toFold $ (,,) <$> Tee Fold.length <*> Tee nlines <*> Tee nwords + +wc :: String -> IO (Int, Int, Int) +wc file = + File.toBytes file -- SerialT IO Word8 + & Stream.fold countAll -- IO (Int, Int, Int) +``` + +This example demonstrates the excellent modularity offered by +[Streamly][]'s simple and concise API. Experienced Haskellers will +notice that we have not used bytestrings—we instead used a stream of +`Word8` values, simplifying our program. + +### The Performance of Word Counting + +We compare two equivalent implementations: one using [Streamly][], +and the other using C. + +The performance of the [Streamly word counting +implementation][WordCount.hs] is: + +``` +$ time WordCount-hs gutenberg-500MB.txt +11242220 97050938 574714449 gutenberg-500MB.txt + +real 0m1.825s +user 0m1.697s +sys 0m0.128s +``` + +The performance of an equivalent [wc implementation in C][WordCount.c] is: + +``` +$ time WordCount-c gutenberg-500MB.txt +11242220 97050938 574714449 gutenberg-500MB.txt + +real 0m2.100s +user 0m1.935s +sys 0m0.165s +``` + +### Concurrent Word Counting + +In our next example we show how the task of counting words, lines, +and bytes could be done in parallel on multiprocessor hardware. + +To count words in parallel we first divide the stream into chunks +(arrays), do the counting within each chunk, and then add all the +counts across chunks. We use the same code as above except that we use +arrays for our input data. + +Please see the file [WordCountParallel.hs][] for the complete working +code for this example, including the imports that we have omitted below. + +The `countArray` function counts the line, word, char counts in one chunk: + +```haskell +import qualified Streamly.Data.Array.Foreign as Array + +countArray :: Array Word8 -> IO Counts +countArray arr = + Stream.unfold Array.read arr -- SerialT IO Word8 + & Stream.decodeLatin1 -- SerialT IO Char + & Stream.foldl' count (Counts 0 0 0 True) -- IO Counts +``` + +Here the function `count` and the `Counts` data type are defined in the +`WordCount` helper module defined in [WordCount.hs][]. + +When combining the counts in two contiguous chunks, we need to check +whether the first element of the next chunk is a whitespace character +in order to determine if the same word continues in the next chunk or +whether the chunk starts with a new word. The `partialCounts` function +adds a `Bool` flag to `Counts` returned by `countArray` to indicate +whether the first character in the chunk is a space. + +```haskell +partialCounts :: Array Word8 -> IO (Bool, Counts) +partialCounts arr = do + let r = Array.getIndex arr 0 + case r of + Just x -> do + counts <- countArray arr + return (isSpace (chr (fromIntegral x)), counts) + Nothing -> return (False, Counts 0 0 0 True) +``` + +`addCounts` then adds the counts from two consecutive chunks: + +```haskell +addCounts :: (Bool, Counts) -> (Bool, Counts) -> (Bool, Counts) +addCounts (sp1, Counts l1 w1 c1 ws1) (sp2, Counts l2 w2 c2 ws2) = + let wcount = + if not ws1 && not sp2 -- No space between two chunks. + then w1 + w2 - 1 + else w1 + w2 + in (sp1, Counts (l1 + l2) wcount (c1 + c2) ws2) +``` + +To count in parallel we now only need to divide the stream into arrays, +apply our counting function to each array, and then combine the counts +from each chunk. + +```haskell +wc :: String -> IO (Bool, Counts) +wc file = do + Stream.unfold File.readChunks file -- AheadT IO (Array Word8) + & Stream.mapM partialCounts -- AheadT IO (Bool, Counts) + & Stream.maxThreads numCapabilities -- AheadT IO (Bool, Counts) + & Stream.fromAhead -- SerialT IO (Bool, Counts) + & Stream.foldl' addCounts (False, Counts 0 0 0 True) -- IO (Bool, Counts) +``` + +Please note that the only difference between a concurrent and a +non-concurrent program lies in the use of the `Stream.fromAhead` +combinator. If we remove the call to `Stream.fromAhead`, we would +still have a perfectly valid and performant serial program. Notice +how succinctly and idiomatically we have expressed the concurrent word +counting problem. + +A benchmark with 2 CPUs: + +``` +$ time WordCount-hs-parallel gutenberg-500MB.txt +11242220 97050938 574714449 gutenberg-500MB.txt + +real 0m1.284s +user 0m1.952s +sys 0m0.140s +``` + +These example programs have assumed ASCII encoded input data. For UTF-8 +streams, we have a [concurrent wc implementation][WordCountParallelUTF8.hs] +with UTF-8 decoding. This concurrent implementation performs as well +as the standard `wc` program in serial benchmarks. In concurrent mode +[Streamly][]'s implementation can utilise multiple processing cores if +these are present, and can thereby run much faster than the standard +binary. + +Streamly provides concurrency facilities similar +to [OpenMP](https://en.wikipedia.org/wiki/OpenMP) and +[Cilk](https://en.wikipedia.org/wiki/Cilk) but with a more declarative +style of expression. With Streamly you can write concurrent programs +with ease, with support for different types of concurrent scheduling. + +### A Concurrent Network Server + +We now move to a slightly more complicated example: we simulate a +dictionary lookup server which can serve word meanings to multiple +clients concurrently. This example demonstrates the use of the concurrent +`mapM` combinator. + +Please see the file [WordServer.hs][] for the complete code for this +example, including the imports that we have omitted below. + +```haskell +import qualified Streamly.Data.Fold as Fold +import qualified Streamly.Network.Inet.TCP as TCP +import qualified Streamly.Network.Socket as Socket +import qualified Streamly.Unicode.Stream as Unicode + +-- Simulate network/db query by adding a delay. +fetch :: String -> IO (String, String) +fetch w = threadDelay 1000000 >> return (w,w) + +-- Read lines of whitespace separated list of words from a socket, fetch the +-- meanings of each word concurrently and return the meanings separated by +-- newlines, in same order as the words were received. Repeat until the +-- connection is closed. +lookupWords :: Socket -> IO () +lookupWords sk = + Stream.unfold Socket.read sk -- SerialT IO Word8 + & Unicode.decodeLatin1 -- SerialT IO Char + & Stream.wordsBy isSpace Fold.toList -- SerialT IO String + & Stream.fromSerial -- AheadT IO String + & Stream.mapM fetch -- AheadT IO (String, String) + & Stream.fromAhead -- SerialT IO (String, String) + & Stream.map show -- SerialT IO String + & Stream.intersperse "\n" -- SerialT IO String + & Unicode.encodeStrings Unicode.encodeLatin1 -- SerialT IO (Array Word8) + & Stream.fold (Socket.writeChunks sk) -- IO () + +serve :: Socket -> IO () +serve sk = finally (lookupWords sk) (close sk) + +-- | Run a server on port 8091. Accept and handle connections concurrently. The +-- connection handler is "serve" (i.e. lookupWords). You can use "telnet" or +-- "nc" as a client to try it out. +main :: IO () +main = + Stream.unfold TCP.acceptOnPort 8091 -- SerialT IO Socket + & Stream.fromSerial -- AsyncT IO () + & Stream.mapM serve -- AsyncT IO () + & Stream.fromAsync -- SerialT IO () + & Stream.drain -- IO () +``` + +### Merging Incoming Streams + +In the next example, we show how to merge logs coming from multiple +nodes in your network. These logs are merged at line boundaries and +the merged logs are written to a file or to a network destination. +This example uses the `concatMapWith` combinator to merge multiple +streams concurrently. + +Please see the file [MergeServer.hs][] for the complete working code, +including the imports that we have omitted below. + +```haskell +import qualified Streamly.Data.Unfold as Unfold +import qualified Streamly.Network.Socket as Socket + +-- | Read a line stream from a socket. +-- Note: lines are buffered, and we could add a limit to the +-- buffering for safety. +readLines :: Socket -> SerialT IO (Array Char) +readLines sk = + Stream.unfold Socket.read sk -- SerialT IO Word8 + & Unicode.decodeLatin1 -- SerialT IO Char + & Stream.splitWithSuffix (== '\n') Array.write -- SerialT IO String + +recv :: Socket -> SerialT IO (Array Char) +recv sk = Stream.finally (liftIO $ close sk) (readLines sk) + +-- | Starts a server at port 8091 listening for lines with space separated +-- words. Multiple clients can connect to the server and send streams of lines. +-- The server handles all the connections concurrently, merges the incoming +-- streams at line boundaries and writes the merged stream to a file. +server :: Handle -> IO () +server file = + Stream.unfold TCP.acceptOnPort 8090 -- SerialT IO Socket + & Stream.concatMapWith Stream.parallel recv -- SerialT IO (Array Char) + & Stream.unfoldMany Array.read -- SerialT IO Char + & Unicode.encodeLatin1 -- SerialT IO Word8 + & Stream.fold (Handle.write file) -- IO () + +main :: IO () +main = withFile "output.txt" AppendMode server +``` + +### Listing Directories Recursively/Concurrently + +Our next example lists a directory tree recursively, reading +multiple directories concurrently. + +This example uses the tree traversing combinator `iterateMapLeftsWith`. +This combinator maps a stream generator on the `Left` values in its +input stream (directory names in this case), feeding the resulting `Left` +values back to the input, while it lets the `Right` values (file names +in this case) pass through to the output. The `Stream.ahead` stream +joining combinator then makes it iterate on the directories concurrently. + +Please see the file [ListDir.hs][] for the complete working code, +including the imports that we have omitted below. + +```haskell +import Streamly.Internal.Data.Stream.IsStream (iterateMapLeftsWith) + +import qualified Streamly.Prelude as Stream +import qualified Streamly.Internal.FileSystem.Dir as Dir (toEither) + +-- Lists a directory as a stream of (Either Dir File). +listDir :: String -> SerialT IO (Either String String) +listDir dir = + Dir.toEither dir -- SerialT IO (Either String String) + & Stream.map (bimap mkAbs mkAbs) -- SerialT IO (Either String String) + + where mkAbs x = dir ++ "/" ++ x + +-- | List the current directory recursively using concurrent processing. +main :: IO () +main = do + hSetBuffering stdout LineBuffering + let start = Stream.fromPure (Left ".") + Stream.iterateMapLeftsWith Stream.ahead listDir start + & Stream.mapM_ print +``` + +### Rate Limiting + +For bounded concurrent streams, a stream yield rate can be specified +easily. For example, to print "tick" once every second you can simply +write: + +```haskell +main :: IO () +main = + Stream.repeatM (pure "tick") -- AsyncT IO String + & Stream.timestamped -- AsyncT IO (AbsTime, String) + & Stream.avgRate 1 -- AsyncT IO (AbsTime, String) + & Stream.fromAsync -- SerialT IO (AbsTime, String) + & Stream.mapM_ print -- IO () +``` + +Please see the file [Rate.hs][] for the complete working code. + +The concurrency of the stream is automatically controlled to match the +specified rate. [Streamly][]'s rate control works precisely even at +throughputs as high as millions of yields per second. + +For more sophisticated rate control needs please see the Streamly [reference +documentation][Streamly]. + +### Reactive Programming + +Streamly supports reactive (time domain) programming because of its +support for declarative concurrency. Please see the `Streamly.Prelude` +module for time-specific combinators like `intervalsOf`, and +folds like `takeInterval` in `Streamly.Internal.Data.Fold`. +Please also see the pre-release sampling combinators in the +`Streamly.Internal.Data.Stream.IsStream.Top` module for `throttle` and +`debounce` like operations. + +The examples [AcidRain.hs][] and [CirclingSquare.hs][] demonstrate +reactive programming using [Streamly][]. + +### More Examples + +If you would like to view more examples, please visit the [Streamly +Examples][streamly-examples] web page. + +### Further Reading + +* [Streaming Benchmarks][streaming-benchmarks] +* [Concurrency Benchmarks][concurrency-benchmarks] +* Functional Conf 2019 [Video](https://www.youtube.com/watch?v=uzsqgdMMgtk) | [Slides](https://www.slideshare.net/HarendraKumar10/streamly-concurrent-data-flow-programming) +* [Other Guides](/) +* [Streamly Homepage][Streamly] + +## Performance + +As you have seen in the word count example above, [Streamly][] offers +highly modular abstractions for building programs while also offering +the performance close to an equivalent (imperative) C program. + +Streamly offers excellent performance even for byte-at-a-time stream +operations using efficient abstractions like `Unfold`s and terminating +`Fold`s. Byte-at-a-time stream operations can simplify programming +because the developer does not have to deal explicitly with chunking +and re-combining data. + +Streamly exploits GHC's stream fusion optimizations (`case-of-case` and +`spec-constr`) aggressively to achieve C-like speed, while also offering +highly modular abstractions to developers. + +[Streamly][] will usually perform very well without any +compiler plugins. However, we have fixed some deficiencies +that we had noticed in GHC's optimizer using a [compiler +plugin](https://github.com/composewell/fusion-plugin). We hope to fold +these optimizations into GHC in the future; until then we recommend that +you use this plugin for applications that are performance sensitive. + +### Benchmarks + +We measured several Haskell streaming implementations +using various micro-benchmarks. Please see the [streaming +benchmarks][streaming-benchmarks] page for a detailed comparison of +Streamly against other streaming libraries. + +Our results show that [Streamly][] is the fastest effectful streaming +implementation on almost all the measured microbenchmarks. In many cases +it runs up to 100x faster, and in some cases even 1000x faster than +some of the tested alternatives. In some composite operation benchmarks +[Streamly][] turns out to be significantly faster than Haskell's list +implementation. + +*Note*: If you can write a program in some other way or with some other +language that runs significantly faster than what [Streamly][] offers, +please let us know and we will improve. + +## Notes + +Streamly comes equipped with a very powerful set of abstractions to +accomplish many kinds of programming tasks: it provides support for +programming with streams and arrays, for reading and writing from the +file system and from the network, for time domain programming (reactive +programming), and for reacting to file system events using `fsnotify`. + +Please view [Streamly's documentation][Streamly] for more information +about Streamly's features. + +### Concurrency + +Streamly uses lock-free synchronization for achieving concurrent +operation with low overheads. The number of tasks performed concurrently +are determined automatically based on the rate at which a consumer +is consuming the results. In other words, you do not need to manage +thread pools or decide how many threads to use for a particular task. +For CPU-bound tasks Streamly will try to keep the number of threads +close to the number of CPUs available; for IO-bound tasks it will utilize +more threads. + +The parallelism available during program execution can be utilized with +very little overhead even where the task size is very +small, because Streamly will automatically switch between +serial or batched execution of tasks on the same CPU depending +on whichever is more efficient. Please see our [concurrency +benchmarks][concurrency-benchmarks] for more detailed performance +measurements, and for a comparison with the `async` package. + +### Design Goals + +Our goals for [Streamly][] from the very beginning have been: + +1. To achieve simplicity by unifying abstractions. +2. To offer high performance. + +These goals are hard to achieve simultaneously because they are usually +inversely related. We have spent many years trying to get the abstractions +right without compromising performance. + +`Unfold` is an example of an abstraction that we have created to achieve +high performance when mapping streams on streams. `Unfold` allows stream +generation to be optimized well by the compiler through stream fusion. +A `Fold` with termination capability is another example which modularizes +stream elimination operations through stream fusion. Terminating folds +can perform many simple parsing tasks that do not require backtracking. +In Streamly, `Parser`s are a natural extension to terminating `Fold`s; +`Parser`s add the ability to backtrack to `Fold`s. Unification leads +to simpler abstractions and lower cognitive overheads while also not +compromising performance. + +## Credits + +The following authors/libraries have influenced or inspired this library in a +significant way: + + * Roman Leshchinskiy ([vector](http://hackage.haskell.org/package/vector)) + * Gabriella Gonzalez ([foldl](https://hackage.haskell.org/package/foldl)) + * Alberto G. Corona ([transient](https://hackage.haskell.org/package/transient)) + +Please see the [`credits`](/docs/Credits.md) directory for a full +list of contributors, credits and licenses. + +## Licensing + +Streamly is an [open source](https://github.com/composewell/streamly) +project available under a liberal [BSD-3-Clause license][LICENSE] + +## Contributing to Streamly + +As an open project we welcome contributions: + +* [Streamly Contributor's Guide][CONTRIBUTING.md] +* [Contact the streamly development team](mailto:streamly@composewell.com) + +## Getting Support + +Professional support is available for [Streamly][]: please contact +[support@composewell.com](mailto:support@composewell.com). + +You can also join our [community chat +channel](https://gitter.im/composewell/streamly) on Gitter. + + + +[Streamly]: https://streamly.composewell.com/ +[streamly-examples]: https://github.com/composewell/streamly-examples +[streaming-benchmarks]: https://github.com/composewell/streaming-benchmarks +[concurrency-benchmarks]: https://github.com/composewell/concurrency-benchmarks + + + + +[WordCountModular.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCountModular.hs +[WordCount.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCount.hs +[WordCount.c]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCount.c +[WordCountParallel.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCountParallel.hs +[WordCountParallelUTF8.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordCountParallelUTF8.hs +[WordServer.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/WordServer.hs +[MergeServer.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/MergeServer.hs +[ListDir.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/ListDir.hs +[Rate.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/Rate.hs +[AcidRain.hs]: https://github.com/composewell/streamly-examples/tree/master/examples/AcidRain.hs +[CirclingSquare.hs]: https://github.com/composewell/streamly-examples/tree/master/examples/CirclingSquare.hs + + +[LICENSE]: /LICENSE +[CONTRIBUTING.md]: /CONTRIBUTING.md +[docs]: docs/ diff --git a/docs/Overview.md b/docs/Overview.md --- a/docs/Overview.md +++ b/docs/Overview.md @@ -95,7 +95,7 @@ processed just like lists, with list like combinators, except that they are monadic and work in a streaming fashion. In other words streamly just completes what lists lack, you do not need to learn anything new. Please see [streamly vs -lists](docs/streamly-vs-lists.md) for a detailed comparison. +lists](/docs/streamly-vs-lists.md) for a detailed comparison. Not surprisingly, the monad instance of streamly is a list transformer, with concurrency capability. @@ -369,7 +369,7 @@ -fmax-worker-args=16` and compare the performance with regular GNU coreutils available on your system. Though many of these are not most optimal solutions to keep them short and elegant. Source file -[HandleIO.hs](https://github.com/composewell/streamly-examples/tree/master/examples/HandleIO.hs) +[CoreUtilsHandle.hs](https://github.com/composewell/streamly-examples/blob/master/examples/CoreUtilsHandle.hs) in the examples directory includes these examples. ``` haskell diff --git a/docs/building.md b/docs/building.md deleted file mode 100644 --- a/docs/building.md +++ /dev/null @@ -1,136 +0,0 @@ -# Build Guide - -## Building - -### Compiler (GHC) Versions - -GHC 8.6 and above are recommended. For best performance use GHC 8.8 or -8.10 along with `fusion-plugin` (see below). Benchmarks show that GHC -8.8 has significantly better performance than GHC 8.6 in many cases. - -GHC 9.0 and GHC 9.2 have some performance issues, please see [this -issue](https://github.com/composewell/streamly/issues/1061) for details. -However, upcoming releases may fix some of these issues. - -### Distributions - -Tested with stackage `lts-18.18` and `nix 21.05`. - -### Memory requirements - -Building streamly itself may require upto 4GB memory. Depending on the -size of the application you may require 1-16GB memory to build. For most -applications up to 8GB of memory should be sufficient. - -To reduce the memory footprint you may want to break big modules into -smaller ones and reduce unnecessary inlining on large functions. You can -also use the `-Rghc-timing` GHC option to report the memory usage during -compilation. - -See the "Build times and space considerations" section below for more -details. - -### Compilation Options - -#### Recommended Options - -Add `fusion-plugin` to the `build-depends` section of your program in -the cabal file and use the following GHC options: - -``` - -O2 - -fdicts-strict - -fmax-worker-args=16 - -fspec-constr-recursive=16 - -fplugin Fusion.Plugin -``` - -Important Notes: - -1. [fusion-plugin](https://hackage.haskell.org/package/fusion-plugin) can - improve performance significantly by better stream fusion, many - cases. If the perform regresses due to fusion-plugin please open - an issue. You may remove the `-fplugin` option for regular builds - but it is recommended for deployment builds and performance - benchmarking. Note, for GHC 8.4 or lower fusion-plugin cannot be used. -2. In certain cases it is possible that GHC takes too long to compile - with `-fspec-constr-recursive=16`, if that happens please reduce the - value or remove that option. -3. At the very least `-O -fdicts-strict` compilation options are - absolutely required to avoid issues in some cases. For example, the - program `main = S.drain $ S.concatMap S.fromList $ S.repeat []` may - hog memory without these options. - -See [Explanation](#explanation) for details about these flags. - -#### Explanation - -* `-fdicts-strict` is needed to avoid [a GHC -issue](https://gitlab.haskell.org/ghc/ghc/issues/17745) leading to -memory leak in some cases. - -* `-fspec-constr-recursive` is needed for better stream fusion by enabling -the `SpecConstr` optimization in more cases. Large values used with this flag -may lead to huge compilation times and code bloat, if that happens please avoid -it or use a lower value (e.g. 3 or 4). - -* `-fmax-worker-args` is needed for better stream fusion by enabling the -`SpecConstr` optimization in some important cases. - -* `-fplugin=Fusion.Plugin` enables predictable stream fusion -optimization in certain cases by helping the compiler inline internal -bindings and therefore enabling case-of-case optimization. In some -cases, especially in some file IO benchmarks, it can make a difference of -5-10x better performance. - -### Multi-core Parallelism - -Concurrency without a threaded runtime may be a bit more efficient. Do not use -threaded runtime unless you really need multi-core parallelism. To get -multi-core parallelism use the following GHC options: - - `-threaded -with-rtsopts "-N"` - -## Platform Specific Features - -Streamly supports Linux, macOS and Windows operating systems. Some -modules and functionality may depend on specific OS kernel features. -Features/modules may get disabled if the kernel/OS does not support it. - -### Linux - -File system events notification module is supported only for kernel versions -2.6.36 onwards. - -### macOS - -File system events notification module supports macOS 10.7+ . You must -have the ``Cocoa`` framework installed which is supplied by the macOS -SDK. If ``Cocoa`` is not installed, you may see an error like this: - -``` -error: ld: framework not found Cocoa -``` - -### Native build - -Usually, if you have a working GHC you would already have the SDK -installed. See the documentation of `Xcode` or `xcode-select` tool for -more details. - -### Nix build - -Please note that cabal2nix may not always be able to generate a complete nix -expression on `macOS`. See [this -issue](https://github.com/NixOS/cabal2nix/issues/470). - -You may need to add ``nixpkgs.darwin.apple_sdk.frameworks.Cocoa`` to -your ``buildInputs`` or ``executableFrameworkDepends``. Something like -this: - -``` -executableFrameworkDepends = - if builtins.currentSystem == "x86_64-darwin" - then [nixpkgs.darwin.apple_sdk.frameworks.Cocoa] - else []; -``` diff --git a/docs/faq.md b/docs/faq.md --- a/docs/faq.md +++ b/docs/faq.md @@ -2,7 +2,7 @@ This document provides idioms or examples to solve common programming problems using streamly. To start with please go through [Streamly Quick -Overview](README.md) and [`Streamly examples repository`][streamly-examples]. +Overview](/docs/Introduction.md) and [`Streamly examples repository`][streamly-examples]. This document provides additional examples. ## Distribute and Zip Concurrently diff --git a/docs/getting-started.md b/docs/getting-started.md --- a/docs/getting-started.md +++ b/docs/getting-started.md @@ -204,7 +204,7 @@ adding a version number constraint to the `--build-depends` flag: ``` -$ cabal repl --build-depends streamly==0.8.1.1 +$ cabal repl --build-depends streamly==0.8.2 [1 of 1] Compiling Main ( Main.hs, interpreted ) Ok, modules loaded: Main. *Main> @@ -279,11 +279,11 @@ If you got this far successfully, congratulations! * For an overview of the `streamly` package, please read the - [Streamly Quick Overview](README.md). + [Streamly Quick Overview](/docs/Introduction.md). * Please browse the code examples in the [`Streamly examples repository`][streamly-examples]. * If you would like to start on a real world project, please take a - look at the [Streamly Build Guide](./docs/building.md). + look at the [Streamly Build Guide](/docs/Compiling.md). * For comprehensive documentation please visit the [Streamly Homepage][Streamly]. diff --git a/docs/streamly-docs.cabal b/docs/streamly-docs.cabal --- a/docs/streamly-docs.cabal +++ b/docs/streamly-docs.cabal @@ -17,6 +17,7 @@ extra-doc-files: Roadmap.link + *.md library default-language: Haskell2010 @@ -28,6 +29,6 @@ ReactiveProgramming build-depends: - base >= 4.9 && < 5 + base >= 4.9 && < 4.17 , transformers >= 0.4 && < 0.6 , streamly diff --git a/docs/streamly-vs-async.md b/docs/streamly-vs-async.md --- a/docs/streamly-vs-async.md +++ b/docs/streamly-vs-async.md @@ -227,7 +227,7 @@ See the [haddock documentation on hackage](https://hackage.haskell.org/package/streamly) and [a comprehensive tutorial -here](https://hackage.haskell.org/package/streamly/docs/Streamly-Tutorial.html). +here](https://streamly.composewell.com/streamly-0.8.2/Tutorial.html). ## References diff --git a/docs/streamly-vs-lists.md b/docs/streamly-vs-lists.md --- a/docs/streamly-vs-lists.md +++ b/docs/streamly-vs-lists.md @@ -237,7 +237,7 @@ shown in a sorted order, from list's worst performing ones on the left to its best ones on the right. -![Streamly vs Lists (time) comparison](streamly-vs-list-time.svg) +![Streamly vs Lists (time) comparison](/docs/streamly-vs-list-time.svg) ## Why use streams instead of lists? diff --git a/docs/unified-abstractions.md b/docs/unified-abstractions.md --- a/docs/unified-abstractions.md +++ b/docs/unified-abstractions.md @@ -8,7 +8,7 @@ This document discusses the related packages in the Haskell ecosystem and how streamly unifies, overlaps, or compares with those. We provide simple code snippets for illustrations, for a better overview of the -library please see the [Streamly Quick Overview](../README.md) document. +library please see the [Streamly Quick Overview](/docs/Introduction.md) document. ## Existing Haskell Libraries @@ -94,7 +94,7 @@ low-level code having performance comparable to C. To further understand the similarity with list API, please see [Streamly vs. -lists](streamly-vs-lists.md). +lists](/docs/streamly-vs-lists.md). For comparison of Streamly performance with other libraries see [streaming benchmarks](https://github.com/composewell/streaming-benchmarks). @@ -161,7 +161,7 @@ 'replicateM', 'repeatM' work concurrently when used at the appropriate type. It allows concurrent programs to be written declaratively and composed idiomatically. They are not much different than serial programs. See -[Streamly vs async](streamly-vs-async.md) +[Streamly vs async](/docs/streamly-vs-async.md) for a comparison of Streamly with the `async` package. Streamly provides concurrent scheduling and looping similar to to @@ -189,10 +189,8 @@ The combination of non-determinism, concurrency, and streaming makes Streamly a strong reactive programming library as well. Reactive programming fundamentally deals with streams of events that can be -processed concurrently. The -[https://github.com/composewell/streamly-examples/tree/master/AcidRain.hs](Acid -Rain) and [Circling -Square](https://github.com/composewell/streamly-examples/tree/master/CirclingSquare.hs) +processed concurrently. The [Acid Rain][AcidRain.hs] and +[Circling Square][CirclingSquare.hs] examples demonstrate the basic reactive capability of Streamly. In core concepts, Streamly is strikingly similar to `dunai`. `dunai` was @@ -228,7 +226,7 @@ then you know how to use Streamly. This library is built with simplicity and ease of use as a design goal. * _Concurrency_: Simple, powerful, and scalable concurrency. Concurrency is - built-in, and not intrusive, concurrent programs are written exactly + built-in, and not intrusive, concurrent programs are written exactly as non-concurrent ones. * _Generality_: Unifies functionality provided by several disparate packages (streaming, concurrency, list transformer, logic programming, reactive @@ -270,3 +268,8 @@ ### Arrays * [vector](https://hackage.haskell.org/package/vector) + + + +[AcidRain.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/AcidRain.hs +[CirclingSquare.hs]: https://github.com/composewell/streamly-examples/blob/master/examples/CirclingSquare.hs diff --git a/src/Streamly/Data/Unfold.hs b/src/Streamly/Data/Unfold.hs --- a/src/Streamly/Data/Unfold.hs +++ b/src/Streamly/Data/Unfold.hs @@ -149,4 +149,17 @@ ( concat, map, mapM, takeWhile, take, filter, const, drop, dropWhile , zipWith ) -import Streamly.Internal.Data.Unfold +import Streamly.Internal.Data.Stream.IsStream.Type (IsStream) +import Streamly.Internal.Data.Unfold hiding (fromStream) + +import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream +import qualified Streamly.Internal.Data.Unfold as Unfold + +-- | Convert a stream into an 'Unfold'. Note that a stream converted to an +-- 'Unfold' may not be as efficient as an 'Unfold' in some situations. +-- +-- /Since: 0.8.0/ +-- +{-# INLINE_NORMAL fromStream #-} +fromStream :: (IsStream t, Monad m) => Unfold m (t m a) a +fromStream = lmap IsStream.adapt Unfold.fromStream diff --git a/src/Streamly/Internal/Control/Concurrent.hs b/src/Streamly/Internal/Control/Concurrent.hs --- a/src/Streamly/Internal/Control/Concurrent.hs +++ b/src/Streamly/Internal/Control/Concurrent.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE UnboxedTuples #-} - -- | -- Module : Streamly.Internal.Control.Concurrent -- Copyright : (c) 2017 Composewell Technologies @@ -7,30 +5,38 @@ -- Maintainer : streamly@composewell.com -- Stability : experimental -- Portability : GHC +-- +-- Note: This module is primarily for abstractions related to MonadBaseControl. +-- Please do not add any general routines in this. It should be renamed +-- appropriately. module Streamly.Internal.Control.Concurrent ( MonadAsync + , MonadRunInIO , RunInIO(..) - , captureMonadState - , doFork - , fork - , forkManaged + , askRunInIO + , withRunInIO + , withRunInIONoRestore + , restoreM ) where -import Control.Concurrent (ThreadId, forkIO, killThread) -import Control.Exception (SomeException(..), catch, mask) import Control.Monad.Catch (MonadThrow) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.Control - (MonadBaseControl, control, StM, liftBaseDiscard) -import Data.Functor (void) -import GHC.Conc (ThreadId(..)) -import GHC.Exts -import GHC.IO (IO(..)) -import System.Mem.Weak (addFinalizer) +#ifdef USE_UNLIFTIO +import Control.Monad.IO.Unlift (MonadUnliftIO(..), UnliftIO(..), askUnliftIO) +#else +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Control (MonadBaseControl(..), control) +#endif + +#ifdef USE_UNLIFTIO +type MonadRunInIO m = MonadUnliftIO m +#else +type MonadRunInIO m = (MonadIO m, MonadBaseControl IO m) +#endif + -- /Since: 0.8.0 ("Streamly.Prelude")/ -- -- | A monad that can perform concurrent or parallel IO operations. Streams @@ -40,9 +46,18 @@ -- /Since: 0.1.0 ("Streamly")/ -- -- @since 0.8.0 +#ifdef USE_UNLIFTIO +type MonadAsync m = (MonadUnliftIO m, MonadThrow m) +#else type MonadAsync m = (MonadIO m, MonadBaseControl IO m, MonadThrow m) +#endif + +#ifdef USE_UNLIFTIO +newtype RunInIO m = RunInIO { runInIO :: forall b. m b -> IO b } +#else newtype RunInIO m = RunInIO { runInIO :: forall b. m b -> IO (StM m b) } +#endif -- | When we run computations concurrently, we completely isolate the state of -- the concurrent computations from the parent computation. The invariant is @@ -51,50 +66,23 @@ -- a concurrent computation in the parent thread, otherwise it may affect the -- state of the parent which is against the defined semantics of concurrent -- execution. -captureMonadState :: MonadBaseControl IO m => m (RunInIO m) -captureMonadState = control $ \run -> run (return $ RunInIO run) - --- Stolen from the async package. The perf improvement is modest, 2% on a --- thread heavy benchmark (parallel composition using noop computations). --- A version of forkIO that does not include the outer exception --- handler: saves a bit of time when we will be installing our own --- exception handler. -{-# INLINE rawForkIO #-} -rawForkIO :: IO () -> IO ThreadId -rawForkIO action = IO $ \ s -> - case fork# action s of (# s1, tid #) -> (# s1, ThreadId tid #) +askRunInIO :: MonadRunInIO m => m (RunInIO m) +#ifdef USE_UNLIFTIO +askRunInIO = fmap (\(UnliftIO run) -> RunInIO run) askUnliftIO +#else +askRunInIO = control $ \run -> run (return $ RunInIO run) +#endif --- | Fork a thread to run the given computation, installing the provided --- exception handler. Lifted to any monad with 'MonadBaseControl IO m' --- capability. --- --- TODO: the RunInIO argument can be removed, we can directly pass the action --- as "mrun action" instead. -{-# INLINE doFork #-} -doFork :: MonadBaseControl IO m - => m () - -> RunInIO m - -> (SomeException -> IO ()) - -> m ThreadId -doFork action (RunInIO mrun) exHandler = - control $ \run -> - mask $ \restore -> do - tid <- rawForkIO $ catch (restore $ void $ mrun action) - exHandler - run (return tid) +#ifdef USE_UNLIFTIO +withRunInIONoRestore :: MonadRunInIO m => ((forall a. m a -> IO a) -> IO b) -> m b +withRunInIONoRestore = withRunInIO --- | 'fork' lifted to any monad with 'MonadBaseControl IO m' capability. --- -{-# INLINABLE fork #-} -fork :: MonadBaseControl IO m => m () -> m ThreadId -fork = liftBaseDiscard forkIO +restoreM :: MonadRunInIO m => a -> m a +restoreM = return +#else +withRunInIO :: MonadRunInIO m => ((forall a. m a -> IO (StM m a)) -> IO (StM m b)) -> m b +withRunInIO = control --- | Fork a thread that is automatically killed as soon as the reference to the --- returned threadId is garbage collected. --- -{-# INLINABLE forkManaged #-} -forkManaged :: (MonadIO m, MonadBaseControl IO m) => m () -> m ThreadId -forkManaged action = do - tid <- fork action - liftIO $ addFinalizer tid (killThread tid) - return tid +withRunInIONoRestore :: MonadRunInIO m => ((forall a. m a -> IO (StM m a)) -> IO b) -> m b +withRunInIONoRestore = liftBaseWith +#endif diff --git a/src/Streamly/Internal/Control/ForkIO.hs b/src/Streamly/Internal/Control/ForkIO.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Control/ForkIO.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE UnboxedTuples #-} + +-- | +-- Module : Streamly.Internal.Control.ForkIO +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Control.ForkIO + ( rawForkIO + , forkIOManaged + , forkManagedWith + ) +where + +import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Monad.IO.Class (MonadIO(..)) +import GHC.Conc (ThreadId(..)) +import GHC.Exts +import GHC.IO (IO(..)) +import System.Mem.Weak (addFinalizer) + +-- | Stolen from the async package. The perf improvement is modest, 2% on a +-- thread heavy benchmark (parallel composition using noop computations). +-- A version of forkIO that does not include the outer exception +-- handler: saves a bit of time when we will be installing our own +-- exception handler. +{-# INLINE rawForkIO #-} +rawForkIO :: IO () -> IO ThreadId +rawForkIO (IO action) = IO $ \ s -> + case fork# action s of (# s1, tid #) -> (# s1, ThreadId tid #) + +-- | Fork a thread that is automatically killed as soon as the reference to the +-- returned threadId is garbage collected. +-- +{-# INLINABLE forkManagedWith #-} +forkManagedWith :: MonadIO m => (m () -> m ThreadId) -> m () -> m ThreadId +forkManagedWith fork action = do + tid <- fork action + liftIO $ addFinalizer tid (killThread tid) + return tid + +-- | Fork a thread that is automatically killed as soon as the reference to the +-- returned threadId is garbage collected. +-- +{-# INLINABLE forkIOManaged #-} +forkIOManaged :: IO () -> IO ThreadId +forkIOManaged = forkManagedWith forkIO diff --git a/src/Streamly/Internal/Control/ForkLifted.hs b/src/Streamly/Internal/Control/ForkLifted.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Control/ForkLifted.hs @@ -0,0 +1,53 @@ +-- | +-- Module : Streamly.Internal.Control.ForkLifted +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC + +module Streamly.Internal.Control.ForkLifted + ( + doFork + , fork + , forkManaged + ) +where + +import Control.Concurrent (ThreadId, forkIO) +import Control.Exception (SomeException(..), catch, mask) +import Data.Functor (void) +import Streamly.Internal.Control.Concurrent (MonadRunInIO, RunInIO(..), withRunInIO, withRunInIONoRestore) +import Streamly.Internal.Control.ForkIO (rawForkIO, forkManagedWith) + +-- | Fork a thread to run the given computation, installing the provided +-- exception handler. Lifted to any monad with 'MonadRunInIO m' +-- capability. +-- +-- TODO: the RunInIO argument can be removed, we can directly pass the action +-- as "mrun action" instead. +{-# INLINE doFork #-} +doFork :: MonadRunInIO m + => m () + -> RunInIO m + -> (SomeException -> IO ()) + -> m ThreadId +doFork action (RunInIO mrun) exHandler = + withRunInIO $ \run -> + mask $ \restore -> do + tid <- rawForkIO $ catch (restore $ void $ mrun action) + exHandler + run (return tid) + +-- | 'fork' lifted to any monad with 'MonadBaseControl IO m' capability. +-- +{-# INLINABLE fork #-} +fork :: MonadRunInIO m => m () -> m ThreadId +fork m = withRunInIONoRestore $ \run -> forkIO $ void $ run m + +-- | Fork a thread that is automatically killed as soon as the reference to the +-- returned threadId is garbage collected. +-- +{-# INLINABLE forkManaged #-} +forkManaged :: MonadRunInIO m => m () -> m ThreadId +forkManaged = forkManagedWith fork diff --git a/src/Streamly/Internal/Data/Array/ArrayMacros.h b/src/Streamly/Internal/Data/Array/ArrayMacros.h new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Array/ArrayMacros.h @@ -0,0 +1,27 @@ +------------------------------------------------------------------------------- +-- Macros to access array pointers +------------------------------------------------------------------------------- + +-- The Storable instance of () has size 0. We ensure that the size is non-zero +-- to avoid a zero sized element and issues due to that. +-- See https://mail.haskell.org/pipermail/libraries/2022-January/thread.html +-- +-- XXX Check the core to see if max can be statically eliminated. llvm can +-- eliminate the comparison, but not sure if GHC NCG can. +#define SIZE_OF(a) max 1 (sizeOf (undefined :: a)) + +-- Move the pointer to ith element of specified type. Type is specified as the +-- type variable in the signature of the function where this macro is used. +#define PTR_NEXT(ptr,a) ptr `plusPtr` SIZE_OF(a) +#define PTR_PREV(ptr,a) ptr `plusPtr` negate (SIZE_OF(a)) + +#define PTR_INDEX(ptr,i,a) ptr `plusPtr` (SIZE_OF(a) * i) +#define PTR_RINDEX(ptr,i,a) ptr `plusPtr` negate (SIZE_OF(a) * (i + 1)) + +-- XXX If we know that the array is guaranteed to have size multiples of the +-- element size then we can use a simpler check saying "ptr < end". Since we +-- always allocate in multiples of elem we can use the simpler check and assert +-- the rigorous check. +#define PTR_VALID(ptr,end,a) ptr `plusPtr` SIZE_OF(a) <= end +#define PTR_INVALID(ptr,end,a) ptr `plusPtr` SIZE_OF(a) > end + diff --git a/src/Streamly/Internal/Data/Array/Foreign.hs b/src/Streamly/Internal/Data/Array/Foreign.hs --- a/src/Streamly/Internal/Data/Array/Foreign.hs +++ b/src/Streamly/Internal/Data/Array/Foreign.hs @@ -1,5 +1,3 @@ -#include "inline.hs" - -- | -- Module : Streamly.Internal.Data.Array.Foreign -- Copyright : (c) 2019 Composewell Technologies @@ -94,7 +92,7 @@ , cast , asBytes , unsafeCast -- castUnsafe? - , unsafeAsPtr -- asPtrUnsafe? + , asPtrUnsafe , unsafeAsCString -- asCStringUnsafe? , A.unsafeFreeze -- asImmutableUnsafe? , A.unsafeThaw -- asMutableUnsafe? @@ -115,6 +113,9 @@ ) where +#include "inline.hs" +#include "ArrayMacros.h" + import Control.Exception (assert) import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) @@ -128,14 +129,13 @@ import Foreign.Storable (Storable(..)) import Prelude hiding (length, null, last, map, (!!), read, concat) -import GHC.Ptr (Ptr(..)) - import Streamly.Internal.Data.Array.Foreign.Mut.Type (ReadUState(..), touch) -import Streamly.Internal.Data.Array.Foreign.Type (Array(..), length) +import Streamly.Internal.Data.Array.Foreign.Type + (Array(..), length, asPtrUnsafe) import Streamly.Internal.Data.Fold.Type (Fold(..)) import Streamly.Internal.Data.Producer.Type (Producer(..)) import Streamly.Internal.Data.Stream.Serial (SerialT(..)) -import Streamly.Internal.Data.Tuple.Strict (Tuple3'(..)) +import Streamly.Internal.Data.Tuple.Strict (Tuple3Fused'(..)) import Streamly.Internal.Data.Unfold.Type (Unfold(..)) import Streamly.Internal.System.IO (unsafeInlineIO) @@ -144,11 +144,10 @@ import qualified Streamly.Internal.Data.Array.Foreign.Type as A import qualified Streamly.Internal.Data.Fold as FL import qualified Streamly.Internal.Data.Producer as Producer -import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream import qualified Streamly.Internal.Data.Stream.Prelude as P import qualified Streamly.Internal.Data.Stream.StreamD as D import qualified Streamly.Internal.Data.Unfold as Unfold -import qualified Streamly.Internal.Ring.Foreign as RB +import qualified Streamly.Internal.Data.Ring.Foreign as RB ------------------------------------------------------------------------------- -- Construction @@ -204,8 +203,7 @@ -- This should be safe as the array contents are guaranteed to be -- evaluated/written to before we peek at them. let !x = unsafeInlineIO $ peek cur - cur1 = cur `plusPtr` sizeOf (undefined :: a) - return $ D.Yield x (ReadUState contents end cur1) + return $ D.Yield x (ReadUState contents end (PTR_NEXT(cur,a))) extract (ReadUState contents end cur) = return $ Array contents cur end @@ -249,7 +247,7 @@ r <- peek p touch contents return r - let !p1 = p `plusPtr` sizeOf (undefined :: a) + let !p1 = PTR_NEXT(p,a) return $ D.Yield x (ReadUState contents end p1) -- | @@ -266,13 +264,12 @@ -- -- /Pre-release/ {-# INLINE getIndexRev #-} -getIndexRev :: forall a. Storable a => Array a -> Int -> Maybe a -getIndexRev arr i = +getIndexRev :: forall a. Storable a => Int -> Array a -> Maybe a +getIndexRev i arr = unsafeInlineIO - $ MA.unsafeWithArrayContents (arrContents arr) (arrStart arr) + $ asPtrUnsafe arr $ \ptr -> do - let elemSize = sizeOf (undefined :: a) - elemPtr = aEnd arr `plusPtr` negate (elemSize * (i + 1)) + let elemPtr = PTR_RINDEX(aEnd arr,i,a) if i >= 0 && elemPtr >= ptr then Just <$> peek elemPtr else return Nothing @@ -285,7 +282,7 @@ -- /Pre-release/ {-# INLINE last #-} last :: Storable a => Array a -> Maybe a -last arr = getIndexRev arr 0 +last = getIndexRev 0 ------------------------------------------------------------------------------- -- Folds with Array as the container @@ -303,15 +300,15 @@ where - step (Tuple3' rb rh i) a = do + step (Tuple3Fused' rb rh i) a = do rh1 <- liftIO $ RB.unsafeInsert rb rh a - return $ FL.Partial $ Tuple3' rb rh1 (i + 1) + return $ FL.Partial $ Tuple3Fused' rb rh1 (i + 1) initial = - let f (a, b) = FL.Partial $ Tuple3' a b (0 :: Int) + let f (a, b) = FL.Partial $ Tuple3Fused' a b (0 :: Int) in fmap f $ liftIO $ RB.new n - done (Tuple3' rb rh i) = do + done (Tuple3Fused' rb rh i) = do arr <- liftIO $ MA.newArray n foldFunc i rh snoc' arr rb @@ -382,7 +379,7 @@ -> Array a -> Array a getSliceUnsafe index len (Array contents start e) = - let size = sizeOf (undefined :: a) + let size = SIZE_OF(a) fp1 = start `plusPtr` (index * size) end = fp1 `plusPtr` (len * size) in assert (end <= e) (Array contents fp1 end) @@ -395,7 +392,7 @@ splitOn :: (Monad m, Storable a) => (a -> Bool) -> Array a -> SerialT m (Array a) splitOn predicate arr = - IsStream.fromStreamD + SerialT $ D.toStreamK $ fmap (\(i, len) -> getSliceUnsafe i len arr) $ D.sliceOnSuffix predicate (A.toStreamD arr) @@ -428,6 +425,8 @@ -- XXX Change this to a partial function instead of a Maybe type? And use -- MA.getIndex instead. -- +-- XXX The signature should be "Int -> Array a -> Maybe a" +-- XXX This is a released API so make this change in the next major release. -- | /O(1)/ Lookup the element at the given index. Index starts from 0. -- -- @since 0.8.0 @@ -435,11 +434,10 @@ getIndex :: forall a. Storable a => Array a -> Int -> Maybe a getIndex arr i = unsafeInlineIO - $ MA.unsafeWithArrayContents (arrContents arr) (arrStart arr) + $ asPtrUnsafe arr $ \ptr -> do - let elemSize = sizeOf (undefined :: a) - elemPtr = ptr `plusPtr` (elemSize * i) - if i >= 0 && elemPtr `plusPtr` elemSize <= aEnd arr + let elemPtr = PTR_INDEX(ptr,i,a) + if i >= 0 && PTR_VALID(elemPtr,aEnd arr,a) then Just <$> peek elemPtr else return Nothing @@ -459,10 +457,12 @@ -- in Unfold.lmap f (getIndicesFromThenTo i (i - 1) 0) -- @ -- --- /Unimplemented/ +-- /Pre-release/ {-# INLINE getIndices #-} -getIndices :: Unfold m (Array a) Int -> Unfold m (Array a) a -getIndices = undefined +getIndices :: (Monad m, Storable a) => SerialT m Int -> Unfold m (Array a) a +getIndices (SerialT stream) = + let unf = MA.getIndicesD (return . unsafeInlineIO) $ D.fromStreamK stream + in Unfold.lmap A.unsafeThaw unf -- | Unfolds @(from, then, to, array)@ generating a finite stream whose first -- element is the array value from the index @from@ and the successive elements @@ -549,21 +549,11 @@ cast :: forall a b. (Storable b) => Array a -> Maybe (Array b) cast arr = let len = A.byteLength arr - r = len `mod` sizeOf (undefined :: b) + r = len `mod` SIZE_OF(b) in if r /= 0 then Nothing else Just $ unsafeCast arr --- | Use an @Array a@ as @Ptr b@. --- --- /Unsafe/ --- --- /Pre-release/ --- -unsafeAsPtr :: Array a -> (Ptr b -> IO c) -> IO c -unsafeAsPtr Array{..} act = do - MA.unsafeWithArrayContents arrContents arrStart $ \ptr -> act (castPtr ptr) - -- | Convert an array of any type into a null terminated CString Ptr. -- -- /Unsafe/ @@ -574,8 +564,8 @@ -- unsafeAsCString :: Array a -> (CString -> IO b) -> IO b unsafeAsCString arr act = do - let Array{..} = asBytes arr <> A.fromList [0] - MA.unsafeWithArrayContents arrContents arrStart $ \ptr -> act (castPtr ptr) + let arr1 = asBytes arr <> A.fromList [0] + asPtrUnsafe arr1 $ \ptr -> act (castPtr ptr) ------------------------------------------------------------------------------- -- Folds diff --git a/src/Streamly/Internal/Data/Array/Foreign/Mut.hs b/src/Streamly/Internal/Data/Array/Foreign/Mut.hs --- a/src/Streamly/Internal/Data/Array/Foreign/Mut.hs +++ b/src/Streamly/Internal/Data/Array/Foreign/Mut.hs @@ -28,20 +28,22 @@ , splitOn , genSlicesFromLen , getSlicesFromLen + , fromStream ) where -import Prelude hiding (foldr, length, read, splitAt) +import Control.Monad.IO.Class (MonadIO(..)) +import Foreign.Storable (Storable) +import Streamly.Internal.Data.Stream.Serial (SerialT(..)) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) -import Streamly.Internal.Data.Array.Foreign.Mut.Type import qualified Streamly.Internal.Data.Stream.StreamD as D -import Foreign.Storable (Storable) -import Streamly.Internal.Data.Stream.IsStream.Type (SerialT) -import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream import qualified Streamly.Internal.Data.Unfold as Unfold -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) -import Control.Monad.IO.Class (MonadIO(..)) +-- import qualified Streamly.Internal.Data.Stream.Prelude as P +import Prelude hiding (foldr, length, read, splitAt) +import Streamly.Internal.Data.Array.Foreign.Mut.Type + -- | Split the array into a stream of slices using a predicate. The element -- matching the predicate is dropped. -- @@ -50,7 +52,8 @@ splitOn :: (MonadIO m, Storable a) => (a -> Bool) -> Array a -> SerialT m (Array a) splitOn predicate arr = - IsStream.fromStreamD + SerialT + $ D.toStreamK $ fmap (\(i, len) -> getSliceUnsafe i len arr) $ D.sliceOnSuffix predicate (toStreamD arr) @@ -84,3 +87,17 @@ getSlicesFromLen from len = let mkSlice arr (i, n) = return $ getSliceUnsafe i n arr in Unfold.mapMWithInput mkSlice (genSlicesFromLen from len) + +-- | Create an 'Array' from a stream. This is useful when we want to create a +-- single array from a stream of unknown size. 'writeN' is at least twice +-- as efficient when the size is already known. +-- +-- Note that if the input stream is too large memory allocation for the array +-- may fail. When the stream size is not known, `arraysOf` followed by +-- processing of indvidual arrays in the resulting stream should be preferred. +-- +-- /Pre-release/ +{-# INLINE fromStream #-} +fromStream :: (MonadIO m, Storable a) => SerialT m a -> m (Array a) +fromStream (SerialT m) = fromStreamD $ D.fromStreamK m +-- fromStream (SerialT m) = P.fold write m diff --git a/src/Streamly/Internal/Data/Array/Foreign/Mut/Type.hs b/src/Streamly/Internal/Data/Array/Foreign/Mut/Type.hs --- a/src/Streamly/Internal/Data/Array/Foreign/Mut/Type.hs +++ b/src/Streamly/Internal/Data/Array/Foreign/Mut/Type.hs @@ -20,13 +20,12 @@ , ArrayContents , arrayToFptrContents , fptrToArrayContents - , unsafeWithArrayContents , nilArrayContents , touch -- * Constructing and Writing -- ** Construction - -- , nil + , nil -- *** Uninitialized Arrays , newArray @@ -74,6 +73,7 @@ , modifyIndices , modify , swapIndices + , unsafeSwapIndices -- * Growing and Shrinking -- Arrays grow only at the end, though it is possible to grow on both sides @@ -93,13 +93,6 @@ , appendWith , append - -- ** Truncation - -- These are not the same as slicing the array at the beginning, they may - -- reduce the length as well as the capacity of the array. - , truncateWith - , truncate - , truncateExp - -- * Eliminating and Reading -- ** To streams @@ -121,6 +114,7 @@ , getIndex , getIndexUnsafe , getIndices + , getIndicesD -- , getFromThenTo , getIndexRev @@ -195,6 +189,7 @@ -- , appendSliceFrom -- * Utilities + , roundUpToPower2 , memcpy , memcmp , c_memchr @@ -202,6 +197,8 @@ where #include "inline.hs" +#include "ArrayMacros.h" +#include "MachDeps.h" #ifdef USE_C_MALLOC #define USE_FOREIGN_PTR @@ -211,7 +208,7 @@ import Control.DeepSeq (NFData(..)) import Control.Monad (when, void) import Control.Monad.IO.Class (MonadIO(..)) -import Data.Bits ((.&.)) +import Data.Bits (shiftR, (.|.), (.&.)) #if __GLASGOW_HASKELL__ < 808 import Data.Semigroup (Semigroup(..)) #endif @@ -245,7 +242,8 @@ import Streamly.Internal.BaseCompat import Streamly.Internal.Data.Fold.Type (Fold(..)) import Streamly.Internal.Data.Producer.Type (Producer (..)) -import Streamly.Internal.Data.SVar.Type (adaptState) +import Streamly.Internal.Data.Stream.Serial (SerialT(..)) +import Streamly.Internal.Data.SVar.Type (adaptState, defState) import Streamly.Internal.Data.Unfold.Type (Unfold(..)) import Streamly.Internal.System.IO (arrayPayloadSize, defaultChunkSize) import System.IO.Unsafe (unsafePerformIO) @@ -273,7 +271,7 @@ -- >>> import qualified Streamly.Internal.Data.Fold.Type as Fold ------------------------------------------------------------------------------- --- Array Data Type +-- Foreign helpers ------------------------------------------------------------------------------- foreign import ccall unsafe "string.h memcpy" c_memcpy @@ -289,10 +287,8 @@ -- how many elements of that type will completely fit in those bytes. -- {-# INLINE bytesToElemCount #-} -bytesToElemCount :: Storable a => a -> Int -> Int -bytesToElemCount x n = - let elemSize = sizeOf x - in n `div` elemSize +bytesToElemCount :: forall a. Storable a => a -> Int -> Int +bytesToElemCount _ n = n `div` SIZE_OF(a) -- XXX we are converting Int to CSize memcpy :: Ptr Word8 -> Ptr Word8 -> Int -> IO () @@ -337,15 +333,6 @@ arrayToFptrContents (ArrayContents contents) = PlainPtr contents #endif --- | Similar to unsafeWithForeignPtr. -{-# INLINE unsafeWithArrayContents #-} -unsafeWithArrayContents :: MonadIO m => - ArrayContents -> Ptr a -> (Ptr a -> m b) -> m b -unsafeWithArrayContents contents ptr f = do - r <- f ptr - liftIO $ touch contents - return r - ------------------------------------------------------------------------------- -- Array Data Type ------------------------------------------------------------------------------- @@ -387,26 +374,6 @@ , aBound :: {-# UNPACK #-} !(Ptr a) -- ^ first address beyond allocated memory } --- | @fromForeignPtrUnsafe foreignPtr end bound@ creates an 'Array' that starts --- at the memory pointed by the @foreignPtr@, @end@ is the first unused --- address, and @bound@ is the first address beyond the allocated memory. --- --- Unsafe: Make sure that foreignPtr <= end <= bound and (end - start) is an --- integral multiple of the element size. Only PlainPtr type ForeignPtr is --- supported. --- --- /Pre-release/ --- -{-# INLINE fromForeignPtrUnsafe #-} -fromForeignPtrUnsafe :: -#ifdef DEVBUILD - Storable a => -#endif - ForeignPtr a -> Ptr a -> Ptr a -> Array a -fromForeignPtrUnsafe fp@(ForeignPtr start contents) end bound = - assert (unsafeForeignPtrToPtr fp <= end && end <= bound) - (Array (fptrToArrayContents contents) (Ptr start) end bound) - ------------------------------------------------------------------------------- -- Construction ------------------------------------------------------------------------------- @@ -435,7 +402,7 @@ newArrayWith :: forall m a. (MonadIO m, Storable a) => (Int -> Int -> m (ArrayContents, Ptr a)) -> Int -> Int -> m (Array a) newArrayWith alloc alignSize count = do - let size = max (count * sizeOf (undefined :: a)) 0 + let size = max (count * SIZE_OF(a)) 0 (contents, p) <- alloc size alignSize return $ Array { arrContents = contents @@ -469,6 +436,35 @@ nilArrayContents = fst $ unsafePerformIO $ newAlignedArrayContents 0 0 +nil :: +#ifdef DEVBUILD + Storable a => +#endif + Array a +nil = Array nilArrayContents nullPtr nullPtr nullPtr + +-- | @fromForeignPtrUnsafe foreignPtr end bound@ creates an 'Array' that starts +-- at the memory pointed by the @foreignPtr@, @end@ is the first unused +-- address, and @bound@ is the first address beyond the allocated memory. +-- +-- Unsafe: Make sure that foreignPtr <= end <= bound and (end - start) is an +-- integral multiple of the element size. Only PlainPtr type ForeignPtr is +-- supported. +-- +-- /Pre-release/ +-- +{-# INLINE fromForeignPtrUnsafe #-} +fromForeignPtrUnsafe :: +#ifdef DEVBUILD + Storable a => +#endif + ForeignPtr a -> Ptr a -> Ptr a -> Array a +fromForeignPtrUnsafe (ForeignPtr start _) _ _ + | Ptr start == nullPtr = nil +fromForeignPtrUnsafe fp@(ForeignPtr start contents) end bound = + assert (unsafeForeignPtrToPtr fp <= end && end <= bound) + (Array (fptrToArrayContents contents) (Ptr start) end bound) + -- | Like 'newArrayWith' but using an allocator that allocates unmanaged pinned -- memory. The memory will never be freed by GHC. This could be useful in -- allocate-once global data structures. Use carefully as incorrect use can @@ -490,7 +486,7 @@ return (ArrayContents contents, Ptr addr) #else newArrayAlignedUnmanaged _align count = do - let size = max (count * sizeOf (undefined :: a)) 0 + let size = max (count * SIZE_OF(a)) 0 p <- liftIO $ mallocBytes size return $ Array { arrContents = nilArrayContents @@ -528,33 +524,24 @@ (MonadIO m, Storable a) => Int -> (Ptr a -> m ()) -> m (Array a) withNewArrayUnsafe count f = do arr <- newArray count - unsafeWithArrayContents (arrContents arr) (arrStart arr) + asPtrUnsafe arr $ \p -> f p >> return arr ------------------------------------------------------------------------------- -- Random writes ------------------------------------------------------------------------------- --- | Write an input stream of (index, value) pairs to an array. Throws an --- error if any index is out of bounds. --- --- /Unimplemented/ -{-# INLINE putIndices #-} -putIndices :: Array a -> Fold m (Int, a) () -putIndices = undefined - -- | Write the given element to the given index of the array. Does not check if -- the index is out of bounds of the array. -- -- /Pre-release/ {-# INLINE putIndexUnsafe #-} putIndexUnsafe :: forall m a. (MonadIO m, Storable a) - => Array a -> Int -> a -> m () -putIndexUnsafe Array{..} i x = - unsafeWithArrayContents arrContents arrStart $ \ptr -> do - let elemSize = sizeOf (undefined :: a) - elemPtr = ptr `plusPtr` (elemSize * i) - assert (i >= 0 && elemPtr `plusPtr` elemSize <= aEnd) (return ()) + => Int -> a -> Array a -> m () +putIndexUnsafe i x arr@(Array{..}) = + asPtrUnsafe arr $ \ptr -> do + let elemPtr = PTR_INDEX(ptr,i,a) + assert (i >= 0 && PTR_VALID(elemPtr,aEnd,a)) (return ()) liftIO $ poke elemPtr x invalidIndex :: String -> Int -> a @@ -564,79 +551,148 @@ {-# INLINE putIndexPtr #-} putIndexPtr :: forall m a. (MonadIO m, Storable a) => Ptr a -> Ptr a -> Int -> a -> m () -putIndexPtr ptr end i x = do - let elemSize = sizeOf (undefined :: a) - elemPtr = ptr `plusPtr` (elemSize * i) - if i >= 0 && elemPtr `plusPtr` elemSize <= end +putIndexPtr start end i x = do + let elemPtr = PTR_INDEX(start,i,a) + if i >= 0 && PTR_VALID(elemPtr,end,a) then liftIO $ poke elemPtr x else invalidIndex "putIndexPtr" i -- | /O(1)/ Write the given element at the given index in the array. -- Performs in-place mutation of the array. -- --- >>> putIndex arr ix val = Array.modifyIndex arr ix (const (val, ())) +-- >>> putIndex arr ix val = Array.modifyIndex ix (const (val, ())) arr -- >>> f = Array.putIndices --- >>> putIndex arr ix val = Stream.fold (f arr) (Stream.fromPure (ix, val)) +-- >>> putIndex ix val arr = Stream.fold (f arr) (Stream.fromPure (ix, val)) -- -- /Pre-release/ {-# INLINE putIndex #-} -putIndex :: (MonadIO m, Storable a) => Array a -> Int -> a -> m () -putIndex arr i x = - unsafeWithArrayContents (arrContents arr) (arrStart arr) +putIndex :: (MonadIO m, Storable a) => Int -> a -> Array a -> m () +putIndex i x arr = + asPtrUnsafe arr $ \p -> putIndexPtr p (aEnd arr) i x +-- | Write an input stream of (index, value) pairs to an array. Throws an +-- error if any index is out of bounds. +-- +-- /Pre-release/ +{-# INLINE putIndices #-} +putIndices :: forall m a. (MonadIO m, Storable a) + => Array a -> Fold m (Int, a) () +putIndices Array{..} = FL.mkFoldM step initial extract + + where + + initial = return $ FL.Partial () + + step () (i, x) = FL.Partial <$> liftIO (putIndexPtr arrStart aEnd i x) + + extract () = liftIO $ touch arrContents + -- | Modify a given index of an array using a modifier function. -- -- /Pre-release/ modifyIndexUnsafe :: forall m a b. (MonadIO m, Storable a) => - Array a -> Int -> (a -> (a, b)) -> m b -modifyIndexUnsafe Array{..} i f = do - liftIO $ unsafeWithArrayContents arrContents arrStart $ \ptr -> do - let elemSize = sizeOf (undefined :: a) - elemPtr = ptr `plusPtr` (elemSize * i) - assert (i >= 0 && elemPtr `plusPtr` elemSize <= aEnd) (return ()) + Int -> (a -> (a, b)) -> Array a -> m b +modifyIndexUnsafe i f arr@(Array{..}) = do + liftIO $ asPtrUnsafe arr $ \ptr -> do + let elemPtr = PTR_INDEX(ptr,i,a) + assert (i >= 0 && PTR_NEXT(elemPtr,a) <= aEnd) (return ()) r <- peek elemPtr let (x, res) = f r poke elemPtr x return res +{-# INLINE modifyIndexPtr #-} +modifyIndexPtr :: forall m a b. (MonadIO m, Storable a) => + Int -> (a -> (a, b)) -> Ptr a -> Ptr a -> m b +modifyIndexPtr i f start end = liftIO $ do + let elemPtr = PTR_INDEX(start,i,a) + if i >= 0 && PTR_VALID(elemPtr,end,a) + then do + r <- peek elemPtr + let (x, res) = f r + poke elemPtr x + return res + else invalidIndex "modifyIndex" i + -- | Modify a given index of an array using a modifier function. -- -- /Pre-release/ modifyIndex :: forall m a b. (MonadIO m, Storable a) => - Array a -> Int -> (a -> (a, b)) -> m b -modifyIndex Array{..} i f = do - liftIO $ unsafeWithArrayContents arrContents arrStart $ \ptr -> do - let elemSize = sizeOf (undefined :: a) - elemPtr = ptr `plusPtr` (elemSize * i) - if i >= 0 && elemPtr `plusPtr` elemSize <= aEnd - then do - r <- peek elemPtr - let (x, res) = f r - poke elemPtr x - return res - else invalidIndex "modifyIndex" i + Int -> (a -> (a, b)) -> Array a -> m b +modifyIndex i f arr@(Array{..}) = do + liftIO $ asPtrUnsafe arr $ \ptr -> do + modifyIndexPtr i f ptr aEnd --- | Modify the array indices generated by the supplied unfold. +-- | Modify the array indices generated by the supplied stream. -- -- /Pre-release/ -modifyIndices :: -- forall m a b. (MonadIO m, Storable a) => - Unfold m (Array a) Int -> Array a -> (a -> a) -> m () -modifyIndices = undefined +{-# INLINE modifyIndices #-} +modifyIndices :: forall m a. (MonadIO m, Storable a) + => (a -> a) -> Array a -> Fold m Int () +modifyIndices f Array{..} = Fold step initial extract + where + + initial = return $ FL.Partial () + + step () i = + let f1 x = (f x, ()) + in FL.Partial <$> liftIO (modifyIndexPtr i f1 arrStart aEnd) + + extract () = liftIO $ touch arrContents + -- | Modify each element of an array using the supplied modifier function. -- --- /Unimplemented/ -modify :: -- forall m a b. (MonadIO m, Storable a) => - Array a -> (a -> a) -> m () -modify = undefined +-- /Pre-release/ +modify :: forall m a. (MonadIO m, Storable a) + => (a -> a) -> Array a -> m () +modify f arr@Array{..} = liftIO $ + asPtrUnsafe arr go + where + + go ptr = + when (PTR_VALID(ptr,aEnd,a)) $ do + r <- peek ptr + poke ptr (f r) + go (PTR_NEXT(ptr,a)) + +{-# INLINE swapPtrs #-} +swapPtrs :: Storable a => Ptr a -> Ptr a -> IO () +swapPtrs ptr1 ptr2 = do + r1 <- peek ptr1 + r2 <- peek ptr2 + poke ptr1 r2 + poke ptr2 r1 + +-- | Swap the elements at two indices without validating the indices. +-- +-- /Unsafe/: This could result in memory corruption if indices are not valid. +-- +-- /Pre-release/ +{-# INLINE unsafeSwapIndices #-} +unsafeSwapIndices :: forall m a. (MonadIO m, Storable a) + => Int -> Int -> Array a -> m () +unsafeSwapIndices i1 i2 arr = liftIO $ do + asPtrUnsafe arr $ \ptr -> do + let ptr1 = PTR_INDEX(ptr,i1,a) + ptr2 = PTR_INDEX(ptr,i2,a) + swapPtrs ptr1 (ptr2 :: Ptr a) + -- | Swap the elements at two indices. -- -- /Pre-release/ -swapIndices :: -- (MonadIO m, Storable a) => - Array a -> Int -> Int -> m () -swapIndices = undefined +swapIndices :: forall m a. (MonadIO m, Storable a) + => Int -> Int -> Array a -> m () +swapIndices i1 i2 Array{..} = liftIO $ do + let ptr1 = PTR_INDEX(arrStart,i1,a) + ptr2 = PTR_INDEX(arrStart,i2,a) + when (i1 < 0 || PTR_INVALID(ptr1,aEnd,a)) + $ invalidIndex "swapIndices" i1 + when (i2 < 0 || PTR_INVALID(ptr2,aEnd,a)) + $ invalidIndex "swapIndices" i2 + swapPtrs ptr1 (ptr2 :: Ptr a) ------------------------------------------------------------------------------- -- Rounding @@ -656,6 +712,7 @@ largeObjectThreshold :: Int largeObjectThreshold = (blockSize * 8) `div` 10 +-- XXX Should be done only when we are using the GHC allocator. -- | Round up an array larger than 'largeObjectThreshold' to use the whole -- block. {-# INLINE roundUpLargeArray #-} @@ -668,11 +725,29 @@ ((size + blockSize - 1) .&. negate blockSize) else size -{- +{-# INLINE isPower2 #-} +isPower2 :: Int -> Bool +isPower2 n = n .&. (n - 1) == 0 + +{-# INLINE roundUpToPower2 #-} roundUpToPower2 :: Int -> Int -roundUpToPower2 = undefined --} +roundUpToPower2 n = +#if WORD_SIZE_IN_BITS == 64 + 1 + z6 +#else + 1 + z5 +#endif + where + + z0 = n - 1 + z1 = z0 .|. z0 `shiftR` 1 + z2 = z1 .|. z1 `shiftR` 2 + z3 = z2 .|. z2 `shiftR` 4 + z4 = z3 .|. z3 `shiftR` 8 + z5 = z4 .|. z4 `shiftR` 16 + z6 = z5 .|. z5 `shiftR` 32 + -- | @allocBytesToBytes elem allocatedBytes@ returns the array size in bytes -- such that the real allocation is less than or equal to @allocatedBytes@, -- unless @allocatedBytes@ is less than the size of one array element in which @@ -680,8 +755,7 @@ -- {-# INLINE allocBytesToBytes #-} allocBytesToBytes :: forall a. Storable a => a -> Int -> Int -allocBytesToBytes _ n = - max (arrayPayloadSize n) (sizeOf (undefined :: a)) +allocBytesToBytes _ n = max (arrayPayloadSize n) (SIZE_OF(a)) -- | Given a 'Storable' type (unused first arg) and real allocation size -- (including overhead), return how many elements of that type will completely @@ -699,6 +773,144 @@ arrayChunkBytes = 1024 ------------------------------------------------------------------------------- +-- Resizing +------------------------------------------------------------------------------- + +-- | Round the second argument down to multiples of the first argument. +{-# INLINE roundDownTo #-} +roundDownTo :: Int -> Int -> Int +roundDownTo elemSize size = size - (size `mod` elemSize) + +-- XXX See if resizing can be implemented by reading the old array as a stream +-- and then using writeN to the new array. +-- +{-# NOINLINE reallocAligned #-} +reallocAligned :: Int -> Int -> Int -> Array a -> IO (Array a) +reallocAligned elemSize alignSize newCapacity Array{..} = do + assert (aEnd <= aBound) (return ()) + + -- Allocate new array + let newCapMax = roundUpLargeArray newCapacity + (contents, pNew) <- newAlignedArrayContents newCapMax alignSize + + -- Copy old data + let oldStart = arrStart + oldSize = aEnd `minusPtr` oldStart + newCap = roundDownTo elemSize newCapMax + newLen = min oldSize newCap + assert (oldSize `mod` elemSize == 0) (return ()) + assert (newLen >= 0) (return ()) + assert (newLen `mod` elemSize == 0) (return ()) + memcpy (castPtr pNew) (castPtr oldStart) newLen + touch arrContents + + return $ Array + { arrStart = pNew + , arrContents = contents + , aEnd = pNew `plusPtr` newLen + , aBound = pNew `plusPtr` newCap + } + +-- | @realloc newCapacity array@ reallocates the array to the specified +-- capacity in bytes. +-- +-- If the new size is less than the original array the array gets truncated. +-- If the new size is not a multiple of array element size then it is rounded +-- down to multiples of array size. If the new size is more than +-- 'largeObjectThreshold' then it is rounded up to the block size (4K). +-- +{-# INLINABLE realloc #-} +realloc :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m (Array a) +realloc n arr = + liftIO $ reallocAligned (SIZE_OF(a)) (alignment (undefined :: a)) n arr + +-- | @reallocWith label capSizer minIncrement array@. The label is used +-- in error messages and the capSizer is used to determine the capacity of the +-- new array in bytes given the current byte length of the array. +reallocWith :: forall m a. (MonadIO m , Storable a) => + String + -> (Int -> Int) + -> Int + -> Array a + -> m (Array a) +reallocWith label capSizer minIncr arr = do + let oldSize = aEnd arr `minusPtr` arrStart arr + newCap = capSizer oldSize + newSize = oldSize + minIncr + safeCap = max newCap newSize + assert (newCap >= newSize || error (badSize newSize)) (return ()) + realloc safeCap arr + + where + + badSize newSize = concat + [ label + , ": new array size is less than required size " + , show newSize + , ". Please check the sizing function passed." + ] + +-- | @resize newCapacity array@ changes the total capacity of the array so that +-- it is enough to hold the specified number of elements. Nothing is done if +-- the specified capacity is less than the length of the array. +-- +-- If the capacity is more than 'largeObjectThreshold' then it is rounded up to +-- the block size (4K). +-- +-- /Pre-release/ +{-# INLINE resize #-} +resize :: forall m a. (MonadIO m, Storable a) => + Int -> Array a -> m (Array a) +resize n arr@Array{..} = do + let req = SIZE_OF(a) * n + len = aEnd `minusPtr` arrStart + if req < len + then return arr + else realloc req arr + +-- | Like 'resize' but if the capacity is more than 'largeObjectThreshold' then +-- it is rounded up to the closest power of 2. +-- +-- /Pre-release/ +{-# INLINE resizeExp #-} +resizeExp :: forall m a. (MonadIO m, Storable a) => + Int -> Array a -> m (Array a) +resizeExp n arr@Array{..} = do + let req = roundUpLargeArray (SIZE_OF(a) * n) + req1 = + if req > largeObjectThreshold + then roundUpToPower2 req + else req + len = aEnd `minusPtr` arrStart + if req1 < len + then return arr + else realloc req1 arr + +-- | Resize the allocated memory to drop any reserved free space at the end of +-- the array and reallocate it to reduce wastage. +-- +-- Up to 25% wastage is allowed to avoid reallocations. If the capacity is +-- more than 'largeObjectThreshold' then free space up to the 'blockSize' is +-- retained. +-- +-- /Pre-release/ +{-# INLINE rightSize #-} +rightSize :: forall m a. (MonadIO m, Storable a) => Array a -> m (Array a) +rightSize arr@Array{..} = do + assert (aEnd <= aBound) (return ()) + let start = arrStart + len = aEnd `minusPtr` start + capacity = aBound `minusPtr` start + target = roundUpLargeArray len + waste = aBound `minusPtr` aEnd + assert (target >= len) (return ()) + assert (len `mod` SIZE_OF(a) == 0) (return ()) + -- We trade off some wastage (25%) to avoid reallocations and copying. + if target < capacity && len < 3 * waste + then realloc target arr + else return arr + +------------------------------------------------------------------------------- -- Snoc ------------------------------------------------------------------------------- @@ -730,8 +942,7 @@ {-# INLINE snocUnsafe #-} snocUnsafe :: forall m a. (MonadIO m, Storable a) => Array a -> a -> m (Array a) -snocUnsafe arr@Array{..} = - snocNewEnd (aEnd `plusPtr` sizeOf (undefined :: a)) arr +snocUnsafe arr@Array{..} = snocNewEnd (PTR_NEXT(aEnd,a)) arr -- | Like 'snoc' but does not reallocate when pre-allocated array capacity -- becomes full. @@ -741,35 +952,11 @@ snocMay :: forall m a. (MonadIO m, Storable a) => Array a -> a -> m (Maybe (Array a)) snocMay arr@Array{..} x = liftIO $ do - let newEnd = aEnd `plusPtr` sizeOf (undefined :: a) + let newEnd = PTR_NEXT(aEnd,a) if newEnd <= aBound then Just <$> snocNewEnd newEnd arr x else return Nothing -reallocWith :: forall m a. (MonadIO m , Storable a) => - String - -> (Int -> Int) - -> Int - -> Array a - -> m (Array a) -reallocWith label sizer reqSize arr = do - let oldSize = aEnd arr `minusPtr` arrStart arr - newSize = sizer oldSize - safeSize = max newSize (oldSize + reqSize) - rounded = roundUpLargeArray safeSize - assert (newSize >= oldSize + reqSize || error badSize) (return ()) - assert (rounded >= safeSize) (return ()) - realloc rounded arr - - where - - badSize = concat - [ label - , ": new array size is less than required size " - , show reqSize - , ". Please check the sizing function passed." - ] - -- NOINLINE to move it out of the way and not pollute the instruction cache. {-# NOINLINE snocWithRealloc #-} snocWithRealloc :: forall m a. (MonadIO m, Storable a) => @@ -778,8 +965,7 @@ -> a -> m (Array a) snocWithRealloc sizer arr x = do - let elemSize = sizeOf (undefined :: a) - arr1 <- liftIO $ reallocWith "snocWith" sizer elemSize arr + arr1 <- liftIO $ reallocWith "snocWith" sizer (SIZE_OF(a)) arr snocUnsafe arr1 x -- | @snocWith sizer arr elem@ mutates @arr@ to append @elem@. The length of @@ -802,7 +988,7 @@ -> a -> m (Array a) snocWith allocSize arr x = liftIO $ do - let newEnd = aEnd arr `plusPtr` sizeOf (undefined :: a) + let newEnd = PTR_NEXT(aEnd arr,a) if newEnd <= aBound arr then snocNewEnd newEnd arr x else snocWithRealloc allocSize arr x @@ -821,8 +1007,6 @@ snocLinear :: forall m a. (MonadIO m, Storable a) => Array a -> a -> m (Array a) snocLinear = snocWith (+ allocBytesToBytes (undefined :: a) arrayChunkBytes) --- XXX round it to next power of 2. --- -- | The array is mutated to append an additional element to it. If there is no -- reserved space available in the array then it is reallocated to double the -- original size. @@ -839,123 +1023,14 @@ -- /Pre-release/ {-# INLINE snoc #-} snoc :: forall m a. (MonadIO m, Storable a) => Array a -> a -> m (Array a) -snoc = snocWith (* 2) - -------------------------------------------------------------------------------- --- Resizing -------------------------------------------------------------------------------- - --- XXX See if resizing can be implemented by reading the old array as a stream --- and then using writeN to the new array. --- --- | Reallocate the array to the specified size in bytes. If the size is less --- than the original array the array gets truncated. -{-# NOINLINE reallocAligned #-} -reallocAligned :: Int -> Int -> Int -> Array a -> IO (Array a) -reallocAligned elemSize alignSize newSize Array{..} = do - assert (aEnd <= aBound) (return ()) - let oldStart = arrStart - oldSize = aEnd `minusPtr` oldStart - assert (oldSize `mod` elemSize == 0) (return ()) - (contents, pNew) <- newAlignedArrayContents newSize alignSize - let size = min oldSize newSize - assert (size >= 0) (return ()) - assert (size `mod` elemSize == 0) (return ()) - memcpy (castPtr pNew) (castPtr oldStart) size - touch arrContents - return $ Array - { arrStart = pNew - , arrContents = contents - , aEnd = pNew `plusPtr` (size - (size `mod` elemSize)) - , aBound = pNew `plusPtr` newSize - } - -{-# INLINABLE realloc #-} -realloc :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m (Array a) -realloc i arr = - liftIO - $ reallocAligned - (sizeOf (undefined :: a)) (alignment (undefined :: a)) i arr - --- | Change the reserved memory of the array so that it is enough to hold the --- specified number of elements. Nothing is done if the specified capacity is --- less than the length of the array. --- --- If the capacity is more than 'largeObjectThreshold' then it is rounded up to --- the block size (4K). --- --- /Unimplemented/ -{-# INLINE resize #-} -resize :: -- (MonadIO m, Storable a) => - Int -> Array a -> m (Array a) -resize = undefined - --- | Like 'resize' but if the capacity is more than 'largeObjectThreshold' then --- it is rounded up to the closest power of 2. --- --- /Unimplemented/ -{-# INLINE resizeExp #-} -resizeExp :: -- (MonadIO m, Storable a) => - Int -> Array a -> m (Array a) -resizeExp = undefined - --- | Resize the allocated memory to drop any reserved free space at the end of --- the array and reallocate it to reduce wastage. --- --- Up to 25% wastage is allowed to avoid reallocations. If the capacity is --- more than 'largeObjectThreshold' then free space up to the 'blockSize' is --- retained. --- --- /Pre-release/ -{-# INLINE rightSize #-} -rightSize :: forall m a. (MonadIO m, Storable a) => Array a -> m (Array a) -rightSize arr@Array{..} = do - assert (aEnd <= aBound) (return ()) - let start = arrStart - len = aEnd `minusPtr` start - capacity = aBound `minusPtr` start - target = roundUpLargeArray len - waste = aBound `minusPtr` aEnd - assert (target >= len) (return ()) - assert (len `mod` sizeOf (undefined :: a) == 0) (return ()) - -- We trade off some wastage (25%) to avoid reallocations and copying. - if target < capacity && len < 3 * waste - then realloc target arr - else return arr - -------------------------------------------------------------------------------- --- Reducing the length -------------------------------------------------------------------------------- - --- XXX Either slice the array or stream it and write it out to a new array? --- --- | Drop the last n elements of the array to reduce the length by n. The --- capacity is reallocated using the user supplied function. --- --- /Unimplemented/ -{-# INLINE truncateWith #-} -truncateWith :: -- (MonadIO m, Storable a) => - Int -> (Int -> Int) -> Array a -> m (Array a) -truncateWith = undefined +snoc = snocWith f --- | Drop the last n elements of the array to reduce the length by n. --- --- The capacity is rounded to 1K or 4K if the length is more than the GHC large --- block threshold. --- --- /Unimplemented/ -{-# INLINE truncate #-} -truncate :: -- (MonadIO m, Storable a) => - Int -> Array a -> m (Array a) -truncate = undefined + where --- | Like 'truncate' but the capacity is rounded to the closest power of 2. --- --- /Unimplemented/ -{-# INLINE truncateExp #-} -truncateExp :: -- (MonadIO m, Storable a) => - Int -> Array a -> m (Array a) -truncateExp = undefined + f oldSize = + if isPower2 oldSize + then oldSize * 2 + else roundUpToPower2 oldSize * 2 ------------------------------------------------------------------------------- -- Random reads @@ -965,39 +1040,36 @@ -- -- Unsafe because it does not check the bounds of the array. {-# INLINE_NORMAL getIndexUnsafe #-} -getIndexUnsafe :: forall m a. (MonadIO m, Storable a) => Array a -> Int -> m a -getIndexUnsafe Array {..} i = - unsafeWithArrayContents arrContents arrStart $ \ptr -> do - let elemSize = sizeOf (undefined :: a) - elemPtr = ptr `plusPtr` (elemSize * i) - assert (i >= 0 && elemPtr `plusPtr` elemSize <= aEnd) (return ()) +getIndexUnsafe :: forall m a. (MonadIO m, Storable a) => Int -> Array a -> m a +getIndexUnsafe i arr@(Array {..}) = + asPtrUnsafe arr $ \ptr -> do + let elemPtr = PTR_INDEX(ptr,i,a) + assert (i >= 0 && PTR_VALID(elemPtr,aEnd,a)) (return ()) liftIO $ peek elemPtr {-# INLINE getIndexPtr #-} getIndexPtr :: forall m a. (MonadIO m, Storable a) => Ptr a -> Ptr a -> Int -> m a -getIndexPtr ptr end i = do - let elemSize = sizeOf (undefined :: a) - elemPtr = ptr `plusPtr` (elemSize * i) - if i >= 0 && elemPtr `plusPtr` elemSize <= end +getIndexPtr start end i = do + let elemPtr = PTR_INDEX(start,i,a) + if i >= 0 && PTR_VALID(elemPtr,end,a) then liftIO $ peek elemPtr else invalidIndex "getIndexPtr" i -- | /O(1)/ Lookup the element at the given index. Index starts from 0. -- {-# INLINE getIndex #-} -getIndex :: (MonadIO m, Storable a) => Array a -> Int -> m a -getIndex arr i = - unsafeWithArrayContents (arrContents arr) (arrStart arr) +getIndex :: (MonadIO m, Storable a) => Int -> Array a -> m a +getIndex i arr = + asPtrUnsafe arr $ \p -> getIndexPtr p (aEnd arr) i {-# INLINE getIndexPtrRev #-} getIndexPtrRev :: forall m a. (MonadIO m, Storable a) => Ptr a -> Ptr a -> Int -> m a -getIndexPtrRev ptr end i = do - let elemSize = sizeOf (undefined :: a) - elemPtr = end `plusPtr` negate (elemSize * (i + 1)) - if i >= 0 && elemPtr >= ptr +getIndexPtrRev start end i = do + let elemPtr = PTR_RINDEX(end,i,a) + if i >= 0 && elemPtr >= start then liftIO $ peek elemPtr else invalidIndex "getIndexPtrRev" i @@ -1007,9 +1079,9 @@ -- Slightly faster than computing the forward index and using getIndex. -- {-# INLINE getIndexRev #-} -getIndexRev :: (MonadIO m, Storable a) => Array a -> Int -> m a -getIndexRev arr i = - unsafeWithArrayContents (arrContents arr) (arrStart arr) +getIndexRev :: (MonadIO m, Storable a) => Int -> Array a -> m a +getIndexRev i arr = + asPtrUnsafe arr $ \p -> getIndexPtrRev p (aEnd arr) i data GetIndicesState contents start end st = @@ -1020,29 +1092,32 @@ -- bounds. -- -- /Pre-release/ -{-# INLINE getIndices #-} -getIndices :: (MonadIO m, Storable a) => - Unfold m (Array a) Int -> Unfold m (Array a) a -getIndices (Unfold stepi injecti) = Unfold step inject +{-# INLINE getIndicesD #-} +getIndicesD :: (Monad m, Storable a) => + (forall b. IO b -> m b) -> D.Stream m Int -> Unfold m (Array a) a +getIndicesD liftio (D.Stream stepi sti) = Unfold step inject where - inject arr@(Array contents start (Ptr end) _) = do - st <- injecti arr - return $ GetIndicesState contents start (Ptr end) st + inject (Array contents start (Ptr end) _) = + return $ GetIndicesState contents start (Ptr end) sti {-# INLINE_LATE step #-} step (GetIndicesState contents start end st) = do - r <- stepi st + r <- stepi defState st case r of D.Yield i s -> do - x <- liftIO $ getIndexPtr start end i + x <- liftio $ getIndexPtr start end i return $ D.Yield x (GetIndicesState contents start end s) D.Skip s -> return $ D.Skip (GetIndicesState contents start end s) D.Stop -> do - liftIO $ touch contents + liftio $ touch contents return D.Stop +{-# INLINE getIndices #-} +getIndices :: (MonadIO m, Storable a) => SerialT m Int -> Unfold m (Array a) a +getIndices (SerialT stream) = getIndicesD liftIO $ D.fromStreamK stream + ------------------------------------------------------------------------------- -- Subarrays ------------------------------------------------------------------------------- @@ -1063,9 +1138,8 @@ -> Array a -> Array a getSliceUnsafe index len (Array contents start e _) = - let size = sizeOf (undefined :: a) - fp1 = start `plusPtr` (index * size) - end = fp1 `plusPtr` (len * size) + let fp1 = PTR_INDEX(start,index,a) + end = fp1 `plusPtr` (len * SIZE_OF(a)) in assert (index >= 0 && len >= 0 && end <= e) (Array contents fp1 end end) @@ -1081,9 +1155,8 @@ -> Array a -> Array a getSlice index len (Array contents start e _) = - let size = sizeOf (undefined :: a) - fp1 = start `plusPtr` (index * size) - end = fp1 `plusPtr` (len * size) + let fp1 = PTR_INDEX(start,index,a) + end = fp1 `plusPtr` (len * SIZE_OF(a)) in if index >= 0 && len >= 0 && end <= e then Array contents fp1 end end else error @@ -1101,11 +1174,21 @@ -- to another array. However, in-place reverse can be useful to take adavantage -- of cache locality and when you do not want to allocate additional memory. -- --- /Unimplemented/ +-- /Pre-release/ {-# INLINE reverse #-} -reverse :: Array a -> m Bool -reverse = undefined +reverse :: forall m a. (MonadIO m, Storable a) => Array a -> m () +reverse Array{..} = liftIO $ do + let l = arrStart + h = PTR_PREV(aEnd,a) + in swap l h + where + + swap l h = do + when (l < h) $ do + swapPtrs l h + swap (PTR_NEXT(l,a)) (PTR_PREV(h,a)) + -- | Generate the next permutation of the sequence, returns False if this is -- the last permutation. -- @@ -1118,11 +1201,69 @@ -- first half retains values where the predicate is 'False' and the second half -- retains values where the predicate is 'True'. -- --- /Unimplemented/ +-- /Pre-release/ {-# INLINE partitionBy #-} -partitionBy :: (a -> Bool) -> Array a -> m (Array a, Array a) -partitionBy = undefined +partitionBy :: forall m a. (MonadIO m, Storable a) + => (a -> Bool) -> Array a -> m (Array a, Array a) +partitionBy f arr@Array{..} = liftIO $ do + if arrStart >= aEnd + then return (arr, arr) + else do + ptr <- go arrStart (PTR_PREV(aEnd,a)) + let pl = Array arrContents arrStart ptr ptr + pr = Array arrContents ptr aEnd aEnd + return (pl, pr) + where + + -- Invariant low < high on entry, and on return as well + moveHigh low high = do + h <- peek high + if f h + then + -- Correctly classified, continue the loop + let high1 = PTR_PREV(high,a) + in if low == high1 + then return Nothing + else moveHigh low high1 + else return (Just (high, h)) -- incorrectly classified + + -- Keep a low pointer starting at the start of the array (first partition) + -- and a high pointer starting at the end of the array (second partition). + -- Keep incrementing the low ptr and decrementing the high ptr until both + -- are wrongly classified, at that point swap the two and continue until + -- the two pointer cross each other. + -- + -- Invariants when entering this loop: + -- low <= high + -- Both low and high are valid locations within the array + go low high = do + l <- peek low + if f l + then + -- low is wrongly classified + if low == high + then return low + else do -- low < high + r <- moveHigh low high + case r of + Nothing -> return low + Just (high1, h) -> do -- low < high1 + poke low h + poke high1 l + let low1 = PTR_NEXT(low,a) + high2 = PTR_PREV(high1,a) + if low1 <= high2 + then go low1 high2 + else return low1 -- low1 > high2 + + else do + -- low is correctly classified + let low1 = PTR_NEXT(low,a) + if low == high + then return low1 + else go low1 high + -- | Shuffle corresponding elements from two arrays using a shuffle function. -- If the shuffle function returns 'False' then do nothing otherwise swap the -- elements. This can be used in a bottom up fold to shuffle or reorder the @@ -1130,7 +1271,7 @@ -- -- /Unimplemented/ {-# INLINE shuffleBy #-} -shuffleBy :: (a -> a -> m Bool) -> Array a -> Array a -> m (Array a) +shuffleBy :: (a -> a -> m Bool) -> Array a -> Array a -> m () shuffleBy = undefined -- XXX we can also make the folds partial by stopping at a certain level. @@ -1146,19 +1287,19 @@ -- /Unimplemented/ {-# INLINABLE divideBy #-} divideBy :: - Int -> (Array a -> Array a -> m (Array a)) -> Array a -> m (Array a) + Int -> (Array a -> m (Array a, Array a)) -> Array a -> m () divideBy = undefined -- | @mergeBy level merge array@ performs a pairwise bottom up fold recursively -- merging the pairs using the supplied merge function. Level indicates the -- level in the tree where the fold would stop. -- --- This performs a random shuffle if the shuffle function is random. If we +-- This performs a random shuffle if the merge function is random. If we -- stop at level 0 and repeatedly apply the function then we can do a bubble -- sort. -- -- /Unimplemented/ -mergeBy :: Int -> (Array a -> Array a -> m (Array a)) -> Array a -> m (Array a) +mergeBy :: Int -> (Array a -> Array a -> m ()) -> Array a -> m () mergeBy = undefined ------------------------------------------------------------------------------- @@ -1188,7 +1329,7 @@ {-# INLINE length #-} length :: forall a. Storable a => Array a -> Int length arr = - let elemSize = sizeOf (undefined :: a) + let elemSize = SIZE_OF(a) blen = byteLength arr in assert (blen `mod` elemSize == 0) (blen `div` elemSize) @@ -1256,13 +1397,13 @@ case r of D.Yield x s -> do liftIO $ poke end x >> touch contents - let end' = end `plusPtr` sizeOf (undefined :: a) + let end1 = PTR_NEXT(end,a) return $ - if end' >= bound + if end1 >= bound then D.Skip (GroupYield - contents start end' bound (GroupStart s)) - else D.Skip (GroupBuffer s contents start end' bound) + contents start end1 bound (GroupStart s)) + else D.Skip (GroupBuffer s contents start end1 bound) D.Skip s -> return $ D.Skip (GroupBuffer s contents start end bound) D.Stop -> @@ -1321,8 +1462,7 @@ r <- peek p touch contents return r - return $ D.Yield x (InnerLoop st contents - (p `plusPtr` sizeOf (undefined :: a)) end) + return $ D.Yield x (InnerLoop st contents (PTR_NEXT(p,a)) end) -- | Use the "readRev" unfold instead. -- @@ -1342,7 +1482,7 @@ r <- step (adaptState gst) st return $ case r of D.Yield Array{..} s -> - let p = aEnd `plusPtr` negate (sizeOf (undefined :: a)) + let p = PTR_PREV(aEnd,a) in D.Skip (InnerLoop s arrContents p arrStart) D.Skip s -> D.Skip (OuterLoop s) D.Stop -> D.Stop @@ -1355,7 +1495,7 @@ r <- peek p touch contents return r - let cur = p `plusPtr` negate (sizeOf (undefined :: a)) + let cur = PTR_PREV(p,a) return $ D.Yield x (InnerLoop st contents cur start) ------------------------------------------------------------------------------- @@ -1384,8 +1524,7 @@ return D.Stop step (ReadUState contents end cur) = do !x <- liftIO $ peek cur - let cur1 = cur `plusPtr` sizeOf (undefined :: a) - return $ D.Yield x (ReadUState contents end cur1) + return $ D.Yield x (ReadUState contents end (PTR_NEXT(cur,a))) extract (ReadUState contents end cur) = return $ Array contents cur end end @@ -1405,7 +1544,7 @@ where inject (Array contents start end _) = - let p = end `plusPtr` negate (sizeOf (undefined :: a)) + let p = PTR_PREV(end,a) in return $ ReadUState contents start p {-# INLINE_LATE step #-} @@ -1413,9 +1552,8 @@ liftIO $ touch contents return D.Stop step (ReadUState contents start p) = do - x <- liftIO $ peek p - let cur = p `plusPtr` negate (sizeOf (undefined :: a)) - return $ D.Yield x (ReadUState contents start cur) + x <- liftIO $ peek p + return $ D.Yield x (ReadUState contents start (PTR_PREV(p,a))) ------------------------------------------------------------------------------- -- to Lists and streams @@ -1442,7 +1580,7 @@ r <- peek p touch arrContents return r - in c x (go (p `plusPtr` sizeOf (undefined :: a))) + in c x (go (PTR_NEXT(p,a))) -} -- XXX Monadic foldr/build fusion? @@ -1459,7 +1597,7 @@ go p = do x <- peek p touch arrContents - (:) x <$> go (p `plusPtr` sizeOf (undefined :: a)) + (:) x <$> go (PTR_NEXT(p,a)) -- | Use the 'read' unfold instead. -- @@ -1477,7 +1615,7 @@ step _ p = liftIO $ do r <- peek p touch arrContents - return $ D.Yield r (p `plusPtr` sizeOf (undefined :: a)) + return $ D.Yield r (PTR_NEXT(p,a)) {-# INLINE toStreamK #-} toStreamK :: forall m a. (MonadIO m, Storable a) => Array a -> K.Stream m a @@ -1491,7 +1629,7 @@ r <- peek p touch arrContents return r - in liftIO elemM `K.consM` go (p `plusPtr` sizeOf (undefined :: a)) + in liftIO elemM `K.consM` go (PTR_NEXT(p,a)) -- | Use the 'readRev' unfold instead. -- @@ -1501,7 +1639,7 @@ {-# INLINE_NORMAL toStreamDRev #-} toStreamDRev :: forall m a. (MonadIO m, Storable a) => Array a -> D.Stream m a toStreamDRev Array{..} = - let p = aEnd `plusPtr` negate (sizeOf (undefined :: a)) + let p = PTR_PREV(aEnd,a) in D.Stream step p where @@ -1511,12 +1649,12 @@ step _ p = liftIO $ do r <- peek p touch arrContents - return $ D.Yield r (p `plusPtr` negate (sizeOf (undefined :: a))) + return $ D.Yield r (PTR_PREV(p,a)) {-# INLINE toStreamKRev #-} toStreamKRev :: forall m a. (MonadIO m, Storable a) => Array a -> K.Stream m a toStreamKRev Array {..} = - let p = aEnd `plusPtr` negate (sizeOf (undefined :: a)) + let p = PTR_PREV(aEnd,a) in go p where @@ -1527,7 +1665,7 @@ r <- peek p touch arrContents return r - in liftIO elemM `K.consM` go (p `plusPtr` negate (sizeOf (undefined :: a))) + in liftIO elemM `K.consM` go (PTR_PREV(p,a)) ------------------------------------------------------------------------------- -- Folding @@ -1596,8 +1734,7 @@ assert (n >= 0) (return ()) arr@(Array _ _ end bound) <- action let free = bound `minusPtr` end - elemSize = sizeOf (undefined :: a) - needed = n * elemSize + needed = n * SIZE_OF(a) -- XXX We can also reallocate if the array has too much free space, -- otherwise we lose that space. arr1 <- @@ -1608,8 +1745,7 @@ step (ArrayUnsafe contents start end) x = do liftIO $ poke end x >> touch contents - let end1 = end `plusPtr` sizeOf (undefined :: a) - return $ ArrayUnsafe contents start end1 + return $ ArrayUnsafe contents start (PTR_NEXT(end,a)) -- | Append @n@ elements to an existing array. Any free space left in the array -- after appending @n@ elements is lost. @@ -1651,6 +1787,44 @@ m (Array a) -> Fold m a (Array a) append = appendWith (* 2) +-- XXX We can carry bound as well in the state to make sure we do not lose the +-- remaining capacity. Need to check perf impact. +-- +-- | Like 'writeNUnsafe' but takes a new array allocator @alloc size@ function +-- as argument. +-- +-- >>> writeNWithUnsafe alloc n = Array.appendNUnsafe (alloc n) n +-- +-- /Pre-release/ +{-# INLINE_NORMAL writeNWithUnsafe #-} +writeNWithUnsafe :: forall m a. (MonadIO m, Storable a) + => (Int -> m (Array a)) -> Int -> Fold m a (Array a) +writeNWithUnsafe alloc n = Fold step initial (return . fromArrayUnsafe) + + where + + initial = FL.Partial . toArrayUnsafe <$> alloc (max n 0) + + step (ArrayUnsafe contents start end) x = do + liftIO $ poke end x >> touch contents + return + $ FL.Partial + $ ArrayUnsafe contents start (PTR_NEXT(end,a)) + +-- | Like 'writeN' but does not check the array bounds when writing. The fold +-- driver must not call the step function more than 'n' times otherwise it will +-- corrupt the memory and crash. This function exists mainly because any +-- conditional in the step function blocks fusion causing 10x performance +-- slowdown. +-- +-- >>> writeNUnsafe = Array.writeNWithUnsafe Array.newArray +-- +-- @since 0.7.0 +{-# INLINE_NORMAL writeNUnsafe #-} +writeNUnsafe :: forall m a. (MonadIO m, Storable a) + => Int -> Fold m a (Array a) +writeNUnsafe = writeNWithUnsafe newArray + -- | @writeNWith alloc n@ folds a maximum of @n@ elements into an array -- allocated using the @alloc@ function. -- @@ -1704,44 +1878,6 @@ => Int -> Int -> Fold m a (Array a) writeNAlignedUnmanaged align = writeNWith (newArrayAlignedUnmanaged align) --- XXX We can carry bound as well in the state to make sure we do not lose the --- remaining capacity. Need to check perf impact. --- --- | Like 'writeNUnsafe' but takes a new array allocator @alloc size@ function --- as argument. --- --- >>> writeNWithUnsafe alloc n = Array.appendNUnsafe (alloc n) n --- --- /Pre-release/ -{-# INLINE_NORMAL writeNWithUnsafe #-} -writeNWithUnsafe :: forall m a. (MonadIO m, Storable a) - => (Int -> m (Array a)) -> Int -> Fold m a (Array a) -writeNWithUnsafe alloc n = Fold step initial (return . fromArrayUnsafe) - - where - - initial = FL.Partial . toArrayUnsafe <$> alloc (max n 0) - - step (ArrayUnsafe contents start end) x = do - liftIO $ poke end x >> touch contents - return - $ FL.Partial - $ ArrayUnsafe contents start (end `plusPtr` sizeOf (undefined :: a)) - --- | Like 'writeN' but does not check the array bounds when writing. The fold --- driver must not call the step function more than 'n' times otherwise it will --- corrupt the memory and crash. This function exists mainly because any --- conditional in the step function blocks fusion causing 10x performance --- slowdown. --- --- >>> writeNUnsafe = Array.writeNWithUnsafe Array.newArray --- --- @since 0.7.0 -{-# INLINE_NORMAL writeNUnsafe #-} -writeNUnsafe :: forall m a. (MonadIO m, Storable a) - => Int -> Fold m a (Array a) -writeNUnsafe = writeNWithUnsafe newArray - -- XXX Buffer to a list instead? -- -- | Buffer a stream into a stream of arrays. @@ -1799,20 +1935,19 @@ insertElem (Array contents start end bound) x = do liftIO $ poke end x - let end1 = end `plusPtr` sizeOf (undefined :: a) - return $ Array contents start end1 bound + return $ Array contents start (PTR_NEXT(end,a)) bound initial = do when (elemCount < 0) $ error "writeWith: elemCount is negative" liftIO $ newArrayAligned (alignment (undefined :: a)) elemCount step arr@(Array _ start end bound) x - | end `plusPtr` sizeOf (undefined :: a) > bound = do + | PTR_NEXT(end,a) > bound = do let oldSize = end `minusPtr` start newSize = max (oldSize * 2) 1 arr1 <- liftIO $ reallocAligned - (sizeOf (undefined :: a)) + (SIZE_OF(a)) (alignment (undefined :: a)) newSize arr @@ -1853,7 +1988,7 @@ fwrite ptr x = do liftIO $ poke ptr x - return $ ptr `plusPtr` sizeOf (undefined :: a) + return $ PTR_NEXT(ptr,a) -- | Create an 'Array' from the first N elements of a list. The array is -- allocated to size N, if the list terminates before N elements then the @@ -1902,7 +2037,7 @@ -- | Create an 'Array' from a list. The list must be of finite size. -- -- @since 0.7.0 -{-# INLINABLE fromList #-} +{-# INLINE fromList #-} fromList :: (MonadIO m, Storable a) => [a] -> m (Array a) fromList xs = fromStreamD $ D.fromList xs @@ -2047,7 +2182,7 @@ else if i > maxIndex then error $ "sliceAt: specified array index " ++ show i ++ " is beyond the maximum index " ++ show maxIndex - else let off = i * sizeOf (undefined :: a) + else let off = i * SIZE_OF(a) p = arrStart `plusPtr` off in ( Array { arrContents = arrContents @@ -2098,20 +2233,22 @@ cast :: forall a b. Storable b => Array a -> Maybe (Array b) cast arr = let len = byteLength arr - r = len `mod` sizeOf (undefined :: b) + r = len `mod` SIZE_OF(b) in if r /= 0 then Nothing else Just $ castUnsafe arr --- | Use an @Array a@ as @Ptr b@. +-- | Use an @Array a@ as @Ptr a@. -- -- /Unsafe/ -- -- /Pre-release/ -- -asPtrUnsafe :: Array a -> (Ptr b -> IO c) -> IO c -asPtrUnsafe Array{..} act = do - unsafeWithArrayContents arrContents arrStart $ \ptr -> act (castPtr ptr) +asPtrUnsafe :: MonadIO m => Array a -> (Ptr a -> m b) -> m b +asPtrUnsafe Array{..} f = do + r <- f arrStart + liftIO $ touch arrContents + return r ------------------------------------------------------------------------------- -- Equality diff --git a/src/Streamly/Internal/Data/Array/Foreign/Type.hs b/src/Streamly/Internal/Data/Array/Foreign/Type.hs --- a/src/Streamly/Internal/Data/Array/Foreign/Type.hs +++ b/src/Streamly/Internal/Data/Array/Foreign/Type.hs @@ -1,5 +1,3 @@ -#include "inline.hs" - -- | -- Module : Streamly.Internal.Data.Array.Foreign.Type -- Copyright : (c) 2020 Composewell Technologies @@ -15,6 +13,7 @@ ( -- $arrayNotes Array (..) + , asPtrUnsafe -- * Freezing and Thawing , unsafeFreeze @@ -25,6 +24,7 @@ , splice , fromPtr + , fromForeignPtrUnsafe , fromAddr# , fromCString# , fromList @@ -73,6 +73,9 @@ ) where +#include "ArrayMacros.h" +#include "inline.hs" + import Control.Exception (assert) import Control.DeepSeq (NFData(..)) import Control.Monad.IO.Class (MonadIO(..)) @@ -84,6 +87,7 @@ import Foreign.Storable (Storable(..)) import GHC.Base (Addr#, nullAddr#, build) import GHC.Exts (IsList, IsString(..)) +import GHC.ForeignPtr (ForeignPtr) import GHC.IO (unsafePerformIO) import GHC.Ptr (Ptr(..)) @@ -118,6 +122,9 @@ -- >>> import Prelude hiding (length, foldr, read, unlines, splitAt) -- >>> import Streamly.Internal.Data.Array.Foreign as Array +-- XXX Since these are immutable arrays MonadIO constraint can be removed from +-- most places. + ------------------------------------------------------------------------------- -- Array Data Type ------------------------------------------------------------------------------- @@ -152,6 +159,18 @@ foreign import ccall unsafe "string.h strlen" c_strlen :: CString -> IO CSize +-- | Use an @Array a@ as @Ptr a@. +-- +-- /Unsafe/ +-- +-- /Pre-release/ +-- +asPtrUnsafe :: MonadIO m => Array a -> (Ptr a -> m b) -> m b +asPtrUnsafe Array{..} f = do + r <- f arrStart + liftIO $ touch arrContents + return r + ------------------------------------------------------------------------------- -- Freezing and Thawing ------------------------------------------------------------------------------- @@ -231,6 +250,24 @@ , aEnd = end } +-- | @fromForeignPtrUnsafe foreignPtr end bound@ creates an 'Array' that starts +-- at the memory pointed by the @foreignPtr@, @end@ is the first unused +-- address. +-- +-- Unsafe: Make sure that foreignPtr <= end and (end - start) is an +-- integral multiple of the element size. Only PlainPtr type ForeignPtr is +-- supported. +-- +-- /Pre-release/ +-- +{-# INLINE fromForeignPtrUnsafe #-} +fromForeignPtrUnsafe :: +#ifdef DEVBUILD + Storable a => +#endif + ForeignPtr a -> Ptr a -> Array a +fromForeignPtrUnsafe fp end = unsafeFreeze $ MA.fromForeignPtrUnsafe fp end end + -- XXX when converting an array of Word8 from a literal string we can simply -- refer to the literal string. Is it possible to write rules such that -- fromList Word8 can be rewritten so that GHC does not first convert the @@ -333,7 +370,7 @@ -- /Since 0.7.0 (Streamly.Memory.Array)/ -- -- @since 0.8.0 -{-# INLINABLE fromList #-} +{-# INLINE fromList #-} fromList :: Storable a => [a] -> Array a fromList xs = unsafePerformIO $ unsafeFreeze <$> MA.fromList xs @@ -409,13 +446,13 @@ -- -- Unsafe because it does not check the bounds of the array. {-# INLINE_NORMAL unsafeIndexIO #-} -unsafeIndexIO :: forall a. Storable a => Array a -> Int -> IO a -unsafeIndexIO arr = MA.getIndexUnsafe (unsafeThaw arr) +unsafeIndexIO :: forall a. Storable a => Int -> Array a -> IO a +unsafeIndexIO i arr = MA.getIndexUnsafe i (unsafeThaw arr) -- | Return element at the specified index without checking the bounds. {-# INLINE_NORMAL unsafeIndex #-} -unsafeIndex :: forall a. Storable a => Array a -> Int -> a -unsafeIndex arr i = let !r = unsafeInlineIO $ unsafeIndexIO arr i in r +unsafeIndex :: forall a. Storable a => Int -> Array a -> a +unsafeIndex i arr = let !r = unsafeInlineIO $ unsafeIndexIO i arr in r -- | /O(1)/ Get the byte length of the array. -- @@ -443,7 +480,7 @@ where inject (Array contents start end) = - let p = end `plusPtr` negate (sizeOf (undefined :: a)) + let p = PTR_PREV(end,a) in return $ ReadUState contents start p {-# INLINE_LATE step #-} @@ -458,8 +495,7 @@ -- This should be safe as the array contents are guaranteed to be -- evaluated/written to before we peek at them. let !x = unsafeInlineIO $ peek p - let cur = p `plusPtr` negate (sizeOf (undefined :: a)) - return $ D.Yield x (ReadUState contents start cur) + return $ D.Yield x (ReadUState contents start (PTR_PREV(p,a))) {-# INLINE_NORMAL toStreamD #-} @@ -482,7 +518,7 @@ r <- peek p touch arrContents return r - return $ D.Yield x (p `plusPtr` sizeOf (undefined :: a)) + return $ D.Yield x (PTR_NEXT(p,a)) {-# INLINE toStreamK #-} toStreamK :: forall m a. Storable a => Array a -> K.Stream m a @@ -497,13 +533,11 @@ r <- peek p touch arrContents return r - in x `K.cons` go (p `plusPtr` sizeOf (undefined :: a)) + in x `K.cons` go (PTR_NEXT(p,a)) {-# INLINE_NORMAL toStreamDRev #-} toStreamDRev :: forall m a. (Monad m, Storable a) => Array a -> D.Stream m a -toStreamDRev Array{..} = - let p = aEnd `plusPtr` negate (sizeOf (undefined :: a)) - in D.Stream step p +toStreamDRev Array{..} = D.Stream step (PTR_PREV(aEnd,a)) where @@ -515,13 +549,11 @@ r <- peek p touch arrContents return r - return $ D.Yield x (p `plusPtr` negate (sizeOf (undefined :: a))) + return $ D.Yield x (PTR_PREV(p,a)) {-# INLINE toStreamKRev #-} toStreamKRev :: forall m a. Storable a => Array a -> K.Stream m a -toStreamKRev Array {..} = - let p = aEnd `plusPtr` negate (sizeOf (undefined :: a)) - in go p +toStreamKRev Array {..} = go (PTR_PREV(aEnd,a)) where @@ -531,7 +563,7 @@ r <- peek p touch arrContents return r - in x `K.cons` go (p `plusPtr` negate (sizeOf (undefined :: a))) + in x `K.cons` go (PTR_PREV(p,a)) -- | Convert an 'Array' into a stream. -- @@ -590,7 +622,7 @@ r <- peek p touch arrContents return r - in c x (go (p `plusPtr` sizeOf (undefined :: a))) + in c x (go (PTR_NEXT(p,a))) -- | Convert an 'Array' into a list. -- @@ -758,7 +790,7 @@ {-# INLINE_NORMAL _foldr #-} _foldr :: forall a b. (a -> b -> b) -> b -> Array a -> b _foldr f z arr = - let !n = sizeOf (undefined :: a) + let !n = SIZE_OF(a) in unsafePerformIO $ D.foldr f z $ toStreamD_ n arr -- | Note that the 'Foldable' instance is 7x slower than the direct diff --git a/src/Streamly/Internal/Data/Array/Mut/Type.hs b/src/Streamly/Internal/Data/Array/Mut/Type.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Array/Mut/Type.hs @@ -0,0 +1,569 @@ +{-# LANGUAGE UnboxedTuples #-} + +-- | +-- Module : Streamly.Internal.Data.Array.Mut.Type +-- Copyright : (c) 2020 Composewell Technologies +-- License : BSD3-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +module Streamly.Internal.Data.Array.Mut.Type +( + -- * Type + -- $arrayNotes + Array (..) + + -- * Constructing and Writing + -- ** Construction + -- , nil + + -- *** Uninitialized Arrays + , newArray + -- , newArrayWith + + -- *** From streams + , writeNUnsafe + , writeN + + -- , writeWith + -- , write + + -- , writeRevN + -- , writeRev + + -- ** From containers + -- , fromListN + -- , fromList + -- , fromStreamDN + -- , fromStreamD + + -- * Random writes + , putIndex + , putIndexUnsafe + -- , putIndices + -- , putFromThenTo + -- , putFrom -- start writing at the given position + -- , putUpto -- write from beginning up to the given position + -- , putFromTo + -- , putFromRev + -- , putUptoRev + , modifyIndexUnsafe + , modifyIndex + -- , modifyIndices + -- , modify + -- , swapIndices + + -- * Growing and Shrinking + -- Arrays grow only at the end, though it is possible to grow on both sides + -- and therefore have a cons as well as snoc. But that will require two + -- bounds in the array representation. + + -- ** Appending elements + , snocWith + , snoc + -- , snocLinear + -- , snocMay + , snocUnsafe + + -- ** Appending streams + -- , appendNUnsafe + -- , appendN + -- , appendWith + -- , append + + -- ** Truncation + -- These are not the same as slicing the array at the beginning, they may + -- reduce the length as well as the capacity of the array. + -- , truncateWith + -- , truncate + -- , truncateExp + + -- * Eliminating and Reading + + -- ** To streams + , read + -- , readRev + + -- ** To containers + , toStreamD + -- , toStreamDRev + , toStreamK + -- , toStreamKRev + , toList + + -- experimental + , producer + + -- ** Random reads + , getIndex + , getIndexUnsafe + -- , getIndices + -- , getFromThenTo + -- , getIndexRev + + -- * In-place Mutation Algorithms + -- , reverse + -- , permute + -- , partitionBy + -- , shuffleBy + -- , divideBy + -- , mergeBy + + -- * Folding + -- , foldl' + -- , foldr + -- , cmp + + -- * Arrays of arrays + -- We can add dimensionality parameter to the array type to get + -- multidimensional arrays. Multidimensional arrays would just be a + -- convenience wrapper on top of single dimensional arrays. + + -- | Operations dealing with multiple arrays, streams of arrays or + -- multidimensional array representations. + + -- ** Construct from streams + -- , arraysOf + -- , arrayStreamKFromStreamD + -- , writeChunks + + -- ** Eliminate to streams + -- , flattenArrays + -- , flattenArraysRev + -- , fromArrayStreamK + + -- ** Construct from arrays + -- get chunks without copying + , getSliceUnsafe + , getSlice + -- , getSlicesFromLenN + -- , splitAt -- XXX should be able to express using getSlice + -- , breakOn + + -- ** Appending arrays + -- , spliceCopy + -- , spliceWith + -- , splice + -- , spliceExp + -- , putSlice + -- , appendSlice + -- , appendSliceFrom + ) +where + +#include "inline.hs" + +import Control.Exception (assert) +import Control.Monad.IO.Class (MonadIO(..)) +import GHC.Base + ( MutableArray# + , RealWorld + , copyMutableArray# + , newArray# + , readArray# + , writeArray# + ) +import GHC.IO (IO(..)) +import GHC.Int (Int(..)) +import Streamly.Internal.Data.Fold.Type (Fold(..)) +import Streamly.Internal.Data.Producer.Type (Producer (..)) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) + +import qualified Streamly.Internal.Data.Fold.Type as FL +import qualified Streamly.Internal.Data.Producer as Producer +import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream.StreamK as K + +import Prelude hiding (read) + +-- $setup +-- >>> :m +-- >>> import qualified Streamly.Internal.Data.Array.Mut.Type as Array +-- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream +-- >>> import qualified Streamly.Internal.Data.Stream.StreamD as StreamD +-- >>> import qualified Streamly.Internal.Data.Fold as Fold +-- >>> import qualified Streamly.Internal.Data.Fold.Type as Fold + +------------------------------------------------------------------------------- +-- Array Data Type +------------------------------------------------------------------------------- + +data Array a = + Array + { arrContents# :: MutableArray# RealWorld a + -- ^ The internal contents of the array representing the entire array. + + , arrStart :: {-# UNPACK #-}!Int + -- ^ The starting index of this slice. + + , arrLen :: {-# UNPACK #-}!Int + -- ^ The length of this slice. + + , arrTrueLen :: {-# UNPACK #-}!Int + -- ^ This is the true length of the array. Coincidentally, this also + -- represents the first index beyond the maximum acceptable index of + -- the array. This is specific to the array contents itself and not + -- dependent on the slice. This value should not change and is shared + -- across all the slices. + } + +{-# INLINE bottomElement #-} +bottomElement :: a +bottomElement = + error + $ unwords + [ funcName + , "This is the bottom element of the array." + , "This is a place holder and should never be reached!" + ] + + where + + funcName = "Streamly.Internal.Data.Array.Mut.Type.bottomElement:" + +-- XXX Would be nice if GHC can provide something like newUninitializedArray# so +-- that we do not have to write undefined or error in the whole array. +-- | @newArray count@ allocates an empty array that can hold 'count' items. +-- +-- /Pre-release/ +{-# INLINE newArray #-} +newArray :: forall m a. MonadIO m => Int -> m (Array a) +newArray n@(I# n#) = + liftIO + $ IO + $ \s# -> + case newArray# n# bottomElement s# of + (# s1#, arr# #) -> + let ma = Array arr# 0 0 n + in (# s1#, ma #) + +------------------------------------------------------------------------------- +-- Random writes +------------------------------------------------------------------------------- + +-- | Write the given element to the given index of the array. Does not check if +-- the index is out of bounds of the array. +-- +-- /Pre-release/ +{-# INLINE putIndexUnsafe #-} +putIndexUnsafe :: forall m a. MonadIO m => Array a -> Int -> a -> m () +putIndexUnsafe Array {..} i x = + liftIO + $ IO + $ \s# -> + case i + arrStart of + I# n# -> + let s1# = writeArray# arrContents# n# x s# + in (# s1#, () #) + +invalidIndex :: String -> Int -> a +invalidIndex label i = + error $ label ++ ": invalid array index " ++ show i + +-- | /O(1)/ Write the given element at the given index in the array. +-- Performs in-place mutation of the array. +-- +-- >>> putIndex arr ix val = Array.modifyIndex arr ix (const (val, ())) +-- +-- /Pre-release/ +{-# INLINE putIndex #-} +putIndex :: MonadIO m => Array a -> Int -> a -> m () +putIndex arr@Array {..} i x = + if i >= 0 && i < arrLen + then putIndexUnsafe arr i x + else invalidIndex "putIndex" i + +-- | Modify a given index of an array using a modifier function without checking +-- the bounds. +-- +-- Unsafe because it does not check the bounds of the array. +-- +-- /Pre-release/ +modifyIndexUnsafe :: MonadIO m => Array a -> Int -> (a -> (a, b)) -> m b +modifyIndexUnsafe Array {..} i f = do + liftIO + $ IO + $ \s# -> + case i + arrStart of + I# n# -> + case readArray# arrContents# n# s# of + (# s1#, a #) -> + let (a1, b) = f a + s2# = writeArray# arrContents# n# a1 s1# + in (# s2#, b #) + +-- | Modify a given index of an array using a modifier function. +-- +-- /Pre-release/ +modifyIndex :: MonadIO m => Array a -> Int -> (a -> (a, b)) -> m b +modifyIndex arr@Array {..} i f = do + if i >= 0 && i < arrLen + then modifyIndexUnsafe arr i f + else invalidIndex "modifyIndex" i + +------------------------------------------------------------------------------- +-- Resizing +------------------------------------------------------------------------------- + +-- | Reallocates the array according to the new size. This is a safe function +-- that always creates a new array and copies the old array into the new one. If +-- the reallocated size is less than the original array it results in a +-- truncated version of the original array. +-- +realloc :: MonadIO m => Int -> Array a -> m (Array a) +realloc n arr = do + arr1 <- newArray n + let !newLen@(I# newLen#) = min n (arrLen arr) + !(I# arrS#) = arrStart arr + !(I# arr1S#) = arrStart arr1 + arrC# = arrContents# arr + arr1C# = arrContents# arr1 + liftIO + $ IO + $ \s# -> + let s1# = copyMutableArray# arrC# arrS# arr1C# arr1S# newLen# s# + in (# s1#, arr1 {arrLen = newLen, arrTrueLen = n} #) + +reallocWith :: + MonadIO m => String -> (Int -> Int) -> Int -> Array a -> m (Array a) +reallocWith label sizer reqSize arr = do + let oldSize = arrLen arr + newSize = sizer oldSize + safeSize = max newSize (oldSize + reqSize) + assert (newSize >= oldSize + reqSize || error badSize) (return ()) + realloc safeSize arr + + where + + badSize = concat + [ label + , ": new array size is less than required size " + , show reqSize + , ". Please check the sizing function passed." + ] + +------------------------------------------------------------------------------- +-- Snoc +------------------------------------------------------------------------------- + +-- XXX Not sure of the behavior of writeArray# if we specify an index which is +-- out of bounds. This comment should be rewritten based on that. +-- | Really really unsafe, appends the element into the first array, may +-- cause silent data corruption or if you are lucky a segfault if the index +-- is out of bounds. +-- +-- /Internal/ +{-# INLINE snocUnsafe #-} +snocUnsafe :: MonadIO m => Array a -> a -> m (Array a) +snocUnsafe arr@Array {..} a = do + assert (arrStart + arrLen < arrTrueLen) (return ()) + putIndexUnsafe arr arrLen a + return $ arr {arrLen = arrLen + 1} + +-- NOINLINE to move it out of the way and not pollute the instruction cache. +{-# NOINLINE snocWithRealloc #-} +snocWithRealloc :: MonadIO m => (Int -> Int) -> Array a -> a -> m (Array a) +snocWithRealloc sizer arr x = do + arr1 <- reallocWith "snocWithRealloc" sizer 1 arr + snocUnsafe arr1 x + +-- | @snocWith sizer arr elem@ mutates @arr@ to append @elem@. The length of +-- the array increases by 1. +-- +-- If there is no reserved space available in @arr@ it is reallocated to a size +-- in bytes determined by the @sizer oldSize@ function, where @oldSize@ is the +-- original size of the array. +-- +-- Note that the returned array may be a mutated version of the original array. +-- +-- /Pre-release/ +{-# INLINE snocWith #-} +snocWith :: MonadIO m => (Int -> Int) -> Array a -> a -> m (Array a) +snocWith sizer arr@Array {..} x = do + if arrStart + arrLen < arrTrueLen + then snocUnsafe arr x + else snocWithRealloc sizer arr x + +-- XXX round it to next power of 2. +-- +-- | The array is mutated to append an additional element to it. If there is no +-- reserved space available in the array then it is reallocated to double the +-- original size. +-- +-- This is useful to reduce allocations when appending unknown number of +-- elements. +-- +-- Note that the returned array may be a mutated version of the original array. +-- +-- >>> snoc = Array.snocWith (* 2) +-- +-- Performs O(n * log n) copies to grow, but is liberal with memory allocation. +-- +-- /Pre-release/ +{-# INLINE snoc #-} +snoc :: MonadIO m => Array a -> a -> m (Array a) +snoc = snocWith (* 2) + +------------------------------------------------------------------------------- +-- Random reads +------------------------------------------------------------------------------- + +-- | Return the element at the specified index without checking the bounds. +-- +-- Unsafe because it does not check the bounds of the array. +{-# INLINE_NORMAL getIndexUnsafe #-} +getIndexUnsafe :: MonadIO m => Array a -> Int -> m a +getIndexUnsafe Array {..} n = + liftIO + $ IO + $ \s# -> + let !(I# i#) = arrStart + n + in readArray# arrContents# i# s# + +-- | /O(1)/ Lookup the element at the given index. Index starts from 0. +-- +{-# INLINE getIndex #-} +getIndex :: MonadIO m => Array a -> Int -> m a +getIndex arr@Array {..} i = + if i >= 0 && i < arrLen + then getIndexUnsafe arr i + else invalidIndex "getIndex" i + +------------------------------------------------------------------------------- +-- Subarrays +------------------------------------------------------------------------------- + +-- XXX We can also get immutable slices. + +-- | /O(1)/ Slice an array in constant time. +-- +-- Unsafe: The bounds of the slice are not checked. +-- +-- /Unsafe/ +-- +-- /Pre-release/ +{-# INLINE getSliceUnsafe #-} +getSliceUnsafe + :: Int -- ^ from index + -> Int -- ^ length of the slice + -> Array a + -> Array a +getSliceUnsafe index len arr@Array {..} = + assert (index >= 0 && len >= 0 && index + len <= arrLen) + $ arr {arrStart = arrStart + index, arrLen = len} + + +-- | /O(1)/ Slice an array in constant time. Throws an error if the slice +-- extends out of the array bounds. +-- +-- /Pre-release/ +{-# INLINE getSlice #-} +getSlice + :: Int -- ^ from index + -> Int -- ^ length of the slice + -> Array a + -> Array a +getSlice index len arr@Array{..} = + if index >= 0 && len >= 0 && index + len <= arrLen + then arr {arrStart = arrStart + index, arrLen = len} + else error + $ "getSlice: invalid slice, index " + ++ show index ++ " length " ++ show len + +------------------------------------------------------------------------------- +-- to Lists and streams +------------------------------------------------------------------------------- + +-- | Convert an 'Array' into a list. +-- +-- /Pre-release/ +{-# INLINE toList #-} +toList :: MonadIO m => Array a -> m [a] +toList arr@Array{..} = mapM (getIndexUnsafe arr) [0 .. (arrLen - 1)] + +-- | Use the 'read' unfold instead. +-- +-- @toStreamD = D.unfold read@ +-- +-- We can try this if the unfold has any performance issues. +{-# INLINE_NORMAL toStreamD #-} +toStreamD :: MonadIO m => Array a -> D.Stream m a +toStreamD arr@Array{..} = + D.mapM (getIndexUnsafe arr) $ D.enumerateFromToIntegral 0 (arrLen - 1) + +{-# INLINE toStreamK #-} +toStreamK :: MonadIO m => Array a -> K.Stream m a +toStreamK arr@Array{..} = K.unfoldrM step 0 + + where + + step i + | i == arrLen = return Nothing + | otherwise = do + x <- getIndexUnsafe arr i + return $ Just (x, i + 1) + + +------------------------------------------------------------------------------- +-- Folds +------------------------------------------------------------------------------- + +-- | Like 'writeN' but does not check the array bounds when writing. The fold +-- driver must not call the step function more than 'n' times otherwise it will +-- corrupt the memory and crash. This function exists mainly because any +-- conditional in the step function blocks fusion causing 10x performance +-- slowdown. +-- +-- /Pre-release/ +{-# INLINE_NORMAL writeNUnsafe #-} +writeNUnsafe :: MonadIO m => Int -> Fold m a (Array a) +writeNUnsafe n = Fold step initial return + + where + + initial = FL.Partial <$> newArray (max n 0) + + step arr x = FL.Partial <$> snocUnsafe arr x + +-- | @writeN n@ folds a maximum of @n@ elements from the input stream to an +-- 'Array'. +-- +-- >>> writeN n = Fold.take n (Array.writeNUnsafe n) +-- +-- /Pre-release/ +{-# INLINE_NORMAL writeN #-} +writeN :: MonadIO m => Int -> Fold m a (Array a) +writeN n = FL.take n $ writeNUnsafe n + +------------------------------------------------------------------------------- +-- Unfolds +------------------------------------------------------------------------------- + +-- | Resumable unfold of an array. +-- +{-# INLINE_NORMAL producer #-} +producer :: MonadIO m => Producer m (Array a) a +producer = Producer step inject extract + + where + + {-# INLINE inject #-} + inject arr = return (arr, 0) + + {-# INLINE extract #-} + extract (arr, i) = + return $ arr {arrStart = arrStart arr + i, arrLen = arrLen arr - i} + + {-# INLINE_LATE step #-} + step (arr, i) + | assert (arrLen arr >= 0) (i == arrLen arr) = return D.Stop + step (arr, i) = do + x <- getIndexUnsafe arr i + return $ D.Yield x (arr, i + 1) + +-- | Unfold an array into a stream. +-- +{-# INLINE_NORMAL read #-} +read :: MonadIO m => Unfold m (Array a) a +read = Producer.simplify producer diff --git a/src/Streamly/Internal/Data/Array/Prim/MutTypesInclude.hs b/src/Streamly/Internal/Data/Array/Prim/MutTypesInclude.hs --- a/src/Streamly/Internal/Data/Array/Prim/MutTypesInclude.hs +++ b/src/Streamly/Internal/Data/Array/Prim/MutTypesInclude.hs @@ -83,7 +83,7 @@ length arr = liftIO $ do blen <- byteLength arr - return $ blen `quot` (sizeOf (undefined :: a)) + return $ blen `quot` (max 1 $ sizeOf (undefined :: a)) ------------------------------------------------------------------------------- -- Random Access diff --git a/src/Streamly/Internal/Data/Array/Prim/TypesInclude.hs b/src/Streamly/Internal/Data/Array/Prim/TypesInclude.hs --- a/src/Streamly/Internal/Data/Array/Prim/TypesInclude.hs +++ b/src/Streamly/Internal/Data/Array/Prim/TypesInclude.hs @@ -128,10 +128,13 @@ -- Length ------------------------------------------------------------------------------- +sizeOfPrimElem :: forall a . (Prim a) => a -> Int +sizeOfPrimElem _ = max 1 $ sizeOf (undefined :: a) + -- XXX rename to byteCount? {-# INLINE byteLength #-} byteLength :: forall a. Prim a => Array a -> Int -byteLength (Array _ _ len) = len * sizeOf (undefined :: a) +byteLength (Array _ _ len) = len * sizeOfPrimElem (undefined :: a) -- XXX Also, rename to elemCount -- XXX I would prefer length to keep the API consistent @@ -546,7 +549,7 @@ where - nElem = n `quot` sizeOf (undefined :: a) + nElem = n `quot` sizeOfPrimElem (undefined :: a) {-# INLINE_LATE step' #-} step' gst (SpliceInitial st) = do @@ -597,7 +600,7 @@ where - nElem = n `quot` sizeOf (undefined :: a) + nElem = n `quot` sizeOfPrimElem (undefined :: a) initial = do when (n <= 0) $ diff --git a/src/Streamly/Internal/Data/Array/Stream/Fold/Foreign.hs b/src/Streamly/Internal/Data/Array/Stream/Fold/Foreign.hs --- a/src/Streamly/Internal/Data/Array/Stream/Fold/Foreign.hs +++ b/src/Streamly/Internal/Data/Array/Stream/Fold/Foreign.hs @@ -33,6 +33,7 @@ -- * Construction , fromFold , fromParser + , fromParserD , fromArrayFold -- * Mapping @@ -51,6 +52,8 @@ ) where +#include "ArrayMacros.h" + import Control.Applicative (liftA2) import Control.Exception (assert) import Control.Monad.Catch (MonadThrow) @@ -67,6 +70,8 @@ import qualified Streamly.Internal.Data.Fold as Fold import qualified Streamly.Internal.Data.Parser.ParserD as ParserD import qualified Streamly.Internal.Data.Parser.ParserD.Type as ParserD +import qualified Streamly.Internal.Data.Parser.ParserK.Type as ParserK +import qualified Streamly.Internal.Data.Parser as Parser import Prelude hiding (concatMap, take) @@ -118,22 +123,22 @@ goArray !_ !cur !fs = do x <- liftIO $ peek cur res <- fstep fs x - let elemSize = sizeOf (undefined :: a) - next = cur `plusPtr` elemSize + let elemSize = SIZE_OF(a) + next = PTR_NEXT(cur,a) case res of Fold.Done b -> return $ Done ((end `minusPtr` next) `div` elemSize) b Fold.Partial fs1 -> goArray SPEC next fs1 --- | Convert an element 'Parser' into an array stream fold. If the parser fails --- the fold would throw an exception. +-- | Convert an element 'ParserD.Parser' into an array stream fold. If the +-- parser fails the fold would throw an exception. -- -- /Pre-release/ -{-# INLINE fromParser #-} -fromParser :: forall m a b. (MonadIO m, Storable a) => +{-# INLINE fromParserD #-} +fromParserD :: forall m a b. (MonadIO m, Storable a) => ParserD.Parser m a b -> Fold m a b -fromParser (ParserD.Parser step1 initial1 extract1) = +fromParserD (ParserD.Parser step1 initial1 extract1) = Fold (ParserD.Parser step initial1 extract1) where @@ -156,8 +161,8 @@ x <- liftIO $ peek cur liftIO $ touch contents res <- step1 fs x - let elemSize = sizeOf (undefined :: a) - next = cur `plusPtr` elemSize + let elemSize = SIZE_OF(a) + next = PTR_NEXT(cur,a) arrRem = (end `minusPtr` next) `div` elemSize case res of ParserD.Done n b -> do @@ -168,6 +173,15 @@ partial arrRem cur next elemSize Continue n fs1 Error err -> return $ Error err +-- | Convert an element 'Parser.Parser' into an array stream fold. If the parser +-- fails the fold would throw an exception. +-- +-- /Pre-release/ +{-# INLINE fromParser #-} +fromParser :: forall m a b. (MonadThrow m, MonadIO m, Storable a) => + Parser.Parser m a b -> Fold m a b +fromParser = fromParserD . ParserK.fromParserK + -- | Adapt an array stream fold. -- -- /Pre-release/ @@ -320,8 +334,7 @@ Error err -> return $ Error err else do let !(Array contents start _) = arr - sz = sizeOf (undefined :: a) - end = start `plusPtr` (i * sz) + end = PTR_INDEX(start,i,a) arr1 = Array contents start end remaining = negate i1 res <- step1 r arr1 diff --git a/src/Streamly/Internal/Data/Array/Stream/Foreign.hs b/src/Streamly/Internal/Data/Array/Stream/Foreign.hs --- a/src/Streamly/Internal/Data/Array/Stream/Foreign.hs +++ b/src/Streamly/Internal/Data/Array/Stream/Foreign.hs @@ -46,6 +46,7 @@ ) where +#include "ArrayMacros.h" #include "inline.hs" import Data.Bifunctor (second) @@ -90,6 +91,9 @@ import qualified Streamly.Internal.Data.Stream.IsStream as S import qualified Streamly.Internal.Data.Stream.StreamD as D +-- XXX Since these are immutable arrays MonadIO constraint can be removed from +-- most places. + ------------------------------------------------------------------------------- -- Generation ------------------------------------------------------------------------------- @@ -115,13 +119,13 @@ -- | Convert a stream of arrays into a stream of their elements. -- --- Same as the following but more efficient: +-- Same as the following: -- -- > concat = Stream.unfoldMany Array.read -- -- @since 0.7.0 {-# INLINE concat #-} -concat :: (IsStream t, MonadIO m, Storable a) => t m (Array a) -> t m a +concat :: (IsStream t, Monad m, Storable a) => t m (Array a) -> t m a -- concat m = fromStreamD $ A.flattenArrays (toStreamD m) -- concat m = fromStreamD $ D.concatMap A.toStreamD (toStreamD m) concat m = fromStreamD $ D.unfoldMany A.read (toStreamD m) @@ -133,8 +137,9 @@ -- -- @since 0.7.0 {-# INLINE concatRev #-} -concatRev :: (IsStream t, MonadIO m, Storable a) => t m (Array a) -> t m a -concatRev m = fromStreamD $ A.flattenArraysRev (toStreamD m) +concatRev :: (IsStream t, Monad m, Storable a) => t m (Array a) -> t m a +-- concatRev m = fromStreamD $ A.flattenArraysRev (toStreamD m) +concatRev m = fromStreamD $ D.unfoldMany A.readRev (toStreamD m) ------------------------------------------------------------------------------- -- Intersperse and append @@ -145,11 +150,11 @@ -- -- /Pre-release/ {-# INLINE interpose #-} -interpose :: (MonadIO m, IsStream t, Storable a) => a -> t m (Array a) -> t m a +interpose :: (Monad m, IsStream t, Storable a) => a -> t m (Array a) -> t m a interpose x = S.interpose x A.read {-# INLINE intercalateSuffix #-} -intercalateSuffix :: (MonadIO m, IsStream t, Storable a) +intercalateSuffix :: (Monad m, IsStream t, Storable a) => Array a -> t m (Array a) -> t m a intercalateSuffix = S.intercalateSuffix A.read @@ -158,7 +163,7 @@ -- -- @since 0.7.0 {-# INLINE interposeSuffix #-} -interposeSuffix :: (MonadIO m, IsStream t, Storable a) +interposeSuffix :: (Monad m, IsStream t, Storable a) => a -> t m (Array a) -> t m a -- interposeSuffix x = fromStreamD . A.unlines x . toStreamD interposeSuffix x = S.interposeSuffix x A.read @@ -167,6 +172,7 @@ OuterLoop s | InnerLoop s !MA.ArrayContents !(Ptr a) !(Ptr a) +-- XXX Remove monadIO constraint {-# INLINE_NORMAL unlines #-} unlines :: forall m a. (MonadIO m, Storable a) => a -> D.Stream m (Array a) -> D.Stream m a @@ -189,8 +195,7 @@ r <- peek p touch contents return r - return $ D.Yield x (InnerLoop st contents - (p `plusPtr` sizeOf (undefined :: a)) end) + return $ D.Yield x (InnerLoop st contents (PTR_NEXT(p,a)) end) ------------------------------------------------------------------------------- -- Compact @@ -283,6 +288,7 @@ step' _ (Yielding arr next) = return $ D.Yield arr next step' _ Finishing = return D.Stop +-- XXX Remove MonadIO constraint. -- | Split a stream of arrays on a given separator byte, dropping the separator -- and coalescing all the arrays between two separators into a single array. -- @@ -343,8 +349,7 @@ goArray !_ st fp@(ForeignPtr end contents) !cur !fs = do x <- liftIO $ peek cur res <- fstep fs x - let elemSize = sizeOf (undefined :: a) - next = cur `plusPtr` elemSize + let next = PTR_NEXT(cur,a) case res of FL.Done b -> do let arr = Array (fptrToArrayContents contents) next (Ptr end) @@ -384,8 +389,7 @@ else if n == len then [x] else let !(Array contents _ end) = x - sz = sizeOf (undefined :: a) - !start = end `plusPtr` negate (n * sz) + !start = end `plusPtr` negate (n * SIZE_OF(a)) in [Array contents start end] -- When we have to take an array partially, take the last part of the array in @@ -407,8 +411,7 @@ else if m == len then ([x],xs) else let !(Array contents start end) = x - sz = sizeOf (undefined :: a) - end1 = end `plusPtr` negate (m * sz) + end1 = end `plusPtr` negate (m * SIZE_OF(a)) arr2 = Array contents start end1 arr1 = Array contents end1 end in ([arr1], arr2:xs) @@ -542,7 +545,6 @@ -- XXX currently we are using a dumb list based approach for backtracking -- buffer. This can be replaced by a sliding/ring buffer using Data.Array. -- That will allow us more efficient random back and forth movement. - {-# INLINE go #-} go !_ st backBuf !pst = do r <- step defState st case r of @@ -562,8 +564,7 @@ gobuf !_ s backBuf fp@(ForeignPtr end contents) !cur !pst = do x <- liftIO $ peek cur pRes <- pstep pst x - let elemSize = sizeOf (undefined :: a) - next = cur `plusPtr` elemSize + let next = PTR_NEXT(cur,a) case pRes of PR.Partial 0 pst1 -> gobuf SPEC s (List []) fp next pst1 @@ -640,7 +641,6 @@ -- XXX currently we are using a dumb list based approach for backtracking -- buffer. This can be replaced by a sliding/ring buffer using Data.Array. -- That will allow us more efficient random back and forth movement. - {-# INLINE go #-} go !_ st backBuf !pst = do r <- step defState st case r of diff --git a/src/Streamly/Internal/Data/Array/Stream/Mut/Foreign.hs b/src/Streamly/Internal/Data/Array/Stream/Mut/Foreign.hs --- a/src/Streamly/Internal/Data/Array/Stream/Mut/Foreign.hs +++ b/src/Streamly/Internal/Data/Array/Stream/Mut/Foreign.hs @@ -25,21 +25,22 @@ where #include "inline.hs" +#include "ArrayMacros.h" import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad (when) +import Control.Monad.Catch (MonadThrow) import Data.Bifunctor (first) import Foreign.Storable (Storable(..)) import Streamly.Internal.Data.Array.Foreign.Mut.Type (Array(..)) import Streamly.Internal.Data.Fold.Type (Fold(..)) import Streamly.Internal.Data.Stream.Serial (SerialT(..)) -import Streamly.Internal.Data.Stream.IsStream.Type - (IsStream, fromStreamD, toStreamD) import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) import qualified Streamly.Internal.Data.Array.Foreign.Mut.Type as MArray import qualified Streamly.Internal.Data.Fold.Type as FL import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Parser.ParserD as ParserD -- | @arraysOf n stream@ groups the elements in the input stream into arrays of -- @n@ elements each. @@ -50,9 +51,10 @@ -- -- /Pre-release/ {-# INLINE arraysOf #-} -arraysOf :: (IsStream t, MonadIO m, Storable a) - => Int -> t m a -> t m (Array a) -arraysOf n = fromStreamD . MArray.arraysOf n . toStreamD +arraysOf :: (MonadIO m, Storable a) + => Int -> SerialT m a -> SerialT m (Array a) +arraysOf n (SerialT xs) = + SerialT $ D.toStreamK $ MArray.arraysOf n $ D.fromStreamK xs ------------------------------------------------------------------------------- -- Compact @@ -194,28 +196,113 @@ compact n (SerialT xs) = SerialT $ D.toStreamK $ packArraysChunksOf n (D.fromStreamK xs) --- See lpackArraysChunksOf/packArraysChunksOf to implement this. --- -- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a -- maximum specified size. Note that if a single array is bigger than the -- specified size we do not split it to fit. When we coalesce multiple arrays -- if the size would exceed the specified size we do not coalesce therefore the -- actual array size may be less than the specified chunk size. -- --- /Unimplemented/ -{-# INLINE_NORMAL compactLEFold #-} -compactLEFold :: -- (MonadIO m, Storable a) => - Int -> Fold m (Array a) (Array a) -compactLEFold = undefined +-- /Internal/ +{-# INLINE_NORMAL compactLEParserD #-} +compactLEParserD :: + forall m a. (MonadThrow m, MonadIO m, Storable a) + => Int -> ParserD.Parser m (Array a) (Array a) +compactLEParserD n = ParserD.Parser step initial extract + where + + nBytes = n * SIZE_OF(a) + + initial = + return + $ if n <= 0 + then error + $ functionPath + ++ ": the size of arrays [" + ++ show n ++ "] must be a natural number" + else ParserD.IPartial Nothing + + step Nothing arr = + return + $ let len = MArray.byteLength arr + in if len >= nBytes + then ParserD.Done 0 arr + else ParserD.Partial 0 (Just arr) + step (Just buf) arr = + let len = MArray.byteLength buf + MArray.byteLength arr + in if len > nBytes + then return $ ParserD.Done 1 buf + else do + buf1 <- + if MArray.byteCapacity buf < nBytes + then liftIO $ MArray.realloc nBytes buf + else return buf + buf2 <- MArray.splice buf1 arr + return $ ParserD.Partial 0 (Just buf2) + + extract Nothing = return MArray.nil + extract (Just buf) = return buf + + functionPath = + "Streamly.Internal.Data.Array.Stream.Mut.Foreign.compactLEParserD" + -- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a +-- minimum specified size. Note that if all the arrays in the stream together +-- are smaller than the specified size the resulting array will be smaller than +-- the specified size. When we coalesce multiple arrays if the size would exceed +-- the specified size we stop coalescing further. +-- +-- /Internal/ +{-# INLINE_NORMAL compactGEFold #-} +compactGEFold :: + forall m a. (MonadIO m, Storable a) + => Int -> FL.Fold m (Array a) (Array a) +compactGEFold n = Fold step initial extract + + where + + nBytes = n * SIZE_OF(a) + + initial = + return + $ if n < 0 + then error + $ functionPath + ++ ": the size of arrays [" + ++ show n ++ "] must be a natural number" + else FL.Partial Nothing + + step Nothing arr = + return + $ let len = MArray.byteLength arr + in if len >= nBytes + then FL.Done arr + else FL.Partial (Just arr) + step (Just buf) arr = do + let len = MArray.byteLength buf + MArray.byteLength arr + buf1 <- + if MArray.byteCapacity buf < len + then liftIO $ MArray.realloc (max len nBytes) buf + else return buf + buf2 <- MArray.splice buf1 arr + if len >= n + then return $ FL.Done buf2 + else return $ FL.Partial (Just buf2) + + extract Nothing = return MArray.nil + extract (Just buf) = return buf + + functionPath = + "Streamly.Internal.Data.Array.Stream.Mut.Foreign.compactGEFold" + +-- | Coalesce adjacent arrays in incoming stream to form bigger arrays of a -- maximum specified size in bytes. -- -- /Internal/ -compactLE :: (MonadIO m {-, Storable a-}) => +compactLE :: (MonadThrow m, MonadIO m, Storable a) => Int -> SerialT m (Array a) -> SerialT m (Array a) compactLE n (SerialT xs) = - SerialT $ D.toStreamK $ D.foldMany (compactLEFold n) (D.fromStreamK xs) + SerialT $ D.toStreamK $ D.parseMany (compactLEParserD n) (D.fromStreamK xs) -- | Like 'compactLE' but generates arrays of exactly equal to the size -- specified except for the last array in the stream which could be shorter. @@ -230,9 +317,10 @@ -- | Like 'compactLE' but generates arrays of size greater than or equal to the -- specified except for the last array in the stream which could be shorter. -- --- /Unimplemented/ +-- /Internal/ {-# INLINE compactGE #-} -compactGE :: -- (MonadIO m, Storable a) => - Int -> SerialT m (Array a) -> SerialT m (Array a) -compactGE _n _xs = undefined - -- IsStream.fromStreamD $ D.foldMany (compactGEFold n) (IsStream.toStreamD xs) +compactGE :: + (MonadIO m, Storable a) + => Int -> SerialT m (Array a) -> SerialT m (Array a) +compactGE n (SerialT xs) = + SerialT $ D.toStreamK $ D.foldMany (compactGEFold n) (D.fromStreamK xs) diff --git a/src/Streamly/Internal/Data/Binary/Decode.hs b/src/Streamly/Internal/Data/Binary/Decode.hs --- a/src/Streamly/Internal/Data/Binary/Decode.hs +++ b/src/Streamly/Internal/Data/Binary/Decode.hs @@ -275,4 +275,4 @@ {-# INLINE word64host #-} word64host :: (MonadIO m, MonadCatch m) => Parser m Word8 Word64 word64host = - fmap (flip A.unsafeIndex 0 . A.unsafeCast) $ PR.takeEQ 8 (A.writeN 8) + fmap (A.unsafeIndex 0 . A.unsafeCast) $ PR.takeEQ 8 (A.writeN 8) diff --git a/src/Streamly/Internal/Data/Fold.hs b/src/Streamly/Internal/Data/Fold.hs --- a/src/Streamly/Internal/Data/Fold.hs +++ b/src/Streamly/Internal/Data/Fold.hs @@ -113,6 +113,7 @@ --, lsequence , lmapM , scan + , postscan , indexed -- ** Filtering @@ -390,6 +391,8 @@ where + -- XXX It can be moved out and used for both scan and postscan + {-# INLINE runStep #-} runStep actionL sR = do rL <- actionL case rL of @@ -416,6 +419,47 @@ extract = extractR . snd +-- | Postscan the input of a 'Fold' to change it in a stateful manner using +-- another 'Fold'. +-- /Pre-release/ +{-# INLINE postscan #-} +postscan :: Monad m => Fold m a b -> Fold m b c -> Fold m a c +postscan (Fold stepL initialL extractL) (Fold stepR initialR extractR) = + Fold step initial extract + + where + + {-# INLINE runStep #-} + runStep actionL sR = do + rL <- actionL + case rL of + Done bL -> do + rR <- stepR sR bL + case rR of + Partial sR1 -> Done <$> extractR sR1 + Done bR -> return $ Done bR + Partial sL -> do + !b <- extractL sL + rR <- stepR sR b + return + $ case rR of + Partial sR1 -> Partial (sL, sR1) + Done bR -> Done bR + + initial = do + r <- initialR + rL <- initialL + case r of + Partial sR -> + case rL of + Done _ -> Done <$> extractR sR + Partial sL -> return $ Partial (sL, sR) + Done b -> return $ Done b + + step (sL, sR) x = runStep (stepL sL x) sR + + extract = extractR . snd + ------------------------------------------------------------------------------ -- Left folds ------------------------------------------------------------------------------ @@ -434,7 +478,7 @@ -- See also: 'Streamly.Prelude.mapM_' -- -- @since 0.7.0 -{-# INLINABLE drainBy #-} +{-# INLINE drainBy #-} drainBy :: Monad m => (a -> m b) -> Fold m a () drainBy f = lmapM f drain @@ -443,7 +487,7 @@ -- > last = fmap getLast $ Fold.foldMap (Last . Just) -- -- @since 0.7.0 -{-# INLINABLE last #-} +{-# INLINE last #-} last :: Monad m => Fold m a (Maybe a) last = foldl1' (\_ x -> x) @@ -568,7 +612,7 @@ -- stream. -- -- @since 0.7.0 -{-# INLINABLE mean #-} +{-# INLINE mean #-} mean :: (Monad m, Fractional a) => Fold m a a mean = fmap done $ foldl' step begin @@ -586,7 +630,7 @@ -- the input stream. -- -- @since 0.7.0 -{-# INLINABLE variance #-} +{-# INLINE variance #-} variance :: (Monad m, Fractional a) => Fold m a a variance = fmap done $ foldl' step begin @@ -609,7 +653,7 @@ -- elements in the input stream. -- -- @since 0.7.0 -{-# INLINABLE stdDev #-} +{-# INLINE stdDev #-} stdDev :: (Monad m, Floating a) => Fold m a a stdDev = sqrt <$> variance @@ -625,7 +669,7 @@ -- See https://en.wikipedia.org/wiki/Rolling_hash -- -- @since 0.8.0 -{-# INLINABLE rollingHashWithSalt #-} +{-# INLINE rollingHashWithSalt #-} rollingHashWithSalt :: (Monad m, Enum a) => Int64 -> Fold m a Int64 rollingHashWithSalt = foldl' step @@ -645,7 +689,7 @@ -- > rollingHash = Fold.rollingHashWithSalt defaultSalt -- -- @since 0.8.0 -{-# INLINABLE rollingHash #-} +{-# INLINE rollingHash #-} rollingHash :: (Monad m, Enum a) => Fold m a Int64 rollingHash = rollingHashWithSalt defaultSalt @@ -655,7 +699,7 @@ -- > rollingHashFirstN = Fold.take n Fold.rollingHash -- -- /Pre-release/ -{-# INLINABLE rollingHashFirstN #-} +{-# INLINE rollingHashFirstN #-} rollingHashFirstN :: (Monad m, Enum a) => Int -> Fold m a Int64 rollingHashFirstN n = take n rollingHash @@ -705,7 +749,7 @@ -- Sum {getSum = 55} -- -- @since 0.7.0 -{-# INLINABLE foldMap #-} +{-# INLINE foldMap #-} foldMap :: (Monad m, Monoid b #if !MIN_VERSION_base(4,11,0) , Semigroup b @@ -723,7 +767,7 @@ -- Sum {getSum = 55} -- -- @since 0.7.0 -{-# INLINABLE foldMapM #-} +{-# INLINE foldMapM #-} foldMapM :: (Monad m, Monoid b) => (a -> m b) -> Fold m a b foldMapM act = foldlM' step (pure mempty) @@ -751,7 +795,7 @@ -- @since 0.8.0 -- xn : ... : x2 : x1 : [] -{-# INLINABLE toListRev #-} +{-# INLINE toListRev #-} toListRev :: Monad m => Fold m a [a] toListRev = foldl' (flip (:)) [] @@ -765,7 +809,7 @@ -- > drainN n = Fold.take n Fold.drain -- -- /Pre-release/ -{-# INLINABLE drainN #-} +{-# INLINE drainN #-} drainN :: Monad m => Int -> Fold m a () drainN n = take n drain @@ -776,7 +820,7 @@ -- | Like 'index', except with a more general 'Integral' argument -- -- /Pre-release/ -{-# INLINABLE genericIndex #-} +{-# INLINE genericIndex #-} genericIndex :: (Integral i, Monad m) => i -> Fold m a (Maybe a) genericIndex i = mkFold step (Partial 0) (const Nothing) @@ -792,21 +836,21 @@ -- See also: 'Streamly.Prelude.!!' -- -- @since 0.7.0 -{-# INLINABLE index #-} +{-# INLINE index #-} index :: Monad m => Int -> Fold m a (Maybe a) index = genericIndex -- | Extract the first element of the stream, if any. -- -- @since 0.7.0 -{-# INLINABLE head #-} +{-# INLINE head #-} head :: Monad m => Fold m a (Maybe a) head = mkFold_ (const (Done . Just)) (Partial Nothing) -- | Returns the first element that satisfies the given predicate. -- -- @since 0.7.0 -{-# INLINABLE find #-} +{-# INLINE find #-} find :: Monad m => (a -> Bool) -> Fold m a (Maybe a) find predicate = mkFold step (Partial ()) (const Nothing) @@ -823,7 +867,7 @@ -- > lookup = snd <$> Fold.find ((==) . fst) -- -- @since 0.7.0 -{-# INLINABLE lookup #-} +{-# INLINE lookup #-} lookup :: (Eq a, Monad m) => a -> Fold m (a,b) (Maybe b) lookup a0 = mkFold step (Partial ()) (const Nothing) @@ -837,7 +881,7 @@ -- | Returns the first index that satisfies the given predicate. -- -- @since 0.7.0 -{-# INLINABLE findIndex #-} +{-# INLINE findIndex #-} findIndex :: Monad m => (a -> Bool) -> Fold m a (Maybe Int) findIndex predicate = mkFold step (Partial 0) (const Nothing) @@ -853,7 +897,7 @@ -- > elemIndex a = Fold.findIndex (== a) -- -- @since 0.7.0 -{-# INLINABLE elemIndex #-} +{-# INLINE elemIndex #-} elemIndex :: (Eq a, Monad m) => a -> Fold m a (Maybe Int) elemIndex a = findIndex (a ==) @@ -866,7 +910,7 @@ -- > null = fmap isJust Fold.head -- -- @since 0.7.0 -{-# INLINABLE null #-} +{-# INLINE null #-} null :: Monad m => Fold m a Bool null = mkFold (\() _ -> Done False) (Partial ()) (const True) @@ -896,7 +940,7 @@ -- > elem a = Fold.any (== a) -- -- @since 0.7.0 -{-# INLINABLE elem #-} +{-# INLINE elem #-} elem :: (Eq a, Monad m) => a -> Fold m a Bool elem a = any (a ==) @@ -908,7 +952,7 @@ -- > all p = Fold.lmap p Fold.and -- -- @since 0.7.0 -{-# INLINABLE all #-} +{-# INLINE all #-} all :: Monad m => (a -> Bool) -> Fold m a Bool all predicate = mkFold_ step initial @@ -926,7 +970,7 @@ -- > notElem a = Fold.all (/= a) -- -- @since 0.7.0 -{-# INLINABLE notElem #-} +{-# INLINE notElem #-} notElem :: (Eq a, Monad m) => a -> Fold m a Bool notElem a = all (a /=) @@ -1738,6 +1782,6 @@ -- /Pre-release/ -- xn : ... : x2 : x1 : [] -{-# INLINABLE toStreamRev #-} +{-# INLINE toStreamRev #-} toStreamRev :: Monad m => Fold m a (SerialT n a) toStreamRev = fmap SerialT toStreamKRev diff --git a/src/Streamly/Internal/Data/Fold/Async.hs b/src/Streamly/Internal/Data/Fold/Async.hs --- a/src/Streamly/Internal/Data/Fold/Async.hs +++ b/src/Streamly/Internal/Data/Fold/Async.hs @@ -21,8 +21,7 @@ import Control.Exception (SomeException(..), catch, mask) import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.Control (control) -import Streamly.Internal.Control.Concurrent (MonadAsync) +import Streamly.Internal.Control.Concurrent (MonadAsync, withRunInIO) import Streamly.Internal.Data.Tuple.Strict (Tuple3'(..)) import Streamly.Internal.Data.Fold.Type @@ -65,7 +64,7 @@ Partial s -> do mv <- liftIO $ newMVar False t <- - control $ \run -> + withRunInIO $ \run -> mask $ \restore -> do tid <- forkIO diff --git a/src/Streamly/Internal/Data/Fold/Type.hs b/src/Streamly/Internal/Data/Fold/Type.hs --- a/src/Streamly/Internal/Data/Fold/Type.hs +++ b/src/Streamly/Internal/Data/Fold/Type.hs @@ -454,6 +454,9 @@ -- need that? -- -- Until we investigate this we are not releasing these. +-- +-- XXX The above text would apply to +-- Streamly.Internal.Data.Parser.ParserD.Type.parser -- | Make a terminating fold using a pure step function, a pure initial state -- and a pure state extraction function. @@ -528,7 +531,7 @@ -- > drain = drainBy (const (return ())) -- -- @since 0.7.0 -{-# INLINABLE drain #-} +{-# INLINE drain #-} drain :: Monad m => Fold m a () drain = foldl' (\_ _ -> ()) () @@ -541,7 +544,7 @@ -- > toList = foldr (:) [] -- -- @since 0.7.0 -{-# INLINABLE toList #-} +{-# INLINE toList #-} toList :: Monad m => Fold m a [a] toList = foldr (:) [] @@ -556,7 +559,7 @@ -- /Pre-release/ -- xn : ... : x2 : x1 : [] -{-# INLINABLE toStreamKRev #-} +{-# INLINE toStreamKRev #-} toStreamKRev :: Monad m => Fold m a (K.Stream n a) toStreamKRev = foldl' (flip K.cons) K.nil @@ -987,7 +990,7 @@ -- > lmap = Fold.lmapM return -- -- @since 0.8.0 -{-# INLINABLE lmap #-} +{-# INLINE lmap #-} lmap :: (a -> b) -> Fold m b r -> Fold m a r lmap f (Fold step begin done) = Fold step' begin done where @@ -996,7 +999,7 @@ -- | @lmapM f fold@ maps the monadic function @f@ on the input of the fold. -- -- @since 0.8.0 -{-# INLINABLE lmapM #-} +{-# INLINE lmapM #-} lmapM :: Monad m => (a -> m b) -> Fold m b r -> Fold m a r lmapM f (Fold step begin done) = Fold step' begin done where @@ -1014,7 +1017,7 @@ -- > filter f = Fold.filterM (return . f) -- -- @since 0.8.0 -{-# INLINABLE filter #-} +{-# INLINE filter #-} filter :: Monad m => (a -> Bool) -> Fold m a r -> Fold m a r filter f (Fold step begin done) = Fold step' begin done where @@ -1023,7 +1026,7 @@ -- | Like 'filter' but with a monadic predicate. -- -- @since 0.8.0 -{-# INLINABLE filterM #-} +{-# INLINE filterM #-} filterM :: Monad m => (a -> m Bool) -> Fold m a r -> Fold m a r filterM f (Fold step begin done) = Fold step' begin done where @@ -1105,7 +1108,7 @@ -- fold. Compare with 'snoc' which appends a singleton value to the fold. -- -- /Pre-release/ -{-# INLINABLE duplicate #-} +{-# INLINE duplicate #-} duplicate :: Monad m => Fold m a b -> Fold m a (Fold m a b) duplicate (Fold step1 initial1 extract1) = Fold step initial (\s -> pure $ Fold step1 (pure $ Partial s) extract1) @@ -1209,7 +1212,6 @@ Partial ss -> return $ Partial $ f ss cs Done sb -> cstep cs sb >>= collect - {-# INLINE collect #-} collect cres = case cres of Partial cs -> sinitial >>= split ManyFirst cs @@ -1269,7 +1271,6 @@ Partial ss1 -> return $ Partial $ Tuple' ss1 cs Done sb -> cstep cs sb >>= collect - {-# INLINE collect #-} collect cres = case cres of Partial cs -> sinitial >>= split cs @@ -1333,7 +1334,6 @@ Partial ss -> return $ Partial $ Tuple' cs (f ss) Done sb -> cstep cs sb >>= collect - {-# INLINE collect #-} collect cres = case cres of Partial cs -> sinitial >>= split cs Left @@ -1385,7 +1385,6 @@ Partial ss -> return $ Partial $ ConsumeMany x cs (f ss) Done sb -> cstep cs sb >>= collect x - {-# INLINE collect #-} collect x cres = case cres of Partial cs -> sinject x >>= split x cs Left diff --git a/src/Streamly/Internal/Data/IOFinalizer.hs b/src/Streamly/Internal/Data/IOFinalizer.hs --- a/src/Streamly/Internal/Data/IOFinalizer.hs +++ b/src/Streamly/Internal/Data/IOFinalizer.hs @@ -21,9 +21,8 @@ import Control.Exception (mask_) import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.Control (MonadBaseControl, control) import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef, IORef) -import Streamly.Internal.Control.Concurrent (captureMonadState, runInIO) +import Streamly.Internal.Control.Concurrent (MonadRunInIO, askRunInIO, runInIO, withRunInIO) -- | An 'IOFinalizer' has an associated IO action that is automatically called -- whenever the finalizer is garbage collected. The action can be run and @@ -38,9 +37,9 @@ newtype IOFinalizer = IOFinalizer (IORef (Maybe (IO ()))) -- | Make a finalizer from a monadic action @m a@ that can run in IO monad. -mkIOFinalizer :: MonadBaseControl IO m => m b -> m (IO ()) +mkIOFinalizer :: MonadRunInIO m => m b -> m (IO ()) mkIOFinalizer f = do - mrun <- captureMonadState + mrun <- askRunInIO return $ void $ do _ <- runInIO mrun f @@ -66,7 +65,7 @@ -- of the monad but we want to keep both the cases consistent. -- -- /Pre-release/ -newIOFinalizer :: (MonadIO m, MonadBaseControl IO m) => m a -> m IOFinalizer +newIOFinalizer :: MonadRunInIO m => m a -> m IOFinalizer newIOFinalizer finalizer = do f <- mkIOFinalizer finalizer ref <- liftIO $ newIORef $ Just f @@ -95,9 +94,9 @@ -- action is run with async exceptions masked. -- -- /Pre-release/ -clearingIOFinalizer :: MonadBaseControl IO m => IOFinalizer -> m a -> m a +clearingIOFinalizer :: MonadRunInIO m => IOFinalizer -> m a -> m a clearingIOFinalizer (IOFinalizer ref) action = do - control $ \runinio -> + withRunInIO $ \runinio -> mask_ $ do writeIORef ref Nothing runinio action diff --git a/src/Streamly/Internal/Data/Maybe/Strict.hs b/src/Streamly/Internal/Data/Maybe/Strict.hs --- a/src/Streamly/Internal/Data/Maybe/Strict.hs +++ b/src/Streamly/Internal/Data/Maybe/Strict.hs @@ -29,20 +29,20 @@ data Maybe' a = Just' !a | Nothing' deriving Show -- | Convert strict Maybe' to lazy Maybe -{-# INLINABLE toMaybe #-} +{-# INLINE toMaybe #-} toMaybe :: Maybe' a -> Maybe a toMaybe Nothing' = Nothing toMaybe (Just' a) = Just a -- | Extract the element out of a Just' and throws an error if its argument is -- Nothing'. -{-# INLINABLE fromJust' #-} +{-# INLINE fromJust' #-} fromJust' :: Maybe' a -> a fromJust' (Just' a) = a fromJust' Nothing' = error "fromJust' cannot be run in Nothing'" -- | Returns True iff its argument is of the form "Just' _". -{-# INLINABLE isJust' #-} +{-# INLINE isJust' #-} isJust' :: Maybe' a -> Bool isJust' (Just' _) = True isJust' Nothing' = False diff --git a/src/Streamly/Internal/Data/Parser.hs b/src/Streamly/Internal/Data/Parser.hs --- a/src/Streamly/Internal/Data/Parser.hs +++ b/src/Streamly/Internal/Data/Parser.hs @@ -534,7 +534,7 @@ -- -- /Pre-release/ -- -{-# INLINABLE sliceSepByP #-} +{-# INLINE sliceSepByP #-} sliceSepByP :: MonadCatch m => (a -> Bool) -> Parser m a b -> Parser m a b @@ -544,7 +544,7 @@ -- separator is emitted as a separate element in the output. -- -- /Unimplemented/ -{-# INLINABLE sliceSepWith #-} +{-# INLINE sliceSepWith #-} sliceSepWith :: -- MonadCatch m => (a -> Bool) -> Fold m a b -> Parser m a b sliceSepWith _cond = undefined -- K.toParserK . D.sliceSepBy cond @@ -583,7 +583,7 @@ -- -- /Pre-release/ -- -{-# INLINABLE sliceBeginWith #-} +{-# INLINE sliceBeginWith #-} sliceBeginWith :: MonadCatch m => (a -> Bool) -> Fold m a b -> Parser m a b @@ -593,7 +593,7 @@ -- escape char determined by the second predicate. -- -- /Unimplemented/ -{-# INLINABLE escapedSliceSepBy #-} +{-# INLINE escapedSliceSepBy #-} escapedSliceSepBy :: -- MonadCatch m => (a -> Bool) -> (a -> Bool) -> Fold m a b -> Parser m a b escapedSliceSepBy _cond _esc = undefined @@ -622,7 +622,7 @@ -- @ -- -- /Unimplemented/ -{-# INLINABLE escapedFrameBy #-} +{-# INLINE escapedFrameBy #-} escapedFrameBy :: -- MonadCatch m => (a -> Bool) -> (a -> Bool) -> (a -> Bool) -> Fold m a b -> Parser m a b escapedFrameBy _begin _end _escape _p = undefined @@ -672,7 +672,7 @@ -- -- /Pre-release/ -- -{-# INLINABLE groupBy #-} +{-# INLINE groupBy #-} groupBy :: MonadCatch m => (a -> a -> Bool) -> Fold m a b -> Parser m a b groupBy eq = K.toParserK . D.groupBy eq @@ -706,7 +706,7 @@ -- -- /Pre-release/ -- -{-# INLINABLE groupByRolling #-} +{-# INLINE groupByRolling #-} groupByRolling :: MonadCatch m => (a -> a -> Bool) -> Fold m a b -> Parser m a b groupByRolling eq = K.toParserK . D.groupByRolling eq @@ -720,7 +720,7 @@ -- Fold.toList Fold.toList'. -- -- /Unimplemented/ -{-# INLINABLE groupByRollingEither #-} +{-# INLINE groupByRollingEither #-} groupByRollingEither :: MonadCatch m => (a -> a -> Bool) -> Fold m a b -> Fold m a c -> Parser m a (Either b c) groupByRollingEither eq f1 = K.toParserK . D.groupByRollingEither eq f1 diff --git a/src/Streamly/Internal/Data/Parser/ParserD.hs b/src/Streamly/Internal/Data/Parser/ParserD.hs --- a/src/Streamly/Internal/Data/Parser/ParserD.hs +++ b/src/Streamly/Internal/Data/Parser/ParserD.hs @@ -268,7 +268,7 @@ -- -- /Pre-release/ -- -{-# INLINABLE peek #-} +{-# INLINE peek #-} peek :: MonadThrow m => Parser m a a peek = Parser step initial extract @@ -284,7 +284,7 @@ -- -- /Pre-release/ -- -{-# INLINABLE eof #-} +{-# INLINE eof #-} eof :: Monad m => Parser m a () eof = Parser step initial return @@ -331,14 +331,14 @@ -- {-# INLINE maybe #-} maybe :: MonadThrow m => (a -> Maybe b) -> Parser m a b -maybe parser = Parser step initial extract +maybe parserF = Parser step initial extract where initial = return $ IPartial () step () a = return $ - case parser a of + case parserF a of Just b -> Done 0 b Nothing -> Error "maybe: predicate failed" @@ -350,14 +350,14 @@ -- {-# INLINE either #-} either :: MonadThrow m => (a -> Either String b) -> Parser m a b -either parser = Parser step initial extract +either parserF = Parser step initial extract where initial = return $ IPartial () step () a = return $ - case parser a of + case parserF a of Right b -> Done 0 b Left err -> Error $ "either: " ++ err @@ -805,7 +805,7 @@ | GroupByGroupingPairL !a !s1 !s2 | GroupByGroupingPairR !a !s1 !s2 -{-# INLINABLE groupByRollingEither #-} +{-# INLINE groupByRollingEither #-} groupByRollingEither :: MonadCatch m => (a -> a -> Bool) -> Fold m a b -> Fold m a c -> Parser m a (Either b c) groupByRollingEither @@ -1176,7 +1176,6 @@ -- Caution: Mutual recursion - -- Don't inline this scrutL fs p c d e = do resL <- initialL case resL of @@ -1188,7 +1187,6 @@ FL.Done fb -> return $ d fb IError err -> return $ e err - {-# INLINE scrutR #-} scrutR fs p c d e = do resR <- initialR case resR of diff --git a/src/Streamly/Internal/Data/Parser/ParserD/Type.hs b/src/Streamly/Internal/Data/Parser/ParserD/Type.hs --- a/src/Streamly/Internal/Data/Parser/ParserD/Type.hs +++ b/src/Streamly/Internal/Data/Parser/ParserD/Type.hs @@ -112,12 +112,17 @@ module Streamly.Internal.Data.Parser.ParserD.Type ( + -- * Types Initial (..) , Step (..) , Parser (..) , ParseError (..) , rmapM + -- * Constructors + , parser + , parserM + , fromPure , fromEffect , serialWith @@ -160,6 +165,7 @@ -- >>> import qualified Streamly.Prelude as Stream -- >>> import qualified Streamly.Internal.Data.Stream.IsStream as Stream (parse) -- >>> import qualified Streamly.Internal.Data.Parser as Parser +-- >>> import qualified Streamly.Internal.Data.Parser.ParserD as ParserD -- XXX The only differences between Initial and Step types are: -- @@ -349,6 +355,30 @@ fmap2 g = fmap (fmap g) ------------------------------------------------------------------------------ +-- General parser constructors +------------------------------------------------------------------------------ + +-- | Make a parser using a parsing step and a starting value. +-- +-- /Pre-release/ +-- +{-# INLINE parser #-} +parser :: Monad m => (b -> a -> Step b b) -> Initial b b -> Parser m a b +parser step initial = + Parser (\s a -> return $ step s a) (return initial) return + +-- | Like 'parser' but with a monadic step function. +-- +-- >>> parserM step initial = ParserD.Parser step initial return +-- +-- /Pre-release/ +-- +{-# INLINE parserM #-} +parserM :: + Monad m => (b -> a -> m (Step b b)) -> m (Initial b b) -> Parser m a b +parserM step initial = Parser step initial return + +------------------------------------------------------------------------------ -- Mapping on the output ------------------------------------------------------------------------------ @@ -426,28 +456,33 @@ -- Note: For the composed parse to terminate, the left parser has to be -- a terminating parser returning a Done at some point. - step (SeqParseL st) a = - (\resL initR -> + step (SeqParseL st) a = do + -- Important: Please do not use Applicative here. See + -- https://github.com/composewell/streamly/issues/1033 and the problem + -- defined in split_ for more info. + resL <- stepL st a case resL of -- Note: We need to buffer the input for a possible Alternative -- e.g. in ((,) <$> p1 <*> p2) <|> p3, if p2 fails we have to -- backtrack and start running p3. So we need to keep the input -- buffered until we know that the applicative cannot fail. - Partial n s -> Continue n (SeqParseL s) - Continue n s -> Continue n (SeqParseL s) - Done n b -> - case initR of + Partial n s -> return $ Continue n (SeqParseL s) + Continue n s -> return $ Continue n (SeqParseL s) + Done n b -> do + initR <- initialR + return $ case initR of IPartial sr -> Continue n $ SeqParseR (func b) sr IDone br -> Done n (func b br) IError err -> Error err - Error err -> Error err) <$> stepL st a <*> initialR + Error err -> return $ Error err - step (SeqParseR f st) a = - (\case + step (SeqParseR f st) a = do + resR <- stepR st a + return $ case resR of Partial n s -> Partial n (SeqParseR f s) Continue n s -> Continue n (SeqParseR f s) Done n b -> Done n (f b) - Error err -> Error err) <$> stepR st a + Error err -> Error err extract (SeqParseR f sR) = fmap f (extractR sR) extract (SeqParseL sL) = do @@ -732,7 +767,6 @@ -- Caution! There is mutual recursion here, inlining the right functions is -- important. - {-# INLINE handleCollect #-} handleCollect partial done fres = case fres of FL.Partial fs -> do @@ -744,7 +778,6 @@ IError _ -> done <$> fextract fs FL.Done fb -> return $ done fb - -- Do not inline this runCollectorWith cont fs pb = fstep fs pb >>= cont initial = finitial >>= handleCollect IPartial IDone @@ -794,7 +827,6 @@ -- Caution! There is mutual recursion here, inlining the right functions is -- important. - {-# INLINE handleCollect #-} handleCollect partial done fres = case fres of FL.Partial fs -> do @@ -806,7 +838,6 @@ IError _ -> done <$> fextract fs FL.Done fb -> return $ done fb - -- Do not inline this runCollectorWith cont fs pb = fstep fs pb >>= cont initial = finitial >>= handleCollect IPartial IDone @@ -854,7 +885,6 @@ -- Caution! There is mutual recursion here, inlining the right functions is -- important. - {-# INLINE handleCollect #-} handleCollect partial done fres = case fres of FL.Partial fs -> do @@ -866,7 +896,6 @@ IError _ -> done <$> fextract fs FL.Done fb -> return $ done fb - -- Do not inline this runCollectorWith cont fs pb = fstep fs pb >>= cont initial = do @@ -1147,4 +1176,3 @@ instance (MonadThrow m, MonadIO m) => MonadIO (Parser m a) where {-# INLINE liftIO #-} liftIO = fromEffect . liftIO - diff --git a/src/Streamly/Internal/Data/Pipe.hs b/src/Streamly/Internal/Data/Pipe.hs --- a/src/Streamly/Internal/Data/Pipe.hs +++ b/src/Streamly/Internal/Data/Pipe.hs @@ -247,7 +247,7 @@ import Streamly.Internal.Data.Pipe.Type (Pipe(..), PipeState(..), Step(..), zipWith, tee, map, compose) -- import Streamly.Internal.Data.Array.Foreign.Type (Array) --- import Streamly.Internal.Ring.Foreign (Ring) +-- import Streamly.Internal.Data.Ring.Foreign (Ring) -- import Streamly.Internal.Data.Stream.Serial (SerialT) -- import Streamly.Internal.Data.Stream.StreamK (IsStream()) -- import Streamly.Internal.Data.Time.Units diff --git a/src/Streamly/Internal/Data/Producer/Source.hs b/src/Streamly/Internal/Data/Producer/Source.hs --- a/src/Streamly/Internal/Data/Producer/Source.hs +++ b/src/Streamly/Internal/Data/Producer/Source.hs @@ -135,7 +135,6 @@ -- XXX currently we are using a dumb list based approach for backtracking -- buffer. This can be replaced by a sliding/ring buffer using Data.Array. -- That will allow us more efficient random back and forth movement. - {-# INLINE go #-} go !_ st buf !pst = do r <- ustep st case r of diff --git a/src/Streamly/Internal/Data/Ring/Foreign.hs b/src/Streamly/Internal/Data/Ring/Foreign.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Ring/Foreign.hs @@ -0,0 +1,558 @@ +-- | +-- Module : Streamly.Internal.Data.Ring.Foreign +-- Copyright : (c) 2019 Composewell Technologies +-- License : BSD3 +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- A ring array is a circular mutable array. + +-- XXX Write benchmarks +-- XXX Make the implementation similar to mutable array +-- XXX Rename this module to Data.RingArray.Storable + +module Streamly.Internal.Data.Ring.Foreign + ( Ring(..) + + -- * Construction + , new + , newRing + , writeN + + , advance + , moveBy + , startOf + + -- * Random writes + , unsafeInsert + , slide + , putIndex + , modifyIndex + + -- * Unfolds + , read + , readRev + + -- * Random reads + , getIndex + , getIndexUnsafe + , getIndexRev + + -- * Size + , length + , byteLength + -- , capacity + , byteCapacity + , bytesFree + + -- * Casting + , cast + , castUnsafe + , asBytes + , fromArray + + -- * Folds + , unsafeFoldRing + , unsafeFoldRingM + , unsafeFoldRingFullM + , unsafeFoldRingNM + + -- * Stream of Arrays + , ringsOf + + -- * Fast Byte Comparisons + , unsafeEqArray + , unsafeEqArrayN + + , slidingWindow + ) where + +#include "ArrayMacros.h" +#include "inline.hs" + +import Control.Exception (assert) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.Word (Word8) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, touchForeignPtr) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import Foreign.Ptr (plusPtr, minusPtr, castPtr) +import Foreign.Storable (Storable(..)) +import GHC.ForeignPtr (mallocPlainForeignPtrAlignedBytes) +import GHC.Ptr (Ptr(..)) +import Streamly.Internal.Data.Array.Foreign.Mut.Type (Array, memcmp) +import Streamly.Internal.Data.Fold.Type (Fold(..), Step(..)) +import Streamly.Internal.Data.Stream.Serial (SerialT(..)) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) +import Streamly.Internal.System.IO (unsafeInlineIO) + +import qualified Streamly.Internal.Data.Array.Foreign.Type as A + +import Prelude hiding (length, concat, read) + +-- $setup +-- >>> :m +-- >>> import qualified Streamly.Internal.Data.Ring.Foreign as Ring + +-- | A ring buffer is a mutable array of fixed size. Initially the array is +-- empty, with ringStart pointing at the start of allocated memory. We call the +-- next location to be written in the ring as ringHead. Initially ringHead == +-- ringStart. When the first item is added, ringHead points to ringStart + +-- sizeof item. When the buffer becomes full ringHead would wrap around to +-- ringStart. When the buffer is full, ringHead always points at the oldest +-- item in the ring and the newest item added always overwrites the oldest +-- item. +-- +-- When using it we should keep in mind that a ringBuffer is a mutable data +-- structure. We should not leak out references to it for immutable use. +-- +data Ring a = Ring + { ringStart :: {-# UNPACK #-} !(ForeignPtr a) -- first address + , ringBound :: {-# UNPACK #-} !(Ptr a) -- first address beyond allocated memory + } + +------------------------------------------------------------------------------- +-- Construction +------------------------------------------------------------------------------- + +-- | Get the first address of the ring as a pointer. +startOf :: Ring a -> Ptr a +startOf = unsafeForeignPtrToPtr . ringStart + +-- | Create a new ringbuffer and return the ring buffer and the ringHead. +-- Returns the ring and the ringHead, the ringHead is same as ringStart. +{-# INLINE new #-} +new :: forall a. Storable a => Int -> IO (Ring a, Ptr a) +new count = do + let size = count * SIZE_OF(a) + fptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: a)) + let p = unsafeForeignPtrToPtr fptr + return (Ring + { ringStart = fptr + , ringBound = p `plusPtr` size + }, p) + +-- XXX Rename this to "new". +-- +-- | @newRing count@ allocates an empty array that can hold 'count' items. The +-- memory of the array is uninitialized and the allocation is aligned as per +-- the 'Storable' instance of the type. +-- +-- /Unimplemented/ +{-# INLINE newRing #-} +newRing :: Int -> m (Ring a) +newRing = undefined + +-- | Advance the ringHead by 1 item, wrap around if we hit the end of the +-- array. +{-# INLINE advance #-} +advance :: forall a. Storable a => Ring a -> Ptr a -> Ptr a +advance Ring{..} ringHead = + let ptr = PTR_NEXT(ringHead,a) + in if ptr < ringBound + then ptr + else unsafeForeignPtrToPtr ringStart + +-- | Move the ringHead by n items. The direction depends on the sign on whether +-- n is positive or negative. Wrap around if we hit the beginning or end of the +-- array. +{-# INLINE moveBy #-} +moveBy :: forall a. Storable a => Int -> Ring a -> Ptr a -> Ptr a +moveBy by Ring {..} ringHead = ringStartPtr `plusPtr` advanceFromHead + + where + + elemSize = SIZE_OF(a) + ringStartPtr = unsafeForeignPtrToPtr ringStart + lenInBytes = ringBound `minusPtr` ringStartPtr + offInBytes = ringHead `minusPtr` ringStartPtr + len = assert (lenInBytes `mod` elemSize == 0) $ lenInBytes `div` elemSize + off = assert (offInBytes `mod` elemSize == 0) $ offInBytes `div` elemSize + advanceFromHead = (off + by `mod` len) * elemSize + +-- XXX Move the writeLastN from array module here. +-- +-- | @writeN n@ is a rolling fold that keeps the last n elements of the stream +-- in a ring array. +-- +-- /Unimplemented/ +{-# INLINE writeN #-} +writeN :: -- (Storable a, MonadIO m) => + Int -> Fold m a (Ring a) +writeN = undefined + +------------------------------------------------------------------------------- +-- Conversions +------------------------------------------------------------------------------- + +-- | Cast a mutable array to a ring array. +fromArray :: Array a -> Ring a +fromArray = undefined + +------------------------------------------------------------------------------- +-- Conversion to/from array +------------------------------------------------------------------------------- + +-- | Modify a given index of a ring array using a modifier function. +-- +-- /Unimplemented/ +modifyIndex :: -- forall m a b. (MonadIO m, Storable a) => + Ring a -> Int -> (a -> (a, b)) -> m b +modifyIndex = undefined + +-- | /O(1)/ Write the given element at the given index in the ring array. +-- Performs in-place mutation of the array. +-- +-- >>> putIndex arr ix val = Ring.modifyIndex arr ix (const (val, ())) +-- +-- /Unimplemented/ +{-# INLINE putIndex #-} +putIndex :: -- (MonadIO m, Storable a) => + Ring a -> Int -> a -> m () +putIndex = undefined + +-- | Insert an item at the head of the ring, when the ring is full this +-- replaces the oldest item in the ring with the new item. This is unsafe +-- beause ringHead supplied is not verified to be within the Ring. Also, +-- the ringStart foreignPtr must be guaranteed to be alive by the caller. +{-# INLINE unsafeInsert #-} +unsafeInsert :: Storable a => Ring a -> Ptr a -> a -> IO (Ptr a) +unsafeInsert rb ringHead newVal = do + poke ringHead newVal + -- touchForeignPtr (ringStart rb) + return $ advance rb ringHead + +-- | Insert an item at the head of the ring, when the ring is full this +-- replaces the oldest item in the ring with the new item. +-- +-- /Unimplemented/ +slide :: -- forall m a. (MonadIO m, Storable a) => + Ring a -> a -> m (Ring a) +slide = undefined + +------------------------------------------------------------------------------- +-- Random reads +------------------------------------------------------------------------------- + +-- | Return the element at the specified index without checking the bounds. +-- +-- Unsafe because it does not check the bounds of the ring array. +{-# INLINE_NORMAL getIndexUnsafe #-} +getIndexUnsafe :: -- forall m a. (MonadIO m, Storable a) => + Ring a -> Int -> m a +getIndexUnsafe = undefined + +-- | /O(1)/ Lookup the element at the given index. Index starts from 0. +-- +{-# INLINE getIndex #-} +getIndex :: -- (MonadIO m, Storable a) => + Ring a -> Int -> m a +getIndex = undefined + +-- | /O(1)/ Lookup the element at the given index from the end of the array. +-- Index starts from 0. +-- +-- Slightly faster than computing the forward index and using getIndex. +-- +{-# INLINE getIndexRev #-} +getIndexRev :: -- (MonadIO m, Storable a) => + Ring a -> Int -> m a +getIndexRev = undefined + +------------------------------------------------------------------------------- +-- Size +------------------------------------------------------------------------------- + +-- | /O(1)/ Get the byte length of the array. +-- +-- /Unimplemented/ +{-# INLINE byteLength #-} +byteLength :: Ring a -> Int +byteLength = undefined + +-- | /O(1)/ Get the length of the array i.e. the number of elements in the +-- array. +-- +-- Note that 'byteLength' is less expensive than this operation, as 'length' +-- involves a costly division operation. +-- +-- /Unimplemented/ +{-# INLINE length #-} +length :: -- forall a. Storable a => + Ring a -> Int +length = undefined + +-- | Get the total capacity of an array. An array may have space reserved +-- beyond the current used length of the array. +-- +-- /Pre-release/ +{-# INLINE byteCapacity #-} +byteCapacity :: Ring a -> Int +byteCapacity = undefined + +-- | The remaining capacity in the array for appending more elements without +-- reallocation. +-- +-- /Pre-release/ +{-# INLINE bytesFree #-} +bytesFree :: Ring a -> Int +bytesFree = undefined + +------------------------------------------------------------------------------- +-- Unfolds +------------------------------------------------------------------------------- + +-- | Unfold a ring array into a stream. +-- +-- /Unimplemented/ +{-# INLINE_NORMAL read #-} +read :: -- forall m a. (MonadIO m, Storable a) => + Unfold m (Ring a) a +read = undefined + +-- | Unfold a ring array into a stream in reverse order. +-- +-- /Unimplemented/ +{-# INLINE_NORMAL readRev #-} +readRev :: -- forall m a. (MonadIO m, Storable a) => + Unfold m (Array a) a +readRev = undefined + +------------------------------------------------------------------------------- +-- Stream of arrays +------------------------------------------------------------------------------- + +-- XXX Move this module to a lower level Ring/Type module and move ringsOf to a +-- higher level ring module where we can import "scan". + +-- | @ringsOf n stream@ groups the input stream into a stream of +-- ring arrays of size n. Each ring is a sliding window of size n. +-- +-- /Unimplemented/ +{-# INLINE_NORMAL ringsOf #-} +ringsOf :: -- forall m a. (MonadIO m, Storable a) => + Int -> SerialT m a -> SerialT m (Array a) +ringsOf = undefined -- Stream.scan (writeN n) + +------------------------------------------------------------------------------- +-- Casting +------------------------------------------------------------------------------- + +-- | Cast an array having elements of type @a@ into an array having elements of +-- type @b@. The array size must be a multiple of the size of type @b@. +-- +-- /Unimplemented/ +-- +castUnsafe :: Ring a -> Ring b +castUnsafe = undefined + +-- | Cast an @Array a@ into an @Array Word8@. +-- +-- /Unimplemented/ +-- +asBytes :: Ring a -> Ring Word8 +asBytes = castUnsafe + +-- | Cast an array having elements of type @a@ into an array having elements of +-- type @b@. The length of the array should be a multiple of the size of the +-- target element otherwise 'Nothing' is returned. +-- +-- /Pre-release/ +-- +cast :: forall a b. Storable b => Ring a -> Maybe (Ring b) +cast arr = + let len = byteLength arr + r = len `mod` SIZE_OF(b) + in if r /= 0 + then Nothing + else Just $ castUnsafe arr + +------------------------------------------------------------------------------- +-- Equality +------------------------------------------------------------------------------- + +-- XXX remove all usage of unsafeInlineIO +-- +-- | Like 'unsafeEqArray' but compares only N bytes instead of entire length of +-- the ring buffer. This is unsafe because the ringHead Ptr is not checked to +-- be in range. +{-# INLINE unsafeEqArrayN #-} +unsafeEqArrayN :: Ring a -> Ptr a -> A.Array a -> Int -> Bool +unsafeEqArrayN Ring{..} rh A.Array{..} n = + let !res = unsafeInlineIO $ do + let rs = unsafeForeignPtrToPtr ringStart + as = arrStart + assert (aEnd `minusPtr` as >= ringBound `minusPtr` rs) (return ()) + let len = ringBound `minusPtr` rh + r1 <- memcmp (castPtr rh) (castPtr as) (min len n) + r2 <- if n > len + then memcmp (castPtr rs) (castPtr (as `plusPtr` len)) + (min (rh `minusPtr` rs) (n - len)) + else return True + -- XXX enable these, check perf impact + -- touchForeignPtr ringStart + -- touchForeignPtr aStart + return (r1 && r2) + in res + +-- | Byte compare the entire length of ringBuffer with the given array, +-- starting at the supplied ringHead pointer. Returns true if the Array and +-- the ringBuffer have identical contents. +-- +-- This is unsafe because the ringHead Ptr is not checked to be in range. The +-- supplied array must be equal to or bigger than the ringBuffer, ARRAY BOUNDS +-- ARE NOT CHECKED. +{-# INLINE unsafeEqArray #-} +unsafeEqArray :: Ring a -> Ptr a -> A.Array a -> Bool +unsafeEqArray Ring{..} rh A.Array{..} = + let !res = unsafeInlineIO $ do + let rs = unsafeForeignPtrToPtr ringStart + let as = arrStart + assert (aEnd `minusPtr` as >= ringBound `minusPtr` rs) + (return ()) + let len = ringBound `minusPtr` rh + r1 <- memcmp (castPtr rh) (castPtr as) len + r2 <- memcmp (castPtr rs) (castPtr (as `plusPtr` len)) + (rh `minusPtr` rs) + -- XXX enable these, check perf impact + -- touchForeignPtr ringStart + -- touchForeignPtr aStart + return (r1 && r2) + in res + +------------------------------------------------------------------------------- +-- Folding +------------------------------------------------------------------------------- + +-- XXX We can unfold it into a stream and fold the stream instead. +-- XXX use MonadIO +-- +-- | Fold the buffer starting from ringStart up to the given 'Ptr' using a pure +-- step function. This is useful to fold the items in the ring when the ring is +-- not full. The supplied pointer is usually the end of the ring. +-- +-- Unsafe because the supplied Ptr is not checked to be in range. +{-# INLINE unsafeFoldRing #-} +unsafeFoldRing :: forall a b. Storable a + => Ptr a -> (b -> a -> b) -> b -> Ring a -> b +unsafeFoldRing ptr f z Ring{..} = + let !res = unsafeInlineIO $ withForeignPtr ringStart $ \p -> + go z p ptr + in res + where + go !acc !p !q + | p == q = return acc + | otherwise = do + x <- peek p + go (f acc x) (PTR_NEXT(p,a)) q + +-- XXX Can we remove MonadIO here? +withForeignPtrM :: MonadIO m => ForeignPtr a -> (Ptr a -> m b) -> m b +withForeignPtrM fp fn = do + r <- fn $ unsafeForeignPtrToPtr fp + liftIO $ touchForeignPtr fp + return r + +-- | Like unsafeFoldRing but with a monadic step function. +{-# INLINE unsafeFoldRingM #-} +unsafeFoldRingM :: forall m a b. (MonadIO m, Storable a) + => Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b +unsafeFoldRingM ptr f z Ring {..} = + withForeignPtrM ringStart $ \x -> go z x ptr + where + go !acc !start !end + | start == end = return acc + | otherwise = do + let !x = unsafeInlineIO $ peek start + acc1 <- f acc x + go acc1 (PTR_NEXT(start,a)) end + +-- | Fold the entire length of a ring buffer starting at the supplied ringHead +-- pointer. Assuming the supplied ringHead pointer points to the oldest item, +-- this would fold the ring starting from the oldest item to the newest item in +-- the ring. +-- +-- Note, this will crash on ring of 0 size. +-- +{-# INLINE unsafeFoldRingFullM #-} +unsafeFoldRingFullM :: forall m a b. (MonadIO m, Storable a) + => Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b +unsafeFoldRingFullM rh f z rb@Ring {..} = + withForeignPtrM ringStart $ \_ -> go z rh + where + go !acc !start = do + let !x = unsafeInlineIO $ peek start + acc' <- f acc x + let ptr = advance rb start + if ptr == rh + then return acc' + else go acc' ptr + +-- | Fold @Int@ items in the ring starting at @Ptr a@. Won't fold more +-- than the length of the ring. +-- +-- Note, this will crash on ring of 0 size. +-- +{-# INLINE unsafeFoldRingNM #-} +unsafeFoldRingNM :: forall m a b. (MonadIO m, Storable a) + => Int -> Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b +unsafeFoldRingNM count rh f z rb@Ring {..} = + withForeignPtrM ringStart $ \_ -> go count z rh + + where + + go 0 acc _ = return acc + go !n !acc !start = do + let !x = unsafeInlineIO $ peek start + acc' <- f acc x + let ptr = advance rb start + if ptr == rh || n == 0 + then return acc' + else go (n - 1) acc' ptr + +data Tuple4' a b c d = Tuple4' !a !b !c !d deriving Show + +-- | @slidingWindow collector@ is an incremental sliding window +-- fold that does not require all the intermediate elements in a computation. +-- This maintains n elements in the window, when a new element comes it slides +-- out the oldest element and the new element along with the old element are +-- supplied to the collector fold. +-- +-- The Maybe is for the case when initially the window is filling and +-- there is no old element. +-- +{-# INLINE slidingWindow #-} +slidingWindow :: forall m a b. (MonadIO m, Storable a) + => Int -> Fold m (a, Maybe a) b -> Fold m a b +slidingWindow n (Fold step1 initial1 extract1)= Fold step initial extract + + where + + initial = do + r <- initial1 + (rb, rh) <- liftIO $ new n + return $ + case r of + Partial s -> Partial $ Tuple4' rb rh (0 :: Int) s + Done b -> Done b + + step (Tuple4' rb rh i st) a + | i < n = do + rh1 <- liftIO $ unsafeInsert rb rh a + liftIO $ touchForeignPtr (ringStart rb) + r <- step1 st (a, Nothing) + return $ + case r of + Partial s -> Partial $ Tuple4' rb rh1 (i + 1) s + Done b -> Done b + | otherwise = do + old <- liftIO $ peek rh + rh1 <- liftIO $ unsafeInsert rb rh a + liftIO $ touchForeignPtr (ringStart rb) + r <- step1 st (a, Just old) + return $ + case r of + Partial s -> Partial $ Tuple4' rb rh1 (i + 1) s + Done b -> Done b + + extract (Tuple4' _ _ _ st) = extract1 st diff --git a/src/Streamly/Internal/Data/SVar.hs b/src/Streamly/Internal/Data/SVar.hs --- a/src/Streamly/Internal/Data/SVar.hs +++ b/src/Streamly/Internal/Data/SVar.hs @@ -48,7 +48,7 @@ import Data.IORef (newIORef, readIORef) import Data.IORef (IORef, atomicModifyIORef) import Streamly.Internal.Control.Concurrent - (MonadAsync, captureMonadState, RunInIO(..)) + (MonadAsync, askRunInIO, RunInIO) import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS, atomicModifyIORefCAS_, writeBarrier) import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) @@ -432,7 +432,7 @@ -> m ()) -> m (SVar t m a) newAheadVar st m wloop = do - mrun <- captureMonadState + mrun <- askRunInIO sv <- liftIO $ getAheadSVar st wloop mrun sendFirstWorker sv m @@ -533,5 +533,5 @@ newParallelVar :: MonadAsync m => SVarStopStyle -> State t m a -> m (SVar t m a) newParallelVar ss st = do - mrun <- captureMonadState + mrun <- askRunInIO liftIO $ getParallelSVar ss st mrun diff --git a/src/Streamly/Internal/Data/SVar/Dispatch.hs b/src/Streamly/Internal/Data/SVar/Dispatch.hs --- a/src/Streamly/Internal/Data/SVar/Dispatch.hs +++ b/src/Streamly/Internal/Data/SVar/Dispatch.hs @@ -49,8 +49,8 @@ #if __GLASGOW_HASKELL__ < 804 import Data.Semigroup ((<>)) #endif -import Streamly.Internal.Control.Concurrent - (MonadAsync, captureMonadState, doFork) +import Streamly.Internal.Control.Concurrent (MonadAsync, askRunInIO) +import Streamly.Internal.Control.ForkLifted (doFork) import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS, atomicModifyIORefCAS_, writeBarrier, storeLoadBarrier) @@ -707,7 +707,7 @@ -- Note: We must have all the work on the queue before sending the -- pushworker, otherwise the pushworker may exit before we even get a -- chance to push. - runIn <- captureMonadState + runIn <- askRunInIO liftIO $ enqueue sv (runIn, m) case yieldRateInfo sv of Nothing -> pushWorker 0 sv diff --git a/src/Streamly/Internal/Data/SVar/Type.hs b/src/Streamly/Internal/Data/SVar/Type.hs --- a/src/Streamly/Internal/Data/SVar/Type.hs +++ b/src/Streamly/Internal/Data/SVar/Type.hs @@ -62,7 +62,7 @@ import Data.Set (Set) import Streamly.Internal.Data.Time.Units (AbsTime, NanoSecond64(..)) -import Streamly.Internal.Control.Concurrent (RunInIO(..)) +import Streamly.Internal.Control.Concurrent (RunInIO) newtype Count = Count Int64 deriving ( Eq diff --git a/src/Streamly/Internal/Data/Stream/Ahead.hs b/src/Streamly/Internal/Data/Stream/Ahead.hs --- a/src/Streamly/Internal/Data/Stream/Ahead.hs +++ b/src/Streamly/Internal/Data/Stream/Ahead.hs @@ -39,7 +39,6 @@ import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Trans.Class (MonadTrans(lift)) -import Control.Monad.Trans.Control (MonadBaseControl (..)) import Data.Heap (Heap, Entry(..)) import Data.IORef (IORef, readIORef, atomicModifyIORef, writeIORef) import Data.Maybe (fromJust) @@ -51,7 +50,7 @@ import qualified Data.Heap as H import Streamly.Internal.Control.Concurrent - (MonadAsync, RunInIO(..), captureMonadState) + (MonadRunInIO, MonadAsync, RunInIO(..), askRunInIO, restoreM) import Streamly.Internal.Data.Stream.Serial (SerialT(..)) import Streamly.Internal.Data.Stream.StreamK.Type (Stream) @@ -229,7 +228,7 @@ -- In both cases we give the drainer a chance to run more often. -- processHeap - :: (MonadIO m, MonadBaseControl IO m) + :: MonadRunInIO m => IORef ([Stream m a], Int) -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)), Maybe Int) -> State Stream m a @@ -326,7 +325,7 @@ stop r else do - runIn <- captureMonadState + runIn <- askRunInIO let ent = Entry seqNo (AheadEntryStream (runIn, r)) liftIO $ do requeueOnHeapTop heap ent seqNo @@ -339,7 +338,7 @@ {-# NOINLINE drainHeap #-} drainHeap - :: (MonadIO m, MonadBaseControl IO m) + :: MonadRunInIO m => IORef ([Stream m a], Int) -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)), Maybe Int) -> State Stream m a @@ -357,7 +356,7 @@ data WorkerStatus = Continue | Suspend processWithoutToken - :: (MonadIO m, MonadBaseControl IO m) + :: MonadRunInIO m => IORef ([Stream m a], Int) -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)), Maybe Int) -> State Stream m a @@ -381,7 +380,7 @@ r <- liftIO $ mrun $ K.foldStreamShared st (\a r -> do - runIn <- captureMonadState + runIn <- askRunInIO toHeap $ AheadEntryStream (runIn, K.cons a r)) (toHeap . AheadEntryPure) stop @@ -432,7 +431,7 @@ data TokenWorkerStatus = TokenContinue Int | TokenSuspend processWithToken - :: (MonadIO m, MonadBaseControl IO m) + :: MonadRunInIO m => IORef ([Stream m a], Int) -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)), Maybe Int) -> State Stream m a @@ -484,7 +483,7 @@ stop r else do - runIn <- captureMonadState + runIn <- askRunInIO let ent = Entry seqNo (AheadEntryStream (runIn, r)) liftIO $ requeueOnHeapTop heap ent seqNo liftIO $ incrementYieldLimit sv @@ -546,7 +545,7 @@ -- XXX we can remove the sv parameter as it can be derived from st workLoopAhead - :: (MonadIO m, MonadBaseControl IO m) + :: MonadRunInIO m => IORef ([Stream m a], Int) -> IORef (Heap (Entry Int (AheadHeapEntry Stream m a)), Maybe Int) -> State Stream m a @@ -610,7 +609,7 @@ K.foldStream st yld sng stp $ getSerialT (fromSVar sv) where concurrently ma mb = K.mkStream $ \st yld sng stp -> do - runInIO <- captureMonadState + runInIO <- askRunInIO liftIO $ enqueue (fromJust $ streamVar st) (runInIO, mb) K.foldStream st yld sng stp ma @@ -619,7 +618,7 @@ aheadK m1 m2 = K.mkStream $ \st yld sng stp -> case streamVar st of Just sv | svarStyle sv == AheadVar -> do - runInIO <- captureMonadState + runInIO <- askRunInIO liftIO $ enqueue sv (runInIO, m2) -- Always run the left side on a new SVar to avoid complexity in -- sequencing results. This means the left side cannot further diff --git a/src/Streamly/Internal/Data/Stream/Async.hs b/src/Streamly/Internal/Data/Stream/Async.hs --- a/src/Streamly/Internal/Data/Stream/Async.hs +++ b/src/Streamly/Internal/Data/Stream/Async.hs @@ -41,7 +41,6 @@ import Control.Concurrent (myThreadId) import Control.Monad.Base (MonadBase(..), liftBaseDefault) import Control.Monad.Catch (MonadThrow, throwM) -import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Concurrent.MVar (newEmptyMVar) -- import Control.Monad.Error.Class (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) @@ -59,7 +58,7 @@ import qualified Data.Set as S import Streamly.Internal.Control.Concurrent - (MonadAsync, RunInIO(..), captureMonadState) + (MonadRunInIO, MonadAsync, RunInIO(..), askRunInIO, restoreM) import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS, atomicModifyIORefCAS_) import Streamly.Internal.Data.Stream.Serial (SerialT (..)) @@ -104,7 +103,7 @@ {-# INLINE workLoopLIFO #-} workLoopLIFO - :: (MonadIO m, MonadBaseControl IO m) + :: MonadRunInIO m => IORef [(RunInIO m, Stream m a)] -> State Stream m a -> SVar Stream m a @@ -143,7 +142,7 @@ if res then K.foldStreamShared st yieldk single (return Continue) r else do - runInIO <- captureMonadState + runInIO <- askRunInIO liftIO $ enqueueLIFO sv q (runInIO, r) return Suspend @@ -158,7 +157,7 @@ -- make a check every time. {-# INLINE workLoopLIFOLimited #-} workLoopLIFOLimited - :: forall m a. (MonadIO m, MonadBaseControl IO m) + :: forall m a. MonadRunInIO m => IORef [(RunInIO m, Stream m a)] -> State Stream m a -> SVar Stream m a @@ -209,7 +208,7 @@ if res && yieldLimitOk then K.foldStreamShared st yieldk single incrContinue r else do - runInIO <- captureMonadState + runInIO <- askRunInIO liftIO $ incrementYieldLimit sv liftIO $ enqueueLIFO sv q (runInIO, r) return Suspend @@ -240,7 +239,7 @@ {-# INLINE workLoopFIFO #-} workLoopFIFO - :: (MonadIO m, MonadBaseControl IO m) + :: MonadRunInIO m => LinkedQueue (RunInIO m, Stream m a) -> State Stream m a -> SVar Stream m a @@ -273,13 +272,13 @@ -- yielding. yieldk a r = do res <- liftIO $ sendYield sv winfo (ChildYield a) - runInIO <- captureMonadState + runInIO <- askRunInIO liftIO $ enqueueFIFO sv q (runInIO, r) return $ if res then Continue else Suspend {-# INLINE workLoopFIFOLimited #-} workLoopFIFOLimited - :: forall m a. (MonadIO m, MonadBaseControl IO m) + :: forall m a. MonadRunInIO m => LinkedQueue (RunInIO m, Stream m a) -> State Stream m a -> SVar Stream m a @@ -316,7 +315,7 @@ yieldk a r = do res <- liftIO $ sendYield sv winfo (ChildYield a) - runInIO <- captureMonadState + runInIO <- askRunInIO liftIO $ enqueueFIFO sv q (runInIO, r) yieldLimitOk <- liftIO $ decrementYieldLimit sv if res && yieldLimitOk @@ -533,7 +532,7 @@ newAsyncVar :: MonadAsync m => State Stream m a -> Stream m a -> m (SVar Stream m a) newAsyncVar st m = do - mrun <- captureMonadState + mrun <- askRunInIO sv <- liftIO $ getLifoSVar st mrun sendFirstWorker sv m @@ -573,7 +572,7 @@ newWAsyncVar :: MonadAsync m => State Stream m a -> Stream m a -> m (SVar Stream m a) newWAsyncVar st m = do - mrun <- captureMonadState + mrun <- askRunInIO sv <- liftIO $ getFifoSVar st mrun -- XXX Use just Stream and IO in all the functions below -- XXX pass mrun instead of calling captureMonadState again inside it @@ -653,7 +652,7 @@ K.foldStream st yld sng stp $ getSerialT $ fromSVar sv where concurrently ma mb = K.mkStream $ \st yld sng stp -> do - runInIO <- captureMonadState + runInIO <- askRunInIO liftIO $ enqueue (fromJust $ streamVar st) (runInIO, mb) K.foldStreamShared st yld sng stp ma @@ -663,7 +662,7 @@ joinStreamVarAsync style m1 m2 = K.mkStream $ \st yld sng stp -> case streamVar st of Just sv | svarStyle sv == style -> do - runInIO <- captureMonadState + runInIO <- askRunInIO liftIO $ enqueue sv (runInIO, m2) K.foldStreamShared st yld sng stp m1 _ -> K.foldStreamShared st yld sng stp (forkSVarAsync style m1 m2) diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Common.hs b/src/Streamly/Internal/Data/Stream/IsStream/Common.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Common.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Common.hs @@ -34,6 +34,7 @@ -- $smapM_Notes , take , takeWhile + , takeEndBy , drop , findIndices , intersperseM @@ -430,6 +431,10 @@ takeWhile :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a takeWhile p m = fromStreamS $ S.takeWhile p $ toStreamS m +{-# INLINE takeEndBy #-} +takeEndBy :: (IsStream t, Monad m) => (a -> Bool) -> t m a -> t m a +takeEndBy p m = fromStreamD $ D.takeEndBy p $ toStreamD m + -- | Discard first 'n' elements from the stream and take the rest. -- -- @since 0.1.0 @@ -463,6 +468,13 @@ -- >>> Stream.toList $ Stream.trace putChar $ Stream.intersperseM (putChar '.' >> return ',') $ Stream.fromList "hello" -- h.,e.,l.,l.,o"h,e,l,l,o" -- +-- Be careful about the order of effects. In the above example we used trace +-- after the intersperse, if we use it before the intersperse the output would +-- be he.l.l.o."h,e,l,l,o". +-- +-- >>> Stream.toList $ Stream.intersperseM (putChar '.' >> return ',') $ Stream.trace putChar $ Stream.fromList "hello" +-- he.l.l.o."h,e,l,l,o" +-- -- @since 0.5.0 {-# INLINE intersperseM #-} intersperseM :: (IsStream t, MonadAsync m) => m a -> t m a -> t m a @@ -680,7 +692,7 @@ -- | Like 'zipWith' but using a monadic zipping function. -- -- @since 0.4.0 -{-# INLINABLE zipWithM #-} +{-# INLINE zipWithM #-} zipWithM :: (IsStream t, Monad m) => (a -> b -> m c) -> t m a -> t m b -> t m c zipWithM f m1 m2 = IsStream.fromStreamS @@ -699,7 +711,7 @@ -- @ -- -- @since 0.1.0 -{-# INLINABLE zipWith #-} +{-# INLINE zipWith #-} zipWith :: (IsStream t, Monad m) => (a -> b -> c) -> t m a -> t m b -> t m c zipWith f m1 m2 = IsStream.fromStreamS diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Exception.hs b/src/Streamly/Internal/Data/Stream/IsStream/Exception.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Exception.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Exception.hs @@ -25,10 +25,8 @@ import Control.Exception (Exception) import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.Control (MonadBaseControl) import Data.Map.Strict (Map) -import Streamly.Internal.Control.Concurrent (MonadAsync) +import Streamly.Internal.Control.Concurrent (MonadRunInIO, MonadAsync) import Streamly.Internal.Data.Stream.IsStream.Type (IsStream(..), fromStreamD, toStreamD) @@ -83,7 +81,7 @@ -- @since 0.7.0 -- {-# INLINE after #-} -after :: (IsStream t, MonadIO m, MonadBaseControl IO m) +after :: (IsStream t, MonadRunInIO m) => m b -> t m a -> t m a after action xs = fromStreamD $ D.after action $ toStreamD xs diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Expand.hs b/src/Streamly/Internal/Data/Stream/IsStream/Expand.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Expand.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Expand.hs @@ -180,7 +180,7 @@ import qualified Streamly.Internal.Data.Stream.StreamD as D import qualified Streamly.Internal.Data.Stream.StreamK as K (mergeBy, mergeByM) import qualified Streamly.Internal.Data.Stream.StreamK.Type as K -import qualified Streamly.Internal.Data.Stream.Zip as Zip +import qualified Streamly.Internal.Data.Stream.ZipAsync as ZipAsync import Prelude hiding (concat, concatMap, zipWith) @@ -665,7 +665,7 @@ zipAsyncWithM :: (IsStream t, MonadAsync m) => (a -> b -> m c) -> t m a -> t m b -> t m c zipAsyncWithM f m1 m2 = - fromStream $ Zip.zipAsyncWithMK f (toStream m1) (toStream m2) + fromStream $ ZipAsync.zipAsyncWithMK f (toStream m1) (toStream m2) -- XXX Should we rename this to zipParWith or zipParallelWith? This can happen -- along with the change of behvaior to end the stream concurrently. @@ -745,7 +745,7 @@ -- See also: 'mergeByMFused' -- -- @since 0.6.0 -{-# INLINABLE mergeByM #-} +{-# INLINE mergeByM #-} mergeByM :: (IsStream t, Monad m) => (a -> a -> m Ordering) -> t m a -> t m a -> t m a diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Reduce.hs b/src/Streamly/Internal/Data/Stream/IsStream/Reduce.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Reduce.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Reduce.hs @@ -1492,7 +1492,7 @@ -- -- /Pre-release/ -- -{-# INLINABLE classifyKeepAliveSessions #-} +{-# INLINE classifyKeepAliveSessions #-} classifyKeepAliveSessions :: (IsStream t, MonadAsync m, Ord k) => (Int -> m Bool) -- ^ predicate to eject sessions on session count @@ -1539,7 +1539,7 @@ -- -- /Pre-release/ -- -{-# INLINABLE classifySessionsOf #-} +{-# INLINE classifySessionsOf #-} classifySessionsOf :: (IsStream t, MonadAsync m, Ord k) => (Int -> m Bool) -- ^ predicate to eject sessions on session count diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Top.hs b/src/Streamly/Internal/Data/Stream/IsStream/Top.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Top.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Top.hs @@ -28,7 +28,7 @@ -- | These are not exactly set operations because streams are not -- necessarily sets, they may have duplicated elements. , intersectBy - , mergeIntersectBy + , intersectBySorted , differenceBy , mergeDifferenceBy , unionBy @@ -36,15 +36,15 @@ -- ** Join operations , crossJoin - , innerJoin - , mergeInnerJoin - , hashInnerJoin - , leftJoin + , joinInner + , joinInnerMap + , joinInnerMerge + , joinLeft , mergeLeftJoin - , hashLeftJoin - , outerJoin + , joinLeftMap + , joinOuter , mergeOuterJoin - , hashOuterJoin + , joinOuterMap ) where @@ -68,6 +68,7 @@ import Streamly.Internal.Data.Time.Units (NanoSecond64(..), toRelTime64) import qualified Data.List as List +import qualified Data.Map.Strict as Map import qualified Streamly.Internal.Data.Array as Array import qualified Streamly.Internal.Data.Fold as Fold import qualified Streamly.Internal.Data.Parser as Parser @@ -78,6 +79,7 @@ import qualified Streamly.Internal.Data.Stream.IsStream.Reduce as Stream import qualified Streamly.Internal.Data.Stream.IsStream.Transform as Stream import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream +import qualified Streamly.Internal.Data.Stream.StreamD as StreamD import Prelude hiding (filter, zipWith, concatMap, concat) @@ -259,57 +261,83 @@ -- are equal by the given equality pedicate then return the tuple (a, b). -- -- The second stream is evaluated multiple times. If the stream is a --- consume-once stream then the caller should cache it in an 'Data.Array.Array' --- before calling this function. Caching may also improve performance if the --- stream is expensive to evaluate. +-- consume-once stream then the caller should cache it (e.g. in a +-- 'Data.Array.Array') before calling this function. Caching may also improve +-- performance if the stream is expensive to evaluate. -- -- For space efficiency use the smaller stream as the second stream. -- +-- You should almost always use joinInnerMap instead of joinInner. joinInnerMap +-- is an order of magnitude faster. joinInner may be used when the second +-- stream is generated from a seed, therefore, need not be stored in memory and +-- the amount of memory it takes is a concern. +-- -- Space: O(n) assuming the second stream is cached in memory. -- -- Time: O(m x n) -- -- /Pre-release/ -{-# INLINE innerJoin #-} -innerJoin :: +{-# INLINE joinInner #-} +joinInner :: forall (t :: (Type -> Type) -> Type -> Type) m a b. - (IsStream t, Monad (t m)) => + (IsStream t, Monad m) => (a -> b -> Bool) -> t m a -> t m b -> t m (a, b) -innerJoin eq s1 s2 = do - -- XXX use concatMap instead? - a <- s1 - b <- s2 - if a `eq` b - then return (a, b) - else Stream.nil +joinInner eq s1 s2 = do + -- ConcatMap works faster than bind + Stream.concatMap (\a -> + Stream.concatMap (\b -> + if a `eq` b + then Stream.fromPure (a, b) + else Stream.nil + ) s2 + ) s1 +-- XXX Generate error if a duplicate insertion is attempted? +toMap :: (Monad m, Ord k) => IsStream.SerialT m (k, v) -> m (Map.Map k v) +toMap = Stream.foldl' (\kv (k, b) -> Map.insert k b kv) Map.empty + -- If the second stream is too big it can be partitioned based on hashes and -- then we can process one parition at a time. -- --- | Like 'innerJoin' but uses a hashmap for efficiency. +-- XXX An IntMap may be faster when the keys are Int. +-- XXX Use hashmap instead of map? -- +-- | Like 'joinInner' but uses a 'Map' for efficiency. +-- +-- If the input streams have duplicate keys, the behavior is undefined. +-- -- For space efficiency use the smaller stream as the second stream. -- -- Space: O(n) -- -- Time: O(m + n) -- --- /Unimplemented/ -{-# INLINE hashInnerJoin #-} -hashInnerJoin :: -- Hashable b => - (a -> b -> Bool) -> t m a -> t m b -> t m (a, b) -hashInnerJoin = undefined +-- /Pre-release/ +{-# INLINE joinInnerMap #-} +joinInnerMap :: (IsStream t, Monad m, Ord k) => + t m (k, a) -> t m (k, b) -> t m (k, a, b) +joinInnerMap s1 s2 = + Stream.concatM $ do + km <- toMap $ IsStream.adapt s2 + pure $ Stream.mapMaybe (joinAB km) s1 --- | Like 'innerJoin' but works only on sorted streams. + where + + joinAB kvm (k, a) = + case k `Map.lookup` kvm of + Just b -> Just (k, a, b) + Nothing -> Nothing + +-- | Like 'joinInner' but works only on sorted streams. -- -- Space: O(1) -- -- Time: O(m + n) -- -- /Unimplemented/ -{-# INLINE mergeInnerJoin #-} -mergeInnerJoin :: (a -> b -> Ordering) -> t m a -> t m b -> t m (a, b) -mergeInnerJoin = undefined +{-# INLINE joinInnerMerge #-} +joinInnerMerge :: (a -> b -> Ordering) -> t m a -> t m b -> t m (a, b) +joinInnerMerge = undefined -- XXX We can do this concurrently. -- XXX If the second stream is sorted and passed as an Array or a seek capable @@ -327,7 +355,7 @@ -- stream is expensive to evaluate. -- -- @ --- rightJoin = flip leftJoin +-- rightJoin = flip joinLeft -- @ -- -- Space: O(n) assuming the second stream is cached in memory. @@ -335,10 +363,10 @@ -- Time: O(m x n) -- -- /Unimplemented/ -{-# INLINE leftJoin #-} -leftJoin :: Monad m => +{-# INLINE joinLeft #-} +joinLeft :: Monad m => (a -> b -> Bool) -> SerialT m a -> SerialT m b -> SerialT m (a, Maybe b) -leftJoin eq s1 s2 = Stream.evalStateT (return False) $ do +joinLeft eq s1 s2 = Stream.evalStateT (return False) $ do a <- Stream.liftInner s1 -- XXX should we use StreamD monad here? -- XXX Is there a better way to perform some action at the end of a loop @@ -359,19 +387,29 @@ else Stream.nil Nothing -> return (a, Nothing) --- | Like 'outerJoin' but uses a hashmap for efficiency. +-- | Like 'joinLeft' but uses a hashmap for efficiency. -- -- Space: O(n) -- -- Time: O(m + n) -- --- /Unimplemented/ -{-# INLINE hashLeftJoin #-} -hashLeftJoin :: -- Hashable b => - (a -> b -> Bool) -> t m a -> t m b -> t m (a, Maybe b) -hashLeftJoin = undefined +-- /Pre-release/ +{-# INLINE joinLeftMap #-} +joinLeftMap :: (IsStream t, Ord k, Monad m) => + t m (k, a) -> t m (k, b) -> t m (k, a, Maybe b) +joinLeftMap s1 s2 = + Stream.concatM $ do + km <- toMap $ IsStream.adapt s2 + return $ Stream.map (joinAB km) s1 --- | Like 'leftJoin' but works only on sorted streams. + where + + joinAB km (k, a) = + case k `Map.lookup` km of + Just b -> (k, a, Just b) + Nothing -> (k, a, Nothing) + +-- | Like 'joinLeft' but works only on sorted streams. -- -- Space: O(1) -- @@ -397,13 +435,13 @@ -- Time: O(m x n) -- -- /Unimplemented/ -{-# INLINE outerJoin #-} -outerJoin :: MonadIO m => +{-# INLINE joinOuter #-} +joinOuter :: MonadIO m => (a -> b -> Bool) -> SerialT m a -> SerialT m b -> SerialT m (Maybe a, Maybe b) -outerJoin eq s1 s = +joinOuter eq s1 s = Stream.concatM $ do arr <- Array.fromStream $ fmap (,False) s return $ go arr <> leftOver arr @@ -444,21 +482,50 @@ -- a flag. At the end go through @t m b@ and find those that are not in that -- hash to return (Nothing, b). -- --- | Like 'outerJoin' but uses a hashmap for efficiency. --- --- For space efficiency use the smaller stream as the second stream. +-- | Like 'joinOuter' but uses a 'Map' for efficiency. -- --- Space: O(n) +-- Space: O(m + n) -- -- Time: O(m + n) -- --- /Unimplemented/ -{-# INLINE hashOuterJoin #-} -hashOuterJoin :: -- (Monad m, Hashable b) => - (a -> b -> Ordering) -> t m a -> t m b -> t m (Maybe a, Maybe b) -hashOuterJoin _eq _s1 _s2 = undefined +-- /Pre-release/ +{-# INLINE joinOuterMap #-} +joinOuterMap :: + (IsStream t, Ord k, MonadIO m) => + t m (k, a) -> t m (k, b) -> t m (k, Maybe a, Maybe b) +joinOuterMap s1 s2 = + Stream.concatM $ do + km1 <- kvFold $ IsStream.adapt s1 + km2 <- kvFold $ IsStream.adapt s2 --- | Like 'outerJoin' but works only on sorted streams. + -- XXX Not sure if toList/fromList would fuse optimally. We may have to + -- create a fused Map.toStream function. + let res1 = Stream.map (joinAB km2) $ Stream.fromList $ Map.toList km1 + where + joinAB km (k, a) = + case k `Map.lookup` km of + Just b -> (k, Just a, Just b) + Nothing -> (k, Just a, Nothing) + + -- XXX We can take advantage of the lookups in the first pass above to + -- reduce the number of lookups in this pass. If we keep mutable cells + -- in the second Map, we can flag it in the first pass and not do any + -- lookup in the second pass if it is flagged. + let res2 = Stream.mapMaybe (joinAB km1) $ Stream.fromList $ Map.toList km2 + where + joinAB km (k, b) = + case k `Map.lookup` km of + Just _ -> Nothing + Nothing -> Just (k, Nothing, Just b) + + return $ Stream.serial res1 res2 + + where + + -- XXX Generate error if a duplicate insertion is attempted? + kvFold = Stream.foldl' (\kv (k, b) -> Map.insert k b kv) Map.empty + +-- | Like 'joinOuter' but works only on sorted streams. -- -- Space: O(1) -- @@ -487,9 +554,9 @@ -- >>> Stream.toList $ Stream.intersectBy (==) (Stream.fromList [2,1,1,3]) (Stream.fromList [1,2,2,4]) -- [2,1,1] -- --- 'intersectBy' is similar to but not the same as 'innerJoin': +-- 'intersectBy' is similar to but not the same as 'joinInner': -- --- >>> Stream.toList $ fmap fst $ Stream.innerJoin (==) (Stream.fromList [1,2,2,4]) (Stream.fromList [2,1,1,3]) +-- >>> Stream.toList $ fmap fst $ Stream.joinInner (==) (Stream.fromList [1,2,2,4]) (Stream.fromList [2,1,1,3]) -- [1,1,2,2] -- -- Space: O(n) where @n@ is the number of elements in the second stream. @@ -508,19 +575,22 @@ xs <- Stream.toListRev $ Stream.uniqBy eq $ adapt s2 return $ Stream.filter (\x -> List.any (eq x) xs) s1 --- | Like 'intersectBy' but works only on sorted streams. +-- | Like 'intersectBy' but works only on streams sorted in ascending order. -- -- Space: O(1) -- -- Time: O(m+n) -- --- /Unimplemented/ -{-# INLINE mergeIntersectBy #-} -mergeIntersectBy :: -- (IsStream t, Monad m) => +-- /Pre-release/ +{-# INLINE intersectBySorted #-} +intersectBySorted :: (IsStream t, Monad m) => (a -> a -> Ordering) -> t m a -> t m a -> t m a -mergeIntersectBy _eq _s1 _s2 = undefined +intersectBySorted eq s1 = + IsStream.fromStreamD + . StreamD.intersectBySorted eq (IsStream.toStreamD s1) + . IsStream.toStreamD --- Roughly leftJoin s1 s2 = s1 `difference` s2 + s1 `intersection` s2 +-- Roughly joinLeft s1 s2 = s1 `difference` s2 + s1 `intersection` s2 -- | Delete first occurrences of those elements from the first stream that are -- present in the second stream. If an element occurs multiple times in the @@ -581,7 +651,7 @@ -- unionBy eq s1 s2 = s1 \`serial` (s2 `differenceBy eq` s1) -- @ -- --- Similar to 'outerJoin' but not the same. +-- Similar to 'joinOuter' but not the same. -- -- Space: O(n) -- diff --git a/src/Streamly/Internal/Data/Stream/IsStream/Type.hs b/src/Streamly/Internal/Data/Stream/IsStream/Type.hs --- a/src/Streamly/Internal/Data/Stream/IsStream/Type.hs +++ b/src/Streamly/Internal/Data/Stream/IsStream/Type.hs @@ -117,8 +117,8 @@ (AsyncT(..), Async, WAsyncT(..), WAsync) import Streamly.Internal.Data.Stream.Ahead (AheadT(..), Ahead) import Streamly.Internal.Data.Stream.Parallel (ParallelT(..), Parallel) -import Streamly.Internal.Data.Stream.Zip - (ZipSerialM(..), ZipSerial, ZipAsyncM(..), ZipAsync) +import Streamly.Internal.Data.Stream.Zip (ZipSerialM(..), ZipSerial) +import Streamly.Internal.Data.Stream.ZipAsync (ZipAsyncM(..), ZipAsync) import Streamly.Internal.Data.SVar.Type (State, adaptState) import qualified Prelude @@ -135,6 +135,7 @@ import qualified Streamly.Internal.Data.Stream.StreamD.Type as S #endif import qualified Streamly.Internal.Data.Stream.Zip as Zip +import qualified Streamly.Internal.Data.Stream.ZipAsync as ZipAsync import Prelude hiding (foldr, repeat) @@ -539,12 +540,12 @@ {-# INLINE consM #-} {-# SPECIALIZE consM :: IO a -> ZipAsyncM IO a -> ZipAsyncM IO a #-} consM :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a - consM = Zip.consMZipAsync + consM = ZipAsync.consMZipAsync {-# INLINE (|:) #-} {-# SPECIALIZE (|:) :: IO a -> ZipAsyncM IO a -> ZipAsyncM IO a #-} (|:) :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a - (|:) = Zip.consMZipAsync + (|:) = ZipAsync.consMZipAsync ------------------------------------------------------------------------------- -- Construction @@ -654,7 +655,7 @@ -- /Since: 0.8.0 (Renamed foldMapWith to concatMapFoldableWith)/ -- -- /Since: 0.1.0 ("Streamly")/ -{-# INLINABLE concatMapFoldableWith #-} +{-# INLINE concatMapFoldableWith #-} concatMapFoldableWith :: (IsStream t, Foldable f) => (t m b -> t m b -> t m b) -> (a -> t m b) -> f a -> t m b concatMapFoldableWith f g = Prelude.foldr (f . g) nil diff --git a/src/Streamly/Internal/Data/Stream/SVar/Eliminate.hs b/src/Streamly/Internal/Data/Stream/SVar/Eliminate.hs --- a/src/Streamly/Internal/Data/Stream/SVar/Eliminate.hs +++ b/src/Streamly/Internal/Data/Stream/SVar/Eliminate.hs @@ -31,7 +31,8 @@ import Control.Monad.Catch (throwM) import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.IORef (newIORef, readIORef, writeIORef) -import Streamly.Internal.Control.Concurrent (MonadAsync, doFork) +import Streamly.Internal.Control.Concurrent (MonadAsync) +import Streamly.Internal.Control.ForkLifted (doFork) import Streamly.Internal.Data.Atomics (atomicModifyIORefCAS_) import Streamly.Internal.Data.Fold.SVar (write, writeLimited) import Streamly.Internal.Data.Fold.Type (Fold(..)) diff --git a/src/Streamly/Internal/Data/Stream/SVar/Generate.hs b/src/Streamly/Internal/Data/Stream/SVar/Generate.hs --- a/src/Streamly/Internal/Data/Stream/SVar/Generate.hs +++ b/src/Streamly/Internal/Data/Stream/SVar/Generate.hs @@ -37,7 +37,7 @@ import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.IORef (newIORef, readIORef, mkWeakIORef, writeIORef) import Data.Maybe (isNothing) -import Streamly.Internal.Control.Concurrent (MonadAsync, captureMonadState) +import Streamly.Internal.Control.Concurrent (MonadAsync, askRunInIO) import Streamly.Internal.Data.Stream.Serial (SerialT(..)) import Streamly.Internal.Data.Time.Clock (Clock(Monotonic), getTime) import System.Mem (performMajorGC) @@ -90,7 +90,7 @@ -- be read back from the SVar using 'fromSVar'. toSVar :: MonadAsync m => SVar SerialT m a -> SerialT m a -> m () toSVar sv m = do - runIn <- captureMonadState + runIn <- askRunInIO liftIO $ enqueue sv (runIn, m) done <- allThreadsDone sv -- XXX This is safe only when called from the consumer thread or when no diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Eliminate.hs b/src/Streamly/Internal/Data/Stream/StreamD/Eliminate.hs --- a/src/Streamly/Internal/Data/Stream/StreamD/Eliminate.hs +++ b/src/Streamly/Internal/Data/Stream/StreamD/Eliminate.hs @@ -166,7 +166,6 @@ -- XXX currently we are using a dumb list based approach for backtracking -- buffer. This can be replaced by a sliding/ring buffer using Data.Array. -- That will allow us more efficient random back and forth movement. - {-# INLINE go #-} go !_ st buf !pst = do r <- step defState st case r of diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Exception.hs b/src/Streamly/Internal/Data/Stream/StreamD/Exception.hs --- a/src/Streamly/Internal/Data/Stream/StreamD/Exception.hs +++ b/src/Streamly/Internal/Data/Stream/StreamD/Exception.hs @@ -28,11 +28,9 @@ import Control.Exception (Exception, SomeException, mask_) import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_) import Data.Map.Strict (Map) import GHC.Exts (inline) -import Streamly.Internal.Control.Concurrent (MonadAsync) +import Streamly.Internal.Control.Concurrent (MonadRunInIO, MonadAsync, withRunInIO) import Streamly.Internal.Data.IOFinalizer (newIOFinalizer, runIOFinalizer, clearingIOFinalizer) @@ -119,7 +117,7 @@ -- /Pre-release/ {-# INLINE_NORMAL gbracket #-} gbracket - :: (MonadIO m, MonadBaseControl IO m) + :: MonadRunInIO m => m c -- ^ before -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling) -> (c -> m d1) -- ^ on normal stop @@ -141,7 +139,7 @@ -- of 'bef' and the registration of 'aft' atomic. -- A similar thing is done in the resourcet package: https://git.io/JvKV3 -- Tutorial: https://markkarpov.com/tutorial/exceptions.html - (r, ref) <- liftBaseOp_ mask_ $ do + (r, ref) <- withRunInIO $ \run -> mask_ $ run $ do r <- bef ref <- newIOFinalizer (gc r) return (r, ref) @@ -210,7 +208,7 @@ -- | See 'Streamly.Internal.Data.Stream.IsStream.after'. -- {-# INLINE_NORMAL after #-} -after :: (MonadIO m, MonadBaseControl IO m) +after :: MonadRunInIO m => m b -> Stream m a -> Stream m a after action (Stream step state) = Stream step' Nothing diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Generate.hs b/src/Streamly/Internal/Data/Stream/StreamD/Generate.hs --- a/src/Streamly/Internal/Data/Stream/StreamD/Generate.hs +++ b/src/Streamly/Internal/Data/Stream/StreamD/Generate.hs @@ -329,7 +329,7 @@ ------------------------------------------------------------------------------ {-# INLINE_NORMAL times #-} -times :: MonadAsync m => Double -> Stream m (AbsTime, RelTime64) +times :: MonadIO m => Double -> Stream m (AbsTime, RelTime64) times g = Stream step Nothing where diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Nesting.hs b/src/Streamly/Internal/Data/Stream/StreamD/Nesting.hs --- a/src/Streamly/Internal/Data/Stream/StreamD/Nesting.hs +++ b/src/Streamly/Internal/Data/Stream/StreamD/Nesting.hs @@ -142,10 +142,12 @@ -- | Opposite to compact in ArrayStream , splitInnerBy , splitInnerBySuffix + , intersectBySorted ) where #include "inline.hs" +#include "ArrayMacros.h" import Control.Exception (assert) import Control.Monad.Catch (MonadThrow, throwM) @@ -172,7 +174,7 @@ import qualified Streamly.Internal.Data.Fold as FL import qualified Streamly.Internal.Data.Parser as PR import qualified Streamly.Internal.Data.Parser.ParserD as PRD -import qualified Streamly.Internal.Ring.Foreign as RB +import qualified Streamly.Internal.Data.Ring.Foreign as RB import Streamly.Internal.Data.Stream.StreamD.Type @@ -481,6 +483,49 @@ => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a mergeBy cmp = mergeByM (\a b -> return $ cmp a b) +------------------------------------------------------------------------------- +-- Intersection of sorted streams +------------------------------------------------------------------------------- + +-- Assuming the streams are sorted in ascending order +{-# INLINE_NORMAL intersectBySorted #-} +intersectBySorted :: Monad m + => (a -> a -> Ordering) -> Stream m a -> Stream m a -> Stream m a +intersectBySorted cmp (Stream stepa ta) (Stream stepb tb) = + Stream step + ( ta -- left stream state + , tb -- right stream state + , Nothing -- left value + , Nothing -- right value + ) + + where + + {-# INLINE_LATE step #-} + -- step 1, fetch the first value + step gst (sa, sb, Nothing, b) = do + r <- stepa gst sa + return $ case r of + Yield a sa' -> Skip (sa', sb, Just a, b) -- step 2/3 + Skip sa' -> Skip (sa', sb, Nothing, b) + Stop -> Stop + + -- step 2, fetch the second value + step gst (sa, sb, a@(Just _), Nothing) = do + r <- stepb gst sb + return $ case r of + Yield b sb' -> Skip (sa, sb', a, Just b) -- step 3 + Skip sb' -> Skip (sa, sb', a, Nothing) + Stop -> Stop + + -- step 3, compare the two values + step _ (sa, sb, Just a, Just b) = do + let res = cmp a b + return $ case res of + GT -> Skip (sa, sb, Just a, Nothing) -- step 2 + LT -> Skip (sa, sb, Nothing, Just b) -- step 1 + EQ -> Yield a (sa, sb, Nothing, Just b) -- step 1 + ------------------------------------------------------------------------------ -- Combine N Streams - unfoldMany ------------------------------------------------------------------------------ @@ -1671,7 +1716,7 @@ patLen = A.length patArr maxIndex = patLen - 1 - elemBits = sizeOf (undefined :: a) * 8 + elemBits = SIZE_OF(a) * 8 -- For word pattern case wordMask :: Word @@ -1717,9 +1762,9 @@ then return $ Skip $ SplitOnSeqEmpty acc state else if patLen == 1 then do - pat <- liftIO $ A.unsafeIndexIO patArr 0 + pat <- liftIO $ A.unsafeIndexIO 0 patArr return $ Skip $ SplitOnSeqSingle acc state pat - else if sizeOf (undefined :: a) * patLen + else if SIZE_OF(a) * patLen <= sizeOf (undefined :: Word) then return $ Skip $ SplitOnSeqWordInit acc state else do @@ -1985,7 +2030,7 @@ patLen = A.length patArr maxIndex = patLen - 1 - elemBits = sizeOf (undefined :: a) * 8 + elemBits = SIZE_OF(a) * 8 -- For word pattern case wordMask :: Word @@ -2050,9 +2095,9 @@ then skip $ SplitOnSuffixSeqEmpty fs state else if patLen == 1 then do - pat <- liftIO $ A.unsafeIndexIO patArr 0 + pat <- liftIO $ A.unsafeIndexIO 0 patArr skip $ SplitOnSuffixSeqSingleInit fs state pat - else if sizeOf (undefined :: a) * patLen + else if SIZE_OF(a) * patLen <= sizeOf (undefined :: Word) then skip $ SplitOnSuffixSeqWordInit fs state else do diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Transform.hs b/src/Streamly/Internal/Data/Stream/StreamD/Transform.hs --- a/src/Streamly/Internal/Data/Stream/StreamD/Transform.hs +++ b/src/Streamly/Internal/Data/Stream/StreamD/Transform.hs @@ -133,7 +133,8 @@ import GHC.Types (SPEC(..)) import qualified Control.Monad.Catch as MC -import Streamly.Internal.Control.Concurrent (MonadAsync, fork, forkManaged) +import Streamly.Internal.Control.Concurrent (MonadAsync) +import Streamly.Internal.Control.ForkLifted (fork, forkManaged) import Streamly.Internal.Data.Fold.Type (Fold(..)) import Streamly.Internal.Data.Pipe.Type (Pipe(..), PipeState(..)) import Streamly.Internal.Data.SVar.Type (defState, adaptState) @@ -1109,12 +1110,13 @@ import Foreign.ForeignPtr (touchForeignPtr) import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import Foreign.Ptr (Ptr, plusPtr) +import Streamly.Internal.Data.Array.Foreign.Mut.Type (sizeOfElem) reverse' m = Stream step Nothing where {-# INLINE_LATE step #-} step _ Nothing = do arr <- A.fromStreamD m - let p = A.aEnd arr `plusPtr` negate (sizeOf (undefined :: a)) + let p = A.aEnd arr `plusPtr` negate (sizeOfElem (undefined :: a)) return $ Skip $ Just (A.aStart arr, p) step _ (Just (start, p)) | p < unsafeForeignPtrToPtr start = return Stop @@ -1124,7 +1126,7 @@ r <- peek p touchForeignPtr start return r - next = p `plusPtr` negate (sizeOf (undefined :: a)) + next = p `plusPtr` negate (sizeOfElem (undefined :: a)) return $ Yield x (Just (start, next)) -} diff --git a/src/Streamly/Internal/Data/Stream/StreamD/Type.hs b/src/Streamly/Internal/Data/Stream/StreamD/Type.hs --- a/src/Streamly/Internal/Data/Stream/StreamD/Type.hs +++ b/src/Streamly/Internal/Data/Stream/StreamD/Type.hs @@ -74,6 +74,8 @@ , take , takeWhile , takeWhileM + , takeEndBy + , takeEndByM -- * Nesting , ConcatMapUState (..) @@ -637,6 +639,32 @@ {-# INLINE takeWhile #-} takeWhile :: Monad m => (a -> Bool) -> Stream m a -> Stream m a takeWhile f = takeWhileM (return . f) + +-- Like takeWhile but with an inverted condition and also taking +-- the matching element. + +{-# INLINE_NORMAL takeEndByM #-} +takeEndByM :: Monad m => (a -> m Bool) -> Stream m a -> Stream m a +takeEndByM f (Stream step state) = Stream step' (Just state) + where + {-# INLINE_LATE step' #-} + step' gst (Just st) = do + r <- step gst st + case r of + Yield x s -> do + b <- f x + return $ + if not b + then Yield x (Just s) + else Yield x Nothing + Skip s -> return $ Skip (Just s) + Stop -> return Stop + + step' _ Nothing = return Stop + +{-# INLINE takeEndBy #-} +takeEndBy :: Monad m => (a -> Bool) -> Stream m a -> Stream m a +takeEndBy f = takeEndByM (return . f) ------------------------------------------------------------------------------ -- Combine N Streams - concatAp diff --git a/src/Streamly/Internal/Data/Stream/StreamK.hs b/src/Streamly/Internal/Data/Stream/StreamK.hs --- a/src/Streamly/Internal/Data/Stream/StreamK.hs +++ b/src/Streamly/Internal/Data/Stream/StreamK.hs @@ -751,19 +751,8 @@ -- -- @since 0.1.0 {-# INLINE zipWith #-} -zipWith :: (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c -zipWith f = go - - where - - go mx my = mkStream $ \st yld sng stp -> do - let merge a ra = - let single2 b = sng (f a b) - yield2 b rb = yld (f a b) (go ra rb) - in foldStream (adaptState st) yield2 single2 stp my - let single1 a = merge a nil - yield1 = merge - foldStream (adaptState st) yield1 single1 stp mx +zipWith :: Monad m => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c +zipWith f = zipWithM (\a b -> return (f a b)) -- | Zip two streams serially using a monadic zipping function. -- diff --git a/src/Streamly/Internal/Data/Stream/Zip.hs b/src/Streamly/Internal/Data/Stream/Zip.hs --- a/src/Streamly/Internal/Data/Stream/Zip.hs +++ b/src/Streamly/Internal/Data/Stream/Zip.hs @@ -21,12 +21,6 @@ , zipWithK , zipWithMK - , ZipAsyncM(..) - , ZipAsync - , consMZipAsync - , zipAsyncWithK - , zipAsyncWithMK - -- * Deprecated , ZipStream ) @@ -49,12 +43,10 @@ ( Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec , readListPrecDefault) import Streamly.Internal.BaseCompat ((#.), errorWithoutStackTrace, oneShot) -import Streamly.Internal.Control.Concurrent (MonadAsync) import Streamly.Internal.Data.Maybe.Strict (Maybe'(..), toMaybe) import Streamly.Internal.Data.Stream.Serial (SerialT(..)) import Streamly.Internal.Data.Stream.StreamK.Type (Stream) -import qualified Streamly.Internal.Data.Stream.Parallel as Par import qualified Streamly.Internal.Data.Stream.Prelude as P (cmpBy, eqBy, foldl', foldr, fromList, toList) import qualified Streamly.Internal.Data.Stream.StreamK.Type as K @@ -87,40 +79,6 @@ zipWithK f = zipWithMK (\a b -> return (f a b)) ------------------------------------------------------------------------------ --- Parallel Zipping ------------------------------------------------------------------------------- - --- | Like 'zipAsyncWith' but with a monadic zipping function. --- --- @since 0.4.0 -{-# INLINE zipAsyncWithMK #-} -zipAsyncWithMK :: MonadAsync m - => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c -zipAsyncWithMK f m1 m2 = D.toStreamK $ - D.zipWithM f (Par.mkParallelD $ D.fromStreamK m1) - (Par.mkParallelD $ D.fromStreamK m2) - --- XXX Should we rename this to zipParWith or zipParallelWith? This can happen --- along with the change of behvaior to end the stream concurrently. --- --- | Like 'zipWith' but zips concurrently i.e. both the streams being zipped --- are evaluated concurrently using the 'ParallelT' concurrent evaluation --- style. The maximum number of elements of each stream evaluated in advance --- can be controlled by 'maxBuffer'. --- --- The stream ends if stream @a@ or stream @b@ ends. However, if stream @b@ --- ends while we are still evaluating stream @a@ and waiting for a result then --- stream will not end until after the evaluation of stream @a@ finishes. This --- behavior can potentially be changed in future to end the stream immediately --- as soon as any of the stream end is detected. --- --- @since 0.1.0 -{-# INLINE zipAsyncWithK #-} -zipAsyncWithK :: MonadAsync m - => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c -zipAsyncWithK f = zipAsyncWithMK (\a b -> return (f a b)) - ------------------------------------------------------------------------------- -- Serially Zipping Streams ------------------------------------------------------------------------------ @@ -175,48 +133,3 @@ FOLDABLE_INSTANCE(ZipSerialM) TRAVERSABLE_INSTANCE(ZipSerialM) - ------------------------------------------------------------------------------- --- Parallely Zipping Streams ------------------------------------------------------------------------------- --- --- | For 'ZipAsyncM' streams: --- --- @ --- (<>) = 'Streamly.Prelude.serial' --- (<*>) = 'Streamly.Prelude.serial.zipAsyncWith' id --- @ --- --- Applicative evaluates the streams being zipped concurrently, the following --- would take half the time that it would take in serial zipping: --- --- >>> s = Stream.fromFoldableM $ Prelude.map delay [1, 1, 1] --- >>> Stream.toList $ Stream.fromZipAsync $ (,) <$> s <*> s --- ... --- [(1,1),(1,1),(1,1)] --- --- /Since: 0.2.0 ("Streamly")/ --- --- @since 0.8.0 -newtype ZipAsyncM m a = ZipAsyncM {getZipAsyncM :: Stream m a} - deriving (Semigroup, Monoid) - --- | An IO stream whose applicative instance zips streams wAsyncly. --- --- /Since: 0.2.0 ("Streamly")/ --- --- @since 0.8.0 -type ZipAsync = ZipAsyncM IO - -consMZipAsync :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a -consMZipAsync m (ZipAsyncM r) = ZipAsyncM $ K.consM m r - -instance Monad m => Functor (ZipAsyncM m) where - {-# INLINE fmap #-} - fmap f (ZipAsyncM m) = ZipAsyncM $ getSerialT $ fmap f (SerialT m) - -instance MonadAsync m => Applicative (ZipAsyncM m) where - pure = ZipAsyncM . getSerialT . Serial.repeat - - {-# INLINE (<*>) #-} - ZipAsyncM m1 <*> ZipAsyncM m2 = ZipAsyncM $ zipAsyncWithK id m1 m2 diff --git a/src/Streamly/Internal/Data/Stream/ZipAsync.hs b/src/Streamly/Internal/Data/Stream/ZipAsync.hs new file mode 100644 --- /dev/null +++ b/src/Streamly/Internal/Data/Stream/ZipAsync.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Streamly.Internal.Data.Stream.ZipAsync +-- Copyright : (c) 2017 Composewell Technologies +-- License : BSD-3-Clause +-- Maintainer : streamly@composewell.com +-- Stability : experimental +-- Portability : GHC +-- +-- To run examples in this module: +-- +-- >>> import qualified Streamly.Prelude as Stream +-- +module Streamly.Internal.Data.Stream.ZipAsync + ( ZipAsyncM(..) + , ZipAsync + , consMZipAsync + , zipAsyncWithK + , zipAsyncWithMK + ) +where + +#if __GLASGOW_HASKELL__ < 808 +import Data.Semigroup (Semigroup(..)) +#endif +import Streamly.Internal.Control.Concurrent (MonadAsync) +import Streamly.Internal.Data.Stream.Serial (SerialT(..)) +import Streamly.Internal.Data.Stream.StreamK.Type (Stream) + +import qualified Streamly.Internal.Data.Stream.StreamK.Type as K +import qualified Streamly.Internal.Data.Stream.StreamK as K +import qualified Streamly.Internal.Data.Stream.StreamD as D +import qualified Streamly.Internal.Data.Stream.Serial as Serial +import qualified Streamly.Internal.Data.Stream.SVar.Eliminate as SVar +import qualified Streamly.Internal.Data.Stream.SVar.Generate as SVar +import Streamly.Internal.Data.SVar + +import Prelude hiding (map, repeat, zipWith, errorWithoutStackTrace) + +#include "Instances.hs" + +-- $setup +-- >>> import qualified Streamly.Prelude as Stream +-- >>> import Control.Concurrent (threadDelay) +-- >>> :{ +-- delay n = do +-- threadDelay (n * 1000000) -- sleep for n seconds +-- putStrLn (show n ++ " sec") -- print "n sec" +-- return n -- IO Int +-- :} + +------------------------------------------------------------------------------ +-- Parallel Zipping +------------------------------------------------------------------------------ + +-- | Like 'zipAsyncWith' but with a monadic zipping function. +-- +-- @since 0.4.0 +{-# INLINE zipAsyncWithMK #-} +zipAsyncWithMK :: MonadAsync m + => (a -> b -> m c) -> Stream m a -> Stream m b -> Stream m c +zipAsyncWithMK f m1 m2 = K.mkStream $ \st yld sng stp -> do + sv <- newParallelVar StopNone (adaptState st) + SVar.toSVarParallel (adaptState st) sv $ D.fromStreamK m2 + K.foldStream st yld sng stp $ K.zipWithM f m1 (getSerialT (SVar.fromSVar sv)) + +-- XXX Should we rename this to zipParWith or zipParallelWith? This can happen +-- along with the change of behvaior to end the stream concurrently. +-- +-- | Like 'zipWith' but zips concurrently i.e. both the streams being zipped +-- are evaluated concurrently using the 'ParallelT' concurrent evaluation +-- style. The maximum number of elements of each stream evaluated in advance +-- can be controlled by 'maxBuffer'. +-- +-- The stream ends if stream @a@ or stream @b@ ends. However, if stream @b@ +-- ends while we are still evaluating stream @a@ and waiting for a result then +-- stream will not end until after the evaluation of stream @a@ finishes. This +-- behavior can potentially be changed in future to end the stream immediately +-- as soon as any of the stream end is detected. +-- +-- @since 0.1.0 +{-# INLINE zipAsyncWithK #-} +zipAsyncWithK :: MonadAsync m + => (a -> b -> c) -> Stream m a -> Stream m b -> Stream m c +zipAsyncWithK f = zipAsyncWithMK (\a b -> return (f a b)) + +------------------------------------------------------------------------------ +-- Parallely Zipping Streams +------------------------------------------------------------------------------ +-- +-- | For 'ZipAsyncM' streams: +-- +-- @ +-- (<>) = 'Streamly.Prelude.serial' +-- (<*>) = 'Streamly.Prelude.serial.zipAsyncWith' id +-- @ +-- +-- Applicative evaluates the streams being zipped concurrently, the following +-- would take half the time that it would take in serial zipping: +-- +-- >>> s = Stream.fromFoldableM $ Prelude.map delay [1, 1, 1] +-- >>> Stream.toList $ Stream.fromZipAsync $ (,) <$> s <*> s +-- ... +-- [(1,1),(1,1),(1,1)] +-- +-- /Since: 0.2.0 ("Streamly")/ +-- +-- @since 0.8.0 +newtype ZipAsyncM m a = ZipAsyncM {getZipAsyncM :: Stream m a} + deriving (Semigroup, Monoid) + +-- | An IO stream whose applicative instance zips streams wAsyncly. +-- +-- /Since: 0.2.0 ("Streamly")/ +-- +-- @since 0.8.0 +type ZipAsync = ZipAsyncM IO + +consMZipAsync :: Monad m => m a -> ZipAsyncM m a -> ZipAsyncM m a +consMZipAsync m (ZipAsyncM r) = ZipAsyncM $ K.consM m r + +instance Monad m => Functor (ZipAsyncM m) where + {-# INLINE fmap #-} + fmap f (ZipAsyncM m) = ZipAsyncM $ getSerialT $ fmap f (SerialT m) + +instance MonadAsync m => Applicative (ZipAsyncM m) where + pure = ZipAsyncM . getSerialT . Serial.repeat + + {-# INLINE (<*>) #-} + ZipAsyncM m1 <*> ZipAsyncM m2 = ZipAsyncM $ zipAsyncWithK id m1 m2 diff --git a/src/Streamly/Internal/Data/Time/Clock.hs b/src/Streamly/Internal/Data/Time/Clock.hs --- a/src/Streamly/Internal/Data/Time/Clock.hs +++ b/src/Streamly/Internal/Data/Time/Clock.hs @@ -15,18 +15,28 @@ -- * Async clock , asyncClock , readClock + + -- * Adjustable Timer + , Timer + , timer + , resetTimer + , extendTimer + , shortenTimer + , readTimer + , waitTimer ) where import Control.Concurrent (threadDelay, ThreadId) -import Control.Monad (forever) +import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, tryPutMVar) +import Control.Monad (forever, when, void) import Streamly.Internal.Data.Time.Clock.Type (Clock(..), getTime) -import Streamly.Internal.Data.Time.Units (MicroSecond64(..), fromAbsTime) -import Streamly.Internal.Control.Concurrent (forkManaged) +import Streamly.Internal.Data.Time.Units + (MicroSecond64(..), fromAbsTime, addToAbsTime, toRelTime) +import Streamly.Internal.Control.ForkIO (forkIOManaged) import qualified Streamly.Internal.Data.IORef.Prim as Prim - ------------------------------------------------------------------------------ -- Async clock ------------------------------------------------------------------------------ @@ -72,9 +82,99 @@ asyncClock clock g = do timeVar <- Prim.newIORef 0 updateTimeVar clock timeVar - tid <- forkManaged $ forever (updateWithDelay clock g timeVar) + tid <- forkIOManaged $ forever (updateWithDelay clock g timeVar) return (tid, timeVar) {-# INLINE readClock #-} readClock :: (ThreadId, Prim.IORef MicroSecond64) -> IO MicroSecond64 readClock (_, timeVar) = Prim.readIORef timeVar + +------------------------------------------------------------------------------ +-- Adjustable Timer +------------------------------------------------------------------------------ + +-- | Adjustable periodic timer. +data Timer = Timer ThreadId (MVar ()) (IO ()) + +-- Set the expiry to current time + timer period +{-# INLINE resetTimerExpiry #-} +resetTimerExpiry :: Clock -> MicroSecond64 -> Prim.IORef MicroSecond64 -> IO () +resetTimerExpiry clock period timeVar = do + t <- getTime clock + let t1 = addToAbsTime t (toRelTime period) + Prim.modifyIORef' timeVar (const (fromAbsTime t1)) + +{-# INLINE processTimerTick #-} +processTimerTick :: RealFrac a => + Clock -> a -> Prim.IORef MicroSecond64 -> MVar () -> IO () -> IO () +processTimerTick clock precision timeVar mvar reset = do + threadDelay (delayTime precision) + t <- fromAbsTime <$> getTime clock + expiry <- Prim.readIORef timeVar + when (t >= expiry) $ do + -- non-blocking put so that we can process multiple timers in a + -- non-blocking manner in future. + void $ tryPutMVar mvar () + reset + + where + + -- Keep the minimum at least a millisecond to avoid high CPU usage + {-# INLINE delayTime #-} + delayTime g + | g' >= fromIntegral (maxBound :: Int) = maxBound + | g' < 1000 = 1000 + | otherwise = round g' + + where + + g' = g * 10 ^ (6 :: Int) + +-- XXX In future we can add a timer in a heap of timers. +-- +-- | @timer clockType granularity period@ creates a timer. The timer produces +-- timer ticks at specified time intervals that can be waited upon using +-- 'waitTimer'. If the previous tick is not yet processed, the new tick is +-- lost. +timer :: Clock -> Double -> Double -> IO Timer +timer clock g period = do + mvar <- newEmptyMVar + timeVar <- Prim.newIORef 0 + let p = round (period * 1e6) :: Int + p1 = fromIntegral p :: MicroSecond64 + reset = resetTimerExpiry clock p1 timeVar + process = processTimerTick clock g timeVar mvar reset + reset + tid <- forkIOManaged $ forever process + return $ Timer tid mvar reset + +-- | Blocking wait for a timer tick. +{-# INLINE waitTimer #-} +waitTimer :: Timer -> IO () +waitTimer (Timer _ mvar _) = takeMVar mvar + +-- | Resets the current period. +{-# INLINE resetTimer #-} +resetTimer :: Timer -> IO () +resetTimer (Timer _ _ reset) = reset + +-- | Elongates the current period by specified amount. +-- +-- /Unimplemented/ +{-# INLINE extendTimer #-} +extendTimer :: Timer -> Double -> IO () +extendTimer = undefined + +-- | Shortens the current period by specified amount. +-- +-- /Unimplemented/ +{-# INLINE shortenTimer #-} +shortenTimer :: Timer -> Double -> IO () +shortenTimer = undefined + +-- | Show the remaining time in the current time period. +-- +-- /Unimplemented/ +{-# INLINE readTimer #-} +readTimer :: Timer -> IO Double +readTimer = undefined diff --git a/src/Streamly/Internal/Data/Tuple/Strict.hs b/src/Streamly/Internal/Data/Tuple/Strict.hs --- a/src/Streamly/Internal/Data/Tuple/Strict.hs +++ b/src/Streamly/Internal/Data/Tuple/Strict.hs @@ -21,15 +21,24 @@ ( Tuple' (..) , Tuple3' (..) + , Tuple3Fused' (..) , Tuple4' (..) ) where +import Fusion.Plugin.Types (Fuse(..)) + -- | A strict '(,)' data Tuple' a b = Tuple' !a !b deriving Show +-- XXX Add TupleFused' + -- | A strict '(,,)' +{-# ANN type Tuple3Fused' Fuse #-} data Tuple3' a b c = Tuple3' !a !b !c deriving Show + +-- | A strict '(,,)' +data Tuple3Fused' a b c = Tuple3Fused' !a !b !c deriving Show -- | A strict '(,,,)' data Tuple4' a b c d = Tuple4' !a !b !c !d deriving Show diff --git a/src/Streamly/Internal/Data/Unfold.hs b/src/Streamly/Internal/Data/Unfold.hs --- a/src/Streamly/Internal/Data/Unfold.hs +++ b/src/Streamly/Internal/Data/Unfold.hs @@ -248,22 +248,19 @@ import Control.Exception (Exception, mask_) import Control.Monad.Catch (MonadCatch) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp_) import Data.Functor (($>)) import GHC.Types (SPEC(..)) -import Streamly.Internal.Control.Concurrent (MonadAsync) +import Streamly.Internal.Control.Concurrent (MonadRunInIO, MonadAsync, withRunInIO) import Streamly.Internal.Data.Fold.Type (Fold(..)) import Streamly.Internal.Data.IOFinalizer (newIOFinalizer, runIOFinalizer, clearingIOFinalizer) -import Streamly.Internal.Data.Stream.IsStream.Type (IsStream) +import Streamly.Internal.Data.Stream.Serial (SerialT(..)) import Streamly.Internal.Data.Stream.StreamD.Type (Stream(..), Step(..)) import Streamly.Internal.Data.SVar.Type (defState) import qualified Control.Monad.Catch as MC import qualified Data.Tuple as Tuple import qualified Streamly.Internal.Data.Fold.Type as FL -import qualified Streamly.Internal.Data.Stream.IsStream.Type as IsStream import qualified Streamly.Internal.Data.Stream.StreamD.Type as D import qualified Streamly.Internal.Data.Stream.StreamK.Type as K @@ -502,8 +499,8 @@ -- /Since: 0.8.0/ -- {-# INLINE_NORMAL fromStream #-} -fromStream :: (IsStream t, Monad m) => Unfold m (t m a) a -fromStream = lmap IsStream.toStream fromStreamK +fromStream :: Monad m => Unfold m (SerialT m a) a +fromStream = lmap getSerialT fromStreamK ------------------------------------------------------------------------------- -- Unfolds @@ -831,7 +828,7 @@ -- /Pre-release/ {-# INLINE_NORMAL gbracket #-} gbracket - :: (MonadIO m, MonadBaseControl IO m) + :: MonadRunInIO m => (a -> m c) -- ^ before -> (forall s. m s -> m (Either e s)) -- ^ try (exception handling) -> (c -> m d) -- ^ after, on normal stop, or GC @@ -846,7 +843,7 @@ inject x = do -- Mask asynchronous exceptions to make the execution of 'bef' and -- the registration of 'aft' atomic. See comment in 'D.gbracketIO'. - (r, ref) <- liftBaseOp_ mask_ $ do + (r, ref) <- withRunInIO $ \run -> mask_ $ run $ do r <- bef x ref <- newIOFinalizer (aft r) return (r, ref) @@ -932,7 +929,7 @@ -- -- /Pre-release/ {-# INLINE_NORMAL after #-} -after :: (MonadIO m, MonadBaseControl IO m) +after :: MonadRunInIO m => (a -> m c) -> Unfold m a b -> Unfold m a b after action (Unfold step1 inject1) = Unfold step inject @@ -1124,7 +1121,7 @@ inject x = do -- Mask asynchronous exceptions to make the execution of 'bef' and -- the registration of 'aft' atomic. See comment in 'D.gbracketIO'. - (r, ref) <- liftBaseOp_ mask_ $ do + (r, ref) <- withRunInIO $ \run -> mask_ $ run $ do r <- bef x ref <- newIOFinalizer (aft r) return (r, ref) diff --git a/src/Streamly/Internal/FileSystem/Dir.hs b/src/Streamly/Internal/FileSystem/Dir.hs --- a/src/Streamly/Internal/FileSystem/Dir.hs +++ b/src/Streamly/Internal/FileSystem/Dir.hs @@ -103,7 +103,7 @@ -- | @toChunksWithBufferOf size h@ reads a stream of arrays from file handle @h@. -- The maximum size of a single array is specified by @size@. The actual size -- read may be less than or equal to @size@. -{-# INLINABLE _toChunksWithBufferOf #-} +{-# INLINE _toChunksWithBufferOf #-} _toChunksWithBufferOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m (Array Word8) _toChunksWithBufferOf size h = go diff --git a/src/Streamly/Internal/FileSystem/Event/Darwin.hs b/src/Streamly/Internal/FileSystem/Event/Darwin.hs --- a/src/Streamly/Internal/FileSystem/Event/Darwin.hs +++ b/src/Streamly/Internal/FileSystem/Event/Darwin.hs @@ -92,7 +92,7 @@ -- ** Default configuration Config (..) - , Toggle (..) + , Switch (..) , defaultConfig -- ** Watch Behavior @@ -247,9 +247,9 @@ -- -- /Pre-release/ -- -data Toggle = On | Off +data Switch = On | Off -setFlag :: Word32 -> Toggle -> Config -> Config +setFlag :: Word32 -> Switch -> Config -> Config setFlag mask status cfg@Config{..} = let flags = case status of @@ -279,7 +279,7 @@ -- -- /Pre-release/ -- -setRootPathEvents :: Toggle -> Config -> Config +setRootPathEvents :: Switch -> Config -> Config setRootPathEvents = setFlag kFSEventStreamCreateFlagWatchRoot foreign import ccall safe @@ -304,7 +304,7 @@ -- -- /Pre-release/ -- -setFileEvents :: Toggle -> Config -> Config +setFileEvents :: Switch -> Config -> Config setFileEvents = setFlag kFSEventStreamCreateFlagFileEvents foreign import ccall safe @@ -320,7 +320,7 @@ -- -- /Pre-release/ -- -setIgnoreSelf :: Toggle -> Config -> Config +setIgnoreSelf :: Switch -> Config -> Config setIgnoreSelf = setFlag kFSEventStreamCreateFlagIgnoreSelf #if HAVE_DECL_KFSEVENTSTREAMCREATEFLAGFULLHISTORY @@ -336,7 +336,7 @@ -- -- /Pre-release/ -- -setFullHistory :: Toggle -> Config -> Config +setFullHistory :: Switch -> Config -> Config setFullHistory = setFlag kFSEventStreamCreateFlagFullHistory #endif @@ -347,7 +347,7 @@ -- -- /Pre-release/ -- -setAllEvents :: Toggle -> Config -> Config +setAllEvents :: Switch -> Config -> Config setAllEvents s = setRootPathEvents s . setFileEvents s @@ -458,7 +458,7 @@ withPathName :: Array Word8 -> (PathName -> IO a) -> IO a withPathName arr act = do - A.unsafeAsPtr arr $ \ptr -> + A.asPtrUnsafe arr $ \ptr -> let pname = PathName (castPtr ptr) (fromIntegral (A.length arr)) in act pname @@ -500,9 +500,9 @@ readOneEvent = do arr <- PR.takeEQ 24 (A.writeN 24) let arr1 = A.unsafeCast arr :: Array Word64 - eid = A.unsafeIndex arr1 0 - eflags = A.unsafeIndex arr1 1 - pathLen = fromIntegral $ A.unsafeIndex arr1 2 + eid = A.unsafeIndex 0 arr1 + eflags = A.unsafeIndex 1 arr1 + pathLen = fromIntegral $ A.unsafeIndex 2 arr1 path <- PR.takeEQ pathLen (A.writeN pathLen) return $ Event { eventId = eid diff --git a/src/Streamly/Internal/FileSystem/Event/Linux.hs b/src/Streamly/Internal/FileSystem/Event/Linux.hs --- a/src/Streamly/Internal/FileSystem/Event/Linux.hs +++ b/src/Streamly/Internal/FileSystem/Event/Linux.hs @@ -64,7 +64,7 @@ -- ** Default configuration Config (..) - , Toggle (..) + , Switch (..) , defaultConfig -- ** Watch Behavior @@ -215,19 +215,17 @@ -- Boolean settings ------------------------------------------------------------------------------- --- XXX Change Toggle to "OnOff" or "Switch". The name Toggle may be confusing. --- -- | Whether a setting is 'On' or 'Off'. -- -- /Pre-release/ -- -data Toggle = On | Off deriving (Show, Eq) +data Switch = On | Off deriving (Show, Eq) -toggle :: Toggle -> Toggle +toggle :: Switch -> Switch toggle On = Off toggle Off = On -setFlag :: Word32 -> Toggle -> Config -> Config +setFlag :: Word32 -> Switch -> Config -> Config setFlag mask status cfg@Config{..} = let flags = case status of @@ -246,7 +244,7 @@ -- -- /Pre-release/ -- -setRecursiveMode :: Toggle -> Config -> Config +setRecursiveMode :: Switch -> Config -> Config setRecursiveMode rec cfg@Config{} = cfg {watchRec = rec == On} foreign import capi @@ -262,7 +260,7 @@ -- -- /Pre-release/ -- -setFollowSymLinks :: Toggle -> Config -> Config +setFollowSymLinks :: Switch -> Config -> Config setFollowSymLinks s = setFlag iN_DONT_FOLLOW (toggle s) foreign import capi @@ -275,7 +273,7 @@ -- -- /Pre-release/ -- -setUnwatchMoved :: Toggle -> Config -> Config +setUnwatchMoved :: Switch -> Config -> Config setUnwatchMoved = setFlag iN_EXCL_UNLINK #if HAVE_DECL_IN_MASK_CREATE @@ -323,7 +321,7 @@ -- -- /Pre-release/ -- -setOneShot :: Toggle -> Config -> Config +setOneShot :: Switch -> Config -> Config setOneShot = setFlag iN_ONESHOT foreign import capi @@ -336,7 +334,7 @@ -- -- /Pre-release/ -- -setOnlyDir :: Toggle -> Config -> Config +setOnlyDir :: Switch -> Config -> Config setOnlyDir = setFlag iN_ONLYDIR ------------------------------------------------------------------------------- @@ -352,7 +350,7 @@ -- -- /Pre-release/ -- -setRootDeleted :: Toggle -> Config -> Config +setRootDeleted :: Switch -> Config -> Config setRootDeleted = setFlag iN_DELETE_SELF foreign import capi @@ -364,7 +362,7 @@ -- -- /Pre-release/ -- -setRootMoved :: Toggle -> Config -> Config +setRootMoved :: Switch -> Config -> Config setRootMoved = setFlag iN_MOVE_SELF -- | Report when the watched root path itself gets deleted or renamed. @@ -373,7 +371,7 @@ -- -- /Pre-release/ -- -setRootPathEvents :: Toggle -> Config -> Config +setRootPathEvents :: Switch -> Config -> Config setRootPathEvents = setFlag (iN_DELETE_SELF .|. iN_MOVE_SELF) foreign import capi @@ -386,7 +384,7 @@ -- -- /Pre-release/ -- -setAttrsModified :: Toggle -> Config -> Config +setAttrsModified :: Switch -> Config -> Config setAttrsModified = setFlag iN_ATTRIB foreign import capi @@ -398,7 +396,7 @@ -- -- /Pre-release/ -- -setAccessed :: Toggle -> Config -> Config +setAccessed :: Switch -> Config -> Config setAccessed = setFlag iN_ACCESS foreign import capi @@ -410,7 +408,7 @@ -- -- /Pre-release/ -- -setOpened :: Toggle -> Config -> Config +setOpened :: Switch -> Config -> Config setOpened = setFlag iN_OPEN foreign import capi @@ -422,7 +420,7 @@ -- -- /Pre-release/ -- -setWriteClosed :: Toggle -> Config -> Config +setWriteClosed :: Switch -> Config -> Config setWriteClosed = setFlag iN_CLOSE_WRITE foreign import capi @@ -434,7 +432,7 @@ -- -- /Pre-release/ -- -setNonWriteClosed :: Toggle -> Config -> Config +setNonWriteClosed :: Switch -> Config -> Config setNonWriteClosed = setFlag iN_CLOSE_NOWRITE foreign import capi @@ -446,7 +444,7 @@ -- -- /Pre-release/ -- -setCreated :: Toggle -> Config -> Config +setCreated :: Switch -> Config -> Config setCreated = setFlag iN_CREATE foreign import capi @@ -458,7 +456,7 @@ -- -- /Pre-release/ -- -setDeleted :: Toggle -> Config -> Config +setDeleted :: Switch -> Config -> Config setDeleted = setFlag iN_DELETE foreign import capi @@ -470,7 +468,7 @@ -- -- /Pre-release/ -- -setMovedFrom :: Toggle -> Config -> Config +setMovedFrom :: Switch -> Config -> Config setMovedFrom = setFlag iN_MOVED_FROM foreign import capi @@ -482,7 +480,7 @@ -- -- /Pre-release/ -- -setMovedTo :: Toggle -> Config -> Config +setMovedTo :: Switch -> Config -> Config setMovedTo = setFlag iN_MOVED_TO foreign import capi @@ -494,7 +492,7 @@ -- -- /Pre-release/ -- -setModified :: Toggle -> Config -> Config +setModified :: Switch -> Config -> Config setModified = setFlag iN_MODIFY -- | Set all tunable events 'On' or 'Off'. Equivalent to setting: @@ -514,7 +512,7 @@ -- -- /Pre-release/ -- -setAllEvents :: Toggle -> Config -> Config +setAllEvents :: Switch -> Config -> Config setAllEvents s = setRootDeleted s . setRootMoved s @@ -838,7 +836,7 @@ readOneEvent cfg wt@(Watch _ wdMap) = do let headerLen = sizeOf (undefined :: CInt) + 12 arr <- PR.takeEQ headerLen (A.writeN headerLen) - (ewd, eflags, cookie, pathLen) <- PR.fromEffect $ A.unsafeAsPtr arr readHeader + (ewd, eflags, cookie, pathLen) <- PR.fromEffect $ A.asPtrUnsafe arr readHeader -- XXX need the "initial" in parsers to return a step type so that "take 0" -- can return without an input. otherwise if pathLen is 0 we will keep -- waiting to read one more char before we return this event. diff --git a/src/Streamly/Internal/FileSystem/Event/Windows.hs b/src/Streamly/Internal/FileSystem/Event/Windows.hs --- a/src/Streamly/Internal/FileSystem/Event/Windows.hs +++ b/src/Streamly/Internal/FileSystem/Event/Windows.hs @@ -48,7 +48,7 @@ -- ** Default configuration Config - , Toggle (..) + , Switch (..) , defaultConfig -- ** Watch Behavior @@ -143,9 +143,9 @@ -- -- /Pre-release/ -- -data Toggle = On | Off deriving (Show, Eq) +data Switch = On | Off deriving (Show, Eq) -setFlag :: DWORD -> Toggle -> Config -> Config +setFlag :: DWORD -> Switch -> Config -> Config setFlag mask status cfg@Config{..} = let flags = case status of @@ -159,7 +159,7 @@ -- -- /Pre-release/ -- -setRecursiveMode :: Toggle -> Config -> Config +setRecursiveMode :: Switch -> Config -> Config setRecursiveMode rec cfg@Config{} = cfg {watchRec = rec == On} -- | Generate notify events on file create, rename or delete. @@ -172,7 +172,7 @@ -- -- /Pre-release/ -- -setFileNameEvents :: Toggle -> Config -> Config +setFileNameEvents :: Switch -> Config -> Config setFileNameEvents = setFlag fILE_NOTIFY_CHANGE_FILE_NAME -- | Generate notify events on directory create, rename or delete. @@ -185,7 +185,7 @@ -- -- /Pre-release/ -- -setDirNameEvents :: Toggle -> Config -> Config +setDirNameEvents :: Switch -> Config -> Config setDirNameEvents = setFlag fILE_NOTIFY_CHANGE_DIR_NAME -- | Generate an 'isModified' event on any attribute change in the watched @@ -195,7 +195,7 @@ -- -- /Pre-release/ -- -setAttrsModified :: Toggle -> Config -> Config +setAttrsModified :: Switch -> Config -> Config setAttrsModified = setFlag fILE_NOTIFY_CHANGE_ATTRIBUTES -- | Generate an 'isModified' event when the file size is changed. @@ -210,7 +210,7 @@ -- -- /Pre-release/ -- -setSizeModified :: Toggle -> Config -> Config +setSizeModified :: Switch -> Config -> Config setSizeModified = setFlag fILE_NOTIFY_CHANGE_SIZE -- | Generate an 'isModified' event when the last write timestamp of the file @@ -227,7 +227,7 @@ -- -- /Pre-release/ -- -setLastWriteTimeModified :: Toggle -> Config -> Config +setLastWriteTimeModified :: Switch -> Config -> Config setLastWriteTimeModified = setFlag fILE_NOTIFY_CHANGE_LAST_WRITE -- | Generate an 'isModified' event when any security-descriptor change occurs @@ -237,7 +237,7 @@ -- -- /Pre-release/ -- -setSecurityModified :: Toggle -> Config -> Config +setSecurityModified :: Switch -> Config -> Config setSecurityModified = setFlag fILE_NOTIFY_CHANGE_SECURITY -- | Set all tunable events 'On' or 'Off'. Equivalent to setting: @@ -251,7 +251,7 @@ -- -- /Pre-release/ -- -setAllEvents :: Toggle -> Config -> Config +setAllEvents :: Switch -> Config -> Config setAllEvents s = setFileNameEvents s . setDirNameEvents s diff --git a/src/Streamly/Internal/FileSystem/FD.hs b/src/Streamly/Internal/FileSystem/FD.hs --- a/src/Streamly/Internal/FileSystem/FD.hs +++ b/src/Streamly/Internal/FileSystem/FD.hs @@ -131,9 +131,8 @@ import qualified GHC.IO.Device as RawIO import Streamly.Internal.Data.Array.Foreign.Type - (Array(..), byteLength, unsafeFreeze) -import Streamly.Internal.Data.Array.Foreign.Mut.Type - (fromForeignPtrUnsafe, unsafeWithArrayContents) + (Array(..), byteLength, unsafeFreeze, asPtrUnsafe) +import Streamly.Internal.Data.Array.Foreign.Mut.Type (fromForeignPtrUnsafe) import Streamly.Internal.System.IO (defaultChunkSize) import Streamly.Internal.Data.Stream.Serial (SerialT) import Streamly.Internal.Data.Stream.IsStream.Type @@ -241,7 +240,7 @@ writeArray :: Storable a => Handle -> Array a -> IO () writeArray _ arr | A.length arr == 0 = return () writeArray (Handle fd) arr = - unsafeWithArrayContents (arrContents arr) (arrStart arr) $ \p -> + asPtrUnsafe arr $ \p -> -- RawIO.writeAll fd (castPtr p) aLen #if MIN_VERSION_base(4,15,0) RawIO.write fd (castPtr p) 0 aLen @@ -266,7 +265,7 @@ writeIOVec :: Handle -> Array RawIO.IOVec -> IO () writeIOVec _ iov | A.length iov == 0 = return () writeIOVec (Handle fd) iov = - unsafeWithArrayContents (arrContents iov) (arrStart iov) $ \p -> + asPtrUnsafe iov $ \p -> RawIO.writevAll fd p (A.length iov) #endif @@ -277,7 +276,7 @@ -- | @readArraysOfUpto size h@ reads a stream of arrays from file handle @h@. -- The maximum size of a single array is specified by @size@. The actual size -- read may be less than or equal to @size@. -{-# INLINABLE _readArraysOfUpto #-} +{-# INLINE _readArraysOfUpto #-} _readArraysOfUpto :: (IsStream t, MonadIO m) => Int -> Handle -> t m (Array Word8) _readArraysOfUpto size h = go diff --git a/src/Streamly/Internal/FileSystem/File.hs b/src/Streamly/Internal/FileSystem/File.hs --- a/src/Streamly/Internal/FileSystem/File.hs +++ b/src/Streamly/Internal/FileSystem/File.hs @@ -151,14 +151,14 @@ -- -- /Pre-release/ -- -{-# INLINABLE usingFile #-} +{-# INLINE usingFile #-} usingFile :: (MonadCatch m, MonadAsync m) => Unfold m Handle a -> Unfold m FilePath a usingFile = UF.bracket (\file -> liftIO $ openFile file ReadMode) (liftIO . hClose) -{-# INLINABLE usingFile2 #-} +{-# INLINE usingFile2 #-} usingFile2 :: (MonadCatch m, MonadAsync m) => Unfold m (x, Handle) a -> Unfold m (x, FilePath) a usingFile2 = UF.bracket before after @@ -171,7 +171,7 @@ after (_, h) = liftIO $ hClose h -{-# INLINABLE usingFile3 #-} +{-# INLINE usingFile3 #-} usingFile3 :: (MonadCatch m, MonadAsync m) => Unfold m (x, y, z, Handle) a -> Unfold m (x, y, z, FilePath) a usingFile3 = UF.bracket before after @@ -215,7 +215,7 @@ -- | @toChunksWithBufferOf size file@ reads a stream of arrays from file @file@. -- The maximum size of a single array is specified by @size@. The actual size -- read may be less than or equal to @size@. -{-# INLINABLE toChunksWithBufferOf #-} +{-# INLINE toChunksWithBufferOf #-} toChunksWithBufferOf :: (IsStream t, MonadCatch m, MonadAsync m) => Int -> FilePath -> t m (Array Word8) toChunksWithBufferOf size file = diff --git a/src/Streamly/Internal/FileSystem/Handle.hs b/src/Streamly/Internal/FileSystem/Handle.hs --- a/src/Streamly/Internal/FileSystem/Handle.hs +++ b/src/Streamly/Internal/FileSystem/Handle.hs @@ -206,7 +206,7 @@ -- | @toChunksWithBufferOf size h@ reads a stream of arrays from file handle @h@. -- The maximum size of a single array is specified by @size@. The actual size -- read may be less than or equal to @size@. -{-# INLINABLE _toChunksWithBufferOf #-} +{-# INLINE _toChunksWithBufferOf #-} _toChunksWithBufferOf :: (IsStream t, MonadIO m) => Int -> Handle -> t m (Array Word8) _toChunksWithBufferOf size h = go diff --git a/src/Streamly/Internal/Network/Inet/TCP.hs b/src/Streamly/Internal/Network/Inet/TCP.hs --- a/src/Streamly/Internal/Network/Inet/TCP.hs +++ b/src/Streamly/Internal/Network/Inet/TCP.hs @@ -103,7 +103,8 @@ socket) import Prelude hiding (read) -import Streamly.Internal.Control.Concurrent (MonadAsync, fork) +import Streamly.Internal.Control.Concurrent (MonadAsync) +import Streamly.Internal.Control.ForkLifted (fork) import Streamly.Internal.Data.Array.Foreign.Type (Array(..), writeNUnsafe) import Streamly.Internal.Data.Fold.Type (Fold(..)) import Streamly.Internal.Data.Stream.IsStream.Type (IsStream) @@ -277,7 +278,7 @@ -- exception, then this exception will be raised by 'usingConnection'. -- -- /Pre-release/ -{-# INLINABLE usingConnection #-} +{-# INLINE usingConnection #-} usingConnection :: (MonadCatch m, MonadAsync m) => Unfold m Socket a -> Unfold m ((Word8, Word8, Word8, Word8), PortNumber) a @@ -297,7 +298,7 @@ -- 'withConnection' rather than any exception raised by 'act'. -- -- /Pre-release/ -{-# INLINABLE withConnection #-} +{-# INLINE withConnection #-} withConnection :: (IsStream t, MonadCatch m, MonadAsync m) => (Word8, Word8, Word8, Word8) -> PortNumber -> (Socket -> t m a) -> t m a withConnection addr port = @@ -418,7 +419,7 @@ -- Transformations ------------------------------------------------------------------------------- -{-# INLINABLE withInputConnect #-} +{-# INLINE withInputConnect #-} withInputConnect :: (IsStream t, MonadCatch m, MonadAsync m) => (Word8, Word8, Word8, Word8) @@ -446,7 +447,7 @@ -- -- /Pre-release/ -- -{-# INLINABLE processBytes #-} +{-# INLINE processBytes #-} processBytes :: (IsStream t, MonadAsync m, MonadCatch m) => (Word8, Word8, Word8, Word8) diff --git a/src/Streamly/Internal/Network/Socket.hs b/src/Streamly/Internal/Network/Socket.hs --- a/src/Streamly/Internal/Network/Socket.hs +++ b/src/Streamly/Internal/Network/Socket.hs @@ -324,7 +324,7 @@ -- Stream of Arrays IO ------------------------------------------------------------------------------- -{-# INLINABLE _readChunksUptoWith #-} +{-# INLINE _readChunksUptoWith #-} _readChunksUptoWith :: (IsStream t, MonadIO m) => (Int -> h -> IO (Array Word8)) -> Int -> h -> t m (Array Word8) diff --git a/src/Streamly/Internal/Ring/Foreign.hs b/src/Streamly/Internal/Ring/Foreign.hs deleted file mode 100644 --- a/src/Streamly/Internal/Ring/Foreign.hs +++ /dev/null @@ -1,511 +0,0 @@ --- | --- Module : Streamly.Internal.Ring.Foreign --- Copyright : (c) 2019 Composewell Technologies --- License : BSD3 --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- --- A ring array is a circular mutable array. - --- XXX Write benchmarks --- XXX Make the implementation similar to mutable array --- XXX Rename this module to Data.RingArray.Storable - -module Streamly.Internal.Ring.Foreign - ( - -- * Type - Ring(..) - - -- * Construction - , new - , newRing - , writeN - - , advance - , moveBy - , startOf - - -- * Random writes - , unsafeInsert - , slide - , putIndex - , modifyIndex - - -- * Unfolds - , read - , readRev - - -- * Random reads - , getIndex - , getIndexUnsafe - , getIndexRev - - -- * Size - , length - , byteLength - -- , capacity - , byteCapacity - , bytesFree - - -- * Casting - , cast - , castUnsafe - , asBytes - , fromArray - - -- * Folds - , unsafeFoldRing - , unsafeFoldRingM - , unsafeFoldRingFullM - , unsafeFoldRingNM - - -- * Stream of Arrays - , ringsOf - - -- * Fast Byte Comparisons - , unsafeEqArray - , unsafeEqArrayN - ) where - -#include "inline.hs" - -import Control.Exception (assert) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Word (Word8) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, touchForeignPtr) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import Foreign.Ptr (plusPtr, minusPtr, castPtr) -import Foreign.Storable (Storable(..)) -import GHC.ForeignPtr (mallocPlainForeignPtrAlignedBytes) -import GHC.Ptr (Ptr(..)) -import Streamly.Internal.Data.Array.Foreign.Mut.Type (Array, memcmp) -import Streamly.Internal.Data.Fold.Type (Fold(..)) -import Streamly.Internal.Data.Stream.Serial (SerialT(..)) --- import Streamly.Internal.Data.Stream.IsStream.Transform (scan) -import Streamly.Internal.Data.Unfold.Type (Unfold(..)) -import Streamly.Internal.System.IO (unsafeInlineIO) - -import qualified Streamly.Internal.Data.Array.Foreign.Type as A - -import Prelude hiding (length, concat, read) - --- $setup --- >>> :m --- >>> import qualified Streamly.Internal.Ring.Foreign as Ring - --- | A ring buffer is a mutable array of fixed size. Initially the array is --- empty, with ringStart pointing at the start of allocated memory. We call the --- next location to be written in the ring as ringHead. Initially ringHead == --- ringStart. When the first item is added, ringHead points to ringStart + --- sizeof item. When the buffer becomes full ringHead would wrap around to --- ringStart. When the buffer is full, ringHead always points at the oldest --- item in the ring and the newest item added always overwrites the oldest --- item. --- --- When using it we should keep in mind that a ringBuffer is a mutable data --- structure. We should not leak out references to it for immutable use. --- -data Ring a = Ring - { ringStart :: {-# UNPACK #-} !(ForeignPtr a) -- first address - , ringBound :: {-# UNPACK #-} !(Ptr a) -- first address beyond allocated memory - } - -------------------------------------------------------------------------------- --- Construction -------------------------------------------------------------------------------- - --- | Get the first address of the ring as a pointer. -startOf :: Ring a -> Ptr a -startOf = unsafeForeignPtrToPtr . ringStart - --- | Create a new ringbuffer and return the ring buffer and the ringHead. --- Returns the ring and the ringHead, the ringHead is same as ringStart. -{-# INLINE new #-} -new :: forall a. Storable a => Int -> IO (Ring a, Ptr a) -new count = do - let size = count * sizeOf (undefined :: a) - fptr <- mallocPlainForeignPtrAlignedBytes size (alignment (undefined :: a)) - let p = unsafeForeignPtrToPtr fptr - return (Ring - { ringStart = fptr - , ringBound = p `plusPtr` size - }, p) - --- XXX Rename this to "new". --- --- | @newRing count@ allocates an empty array that can hold 'count' items. The --- memory of the array is uninitialized and the allocation is aligned as per --- the 'Storable' instance of the type. --- --- /Unimplemented/ -{-# INLINE newRing #-} -newRing :: Int -> m (Ring a) -newRing = undefined - --- | Advance the ringHead by 1 item, wrap around if we hit the end of the --- array. -{-# INLINE advance #-} -advance :: forall a. Storable a => Ring a -> Ptr a -> Ptr a -advance Ring{..} ringHead = - let ptr = ringHead `plusPtr` sizeOf (undefined :: a) - in if ptr < ringBound - then ptr - else unsafeForeignPtrToPtr ringStart - --- | Move the ringHead by n items. The direction depends on the sign on whether --- n is positive or negative. Wrap around if we hit the beginning or end of the --- array. -{-# INLINE moveBy #-} -moveBy :: forall a. Storable a => Int -> Ring a -> Ptr a -> Ptr a -moveBy by Ring {..} ringHead = ringStartPtr `plusPtr` advanceFromHead - - where - - elemSize = sizeOf (undefined :: a) - ringStartPtr = unsafeForeignPtrToPtr ringStart - lenInBytes = ringBound `minusPtr` ringStartPtr - offInBytes = ringHead `minusPtr` ringStartPtr - len = assert (lenInBytes `mod` elemSize == 0) $ lenInBytes `div` elemSize - off = assert (offInBytes `mod` elemSize == 0) $ offInBytes `div` elemSize - advanceFromHead = (off + by `mod` len) * elemSize - --- XXX Move the writeLastN from array module here. --- --- | @writeN n@ is a rolling fold that keeps the last n elements of the stream --- in a ring array. --- --- /Unimplemented/ -{-# INLINE writeN #-} -writeN :: -- (Storable a, MonadIO m) => - Int -> Fold m a (Ring a) -writeN = undefined - -------------------------------------------------------------------------------- --- Conversions -------------------------------------------------------------------------------- - --- | Cast a mutable array to a ring array. -fromArray :: Array a -> Ring a -fromArray = undefined - -------------------------------------------------------------------------------- --- Conversion to/from array -------------------------------------------------------------------------------- - --- | Modify a given index of a ring array using a modifier function. --- --- /Unimplemented/ -modifyIndex :: -- forall m a b. (MonadIO m, Storable a) => - Ring a -> Int -> (a -> (a, b)) -> m b -modifyIndex = undefined - --- | /O(1)/ Write the given element at the given index in the ring array. --- Performs in-place mutation of the array. --- --- >>> putIndex arr ix val = Ring.modifyIndex arr ix (const (val, ())) --- --- /Unimplemented/ -{-# INLINE putIndex #-} -putIndex :: -- (MonadIO m, Storable a) => - Ring a -> Int -> a -> m () -putIndex = undefined - --- | Insert an item at the head of the ring, when the ring is full this --- replaces the oldest item in the ring with the new item. This is unsafe --- beause ringHead supplied is not verified to be within the Ring. Also, --- the ringStart foreignPtr must be guaranteed to be alive by the caller. -{-# INLINE unsafeInsert #-} -unsafeInsert :: Storable a => Ring a -> Ptr a -> a -> IO (Ptr a) -unsafeInsert rb ringHead newVal = do - poke ringHead newVal - -- touchForeignPtr (ringStart rb) - return $ advance rb ringHead - --- | Insert an item at the head of the ring, when the ring is full this --- replaces the oldest item in the ring with the new item. --- --- /Unimplemented/ -slide :: -- forall m a. (MonadIO m, Storable a) => - Ring a -> a -> m (Ring a) -slide = undefined - -------------------------------------------------------------------------------- --- Random reads -------------------------------------------------------------------------------- - --- | Return the element at the specified index without checking the bounds. --- --- Unsafe because it does not check the bounds of the ring array. -{-# INLINE_NORMAL getIndexUnsafe #-} -getIndexUnsafe :: -- forall m a. (MonadIO m, Storable a) => - Ring a -> Int -> m a -getIndexUnsafe = undefined - --- | /O(1)/ Lookup the element at the given index. Index starts from 0. --- -{-# INLINE getIndex #-} -getIndex :: -- (MonadIO m, Storable a) => - Ring a -> Int -> m a -getIndex = undefined - --- | /O(1)/ Lookup the element at the given index from the end of the array. --- Index starts from 0. --- --- Slightly faster than computing the forward index and using getIndex. --- -{-# INLINE getIndexRev #-} -getIndexRev :: -- (MonadIO m, Storable a) => - Ring a -> Int -> m a -getIndexRev = undefined - -------------------------------------------------------------------------------- --- Size -------------------------------------------------------------------------------- - --- | /O(1)/ Get the byte length of the array. --- --- /Unimplemented/ -{-# INLINE byteLength #-} -byteLength :: Ring a -> Int -byteLength = undefined - --- | /O(1)/ Get the length of the array i.e. the number of elements in the --- array. --- --- Note that 'byteLength' is less expensive than this operation, as 'length' --- involves a costly division operation. --- --- /Unimplemented/ -{-# INLINE length #-} -length :: -- forall a. Storable a => - Ring a -> Int -length = undefined - --- | Get the total capacity of an array. An array may have space reserved --- beyond the current used length of the array. --- --- /Pre-release/ -{-# INLINE byteCapacity #-} -byteCapacity :: Ring a -> Int -byteCapacity = undefined - --- | The remaining capacity in the array for appending more elements without --- reallocation. --- --- /Pre-release/ -{-# INLINE bytesFree #-} -bytesFree :: Ring a -> Int -bytesFree = undefined - -------------------------------------------------------------------------------- --- Unfolds -------------------------------------------------------------------------------- - --- | Unfold a ring array into a stream. --- --- /Unimplemented/ -{-# INLINE_NORMAL read #-} -read :: -- forall m a. (MonadIO m, Storable a) => - Unfold m (Ring a) a -read = undefined - --- | Unfold a ring array into a stream in reverse order. --- --- /Unimplemented/ -{-# INLINE_NORMAL readRev #-} -readRev :: -- forall m a. (MonadIO m, Storable a) => - Unfold m (Array a) a -readRev = undefined - -------------------------------------------------------------------------------- --- Stream of arrays -------------------------------------------------------------------------------- - --- XXX Move this module to a lower level Ring/Type module and move ringsOf to a --- higher level ring module where we can import "scan". - --- | @ringsOf n stream@ groups the input stream into a stream of --- ring arrays of size n. Each ring is a sliding window of size n. --- --- /Unimplemented/ -{-# INLINE_NORMAL ringsOf #-} -ringsOf :: -- forall m a. (MonadIO m, Storable a) => - Int -> SerialT m a -> SerialT m (Array a) -ringsOf = undefined -- Stream.scan (writeN n) - -------------------------------------------------------------------------------- --- Casting -------------------------------------------------------------------------------- - --- | Cast an array having elements of type @a@ into an array having elements of --- type @b@. The array size must be a multiple of the size of type @b@. --- --- /Unimplemented/ --- -castUnsafe :: Ring a -> Ring b -castUnsafe = undefined - --- | Cast an @Array a@ into an @Array Word8@. --- --- /Unimplemented/ --- -asBytes :: Ring a -> Ring Word8 -asBytes = castUnsafe - --- | Cast an array having elements of type @a@ into an array having elements of --- type @b@. The length of the array should be a multiple of the size of the --- target element otherwise 'Nothing' is returned. --- --- /Pre-release/ --- -cast :: forall a b. Storable b => Ring a -> Maybe (Ring b) -cast arr = - let len = byteLength arr - r = len `mod` sizeOf (undefined :: b) - in if r /= 0 - then Nothing - else Just $ castUnsafe arr - -------------------------------------------------------------------------------- --- Equality -------------------------------------------------------------------------------- - --- XXX remove all usage of unsafeInlineIO --- --- | Like 'unsafeEqArray' but compares only N bytes instead of entire length of --- the ring buffer. This is unsafe because the ringHead Ptr is not checked to --- be in range. -{-# INLINE unsafeEqArrayN #-} -unsafeEqArrayN :: Ring a -> Ptr a -> A.Array a -> Int -> Bool -unsafeEqArrayN Ring{..} rh A.Array{..} n = - let !res = unsafeInlineIO $ do - let rs = unsafeForeignPtrToPtr ringStart - as = arrStart - assert (aEnd `minusPtr` as >= ringBound `minusPtr` rs) (return ()) - let len = ringBound `minusPtr` rh - r1 <- memcmp (castPtr rh) (castPtr as) (min len n) - r2 <- if n > len - then memcmp (castPtr rs) (castPtr (as `plusPtr` len)) - (min (rh `minusPtr` rs) (n - len)) - else return True - -- XXX enable these, check perf impact - -- touchForeignPtr ringStart - -- touchForeignPtr aStart - return (r1 && r2) - in res - --- | Byte compare the entire length of ringBuffer with the given array, --- starting at the supplied ringHead pointer. Returns true if the Array and --- the ringBuffer have identical contents. --- --- This is unsafe because the ringHead Ptr is not checked to be in range. The --- supplied array must be equal to or bigger than the ringBuffer, ARRAY BOUNDS --- ARE NOT CHECKED. -{-# INLINE unsafeEqArray #-} -unsafeEqArray :: Ring a -> Ptr a -> A.Array a -> Bool -unsafeEqArray Ring{..} rh A.Array{..} = - let !res = unsafeInlineIO $ do - let rs = unsafeForeignPtrToPtr ringStart - let as = arrStart - assert (aEnd `minusPtr` as >= ringBound `minusPtr` rs) - (return ()) - let len = ringBound `minusPtr` rh - r1 <- memcmp (castPtr rh) (castPtr as) len - r2 <- memcmp (castPtr rs) (castPtr (as `plusPtr` len)) - (rh `minusPtr` rs) - -- XXX enable these, check perf impact - -- touchForeignPtr ringStart - -- touchForeignPtr aStart - return (r1 && r2) - in res - -------------------------------------------------------------------------------- --- Folding -------------------------------------------------------------------------------- - --- XXX We can unfold it into a stream and fold the stream instead. --- XXX use MonadIO --- --- | Fold the buffer starting from ringStart up to the given 'Ptr' using a pure --- step function. This is useful to fold the items in the ring when the ring is --- not full. The supplied pointer is usually the end of the ring. --- --- Unsafe because the supplied Ptr is not checked to be in range. -{-# INLINE unsafeFoldRing #-} -unsafeFoldRing :: forall a b. Storable a - => Ptr a -> (b -> a -> b) -> b -> Ring a -> b -unsafeFoldRing ptr f z Ring{..} = - let !res = unsafeInlineIO $ withForeignPtr ringStart $ \p -> - go z p ptr - in res - where - go !acc !p !q - | p == q = return acc - | otherwise = do - x <- peek p - go (f acc x) (p `plusPtr` sizeOf (undefined :: a)) q - --- XXX Can we remove MonadIO here? -withForeignPtrM :: MonadIO m => ForeignPtr a -> (Ptr a -> m b) -> m b -withForeignPtrM fp fn = do - r <- fn $ unsafeForeignPtrToPtr fp - liftIO $ touchForeignPtr fp - return r - --- | Like unsafeFoldRing but with a monadic step function. -{-# INLINE unsafeFoldRingM #-} -unsafeFoldRingM :: forall m a b. (MonadIO m, Storable a) - => Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b -unsafeFoldRingM ptr f z Ring {..} = - withForeignPtrM ringStart $ \x -> go z x ptr - where - go !acc !start !end - | start == end = return acc - | otherwise = do - let !x = unsafeInlineIO $ peek start - acc' <- f acc x - go acc' (start `plusPtr` sizeOf (undefined :: a)) end - --- | Fold the entire length of a ring buffer starting at the supplied ringHead --- pointer. Assuming the supplied ringHead pointer points to the oldest item, --- this would fold the ring starting from the oldest item to the newest item in --- the ring. --- --- Note, this will crash on ring of 0 size. --- -{-# INLINE unsafeFoldRingFullM #-} -unsafeFoldRingFullM :: forall m a b. (MonadIO m, Storable a) - => Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b -unsafeFoldRingFullM rh f z rb@Ring {..} = - withForeignPtrM ringStart $ \_ -> go z rh - where - go !acc !start = do - let !x = unsafeInlineIO $ peek start - acc' <- f acc x - let ptr = advance rb start - if ptr == rh - then return acc' - else go acc' ptr - --- | Fold @Int@ items in the ring starting at @Ptr a@. Won't fold more --- than the length of the ring. --- --- Note, this will crash on ring of 0 size. --- -{-# INLINE unsafeFoldRingNM #-} -unsafeFoldRingNM :: forall m a b. (MonadIO m, Storable a) - => Int -> Ptr a -> (b -> a -> m b) -> b -> Ring a -> m b -unsafeFoldRingNM count rh f z rb@Ring {..} = - withForeignPtrM ringStart $ \_ -> go count z rh - - where - - go 0 acc _ = return acc - go !n !acc !start = do - let !x = unsafeInlineIO $ peek start - acc' <- f acc x - let ptr = advance rb start - if ptr == rh || n == 0 - then return acc' - else go (n - 1) acc' ptr diff --git a/src/Streamly/Internal/System/IOVec.hs b/src/Streamly/Internal/System/IOVec.hs --- a/src/Streamly/Internal/System/IOVec.hs +++ b/src/Streamly/Internal/System/IOVec.hs @@ -28,7 +28,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import Foreign.Ptr (castPtr) import Streamly.Internal.Data.Array.Foreign.Mut.Type (length) -import Streamly.Internal.Data.SVar (adaptState) +import Streamly.Internal.Data.SVar.Type (adaptState) import Streamly.Internal.Data.Array.Foreign.Mut.Type (Array(..)) import qualified Streamly.Internal.Data.Array.Foreign.Type as Array diff --git a/src/Streamly/Internal/Unicode/Char/Parser.hs b/src/Streamly/Internal/Unicode/Char/Parser.hs --- a/src/Streamly/Internal/Unicode/Char/Parser.hs +++ b/src/Streamly/Internal/Unicode/Char/Parser.hs @@ -11,12 +11,39 @@ -- Unicode Char stream and then use these parsers on the Char stream. -- XXX Add explicit export list. -module Streamly.Internal.Unicode.Char.Parser where +module Streamly.Internal.Unicode.Char.Parser + ( alpha + , alphaNum + , ascii + , asciiLower + , asciiUpper + , char + , decimal + , digit + , double + , hexadecimal + , hexDigit + , latin1 + , letter + , lower + , mark + , number + , octDigit + , print + , punctuation + , separator + , signed + , space + , symbol + , upper + ) +where import Control.Applicative (Alternative(..)) import Control.Monad.Catch (MonadCatch) import Data.Bits (Bits, (.|.), shiftL) import Data.Char (ord) +import Prelude hiding (print) import Streamly.Internal.Data.Parser (Parser) import qualified Data.Char as Char diff --git a/src/Streamly/Internal/Unicode/Stream.hs b/src/Streamly/Internal/Unicode/Stream.hs --- a/src/Streamly/Internal/Unicode/Stream.hs +++ b/src/Streamly/Internal/Unicode/Stream.hs @@ -15,6 +15,9 @@ decodeLatin1 -- ** UTF-8 Decoding + , CodingFailureMode(..) + , writeCharUtf8' + , parseCharUtf8With , decodeUtf8 , decodeUtf8' , decodeUtf8_ @@ -38,6 +41,7 @@ , encodeLatin1_ -- ** UTF-8 Encoding + , readCharUtf8' , encodeUtf8 , encodeUtf8' , encodeUtf8_ @@ -77,6 +81,7 @@ #include "inline.hs" +import Control.Monad.Catch (MonadThrow, MonadCatch) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Bits (shiftR, shiftL, (.|.), (.&.)) import Data.Char (chr, ord) @@ -96,10 +101,13 @@ import Streamly.Internal.Data.Stream.StreamD (Stream(..), Step (..)) import Streamly.Internal.Data.SVar (adaptState) import Streamly.Internal.Data.Tuple.Strict (Tuple'(..)) -import Streamly.Internal.Data.Unfold (Unfold) +import Streamly.Internal.Data.Unfold.Type (Unfold(..)) import Streamly.Internal.System.IO (unsafeInlineIO) import qualified Streamly.Internal.Data.Unfold as Unfold +import qualified Streamly.Internal.Data.Parser as Parser +import qualified Streamly.Internal.Data.Parser.ParserD as ParserD +import qualified Streamly.Internal.Data.Parser.ParserK.Type as ParserK import qualified Streamly.Internal.Data.Stream.Serial as Serial import qualified Streamly.Internal.Data.Array.Foreign as Array import qualified Streamly.Internal.Data.Array.Foreign.Type as A @@ -422,6 +430,96 @@ replacementChar :: Char replacementChar = '\xFFFD' +data UTF8CharDecodeState a + = UTF8CharDecodeInit + | UTF8CharDecoding !DecodeState !CodePoint + +{-# INLINE parseCharUtf8WithD #-} +parseCharUtf8WithD :: + Monad m => CodingFailureMode -> ParserD.Parser m Word8 Char +parseCharUtf8WithD cfm = + let A.Array _ ptr _ = utf8d + in ParserD.Parser (step' ptr) initial extract + + where + + prefix = "Streamly.Internal.Data.Stream.parseCharUtf8WithD:" + + {-# INLINE initial #-} + initial = return $ ParserD.IPartial UTF8CharDecodeInit + + handleError err souldBackTrack = + case cfm of + ErrorOnCodingFailure -> ParserD.Error err + TransliterateCodingFailure -> + case souldBackTrack of + True -> ParserD.Done 1 replacementChar + False -> ParserD.Done 0 replacementChar + DropOnCodingFailure -> + case souldBackTrack of + True -> ParserD.Continue 1 UTF8CharDecodeInit + False -> ParserD.Continue 0 UTF8CharDecodeInit + + {-# INLINE step' #-} + step' table UTF8CharDecodeInit x = + -- Note: It is important to use a ">" instead of a "<=" test + -- here for GHC to generate code layout for default branch + -- prediction for the common case. This is fragile and might + -- change with the compiler versions, we need a more reliable + -- "likely" primitive to control branch predication. + return $ case x > 0x7f of + False -> ParserD.Done 0 $ unsafeChr $ fromIntegral x + True -> + let (Tuple' sv cp) = decode0 table x + in case sv of + 12 -> + let msg = prefix + ++ "Invalid first UTF8 byte" ++ show x + in handleError msg False + 0 -> error $ prefix ++ "unreachable state" + _ -> ParserD.Continue 0 (UTF8CharDecoding sv cp) + + step' table (UTF8CharDecoding statePtr codepointPtr) x = return $ + let (Tuple' sv cp) = decode1 table statePtr codepointPtr x + in case sv of + 0 -> ParserD.Done 0 $ unsafeChr cp + 12 -> + let msg = prefix + ++ "Invalid subsequent UTF8 byte" + ++ show x + ++ "in state" + ++ show statePtr + ++ "accumulated value" + ++ show codepointPtr + in handleError msg True + _ -> ParserD.Continue 0 (UTF8CharDecoding sv cp) + + {-# INLINE extract #-} + extract _ = error $ prefix ++ "Not enough input" + +-- XXX This should ideally accept a "CodingFailureMode" and perform appropriate +-- error handling. This isn't possible now as "TransliterateCodingFailure"'s +-- workflow requires backtracking 1 element. This can be revisited once "Fold" +-- supports backtracking. +{-# INLINE writeCharUtf8' #-} +writeCharUtf8' :: MonadThrow m => Fold m Word8 Char +writeCharUtf8' = ParserD.toFold (parseCharUtf8WithD ErrorOnCodingFailure) + +-- XXX The initial idea was to have "parseCharUtf8" and offload the error +-- handling to another parser. So, say we had "parseCharUtf8'", +-- +-- >>> parseCharUtf8Smart = parseCharUtf8' <|> Parser.fromPure replacementChar +-- +-- But unfortunately parseCharUtf8Smart used in conjunction with "parseMany" - +-- that is "parseMany parseCharUtf8Smart" on a stream causes the heap to +-- overflow. Even a heap size of 500 MB was not sufficient. +-- +-- This needs to be investigated futher. +{-# INLINE parseCharUtf8With #-} +parseCharUtf8With :: + MonadCatch m => CodingFailureMode -> Parser.Parser m Word8 Char +parseCharUtf8With = ParserK.toParserK . parseCharUtf8WithD + -- XXX write it as a parser and use parseMany to decode a stream, need to check -- if that preserves the same performance. Or we can use a resumable parser -- that parses a chunk at a time. @@ -775,75 +873,28 @@ x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 x4 = fromIntegral $ (n .&. 0x3F) + 0x80 -#ifndef __GHCJS__ -{-# ANN type EncodeState Fuse #-} -#endif -data EncodeState s = EncodeState s !WList - -#ifndef __GHCJS__ -{-# ANN type InvalidAction Fuse #-} -#endif -data InvalidAction = - DropInvalid | ErrorInvalid | IgnoreInvalid | ReplaceInvalid - -replaceInvalid :: s -> Step (EncodeState s) a -replaceInvalid s = - Skip $ EncodeState s (WCons 239 (WCons 191 (WCons 189 WNil))) - -dropInvalid :: s -> Step (EncodeState s) a -dropInvalid s = Skip (EncodeState s WNil) - -errorOnInvalid :: s -> Step (EncodeState s) a -errorOnInvalid _ = - error $ - show "Streamly.Internal.Data.Stream.StreamD.encodeUtf8:" - ++ "Encountered a surrogate" - -{-# INLINE_NORMAL encodeUtf8DGeneric #-} -encodeUtf8DGeneric :: - Monad m - => InvalidAction - -> Stream m Char - -> Stream m Word8 -encodeUtf8DGeneric act (Stream step state) = - Stream step' (EncodeState state WNil) +{-# INLINE_NORMAL readCharUtf8With #-} +readCharUtf8With :: Monad m => WList -> Unfold m Char Word8 +readCharUtf8With surr = Unfold step inject where - {-# INLINE_LATE step' #-} - step' gst (EncodeState st WNil) = do - r <- step (adaptState gst) st - return $ - case r of - Yield c s -> - case ord c of - x | x <= 0x7F -> - Yield (fromIntegral x) (EncodeState s WNil) - | x <= 0x7FF -> Skip (EncodeState s (ord2 c)) - | x <= 0xFFFF -> - case act of - DropInvalid -> - if isSurrogate c - then dropInvalid s - else Skip (EncodeState s (ord3 c)) - - ErrorInvalid -> - if isSurrogate c - then errorOnInvalid s - else Skip (EncodeState s (ord3 c)) - - IgnoreInvalid -> - Skip (EncodeState s (ord3 c)) + inject c = + return $ case ord c of + x | x <= 0x7F -> fromIntegral x `WCons` WNil + | x <= 0x7FF -> ord2 c + | x <= 0xFFFF -> if isSurrogate c then surr else ord3 c + | otherwise -> ord4 c - ReplaceInvalid -> - if isSurrogate c - then replaceInvalid s - else Skip (EncodeState s (ord3 c)) + {-# INLINE_LATE step #-} + step WNil = return Stop + step (WCons x xs) = return $ Yield x xs - | otherwise -> Skip (EncodeState s (ord4 c)) - Skip s -> Skip (EncodeState s WNil) - Stop -> Stop - step' _ (EncodeState s (WCons x xs)) = return $ Yield x (EncodeState s xs) +{-# INLINE_NORMAL readCharUtf8' #-} +readCharUtf8' :: Monad m => Unfold m Char Word8 +readCharUtf8' = + readCharUtf8With $ + error "Streamly.Internal.Unicode.readCharUtf8': Encountered a surrogate" -- More yield points improve performance, but I am not sure if they can cause -- too much code bloat or some trouble with fusion. So keeping only two yield @@ -851,7 +902,7 @@ -- paths (slow path). {-# INLINE_NORMAL encodeUtf8D' #-} encodeUtf8D' :: Monad m => Stream m Char -> Stream m Word8 -encodeUtf8D' = encodeUtf8DGeneric ErrorInvalid +encodeUtf8D' = D.unfoldMany readCharUtf8' -- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. When -- any invalid character (U+D800-U+D8FF) is encountered in the input stream the @@ -862,12 +913,16 @@ encodeUtf8' :: (Monad m, IsStream t) => t m Char -> t m Word8 encodeUtf8' = fromStreamD . encodeUtf8D' . toStreamD +{-# INLINE_NORMAL readCharUtf8 #-} +readCharUtf8 :: Monad m => Unfold m Char Word8 +readCharUtf8 = readCharUtf8With $ WCons 239 (WCons 191 (WCons 189 WNil)) + -- | See section "3.9 Unicode Encoding Forms" in -- https://www.unicode.org/versions/Unicode13.0.0/UnicodeStandard-13.0.pdf -- {-# INLINE_NORMAL encodeUtf8D #-} encodeUtf8D :: Monad m => Stream m Char -> Stream m Word8 -encodeUtf8D = encodeUtf8DGeneric ReplaceInvalid +encodeUtf8D = D.unfoldMany readCharUtf8 -- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. Any -- Invalid characters (U+D800-U+D8FF) in the input stream are replaced by the @@ -880,9 +935,13 @@ encodeUtf8 :: (Monad m, IsStream t) => t m Char -> t m Word8 encodeUtf8 = fromStreamD . encodeUtf8D . toStreamD +{-# INLINE_NORMAL readCharUtf8_ #-} +readCharUtf8_ :: Monad m => Unfold m Char Word8 +readCharUtf8_ = readCharUtf8With WNil + {-# INLINE_NORMAL encodeUtf8D_ #-} encodeUtf8D_ :: Monad m => Stream m Char -> Stream m Word8 -encodeUtf8D_ = encodeUtf8DGeneric DropInvalid +encodeUtf8D_ = D.unfoldMany readCharUtf8_ -- | Encode a stream of Unicode characters to a UTF-8 encoded bytestream. Any -- Invalid characters (U+D800-U+D8FF) in the input stream are dropped. diff --git a/streamly.cabal b/streamly.cabal --- a/streamly.cabal +++ b/streamly.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: streamly -version: 0.8.1.1 +version: 0.8.2 synopsis: Dataflow programming and declarative concurrency description: Browse the documentation at https://streamly.composewell.com. @@ -56,6 +56,13 @@ benchmark/bench-report/bin/build-lib.sh benchmark/bench-report/cabal.project benchmark/Streamly/Benchmark/Data/*.hs + benchmark/Streamly/Benchmark/Data/Array/Common.hs + benchmark/Streamly/Benchmark/Data/Array/CommonImports.hs + benchmark/Streamly/Benchmark/Data/Array/SmallArray.hs + benchmark/Streamly/Benchmark/Data/Array/Foreign.hs + benchmark/Streamly/Benchmark/Data/Array/Foreign/Mut.hs + benchmark/Streamly/Benchmark/Data/Array/Prim.hs + benchmark/Streamly/Benchmark/Data/Array/Prim/Pinned.hs benchmark/Streamly/Benchmark/Data/Array/Stream/Foreign.hs benchmark/Streamly/Benchmark/Data/Parser/*.hs benchmark/Streamly/Benchmark/Data/Stream/*.hs @@ -80,14 +87,16 @@ src/Streamly/Internal/Data/Stream/Instances.hs src/Streamly/Internal/Data/Stream/PreludeCommon.hs src/Streamly/Internal/Data/Time/Clock/config-clock.h + src/Streamly/Internal/Data/Array/ArrayMacros.h src/Streamly/Internal/Data/Array/PrimInclude.hs src/Streamly/Internal/Data/Array/Prim/TypesInclude.hs src/Streamly/Internal/Data/Array/Prim/MutTypesInclude.hs src/Streamly/Internal/FileSystem/Event/Darwin.h src/config.h.in src/inline.hs - test/Streamly/Test/Common/Array.hs test/Streamly/Test/Data/*.hs + test/Streamly/Test/Data/Array/CommonImports.hs + test/Streamly/Test/Data/Array/Common.hs test/Streamly/Test/Data/Array/Prim.hs test/Streamly/Test/Data/Array/Prim/Pinned.hs test/Streamly/Test/Data/Array/Foreign.hs @@ -120,7 +129,7 @@ extra-doc-files: CONTRIBUTING.md - Changelog.md + CHANGELOG.md README.md benchmark/README.md dev/*.md @@ -193,6 +202,16 @@ manual: True default: False +flag streamly-core + description: Build only the core modules + manual: True + default: False + +flag use-unliftio + description: Use unliftio-core instead of monad-control + manual: True + default: False + ------------------------------------------------------------------------------- -- Common stanzas ------------------------------------------------------------------------------- @@ -232,6 +251,7 @@ -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances + -Wmissing-export-lists -Rghc-timing if flag(has-llvm) @@ -244,6 +264,9 @@ if flag(limit-build-mem) ghc-options: +RTS -M1000M -RTS + if flag(use-unliftio) + cpp-options: -DUSE_UNLIFTIO + common default-extensions default-extensions: BangPatterns @@ -314,85 +337,52 @@ default-extensions: QuantifiedConstraints js-sources: jsbits/clock.js - include-dirs: src, src/Streamly/Internal/Data/Stream + include-dirs: + src + , src/Streamly/Internal/Data/Stream + , src/Streamly/Internal/Data/Array + if os(windows) c-sources: src/Streamly/Internal/Data/Time/Clock/Windows.c - exposed-modules: Streamly.Internal.FileSystem.Event.Windows - build-depends: Win32 >= 2.6 && < 2.13 if os(darwin) - frameworks: Cocoa include-dirs: src/Streamly/Internal c-sources: src/Streamly/Internal/Data/Time/Clock/Darwin.c - , src/Streamly/Internal/FileSystem/Event/Darwin.m - exposed-modules: - Streamly.Internal.FileSystem.Event.Darwin - if os(linux) - exposed-modules: Streamly.Internal.FileSystem.Event.Linux - - if os(linux) || os(darwin) || os(windows) - exposed-modules: Streamly.Internal.FileSystem.Event - hs-source-dirs: src - other-modules: - Streamly.Data.Array - , Streamly.Data.Prim.Array - , Streamly.Data.SmallArray - exposed-modules: - Streamly.Prelude - , Streamly.Data.Unfold - , Streamly.Data.Fold - , Streamly.Data.Fold.Tee - , Streamly.Data.Array.Foreign - - -- Text Processing - , Streamly.Unicode.Stream - - -- Filesystem/IO - , Streamly.FileSystem.Handle - , Streamly.Console.Stdio - - -- Network/IO - , Streamly.Network.Socket - , Streamly.Network.Inet.TCP - - -- Deprecated - , Streamly - , Streamly.Data.Unicode.Stream - , Streamly.Memory.Array - - -- Internal modules, listed roughly in dependency order - -- To view dependency graph: + -- Internal modules, listed roughly in bottom up + -- dependency order To view dependency graph: -- graphmod | dot -Tps > deps.ps -- streamly-base - , Streamly.Internal.BaseCompat + Streamly.Internal.BaseCompat , Streamly.Internal.Control.Exception , Streamly.Internal.Control.Monad - , Streamly.Internal.Control.Concurrent + , Streamly.Internal.Control.ForkIO , Streamly.Internal.Data.Cont + , Streamly.Internal.Foreign.Malloc + , Streamly.Internal.System.IO + + -- streamly-strict-data , Streamly.Internal.Data.Tuple.Strict , Streamly.Internal.Data.Maybe.Strict , Streamly.Internal.Data.Either.Strict - , Streamly.Internal.Foreign.Malloc - , Streamly.Internal.Data.Atomics + + -- XXX Depends on monad-control or unliftio-core + , Streamly.Internal.Control.Concurrent + , Streamly.Internal.Control.ForkLifted , Streamly.Internal.Data.IOFinalizer + + -- streamly-time , Streamly.Internal.Data.Time , Streamly.Internal.Data.Time.TimeSpec , Streamly.Internal.Data.Time.Units , Streamly.Internal.Data.Time.Clock.Type , Streamly.Internal.Data.Time.Clock - , Streamly.Internal.System.IO - , Streamly.Internal.System.IOVec.Type - -- streamly-core-stream + -- streamly-core-stream-types , Streamly.Internal.Data.SVar.Type - , Streamly.Internal.Data.SVar.Worker - , Streamly.Internal.Data.SVar.Dispatch - , Streamly.Internal.Data.SVar.Pull - , Streamly.Internal.Data.SVar , Streamly.Internal.Data.Stream.StreamK.Type , Streamly.Internal.Data.Fold.Step , Streamly.Internal.Data.Refold.Type @@ -409,22 +399,18 @@ , Streamly.Internal.Data.Parser.ParserD.Type , Streamly.Internal.Data.Pipe.Type + -- streamly-core-array-types -- Unboxed IORef + -- XXX Depends on primitive , Streamly.Internal.Data.IORef.Prim - - -- streamly-core-array -- May depend on streamly-core-stream , Streamly.Internal.Data.Array.Foreign.Mut.Type , Streamly.Internal.Data.Array.Foreign.Mut , Streamly.Internal.Data.Array.Foreign.Type - , Streamly.Internal.Data.Array.Prim.Mut.Type - , Streamly.Internal.Data.Array.Prim.Type - , Streamly.Internal.Data.Array.Prim.Pinned.Mut.Type - , Streamly.Internal.Data.Array.Prim.Pinned.Type - , Streamly.Internal.Data.SmallArray.Type + , Streamly.Internal.Data.Array.Mut.Type - -- streamly-base-streams - -- StreamD depends on streamly-core-array + -- streamly-core-streams + -- StreamD depends on streamly-array-types , Streamly.Internal.Data.Stream.StreamD.Generate , Streamly.Internal.Data.Stream.StreamD.Eliminate , Streamly.Internal.Data.Stream.StreamD.Nesting @@ -438,26 +424,70 @@ , Streamly.Internal.Data.Parser.ParserD.Tee , Streamly.Internal.Data.Parser.ParserD - -- streamly-core + -- streamly-core-data , Streamly.Internal.Data.Unfold - , Streamly.Internal.Data.Unfold.SVar , Streamly.Internal.Data.Unfold.Enumeration , Streamly.Internal.Data.Fold.Tee , Streamly.Internal.Data.Fold - , Streamly.Internal.Data.Fold.SVar - , Streamly.Internal.Data.Fold.Async , Streamly.Internal.Data.Sink , Streamly.Internal.Data.Parser , Streamly.Internal.Data.Pipe + , Streamly.Internal.Data.Stream.Serial + , Streamly.Internal.Data.Stream.Zip + , Streamly.Internal.Data.List + -- streamly-core-data-arrays + -- XXX Depends on primitive + , Streamly.Internal.Data.Array + , Streamly.Internal.Data.Array.Foreign + , Streamly.Internal.Data.Array.Stream.Mut.Foreign + , Streamly.Internal.Data.Array.Stream.Fold.Foreign + + -- Ring Arrays + , Streamly.Internal.Data.Ring.Foreign + -- XXX Depends on primitive + , Streamly.Internal.Data.Ring + + -- Only used for benchmarks + , Streamly.Internal.Data.Stream.StreamK + + -- streamly-core exposed modules + , Streamly.Data.Fold + , Streamly.Data.Fold.Tee + , Streamly.Data.Array.Foreign + + if !flag(streamly-core) + exposed-modules: + -- XXX To be moved to streamly-core + Streamly.Data.Unfold + + -- XXX To be removed or put under dev flag + , Streamly.Internal.Data.Array.Prim.Mut.Type + , Streamly.Internal.Data.Array.Prim.Type + , Streamly.Internal.Data.Array.Prim.Pinned.Mut.Type + , Streamly.Internal.Data.Array.Prim.Pinned.Type + , Streamly.Internal.Data.SmallArray.Type + , Streamly.Internal.Data.Array.Prim + , Streamly.Internal.Data.Array.Prim.Pinned + , Streamly.Internal.Data.SmallArray + + -- streamly-concurrent + , Streamly.Internal.Data.Atomics + , Streamly.Internal.Data.SVar.Worker + , Streamly.Internal.Data.SVar.Dispatch + , Streamly.Internal.Data.SVar.Pull + , Streamly.Internal.Data.SVar + + , Streamly.Internal.Data.Unfold.SVar + , Streamly.Internal.Data.Fold.SVar + , Streamly.Internal.Data.Fold.Async , Streamly.Internal.Data.Stream.SVar.Generate , Streamly.Internal.Data.Stream.SVar.Eliminate - , Streamly.Internal.Data.Stream.Serial + , Streamly.Internal.Data.Stream.Async , Streamly.Internal.Data.Stream.Parallel , Streamly.Internal.Data.Stream.Ahead - , Streamly.Internal.Data.Stream.Zip - , Streamly.Internal.Data.List + , Streamly.Internal.Data.Stream.ZipAsync , Streamly.Internal.Data.Stream.IsStream.Type , Streamly.Internal.Data.Stream.IsStream.Combinators @@ -473,23 +503,10 @@ , Streamly.Internal.Data.Stream.IsStream.Top , Streamly.Internal.Data.Stream.IsStream - -- streamly-arrays - -- May depend on streamly-core - , Streamly.Internal.Data.Array - , Streamly.Internal.Data.Array.Foreign - , Streamly.Internal.Data.Array.Prim - , Streamly.Internal.Data.Array.Prim.Pinned - , Streamly.Internal.Data.SmallArray - , Streamly.Internal.Data.Array.Stream.Mut.Foreign , Streamly.Internal.Data.Array.Stream.Foreign - , Streamly.Internal.Data.Array.Stream.Fold.Foreign - -- Memory storage - , Streamly.Internal.Ring.Foreign - , Streamly.Internal.Data.Ring - - -- IOVec (depends on arrays/streams) - , Streamly.Internal.System.IOVec + -- streamly-serde + , Streamly.Internal.Data.Binary.Decode -- streamly-unicode , Streamly.Internal.Unicode.Stream @@ -499,10 +516,9 @@ , Streamly.Internal.Unicode.Array.Char , Streamly.Internal.Unicode.Array.Prim.Pinned - -- streamly-serde - , Streamly.Internal.Data.Binary.Decode - -- streamly-filesystem + , Streamly.Internal.System.IOVec.Type + , Streamly.Internal.System.IOVec , Streamly.Internal.FileSystem.Handle , Streamly.Internal.FileSystem.Dir , Streamly.Internal.FileSystem.File @@ -516,9 +532,43 @@ , Streamly.Internal.Network.Socket , Streamly.Internal.Network.Inet.TCP - -- Only used for benchmarks - , Streamly.Internal.Data.Stream.StreamK + -- Exposed modules + , Streamly.Prelude + -- Text Processing + , Streamly.Unicode.Stream + + -- Filesystem/IO + , Streamly.FileSystem.Handle + , Streamly.Console.Stdio + + -- Network/IO + , Streamly.Network.Socket + , Streamly.Network.Inet.TCP + + -- Deprecated + , Streamly + , Streamly.Data.Unicode.Stream + , Streamly.Memory.Array + + other-modules: + Streamly.Data.Array + , Streamly.Data.Prim.Array + , Streamly.Data.SmallArray + + if os(windows) + exposed-modules: Streamly.Internal.FileSystem.Event.Windows + + if os(darwin) + c-sources: src/Streamly/Internal/FileSystem/Event/Darwin.m + exposed-modules: Streamly.Internal.FileSystem.Event.Darwin + + if os(linux) + exposed-modules: Streamly.Internal.FileSystem.Event.Linux + + if os(linux) || os(darwin) || os(windows) + exposed-modules: Streamly.Internal.FileSystem.Event + build-depends: -- Core libraries shipped with ghc, the min and max -- constraints of these libraries should match with @@ -526,33 +576,44 @@ -- packages depending on the "ghc" package (packages -- depending on doctest is a common example) can -- depend on streamly. - base >= 4.9 && < 5 + base >= 4.9 && < 4.17 , containers >= 0.5 && < 0.7 , deepseq >= 1.4.1 && < 1.5 , directory >= 1.2.2 && < 1.4 , exceptions >= 0.8 && < 0.11 , ghc-prim >= 0.2 && < 0.9 - , mtl >= 2.2 && < 3 - , primitive >= 0.5.4 && < 0.8 + , mtl >= 2.2 && < 2.3 , transformers >= 0.4 && < 0.7 + , filepath >= 1.2.0.0 && < 1.5 + , fusion-plugin-types >= 0.1 && < 0.2 + + -- XXX to be removed + , transformers-base >= 0.4 && < 0.5 + , primitive >= 0.5.4 && < 0.8 , heaps >= 0.3 && < 0.5 - , filepath >= 1.2.0.0 && < 1.4.3.0 + if flag(use-unliftio) + build-depends: unliftio-core >= 0.2 && < 0.3 + else + build-depends: monad-control >= 1.0 && < 1.1 + if !flag(streamly-core) + build-depends: -- concurrency , atomic-primops >= 0.8 && < 0.9 , lockfree-queue >= 0.2.3 && < 0.3 - -- transfomers - , monad-control >= 1.0 && < 2 - , transformers-base >= 0.4 && < 0.5 - - , fusion-plugin-types >= 0.1 && < 0.2 - , unicode-data >= 0.1 && < 0.3 + , unicode-data >= 0.1 && < 0.4 -- Network - , network >= 2.6 && < 4 + , network >= 2.6 && < 3.2 + + if os(windows) + build-depends: Win32 >= 2.6 && < 2.13 + + if os(darwin) + frameworks: Cocoa if flag(inspection) build-depends: template-haskell >= 2.14 && < 2.17 diff --git a/test/Streamly/Test/Common/Array.hs b/test/Streamly/Test/Common/Array.hs deleted file mode 100644 --- a/test/Streamly/Test/Common/Array.hs +++ /dev/null @@ -1,291 +0,0 @@ --- | --- Module : Main --- Copyright : (c) 2019 Composewell Technologies --- --- License : BSD-3-Clause --- Maintainer : streamly@composewell.com --- Stability : experimental --- Portability : GHC --- - --- This is a common array test module that gets included in different --- Array test modules with the corresponding macro defined. --- --- Meanings of CPP macros: --- Default => Data.Array --- TEST_ARRAY => Data.Array.Foreign --- TEST_SMALL_ARRAY => Data.SmallArray --- DATA_ARRAY_PRIM => Data.Array.Prim --- DATA_ARRAY_PRIM_PINNED => Data.Array.Prim.Pinned - -import Foreign.Storable (Storable(..)) - -import Test.Hspec.QuickCheck -import Test.QuickCheck (Property, forAll, Gen, vectorOf, arbitrary, choose) -import Test.QuickCheck.Monadic (monadicIO, assert, run) -import Test.Hspec as H - -import Streamly.Data.Fold (Fold) -import Streamly.Prelude (SerialT) -import Streamly.Test.Common (listEquals) - -import qualified Streamly.Prelude as S - -#if defined(TEST_ARRAY) ||\ - defined(DATA_ARRAY_PRIM) ||\ - defined(DATA_ARRAY_PRIM_PINNED) -import qualified Streamly.Internal.Data.Fold as Fold -#endif - -#ifdef TEST_SMALL_ARRAY -import qualified Streamly.Internal.Data.SmallArray as A -type Array = A.SmallArray -#elif defined(TEST_ARRAY) -import Data.Word(Word8) - -import qualified Streamly.Internal.Data.Array.Foreign as A -import qualified Streamly.Internal.Data.Array.Foreign.Type as A -import qualified Streamly.Internal.Data.Array.Foreign.Mut.Type as MA -import qualified Streamly.Internal.Data.Array.Stream.Foreign as AS -type Array = A.Array -#elif defined(DATA_ARRAY_PRIM_PINNED) -import qualified Streamly.Internal.Data.Array.Prim.Pinned as A -import qualified Streamly.Internal.Data.Array.Prim.Pinned.Type as A -type Array = A.Array -#elif defined(DATA_ARRAY_PRIM) -import qualified Streamly.Internal.Data.Array.Prim as A -import qualified Streamly.Internal.Data.Array.Prim.Type as A -type Array = A.Array -#else -import qualified Streamly.Internal.Data.Array as A -type Array = A.Array -#endif - -moduleName :: String -#ifdef TEST_SMALL_ARRAY -moduleName = "Data.SmallArray" -#elif defined(TEST_ARRAY) -moduleName = "Data.Array.Foreign" -#elif defined(DATA_ARRAY_PRIM_PINNED) -moduleName = "Data.Array.Prim.Pinned" -#elif defined(DATA_ARRAY_PRIM) -moduleName = "Data.Array.Prim" -#else -moduleName = "Data.Array" -#endif - --- Coverage build takes too long with default number of tests -maxTestCount :: Int -#ifdef DEVBUILD -maxTestCount = 100 -#else -maxTestCount = 10 -#endif - -allocOverhead :: Int -allocOverhead = 2 * sizeOf (undefined :: Int) - --- XXX this should be in sync with the defaultChunkSize in Array code, or we --- should expose that and use that. For fast testing we could reduce the --- defaultChunkSize under CPP conditionals. --- -defaultChunkSize :: Int -defaultChunkSize = 32 * k - allocOverhead - where k = 1024 - -maxArrLen :: Int -maxArrLen = defaultChunkSize * 8 - -genericTestFrom :: - (Int -> SerialT IO Int -> IO (Array Int)) - -> Property -genericTestFrom arrFold = - forAll (choose (0, maxArrLen)) $ \len -> - forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> - monadicIO $ do - arr <- run $ arrFold len $ S.fromList list - assert (A.length arr == len) - -testLength :: Property -testLength = genericTestFrom (\n -> S.fold (A.writeN n)) - -testLengthFromStreamN :: Property -testLengthFromStreamN = genericTestFrom A.fromStreamN - -#ifndef TEST_SMALL_ARRAY -testLengthFromStream :: Property -testLengthFromStream = genericTestFrom (const A.fromStream) -#endif - -genericTestFromTo :: - (Int -> SerialT IO Int -> IO (Array Int)) - -> (Array Int -> SerialT IO Int) - -> ([Int] -> [Int] -> Bool) - -> Property -genericTestFromTo arrFold arrUnfold listEq = - forAll (choose (0, maxArrLen)) $ \len -> - forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> - monadicIO $ do - arr <- run $ arrFold len $ S.fromList list - xs <- run $ S.toList $ arrUnfold arr - assert (listEq xs list) - -testFoldNUnfold :: Property -testFoldNUnfold = - genericTestFromTo (\n -> S.fold (A.writeN n)) (S.unfold A.read) (==) - -testFoldNToStream :: Property -testFoldNToStream = - genericTestFromTo (\n -> S.fold (A.writeN n)) A.toStream (==) - -testFoldNToStreamRev :: Property -testFoldNToStreamRev = - genericTestFromTo - (\n -> S.fold (A.writeN n)) - A.toStreamRev - (\xs list -> xs == reverse list) - -testFromStreamNUnfold :: Property -testFromStreamNUnfold = genericTestFromTo A.fromStreamN (S.unfold A.read) (==) - -testFromStreamNToStream :: Property -testFromStreamNToStream = genericTestFromTo A.fromStreamN A.toStream (==) - -testFromListN :: Property -testFromListN = - forAll (choose (0, maxArrLen)) $ \len -> - forAll (choose (0, len)) $ \n -> - forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> - monadicIO $ do - let arr = A.fromListN n list - xs <- run $ S.toList $ (S.unfold A.read) arr - listEquals (==) xs (take n list) - -#ifndef TEST_SMALL_ARRAY -testFromStreamToStream :: Property -testFromStreamToStream = genericTestFromTo (const A.fromStream) A.toStream (==) - -testFoldUnfold :: Property -testFoldUnfold = genericTestFromTo (const (S.fold A.write)) (S.unfold A.read) (==) - -testFromList :: Property -testFromList = - forAll (choose (0, maxArrLen)) $ \len -> - forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> - monadicIO $ do - let arr = A.fromList list - xs <- run $ S.toList $ (S.unfold A.read) arr - assert (xs == list) -#endif - -foldManyWith :: (Int -> Fold IO Int (Array Int)) -> Property -foldManyWith f = - forAll (choose (0, maxArrLen)) $ \len -> - forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> - monadicIO $ do - xs <- run - $ S.toList - $ S.unfoldMany A.read - $ S.foldMany (f 240) - $ S.fromList list - assert (xs == list) - -#ifdef TEST_ARRAY - -unsafeWriteIndex :: [Int] -> Int -> Int -> IO Bool -unsafeWriteIndex xs i x = do - arr <- MA.fromList xs - MA.putIndexUnsafe arr i x - x1 <- MA.getIndexUnsafe arr i - return $ x1 == x - -lastN :: Int -> [a] -> [a] -lastN n l = drop (length l - n) l - -testLastN :: Property -testLastN = - forAll (choose (0, maxArrLen)) $ \len -> - forAll (choose (0, len)) $ \n -> - forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> - monadicIO $ do - xs <- run - $ fmap A.toList - $ S.fold (A.writeLastN n) - $ S.fromList list - assert (xs == lastN n list) - -testLastN_LN :: Int -> Int -> IO Bool -testLastN_LN len n = do - let list = [1..len] - l1 <- fmap A.toList $ S.fold (A.writeLastN n) $ S.fromList list - let l2 = lastN n list - return $ l1 == l2 - --- Instead of hard coding 10000 here we can have maxStreamLength for operations --- that use stream of arrays. -concatArrayW8 :: Property -concatArrayW8 = - forAll (vectorOf 10000 (arbitrary :: Gen Word8)) - $ \w8List -> do - let w8ArrList = A.fromList . (: []) <$> w8List - f2 <- S.toList $ AS.concat $ S.fromList w8ArrList - w8List `shouldBe` f2 - -unsafeSlice :: Int -> Int -> [Int] -> Bool -unsafeSlice i n list = - let lst = take n $ drop i $ list - arr = A.toList $ A.getSliceUnsafe i n $ A.fromList list - in arr == lst - -#endif - -main :: IO () -main = - hspec $ - H.parallel $ - modifyMaxSuccess (const maxTestCount) $ do - describe moduleName $ do - describe "Construction" $ do - prop "length . writeN n === n" testLength - prop "length . fromStreamN n === n" testLengthFromStreamN - prop "read . writeN === id " testFoldNUnfold - prop "toStream . writeN === id" testFoldNToStream - prop "toStreamRev . writeN === reverse" testFoldNToStreamRev - prop "read . fromStreamN === id" testFromStreamNUnfold - prop "toStream . fromStreamN === id" testFromStreamNToStream - prop "fromListN" testFromListN - -#ifndef TEST_SMALL_ARRAY - prop "length . fromStream === n" testLengthFromStream - prop "toStream . fromStream === id" testFromStreamToStream - prop "read . write === id" testFoldUnfold - prop "fromList" testFromList -#endif - -#if defined(TEST_ARRAY) ||\ - defined(DATA_ARRAY_PRIM) ||\ - defined(DATA_ARRAY_PRIM_PINNED) - prop "foldMany with writeNUnsafe concats to original" - (foldManyWith (\n -> Fold.take n (A.writeNUnsafe n))) -#endif - prop "foldMany with writeN concats to original" - (foldManyWith A.writeN) - -#ifdef TEST_ARRAY - prop "AS.concat . (A.fromList . (:[]) <$>) === id" $ concatArrayW8 - describe "unsafeSlice" $ do - it "partial" $ unsafeSlice 2 4 [1..10] - it "none" $ unsafeSlice 10 0 [1..10] - it "full" $ unsafeSlice 0 10 [1..10] - describe "Mut.unsafeWriteIndex" $ do - it "first" (unsafeWriteIndex [1..10] 0 0 `shouldReturn` True) - it "middle" (unsafeWriteIndex [1..10] 5 0 `shouldReturn` True) - it "last" (unsafeWriteIndex [1..10] 9 0 `shouldReturn` True) - describe "Fold" $ do - prop "writeLastN : 0 <= n <= len" $ testLastN - describe "writeLastN boundary conditions" $ do - it "writeLastN -1" (testLastN_LN 10 (-1) `shouldReturn` True) - it "writeLastN 0" (testLastN_LN 10 0 `shouldReturn` True) - it "writeLastN length" (testLastN_LN 10 10 `shouldReturn` True) - it "writeLastN (length + 1)" (testLastN_LN 10 11 `shouldReturn` True) -#endif diff --git a/test/Streamly/Test/Data/Array.hs b/test/Streamly/Test/Data/Array.hs --- a/test/Streamly/Test/Data/Array.hs +++ b/test/Streamly/Test/Data/Array.hs @@ -6,6 +6,45 @@ -- Stability : experimental -- Portability : GHC -module Streamly.Test.Data.Array where +module Streamly.Test.Data.Array (main) where -#include "Streamly/Test/Common/Array.hs" +#include "Streamly/Test/Data/Array/CommonImports.hs" + +import qualified Streamly.Internal.Data.Array as A +type Array = A.Array + +moduleName :: String +moduleName = "Data.Array" + +#include "Streamly/Test/Data/Array/Common.hs" + +testFromStreamToStream :: Property +testFromStreamToStream = genericTestFromTo (const A.fromStream) A.toStream (==) + +testFoldUnfold :: Property +testFoldUnfold = genericTestFromTo (const (S.fold A.write)) (S.unfold A.read) (==) + +testFromList :: Property +testFromList = + forAll (choose (0, maxArrLen)) $ \len -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> + monadicIO $ do + let arr = A.fromList list + xs <- run $ S.toList $ (S.unfold A.read) arr + assert (xs == list) + +testLengthFromStream :: Property +testLengthFromStream = genericTestFrom (const A.fromStream) + +main :: IO () +main = + hspec $ + H.parallel $ + modifyMaxSuccess (const maxTestCount) $ do + describe moduleName $ do + commonMain + describe "Construction" $ do + prop "length . fromStream === n" testLengthFromStream + prop "toStream . fromStream === id" testFromStreamToStream + prop "read . write === id" testFoldUnfold + prop "fromList" testFromList diff --git a/test/Streamly/Test/Data/Array/Common.hs b/test/Streamly/Test/Data/Array/Common.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/Array/Common.hs @@ -0,0 +1,109 @@ + +-- Coverage build takes too long with default number of tests +maxTestCount :: Int +#ifdef DEVBUILD +maxTestCount = 100 +#else +maxTestCount = 10 +#endif + +allocOverhead :: Int +allocOverhead = 2 * sizeOf (undefined :: Int) + +-- XXX this should be in sync with the defaultChunkSize in Array code, or we +-- should expose that and use that. For fast testing we could reduce the +-- defaultChunkSize under CPP conditionals. +-- +defaultChunkSize :: Int +defaultChunkSize = 32 * k - allocOverhead + where k = 1024 + +maxArrLen :: Int +maxArrLen = defaultChunkSize * 8 + +genericTestFrom :: + (Int -> SerialT IO Int -> IO (Array Int)) + -> Property +genericTestFrom arrFold = + forAll (choose (0, maxArrLen)) $ \len -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> + monadicIO $ do + arr <- run $ arrFold len $ S.fromList list + assert (A.length arr == len) + +testLength :: Property +testLength = genericTestFrom (S.fold . A.writeN) + +testLengthFromStreamN :: Property +testLengthFromStreamN = genericTestFrom A.fromStreamN + +genericTestFromTo :: + (Int -> SerialT IO Int -> IO (Array Int)) + -> (Array Int -> SerialT IO Int) + -> ([Int] -> [Int] -> Bool) + -> Property +genericTestFromTo arrFold arrUnfold listEq = + forAll (choose (0, maxArrLen)) $ \len -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> + monadicIO $ do + arr <- run $ arrFold len $ S.fromList list + xs <- run $ S.toList $ arrUnfold arr + assert (listEq xs list) + + +testFoldNUnfold :: Property +testFoldNUnfold = + genericTestFromTo (S.fold . A.writeN) (S.unfold A.read) (==) + +testFoldNToStream :: Property +testFoldNToStream = + genericTestFromTo (S.fold . A.writeN) A.toStream (==) + +testFoldNToStreamRev :: Property +testFoldNToStreamRev = + genericTestFromTo + (S.fold . A.writeN) + A.toStreamRev + (\xs list -> xs == reverse list) + +testFromStreamNUnfold :: Property +testFromStreamNUnfold = genericTestFromTo A.fromStreamN (S.unfold A.read) (==) + +testFromStreamNToStream :: Property +testFromStreamNToStream = genericTestFromTo A.fromStreamN A.toStream (==) + +testFromListN :: Property +testFromListN = + forAll (choose (0, maxArrLen)) $ \len -> + forAll (choose (0, len)) $ \n -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> + monadicIO $ do + let arr = A.fromListN n list + xs <- run $ S.toList $ S.unfold A.read arr + listEquals (==) xs (take n list) + +foldManyWith :: (Int -> Fold IO Int (Array Int)) -> Property +foldManyWith f = + forAll (choose (0, maxArrLen)) $ \len -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> + monadicIO $ do + xs <- run + $ S.toList + $ S.unfoldMany A.read + $ S.foldMany (f 240) + $ S.fromList list + assert (xs == list) + +commonMain :: SpecWith () +commonMain = do + describe "Construction" $ do + prop "length . writeN n === n" testLength + prop "length . fromStreamN n === n" testLengthFromStreamN + prop "read . writeN === id " testFoldNUnfold + prop "toStream . writeN === id" testFoldNToStream + prop "toStreamRev . writeN === reverse" testFoldNToStreamRev + prop "read . fromStreamN === id" testFromStreamNUnfold + prop "toStream . fromStreamN === id" testFromStreamNToStream + prop "fromListN" testFromListN + prop "foldMany with writeN concats to original" + (foldManyWith A.writeN) diff --git a/test/Streamly/Test/Data/Array/CommonImports.hs b/test/Streamly/Test/Data/Array/CommonImports.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Data/Array/CommonImports.hs @@ -0,0 +1,13 @@ + +import Foreign.Storable (Storable(..)) + +import Test.Hspec.QuickCheck +import Test.QuickCheck (Property, forAll, Gen, vectorOf, arbitrary, choose) +import Test.QuickCheck.Monadic (monadicIO, assert, run) +import Test.Hspec as H + +import Streamly.Data.Fold (Fold) +import Streamly.Prelude (SerialT) +import Streamly.Test.Common (listEquals) + +import qualified Streamly.Prelude as S diff --git a/test/Streamly/Test/Data/Array/Foreign.hs b/test/Streamly/Test/Data/Array/Foreign.hs --- a/test/Streamly/Test/Data/Array/Foreign.hs +++ b/test/Streamly/Test/Data/Array/Foreign.hs @@ -8,5 +8,113 @@ module Streamly.Test.Data.Array.Foreign (main) where -#define TEST_ARRAY -#include "Streamly/Test/Common/Array.hs" +#include "Streamly/Test/Data/Array/CommonImports.hs" + +import Data.Word(Word8) + +import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Internal.Data.Array.Foreign as A +import qualified Streamly.Internal.Data.Array.Foreign.Type as A +import qualified Streamly.Internal.Data.Array.Foreign.Mut.Type as MA +import qualified Streamly.Internal.Data.Array.Stream.Foreign as AS +type Array = A.Array + +moduleName :: String +moduleName = "Data.Array.Foreign" + +#include "Streamly/Test/Data/Array/Common.hs" + +testFromStreamToStream :: Property +testFromStreamToStream = genericTestFromTo (const A.fromStream) A.toStream (==) + +testFoldUnfold :: Property +testFoldUnfold = genericTestFromTo (const (S.fold A.write)) (S.unfold A.read) (==) + +testFromList :: Property +testFromList = + forAll (choose (0, maxArrLen)) $ \len -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> + monadicIO $ do + let arr = A.fromList list + xs <- run $ S.toList $ (S.unfold A.read) arr + assert (xs == list) + +testLengthFromStream :: Property +testLengthFromStream = genericTestFrom (const A.fromStream) + + +unsafeWriteIndex :: [Int] -> Int -> Int -> IO Bool +unsafeWriteIndex xs i x = do + arr <- MA.fromList xs + MA.putIndexUnsafe i x arr + x1 <- MA.getIndexUnsafe i arr + return $ x1 == x + +lastN :: Int -> [a] -> [a] +lastN n l = drop (length l - n) l + +testLastN :: Property +testLastN = + forAll (choose (0, maxArrLen)) $ \len -> + forAll (choose (0, len)) $ \n -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> + monadicIO $ do + xs <- run + $ fmap A.toList + $ S.fold (A.writeLastN n) + $ S.fromList list + assert (xs == lastN n list) + +testLastN_LN :: Int -> Int -> IO Bool +testLastN_LN len n = do + let list = [1..len] + l1 <- fmap A.toList $ S.fold (A.writeLastN n) $ S.fromList list + let l2 = lastN n list + return $ l1 == l2 + +-- Instead of hard coding 10000 here we can have maxStreamLength for operations +-- that use stream of arrays. +concatArrayW8 :: Property +concatArrayW8 = + forAll (vectorOf 10000 (arbitrary :: Gen Word8)) + $ \w8List -> do + let w8ArrList = A.fromList . (: []) <$> w8List + f2 <- S.toList $ AS.concat $ S.fromList w8ArrList + w8List `shouldBe` f2 + +unsafeSlice :: Int -> Int -> [Int] -> Bool +unsafeSlice i n list = + let lst = take n $ drop i $ list + arr = A.toList $ A.getSliceUnsafe i n $ A.fromList list + in arr == lst + +main :: IO () +main = + hspec $ + H.parallel $ + modifyMaxSuccess (const maxTestCount) $ do + describe moduleName $ do + commonMain + describe "Construction" $ do + prop "length . fromStream === n" testLengthFromStream + prop "toStream . fromStream === id" testFromStreamToStream + prop "read . write === id" testFoldUnfold + prop "fromList" testFromList + prop "foldMany with writeNUnsafe concats to original" + (foldManyWith (\n -> Fold.take n (A.writeNUnsafe n))) + prop "AS.concat . (A.fromList . (:[]) <$>) === id" $ concatArrayW8 + describe "unsafeSlice" $ do + it "partial" $ unsafeSlice 2 4 [1..10] + it "none" $ unsafeSlice 10 0 [1..10] + it "full" $ unsafeSlice 0 10 [1..10] + describe "Mut.unsafeWriteIndex" $ do + it "first" (unsafeWriteIndex [1..10] 0 0 `shouldReturn` True) + it "middle" (unsafeWriteIndex [1..10] 5 0 `shouldReturn` True) + it "last" (unsafeWriteIndex [1..10] 9 0 `shouldReturn` True) + describe "Fold" $ do + prop "writeLastN : 0 <= n <= len" $ testLastN + describe "writeLastN boundary conditions" $ do + it "writeLastN -1" (testLastN_LN 10 (-1) `shouldReturn` True) + it "writeLastN 0" (testLastN_LN 10 0 `shouldReturn` True) + it "writeLastN length" (testLastN_LN 10 10 `shouldReturn` True) + it "writeLastN (length + 1)" (testLastN_LN 10 11 `shouldReturn` True) diff --git a/test/Streamly/Test/Data/Array/Prim.hs b/test/Streamly/Test/Data/Array/Prim.hs --- a/test/Streamly/Test/Data/Array/Prim.hs +++ b/test/Streamly/Test/Data/Array/Prim.hs @@ -6,7 +6,50 @@ -- Stability : experimental -- Portability : GHC -module Streamly.Test.Data.Array.Prim where +module Streamly.Test.Data.Array.Prim (main) where -#define DATA_ARRAY_PRIM -#include "Streamly/Test/Common/Array.hs" +#include "Streamly/Test/Data/Array/CommonImports.hs" + +import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Internal.Data.Array.Prim as A +import qualified Streamly.Internal.Data.Array.Prim.Type as A +type Array = A.Array + +moduleName :: String +moduleName = "Data.Array.Prim" + +#include "Streamly/Test/Data/Array/Common.hs" + +testFromStreamToStream :: Property +testFromStreamToStream = genericTestFromTo (const A.fromStream) A.toStream (==) + +testFoldUnfold :: Property +testFoldUnfold = genericTestFromTo (const (S.fold A.write)) (S.unfold A.read) (==) + +testFromList :: Property +testFromList = + forAll (choose (0, maxArrLen)) $ \len -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> + monadicIO $ do + let arr = A.fromList list + xs <- run $ S.toList $ (S.unfold A.read) arr + assert (xs == list) + +testLengthFromStream :: Property +testLengthFromStream = genericTestFrom (const A.fromStream) + + +main :: IO () +main = + hspec $ + H.parallel $ + modifyMaxSuccess (const maxTestCount) $ do + describe moduleName $ do + commonMain + describe "Construction" $ do + prop "length . fromStream === n" testLengthFromStream + prop "toStream . fromStream === id" testFromStreamToStream + prop "read . write === id" testFoldUnfold + prop "fromList" testFromList + prop "foldMany with writeNUnsafe concats to original" + (foldManyWith (\n -> Fold.take n (A.writeNUnsafe n))) diff --git a/test/Streamly/Test/Data/Array/Prim/Pinned.hs b/test/Streamly/Test/Data/Array/Prim/Pinned.hs --- a/test/Streamly/Test/Data/Array/Prim/Pinned.hs +++ b/test/Streamly/Test/Data/Array/Prim/Pinned.hs @@ -6,7 +6,50 @@ -- Stability : experimental -- Portability : GHC -module Streamly.Test.Data.Array.Prim.Pinned where +module Streamly.Test.Data.Array.Prim.Pinned (main) where -#define DATA_ARRAY_PRIM_PINNED -#include "Streamly/Test/Common/Array.hs" +#include "Streamly/Test/Data/Array/CommonImports.hs" + +import qualified Streamly.Internal.Data.Fold as Fold +import qualified Streamly.Internal.Data.Array.Prim as A +import qualified Streamly.Internal.Data.Array.Prim.Type as A +type Array = A.Array + +moduleName :: String +moduleName = "Data.Array.Prim.Pinned" + +#include "Streamly/Test/Data/Array/Common.hs" + +testFromStreamToStream :: Property +testFromStreamToStream = genericTestFromTo (const A.fromStream) A.toStream (==) + +testFoldUnfold :: Property +testFoldUnfold = genericTestFromTo (const (S.fold A.write)) (S.unfold A.read) (==) + +testFromList :: Property +testFromList = + forAll (choose (0, maxArrLen)) $ \len -> + forAll (vectorOf len (arbitrary :: Gen Int)) $ \list -> + monadicIO $ do + let arr = A.fromList list + xs <- run $ S.toList $ (S.unfold A.read) arr + assert (xs == list) + +testLengthFromStream :: Property +testLengthFromStream = genericTestFrom (const A.fromStream) + + +main :: IO () +main = + hspec $ + H.parallel $ + modifyMaxSuccess (const maxTestCount) $ do + describe moduleName $ do + commonMain + describe "Construction" $ do + prop "length . fromStream === n" testLengthFromStream + prop "toStream . fromStream === id" testFromStreamToStream + prop "read . write === id" testFoldUnfold + prop "fromList" testFromList + prop "foldMany with writeNUnsafe concats to original" + (foldManyWith (\n -> Fold.take n (A.writeNUnsafe n))) diff --git a/test/Streamly/Test/Data/Parser.hs b/test/Streamly/Test/Data/Parser.hs --- a/test/Streamly/Test/Data/Parser.hs +++ b/test/Streamly/Test/Data/Parser.hs @@ -678,9 +678,9 @@ readOneEvent = do arr <- P.takeEQ 24 (A.writeN 24) let arr1 = A.unsafeCast arr :: A.Array Word64 - eid = A.unsafeIndex arr1 0 - eflags = A.unsafeIndex arr1 1 - pathLen = fromIntegral $ A.unsafeIndex arr1 2 + eid = A.unsafeIndex 0 arr1 + eflags = A.unsafeIndex 1 arr1 + pathLen = fromIntegral $ A.unsafeIndex 2 arr1 -- XXX handle if pathLen is 0 path <- P.takeEQ pathLen (A.writeN pathLen) return $ Event diff --git a/test/Streamly/Test/Data/Parser/ParserD.hs b/test/Streamly/Test/Data/Parser/ParserD.hs --- a/test/Streamly/Test/Data/Parser/ParserD.hs +++ b/test/Streamly/Test/Data/Parser/ParserD.hs @@ -669,9 +669,9 @@ readOneEvent = do arr <- P.takeEQ 24 (A.writeN 24) let arr1 = A.unsafeCast arr :: A.Array Word64 - eid = A.unsafeIndex arr1 0 - eflags = A.unsafeIndex arr1 1 - pathLen = fromIntegral $ A.unsafeIndex arr1 2 + eid = A.unsafeIndex 0 arr1 + eflags = A.unsafeIndex 1 arr1 + pathLen = fromIntegral $ A.unsafeIndex 2 arr1 path <- P.takeEQ pathLen (A.writeN pathLen) return $ Event { eventId = eid diff --git a/test/Streamly/Test/Data/SmallArray.hs b/test/Streamly/Test/Data/SmallArray.hs --- a/test/Streamly/Test/Data/SmallArray.hs +++ b/test/Streamly/Test/Data/SmallArray.hs @@ -6,7 +6,22 @@ -- Stability : experimental -- Portability : GHC -module Streamly.Test.Data.SmallArray where +module Streamly.Test.Data.SmallArray (main) where -#define TEST_SMALL_ARRAY -#include "Streamly/Test/Common/Array.hs" +#include "Streamly/Test/Data/Array/CommonImports.hs" + +import qualified Streamly.Internal.Data.SmallArray as A +type Array = A.SmallArray + +moduleName :: String +moduleName = "Data.SmallArray" + +#include "Streamly/Test/Data/Array/Common.hs" + +main :: IO () +main = + hspec $ + H.parallel $ + modifyMaxSuccess (const maxTestCount) $ do + describe moduleName $ do + commonMain diff --git a/test/Streamly/Test/FileSystem/Event/Darwin.hs b/test/Streamly/Test/FileSystem/Event/Darwin.hs --- a/test/Streamly/Test/FileSystem/Event/Darwin.hs +++ b/test/Streamly/Test/FileSystem/Event/Darwin.hs @@ -57,8 +57,9 @@ -- The watch root create event always seems to come even though the -- root is created before the watch is started. That may be because -- of batching? - -- XXX Need to create watch root after adding the watch - : dirCreate "" (\dir -> [(dir, dirEvent Event.isCreated)]) + -- XXX Need to create watch root after adding the watch, otherwise + -- it fails intermittently. + -- : dirCreate "" (\dir -> [(dir, dirEvent Event.isCreated)]) : rootDirMove "moved" (\src -> [ (src, Event.isRootPathEvent) , (src, Event.isMoved) diff --git a/test/Streamly/Test/Prelude/Ahead.hs b/test/Streamly/Test/Prelude/Ahead.hs --- a/test/Streamly/Test/Prelude/Ahead.hs +++ b/test/Streamly/Test/Prelude/Ahead.hs @@ -7,7 +7,7 @@ -- Stability : experimental -- Portability : GHC -module Streamly.Test.Prelude.Ahead where +module Streamly.Test.Prelude.Ahead (main) where #if __GLASGOW_HASKELL__ < 808 import Data.Semigroup ((<>)) diff --git a/test/Streamly/Test/Prelude/Async.hs b/test/Streamly/Test/Prelude/Async.hs --- a/test/Streamly/Test/Prelude/Async.hs +++ b/test/Streamly/Test/Prelude/Async.hs @@ -7,23 +7,52 @@ -- Stability : experimental -- Portability : GHC -module Streamly.Test.Prelude.Async where +module Streamly.Test.Prelude.Async (main) where +import Control.Concurrent (threadDelay) import Data.List (sort) #if __GLASGOW_HASKELL__ < 808 import Data.Semigroup ((<>)) #endif import Test.Hspec.QuickCheck +import Test.QuickCheck (Property, withMaxSuccess) +import Test.QuickCheck.Monadic (monadicIO, run) import Test.Hspec as H import Streamly.Prelude import qualified Streamly.Prelude as S +import Data.IORef +import Streamly.Test.Common import Streamly.Test.Prelude.Common + moduleName :: String -moduleName = "Prelude.Ahead" +moduleName = "Prelude.Async" +constructfromAsyncSingleThread :: + S.AsyncT IO Int -> S.AsyncT IO Int-> [Int] -> Property +constructfromAsyncSingleThread s1 s2 res = + withMaxSuccess maxTestCount $ + monadicIO $ do + x <- run + $ S.toList + $ S.fromAsync + $ S.maxThreads 1 + $ s1 `S.async` s2 + equals (==) x res + +concurrentApplicative :: IO () +concurrentApplicative = do + ref <- newIORef [] + let action i = modifyIORef ref (++ [i]) >> return (i :: Int) + s1 = S.fromEffect (threadDelay 2000000 >> action 1) + s2 = S.fromEffect (threadDelay 1000000 >> action 2) + res <- S.toList $ S.fromZipAsync $ (,) <$> s1 <*> s2 + refVal <- readIORef ref + res `shouldBe` [(1, 2)] + refVal `shouldBe` [2, 1] + main :: IO () main = hspec $ H.parallel @@ -43,6 +72,11 @@ asyncOps $ prop "asyncly consM" . constructWithConsM S.consM sort asyncOps $ prop "asyncly (.:)" . constructWithCons (S..:) asyncOps $ prop "asyncly (|:)" . constructWithConsM (S.|:) sort + prop "asyncSingleThreaded" $ + constructfromAsyncSingleThread + (S.fromList [1,2,3,4,5]) + (S.fromList [6,7,8,9,10]) + [1,2,3,4,5,6,7,8,9,10] describe "Functor operations" $ do asyncOps $ functorOps S.fromFoldable "asyncly" sortEq @@ -75,6 +109,7 @@ asyncOps $ prop "zip applicative asyncly folded" . zipAsyncApplicative folded (==) asyncOps $ prop "zip monadic asyncly" . zipAsyncMonadic S.fromFoldable (==) asyncOps $ prop "zip monadic asyncly folded" . zipAsyncMonadic folded (==) + it "zip monadic asyncly order" concurrentApplicative -- XXX add merge tests like zip tests -- for mergeBy, we can split a list randomly into two lists and diff --git a/test/Streamly/Test/Prelude/Concurrent.hs b/test/Streamly/Test/Prelude/Concurrent.hs --- a/test/Streamly/Test/Prelude/Concurrent.hs +++ b/test/Streamly/Test/Prelude/Concurrent.hs @@ -9,7 +9,7 @@ {-# LANGUAGE OverloadedLists #-} -module Streamly.Test.Prelude.Concurrent where +module Streamly.Test.Prelude.Concurrent (main) where import Control.Concurrent (MVar, takeMVar, threadDelay, putMVar, newEmptyMVar) import Control.Exception diff --git a/test/Streamly/Test/Prelude/Fold.hs b/test/Streamly/Test/Prelude/Fold.hs --- a/test/Streamly/Test/Prelude/Fold.hs +++ b/test/Streamly/Test/Prelude/Fold.hs @@ -7,7 +7,7 @@ -- Stability : experimental -- Portability : GHC -module Streamly.Test.Prelude.Fold where +module Streamly.Test.Prelude.Fold (main) where #ifdef DEVBUILD import Control.Concurrent (threadDelay) diff --git a/test/Streamly/Test/Prelude/Parallel.hs b/test/Streamly/Test/Prelude/Parallel.hs --- a/test/Streamly/Test/Prelude/Parallel.hs +++ b/test/Streamly/Test/Prelude/Parallel.hs @@ -7,7 +7,7 @@ -- Stability : experimental -- Portability : GHC -module Streamly.Test.Prelude.Parallel where +module Streamly.Test.Prelude.Parallel (main) where import Data.List (sort) #if !(MIN_VERSION_base(4,11,0)) diff --git a/test/Streamly/Test/Prelude/Rate.hs b/test/Streamly/Test/Prelude/Rate.hs --- a/test/Streamly/Test/Prelude/Rate.hs +++ b/test/Streamly/Test/Prelude/Rate.hs @@ -7,7 +7,7 @@ -- Stability : experimental -- Portability : GHC -module Streamly.Test.Prelude.Rate where +module Streamly.Test.Prelude.Rate (main) where import qualified Streamly.Prelude as S diff --git a/test/Streamly/Test/Prelude/Serial.hs b/test/Streamly/Test/Prelude/Serial.hs --- a/test/Streamly/Test/Prelude/Serial.hs +++ b/test/Streamly/Test/Prelude/Serial.hs @@ -7,7 +7,7 @@ -- Stability : experimental -- Portability : GHC -module Streamly.Test.Prelude.Serial where +module Streamly.Test.Prelude.Serial (checkTakeDropTime, main) where import Control.Concurrent ( threadDelay ) import Control.Monad ( when, forM_ ) diff --git a/test/Streamly/Test/Prelude/Top.hs b/test/Streamly/Test/Prelude/Top.hs new file mode 100644 --- /dev/null +++ b/test/Streamly/Test/Prelude/Top.hs @@ -0,0 +1,221 @@ +module Main (main) where + +import Data.List (elem, intersect, nub, sort) +import Data.Maybe (isNothing) +import Streamly.Prelude (SerialT) +import Test.QuickCheck + ( Gen + , Property + , choose + , forAll + , listOf + ) +import Test.QuickCheck.Monadic (monadicIO, assert, run) +import qualified Streamly.Prelude as S +import qualified Streamly.Internal.Data.Stream.IsStream.Top as Top + +import Prelude hiding + (maximum, minimum, elem, notElem, null, product, sum, head, last, take) +import Test.Hspec as H +import Test.Hspec.QuickCheck + +min_value :: Int +min_value = 0 + +max_value :: Int +max_value = 10000 + +chooseInt :: (Int, Int) -> Gen Int +chooseInt = choose + +eq :: Int -> Int -> Bool +eq = (==) + +joinInner :: Property +joinInner = + forAll (listOf (chooseInt (min_value, max_value))) $ \ls0 -> + forAll (listOf (chooseInt (min_value, max_value))) $ \ls1 -> + monadicIO $ action ls0 ls1 + + where + + action ls0 ls1 = do + v1 <- + run + $ S.toList + $ Top.joinInner eq (S.fromList ls0) (S.fromList $ sort ls1) + let v2 = [ (i,j) | i <- ls0, j <- ls1, i == j ] + assert (v1 == v2) + +joinInnerMap :: Property +joinInnerMap = + forAll (listOf (chooseInt (min_value, max_value))) $ \ls0 -> + forAll (listOf (chooseInt (min_value, max_value))) $ \ls1 -> + monadicIO $ + action + (map (\a -> (a,a)) ls0) + (map (\a -> (a,a)) ls1) + + where + + action ls0 ls1 = do + v1 <- + run + $ S.toList + $ Top.joinInnerMap (S.fromList ls0) (S.fromList ls1) + let v2 = [ + (fst i, fst i, fst j) + | i <- ls0, j <- nub ls1 + , fst i == fst j + ] + assert (sort v1 == sort v2) + +joinOuterList :: [(Int, Int)] -> [(Int, Int)] -> [(Int, Maybe Int, Maybe Int)] +joinOuterList ls0 ls1 = + let v2 = do + i <- ls0 + if i `elem` ls1 + then return (fst i, Just (fst i), Just (fst i)) + else return (fst i, Just (fst i), Nothing) + v3 = do + j <- ls1 + if j `elem` ls0 + then return (fst j, Just (fst j), Just (fst j)) + else return (fst j, Nothing, Just (fst j)) + v4 = filter (\(_, a2, _) -> isNothing a2) v3 + in v2 ++ v4 + +-- XXX A bug need to be fixed in joinOuter function +{- +joinOuter :: Property +joinOuter = + forAll (listOf (chooseInt (min_value, max_value))) $ \ls0 -> + forAll (listOf (chooseInt (min_value, max_value))) $ \ls1 -> + monadicIO $ action ls0 (nub ls1) + where + action ls0 ls1 = do + v1 <- + run + $ S.toList + $ Top.joinOuter eq (S.fromList ls0) (S.fromList ls1) + let v2 = joinOuterList + (map (\a -> (a, a)) ls0) + (map (\a -> (a, a)) ls1) + v3 = map (\(_, v10, v20) -> (v10, v20)) v2 + assert (sort v1 == sort v3) +-} + +joinOuterMap :: Property +joinOuterMap = + forAll (listOf (chooseInt (min_value, max_value))) $ \ls0 -> + forAll (listOf (chooseInt (min_value, max_value))) $ \ls1 -> + monadicIO $ + action + (map (\a -> (a,a)) (nub ls0)) + (map (\a -> (a,a)) (nub ls1)) + + where + + action ls0 ls1 = do + v1 <- + run + $ S.toList + $ Top.joinOuterMap (S.fromList ls0) (S.fromList ls1) + let v2 = joinOuterList ls0 ls1 + assert (sort v1 == sort v2) + +joinLeftList :: [(Int, Int)] -> [(Int, Int)] -> [(Int, Int, Maybe Int)] +joinLeftList ls0 ls1 = + let v = do + i <- ls0 + if i `elem` ls1 + then return (fst i, fst i, Just (fst i)) + else return (fst i, fst i, Nothing) + in v + +joinLeft :: Property +joinLeft = + forAll (listOf (chooseInt (min_value, max_value))) $ \ls0 -> + forAll (listOf (chooseInt (min_value, max_value))) $ \ls1 -> + -- nub the second list as no way to validate using list functions + monadicIO $ action ls0 (nub ls1) + + where + + action ls0 ls1 = do + v1 <- + run + $ S.toList + $ Top.joinLeft eq (S.fromList ls0) (S.fromList ls1) + let v2 = joinLeftList (map (\a -> (a,a)) ls0) (map (\a -> (a,a)) ls1) + v3 = map (\ (_, x1, x2) -> (x1, x2)) v2 + assert (v1 == v3) + +joinLeftMap :: Property +joinLeftMap = + forAll (listOf (chooseInt (min_value, max_value))) $ \ls0 -> + forAll (listOf (chooseInt (min_value, max_value))) $ \ls1 -> + -- nub the second list as no way to validate using list functions + monadicIO $ + action (map (\a -> (a,a)) ls0) (map (\a -> (a,a)) (nub ls1)) + + where + + action ls0 ls1 = do + v1 <- + run + $ S.toList + $ Top.joinLeftMap (S.fromList ls0) (S.fromList ls1) + let v2 = joinLeftList ls0 ls1 + assert (v1 == v2) + +intersectBy :: + ([Int] -> [Int]) + -> ( (Int -> Int -> a) + -> SerialT IO Int + -> SerialT IO Int + -> SerialT IO Int + ) + -> (Int -> Int -> a) + -> Property +intersectBy _srt intersectFunc cmp = + forAll (listOf (chooseInt (min_value, max_value))) $ \ls0 -> + forAll (listOf (chooseInt (min_value, max_value))) $ \ls1 -> + monadicIO $ action (sort ls0) (sort ls1) + + where + + action ls0 ls1 = do + v1 <- + run + $ S.toList + $ intersectFunc + cmp + (S.fromList ls0) + (S.fromList ls1) + let v2 = ls0 `intersect` ls1 + assert (v1 == sort v2) + +------------------------------------------------------------------------------- +-- Main +------------------------------------------------------------------------------- + +moduleName :: String +moduleName = "Prelude.Top" + +main :: IO () +main = hspec $ do + describe moduleName $ do + -- Joins + prop "joinInner" Main.joinInner + prop "joinInnerMap" Main.joinInnerMap + -- XXX currently API is broken https://github.com/composewell/streamly/issues/1032 + --prop "joinOuter" Main.joinOuter + prop "joinOuterMap" Main.joinOuterMap + prop "joinLeft" Main.joinLeft + prop "joinLeftMap" Main.joinLeftMap + -- intersect + -- XXX currently API is broken https://github.com/composewell/streamly/issues/1471 + --prop "intersectBy" (intersectBy id Top.intersectBy (==)) + prop "intersectBySorted" + (intersectBy sort Top.intersectBySorted compare) diff --git a/test/Streamly/Test/Prelude/WAsync.hs b/test/Streamly/Test/Prelude/WAsync.hs --- a/test/Streamly/Test/Prelude/WAsync.hs +++ b/test/Streamly/Test/Prelude/WAsync.hs @@ -7,7 +7,7 @@ -- Stability : experimental -- Portability : GHC -module Streamly.Test.Prelude.WAsync where +module Streamly.Test.Prelude.WAsync (main) where #ifdef DEVBUILD import Control.Concurrent ( threadDelay ) @@ -17,16 +17,31 @@ import Data.Semigroup ((<>)) #endif import Test.Hspec.QuickCheck +import Test.QuickCheck (Property, withMaxSuccess) +import Test.QuickCheck.Monadic (monadicIO, run) import Test.Hspec as H import Streamly.Prelude import qualified Streamly.Prelude as S +import Streamly.Test.Common import Streamly.Test.Prelude.Common moduleName :: String moduleName = "Prelude.WAsync" +constructfromWAsync :: + S.WAsyncT IO Int -> S.WAsyncT IO Int-> [Int] -> Property +constructfromWAsync s1 s2 res = + withMaxSuccess maxTestCount $ + monadicIO $ do + x <- run + $ S.toList + $ S.fromWAsync + $ S.maxThreads 1 + $ s1 `S.wAsync` s2 + equals (==) x res + main :: IO () main = hspec $ H.parallel @@ -47,6 +62,42 @@ wAsyncOps $ prop "wAsyncly consM" . constructWithConsM S.consM sort wAsyncOps $ prop "wAsyncly (.:)" . constructWithCons (S..:) wAsyncOps $ prop "wAsyncly (|:)" . constructWithConsM (S.|:) sort + prop "wAsync1" $ + constructfromWAsync + (S.fromList [1,2,3,4,5]) + (S.fromList [6,7,8,9,10]) + [1,6,2,7,3,8,4,9,5,10] + + prop "wAsync2" $ + constructfromWAsync + (S.fromList [1,2,3,4,5,6,7]) + (S.fromList [8,9,10]) + [1,8,2,9,3,10,4,5,6,7] + + prop "wAsync3" $ + constructfromWAsync + (S.fromList [1,2,3,4]) + (S.fromList [5,6,7,8,9,10]) + [1,5,2,6,3,7,4,8,9,10] + + prop "wAsync4" $ + constructfromWAsync + (S.fromList []) + (S.fromList [5,6,7,8,9,10]) + [5,6,7,8,9,10] + + prop "wAsync5" $ + constructfromWAsync + (S.fromList [1,2,3,4]) + (S.fromList []) + [1,2,3,4] + + prop "wAsync6" $ + constructfromWAsync + (S.fromList []) + (S.fromList []) + [] + describe "Functor operations" $ do wAsyncOps $ functorOps S.fromFoldable "wAsyncly" sortEq diff --git a/test/Streamly/Test/Prelude/WSerial.hs b/test/Streamly/Test/Prelude/WSerial.hs --- a/test/Streamly/Test/Prelude/WSerial.hs +++ b/test/Streamly/Test/Prelude/WSerial.hs @@ -7,7 +7,7 @@ -- Stability : experimental -- Portability : GHC -module Streamly.Test.Prelude.WSerial where +module Streamly.Test.Prelude.WSerial (main) where import Data.List (sort) #if __GLASGOW_HASKELL__ < 808 diff --git a/test/Streamly/Test/Prelude/ZipAsync.hs b/test/Streamly/Test/Prelude/ZipAsync.hs --- a/test/Streamly/Test/Prelude/ZipAsync.hs +++ b/test/Streamly/Test/Prelude/ZipAsync.hs @@ -7,7 +7,7 @@ -- Stability : experimental -- Portability : GHC -module Streamly.Test.Prelude.ZipAsync where +module Streamly.Test.Prelude.ZipAsync (main) where import Test.Hspec.QuickCheck import Test.Hspec as H diff --git a/test/Streamly/Test/Prelude/ZipSerial.hs b/test/Streamly/Test/Prelude/ZipSerial.hs --- a/test/Streamly/Test/Prelude/ZipSerial.hs +++ b/test/Streamly/Test/Prelude/ZipSerial.hs @@ -7,7 +7,7 @@ -- Stability : experimental -- Portability : GHC -module Streamly.Test.Prelude.ZipSerial where +module Streamly.Test.Prelude.ZipSerial (main) where #if __GLASGOW_HASKELL__ < 808 import Data.Semigroup ((<>)) diff --git a/test/lib/Streamly/Test/Prelude/Common.hs b/test/lib/Streamly/Test/Prelude/Common.hs --- a/test/lib/Streamly/Test/Prelude/Common.hs +++ b/test/lib/Streamly/Test/Prelude/Common.hs @@ -124,7 +124,7 @@ import System.Mem (performMajorGC) import Test.Hspec.QuickCheck import Test.Hspec -import Test.QuickCheck (Property, choose, forAll, withMaxSuccess) +import Test.QuickCheck (Property, choose, forAll, listOf, withMaxSuccess) import Test.QuickCheck.Monadic (assert, monadicIO, run) import Streamly.Prelude (SerialT, IsStream, (.:), nil, (|&), fromSerial) @@ -134,6 +134,7 @@ import qualified Streamly.Prelude as S import qualified Streamly.Data.Fold as FL import qualified Streamly.Internal.Data.Stream.IsStream as S +import qualified Streamly.Internal.Data.Stream.IsStream.Common as IS import qualified Streamly.Internal.Data.Unfold as UF import qualified Data.Map.Strict as Map @@ -1074,6 +1075,13 @@ let list = a <> listOp (b <> c) listEquals eq stream list +takeEndBy :: Property +takeEndBy = forAll (listOf (chooseInt (0, maxStreamLen))) $ \lst -> monadicIO $ do + let (s1, s3) = span (<= 200) lst + let s4 = [head s3 | not (null s3)] + s2 <- run $ S.toList $ IS.takeEndBy (> 200) $ S.fromList lst + assert $ s1 ++ s4 == s2 + -- XXX add tests for MonadReader and MonadError etc. In case an SVar is -- accidentally passed through them. -- @@ -1119,6 +1127,8 @@ transform (takeWhile (const True)) t (S.takeWhileM (const $ return True)) prop (desc <> " takeWhileM False") $ transform (takeWhile (const False)) t (S.takeWhileM (const $ return False)) + + prop "takeEndBy" takeEndBy prop (desc <> " drop maxBound") $ transform (drop maxBound) t (S.drop maxBound) diff --git a/test/streamly-tests.cabal b/test/streamly-tests.cabal --- a/test/streamly-tests.cabal +++ b/test/streamly-tests.cabal @@ -67,6 +67,7 @@ -Wincomplete-uni-patterns -Wredundant-constraints -Wnoncanonical-monad-instances + -Wmissing-export-lists -Rghc-timing if flag(has-llvm) @@ -139,13 +140,13 @@ common test-dependencies build-depends: streamly - , base >= 4.9 && < 5 + , base >= 4.9 && < 4.17 , containers >= 0.5 && < 0.7 , exceptions >= 0.8 && < 0.11 , ghc - , hspec >= 2.0 && < 3 - , mtl >= 2.2 && < 3 - , random >= 1.0.0 && < 2 + , hspec >= 2.0 && < 2.10 + , mtl >= 2.2 && < 2.3 + , random >= 1.0.0 && < 1.3 , transformers >= 0.4 && < 0.7 , QuickCheck >= 2.13 && < 2.15 , directory >= 1.2.2 && < 1.4 @@ -383,6 +384,10 @@ if flag(limit-build-mem) ghc-options: +RTS -M1500M -RTS +test-suite Prelude.Top + import: test-options + type: exitcode-stdio-1.0 + main-is: Streamly/Test/Prelude/Top.hs test-suite Prelude.WAsync import: test-options @@ -401,6 +406,8 @@ type: exitcode-stdio-1.0 main-is: Streamly/Test/Prelude/ZipAsync.hs ghc-options: -main-is Streamly.Test.Prelude.ZipAsync.main + if flag(limit-build-mem) + ghc-options: +RTS -M750M -RTS test-suite Prelude.ZipSerial import: test-options