pure-borrow 0.0.0.0 → 0.1.0.0

raw patch · 95 files changed

+23083/−1510 lines, 95 filesdep +atomic-primopsdep +filepathdep +fmlistdep −file-embeddep −processdep −template-haskelldep ~basenew-component:exe:fftPVP ok

version bump matches the API change (PVP)

Dependencies added: atomic-primops, filepath, fmlist, hashable, integer-logarithms, primitive, stm-chans, tasty-inspection-testing

Dependencies removed: file-embed, process, template-haskell, temporary, transformers

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +65/−0
• app/artifact-runner.hs +0/−238
• app/convert-qsort-bench-csv.hs +66/−66
• app/fft.hs +17/−0
• bench/fft.hs +139/−0
• bench/qsort.hs +118/−2
• bench/suite/Main.hs +5/−0
• bench/suite/PureBorrow/Bench/CopyAt.hs +176/−0
• bench/suite/PureBorrow/Bench/Growable.hs +97/−0
• bench/suite/PureBorrow/Bench/HashMap.hs +270/−0
• bench/suite/PureBorrow/Bench/Ingredients.hs +21/−0
• bench/suite/PureBorrow/Bench/MultiStoreScan.hs +12/−0
• bench/suite/PureBorrow/Bench/ScopeDensity.hs +478/−0
• bench/suite/PureBorrow/Bench/Unboxed.hs +11/−0
• bench/suite/PureBorrow/Bench/Worklist/Resume.hs +12/−0
• dockerfiles/artifact/Dockerfile +0/−44
• internal-src/demo-impl/PureBorrow/Demo/Fft.hs +158/−0
• internal-src/demo-impl/PureBorrow/Demo/QSort.hs +121/−0
• internal-src/qsort-bench-suites/PureBorrow/Internal/Bench/QSort.hs +0/−169
• internal-src/qsort-demo-impl/PureBorrow/Demo/QSort.hs +0/−111
• internal-src/test-bench-common/PureBorrow/Internal/Bench/MultiStoreScan.hs +1866/−0
• internal-src/test-bench-common/PureBorrow/Internal/Bench/Unboxed.hs +421/−0
• internal-src/test-bench-common/PureBorrow/Internal/Bench/Worklist/Resume.hs +2688/−0
• pure-borrow.cabal +242/−70
• src/Control/Concurrent/DivideConquer/Linear.hs +590/−102
• src/Control/Concurrent/DivideConquer/Linear/Internal.hs +67/−0
• src/Control/Concurrent/DivideConquer/Utils/QueuePool.hs +160/−80
• src/Control/Concurrent/DivideConquer/Utils/Semaphore.hs +58/−0
• src/Control/Concurrent/Queue/ChaseLev.hs +226/−0
• src/Control/Concurrent/STM/TMDeque.hs +0/−229
• src/Control/Concurrent/STM/TMDequeRingBuffer.hs +0/−218
• src/Control/Monad/Borrow/Pure.hs +45/−0
• src/Control/Monad/Borrow/Pure/BO.hs +96/−0
• src/Control/Monad/Borrow/Pure/BO/Internal.hs +225/−38
• src/Control/Monad/Borrow/Pure/BO/Unsafe.hs +2/−0
• src/Control/Monad/Borrow/Pure/Clone.hs +1/−1
• src/Control/Monad/Borrow/Pure/Copyable.hs +83/−20
• src/Control/Monad/Borrow/Pure/Experimental/Borrows.hs +242/−12
• src/Control/Monad/Borrow/Pure/Experimental/Loop.hs +44/−17
• src/Control/Monad/Borrow/Pure/Experimental/Reborrowable.hs +95/−26
• src/Control/Monad/Borrow/Pure/Lifetime/Token/Internal.hs +6/−0
• src/Control/Monad/Borrow/Pure/Utils.hs +12/−0
• src/Data/Coerce/Directed/Internal.hs +6/−0
• src/Data/HashMap/RobinHood/Mutable/Linear.hs +58/−0
• src/Data/HashMap/RobinHood/Mutable/Linear/Borrow.hs +274/−0
• src/Data/HashMap/RobinHood/Mutable/Linear/Borrow/Internal.hs +144/−0
• src/Data/HashMap/RobinHood/Mutable/Linear/Internal.hs +778/−0
• src/Data/Record/Linear/Borrow/Experimental/PatternMatch.hs +6/−2
• src/Data/Record/Linear/Borrow/Experimental/Split.hs +4/−4
• src/Data/Ref/Linear/Borrow.hs +8/−0
• src/Data/Vector/Generic/Mutable/Growable/Linear/Borrow/Unrestricted.hs +79/−0
• src/Data/Vector/Generic/Mutable/Growable/Linear/Borrow/Unrestricted/Internal.hs +867/−0
• src/Data/Vector/Generic/Mutable/Linear/Borrow/Experimental/Multiplicity.hs +58/−0
• src/Data/Vector/Generic/Mutable/Linear/Borrow/Experimental/Multiplicity/Internal.hs +710/−0
• src/Data/Vector/Generic/Mutable/Linear/Borrow/Unrestricted.hs +47/−0
• src/Data/Vector/Generic/Mutable/Linear/Borrow/Unrestricted/Internal.hs +477/−0
• src/Data/Vector/Mutable/Growable/Linear/Borrow.hs +75/−0
• src/Data/Vector/Mutable/Growable/Linear/Borrow/Internal.hs +894/−0
• src/Data/Vector/Mutable/Linear/Borrow.hs +75/−47
• src/Data/Vector/Mutable/Linear/Borrow/Internal.hs +61/−0
• src/Data/Vector/Unboxed/Mutable/Growable/Linear/Borrow.hs +45/−0
• src/Data/Vector/Unboxed/Mutable/Growable/Linear/Borrow/Internal.hs +797/−0
• src/Data/Vector/Unboxed/Mutable/Linear/Borrow.hs +36/−0
• src/Data/Vector/Unboxed/Mutable/Linear/Borrow/Internal.hs +535/−0
• test-inspection/Main.hs +22/−0
• test-inspection/PureBorrow/Inspection/Fft.hs +77/−0
• test-inspection/PureBorrow/Inspection/Flags.hs +29/−0
• test-inspection/PureBorrow/Inspection/GenericGrowableUnrestricted.hs +68/−0
• test-inspection/PureBorrow/Inspection/MultiStoreScan.hs +122/−0
• test-inspection/PureBorrow/Inspection/QSort.hs +75/−0
• test-inspection/PureBorrow/Inspection/Sublifetime.hs +387/−0
• test-inspection/PureBorrow/Inspection/Worklist/Resume.hs +130/−0
• test/Control/Concurrent/DivideConquer/LinearSpec.hs +256/−13
• test/Control/Monad/Borrow/Pure/BOSpec.hs +570/−0
• test/Control/Monad/Borrow/Pure/CopyableSpec.hs +157/−0
• test/Control/Monad/Borrow/Pure/Experimental/Borrows/TypingCases.hs +77/−0
• test/Control/Monad/Borrow/Pure/Experimental/BorrowsSpec.hs +90/−0
• test/Data/HashMap/RobinHood/Mutable/Linear/BorrowSpec.hs +237/−0
• test/Data/HashMap/RobinHood/Mutable/LinearSpec.hs +231/−0
• test/Data/HashMap/RobinHood/Mutable/LinearSpec/Cases.hs +113/−0
• test/Data/Vector/Generic/Mutable/Growable/Linear/Borrow/Unrestricted/TypingCases.hs +229/−0
• test/Data/Vector/Generic/Mutable/Growable/Linear/Borrow/UnrestrictedSpec.hs +668/−0
• test/Data/Vector/Generic/Mutable/Linear/Borrow/Experimental/Multiplicity/TypingCases.hs +103/−0
• test/Data/Vector/Generic/Mutable/Linear/Borrow/Experimental/MultiplicitySpec.hs +317/−0
• test/Data/Vector/Generic/Mutable/Linear/Borrow/Unrestricted/TypingCases.hs +105/−0
• test/Data/Vector/Generic/Mutable/Linear/Borrow/UnrestrictedSpec.hs +446/−0
• test/Data/Vector/Mutable/Growable/Linear/BorrowSpec.hs +908/−0
• test/Data/Vector/Mutable/Growable/Linear/TypingCases.hs +172/−0
• test/Data/Vector/Mutable/Linear/BorrowSpec.hs +171/−1
• test/Data/Vector/Unboxed/Mutable/Growable/Linear/BorrowSpec.hs +948/−0
• test/Data/Vector/Unboxed/Mutable/Growable/Linear/TypingCases.hs +205/−0
• test/Data/Vector/Unboxed/Mutable/Linear/BorrowSpec.hs +733/−0
• test/Data/Vector/Unboxed/Mutable/Linear/TypingCases.hs +124/−0
• test/PureBorrow/Internal/Bench/MultiStoreScanSpec.hs +96/−0
• test/PureBorrow/Internal/Bench/Worklist/ResumeSpec.hs +248/−0

@@ -1,5 +1,70 @@ # Revision history for pure-borrow +## 0.1.0.0 - 2026-09-19++### Breaking changes++- `Alias` carries its lifetime in the alias kind instead of as its own parameter, so a kind-polymorphic function can abstract over an alias including its lifetime:++    ```haskell+    -- before+    newtype Alias ak α a = UnsafeAlias a+    data AliasKind = Borrow BorrowKind | Lend+    -- after+    newtype Alias ak a = UnsafeAlias a+    data AliasKind = Borrow BorrowKind Lifetime | Lend Lifetime+    ```++  `Mut α`, `Share α` and `Lend α` are unchanged for users.+  The bundle is now `Aliases k xs`, with `Borrows bk α`, `Muts α`, `Shares α` and `Lends α` as synonyms; `Experimental.Loop` no longer re-exports its constructors, and `Experimental.Borrows` absorbs the reborrow instances from `Experimental.Reborrowable`.+- `Reborrowable` takes the lifetime through associated types, so an instance is written for the applied type:++    ```haskell+    -- before+    class Reborrowable bor where+      locally' :: bor α a %1 -> (forall β. bor (β /\ α) a %1 -> BO (β /\ α') (After β r)) %1 -> BO α' (r, bor α a)+    -- after+    class (bor ~ WithLifetime bor (LifetimeOf bor)) => Reborrowable bor where+      type LifetimeOf bor :: Lifetime+      type WithLifetime bor (β :: Lifetime) :: k -> Type+      locally' :: bor a %1 -> (forall β. WithLifetime bor (β /\ LifetimeOf bor) a %1 -> BO (β /\ α') (After β r)) %1 -> BO α' (r, bor a)+    ```++- `Data.Vector.Mutable.Linear.Borrow`'s `toVector` and `toList` require `Movable` rather than `Copyable`, and are now \(O(n)\): each element goes through `move`, which is what hands a linearly owned buffer to a GC-owned result.+- `Affine (Aliases k xs)` is constrained to borrow kinds, so a `Lends` bundle can no longer be discarded in safe code, matching the scalar `Lend`.+- `Control.Concurrent.STM.TMDeque` and `TMDequeRingBuffer` are removed; the scheduler runs on `Control.Concurrent.Queue.ChaseLev`.+- `DivideConquer` is now generalized to run on generic vector and qsort benchmarks are now run against unboxed vectors.++### Clarified++- `Copyable.copy` must complete the copy and return it in WHNF.+  This was always the contract — a `copy` returning a thunk that still reaches into the borrowed structure was never sound — but nothing stated or enforced it.+  The class Haddock now says so, and the generic machinery forces each component copy, so derived instances discharge it for free.++### New++- Five borrow-aware mutable vector families beside the existing boxed `Data.Vector.Mutable.Linear.Borrow`.+  Element-owning: fixed unboxed, and growable boxed and unboxed.+  Backend-generic and *not* element-owning, with GC-owned entries and \(O(1)\) consuming freeze: `Data.Vector.Generic.Mutable.Linear.Borrow.Unrestricted` and its growable counterpart.+  `…Borrow.Experimental.Multiplicity` parameterizes the same storage by element multiplicity.+- The growable families keep their length and backing buffer behind a stable header, and project the initialized prefix through `getContents` or the rank-2 `withContent`/`withContent_` as a fixed borrow of the same kind and lifetime.+  Growth replaces the buffer, so it is unavailable while a content borrow is live.+- Added a Robin Hood hash table with backward-shift deletion.+  `Data.HashMap.RobinHood.Mutable.Linear` is the owned table, whose operations are ordinary linear functions; `Data.HashMap.RobinHood.Mutable.Linear.Borrow` keeps one behind a linear `Ref` so that it can be mutated, and grown, through a `Mut` borrow.+  Its keys and values are GC-owned, and it caches a fingerprint per slot so that a key with a cheap hash and an expensive equality is rejected without a full comparison.+  This adds a dependency on `hashable`.+- `subShare` shortens a `Share` without opening a scope, and `Par` is an applicative for parallel composition inside `BO`, with directly inlinable methods.+- `BO.Unsafe` exports `unsafeCastAlias`, a `coerceLin` retagging that replaces a bare `unsafeCoerce`.+- The divide-and-conquer scheduler now correctly exposes `Result` to allow users to write their own algorithm.+  Now it further supports non-trivial "conquer" phase and now comes with FFT example.++### Performance++- Delimiting a sublifetime got much cheaper in `srunBO`/`srunBO_`, `sharing`/`sharing'`/`sharing_`, `reborrowing`/`reborrowing'`/`reborrowing_` and `reborrowings`/`reborrowings'`/`reborrowings_`.+  The `slow` flag restores the old, safe-but-slow implementation.+  Measured on a scope-dominated microbenchmark, the plural scopes went from 40 bytes and 4.5 ns per crossing to 0 bytes and 1.2–1.6 ns.+  The FFT example picks this up through `iterReborrowing_`, which crosses a plural scope per iteration of its setup phase: −4.8% allocation and −5.6% wall at 2^20 points.+ ## 0.0.0.0 -- 2026-05-05  This is the first release on Hackage :tada:

@@ -1,238 +0,0 @@-{-# LANGUAGE GHC2021 #-}-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedRecordDot #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE NoFieldSelectors #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--module Main (main) where--import Control.Applicative-import Control.Concurrent (getNumCapabilities, setNumCapabilities)-import Control.Exception (throwIO, try)-import Control.Monad (forM_)-import Control.Monad.Trans.Writer.CPS (execWriter, tell)-import Data.ByteString qualified as BS-import Data.ByteString.Builder qualified as BB-import Data.ByteString.Lazy qualified as LBS-import Data.Csv (FromNamedRecord (..), decodeByName, (.:))-import Data.FileEmbed-import Data.Foldable (fold)-import Data.Foldable1 (fold1)-import Data.Functor-import Data.IntMap.Monoidal.Strict (MonoidalIntMap)-import Data.IntMap.Monoidal.Strict qualified as MIM-import Data.IntSet qualified as IS-import Data.List qualified as List-import Data.List.NonEmpty (NonEmpty (..))-import Data.Map.Monoidal.Strict (MonoidalMap)-import Data.Map.Monoidal.Strict qualified as MonoidalMap-import Data.Monoid (First (..))-import Data.Semigroup qualified as Semi-import Data.Set qualified as Set-import Data.Text qualified as T-import Data.Text.Encoding qualified as TE-import GHC.Generics-import Options.Applicative qualified as Opts-import PureBorrow.Demo.QSort qualified as QS-import PureBorrow.Internal.Bench.QSort (BenchOpts)-import PureBorrow.Internal.Bench.QSort qualified as Bench-import System.Directory (canonicalizePath, findExecutable)-import System.Environment (withArgs)-import System.Exit (ExitCode)-import System.IO (hClose, hFlush)-import System.IO.Temp (withSystemTempFile)-import System.Process (readProcess)-import Text.Read (readEither)--data Cmd = Bench BenchOpts | QuickBench | QSortDemo QS.CLIOpts-  deriving (Show, Eq, Ord, Generic)--optionsP :: Int -> Opts.ParserInfo Cmd-optionsP numCapa =-  Opts.info (p <**> Opts.helper) $-    Opts.fullDesc-      <> Opts.progDesc "Artifact runner for qsort benchmarks and demos"-  where-    p = cmds <|> Bench <$> Bench.rawOptsP-    cmds =-      Opts.hsubparser $-        fold1 $-          Opts.command "bench" (Bench <$> Bench.optionsP)-            :| [ Opts.command "demo" $ QSortDemo <$> QS.optionsP numCapa-               , Opts.command "quick" $-                   Opts.info (pure QuickBench) $-                     Opts.progDesc $-                       "Run quick benchmarks with numcpu = 4 for sizes 0 and " <> show Bench.kMAX_SIZE-               ]--main :: IO ()-main = do-  numCap <- getNumCapabilities-  Opts.customExecParser (Opts.prefs Opts.subparserInline) (optionsP numCap) >>= \case-    Bench benchOpts -> runBench benchOpts-    QuickBench -> runBench Bench.BenchOpts {numThreads = 4, sampleSize = 2}-    QSortDemo cliOpts -> QS.defaultMainWith cliOpts--runBench :: BenchOpts -> IO ()-runBench benchOpts = do-  let rawDest = "qsort-raw.csv"-  void $ try @ExitCode $ withArgs ["--csv", rawDest, "-j1", "--time-mode=wall", "-t", "10s"] do-    setNumCapabilities benchOpts.numThreads-    Bench.defaultMainWith benchOpts--  putStrLn "Processing results..."-  (_, rawRows) <- either (throwIO . userError) pure . decodeByName =<< LBS.readFile rawDest-  let sd = foldMap fromRawRow rawRows-      builder = buildOutput sd-  csvDest <- canonicalizePath "qsort.csv"-  BB.writeFile csvDest builder--  mgp <- findExecutable "gnuplot"-  forM_ mgp \gnuplot -> withSystemTempFile "plot.gp" \tmp h -> do-    putStrLn $ "Gnuplot found: " <> gnuplot-    pngDest <- canonicalizePath "qsort.png"-    BS.hPutStr h gnuplotScript-    hFlush h-    hClose h-    !_ <- readProcess gnuplot ["-e", "input='" <> csvDest <> "'; output='" <> pngDest <> "'", tmp] ""-    putStrLn $ "Plot generated: " <> pngDest--gnuplotScript :: BS.ByteString-gnuplotScript =-  $(embedFile "scripts/genplot.gnuplot")--buildOutput :: Statistics -> BB.Builder-buildOutput sd = execWriter do-  let (hdrs, targets) = toHeaders sd--  putLine $-    fold $-      List.intersperse "," $-        map (BB.byteString . TE.encodeUtf8) hdrs-  forM_ (MIM.toAscList sd) \(size, ps) -> do-    let row =-          BB.intDec size-            : concatMap-              ( \t ->-                  maybe (replicate 5 mempty) (\p -> map BB.doubleDec [p.mean, p.stddev, p.alloc, p.copied, p.peak]) $-                    lookupStat t ps-              )-              targets-    putLine $ fold $ List.intersperse "," row-  where-    crlf = tell "\r\n"-    putLine = (>> crlf) . tell--data RawRow = RawRow-  { size :: !Int-  , name :: !T.Text-  , mean :: !Int-  , stddev :: !Int-  , alloc :: !Int-  , copied :: !Int-  , peak :: !Int-  }-  deriving (Show, Eq, Ord, Generic)--instance FromNamedRecord RawRow where-  parseNamedRecord r = do-    fullName <- r .: "Name"-    let ~(sz : name : _) = drop 2 $ T.splitOn "." fullName-    size <- either fail pure $ readEither $ T.unpack sz-    mean <- r .: "Mean (ps)"-    stddev <- r .: "2*Stdev (ps)" <&> (`quot` 2)-    alloc <- r .: "Allocated"-    copied <- r .: "Copied"-    peak <- r .: "Peak Memory"-    pure RawRow {..}--data Performance = Performance-  { mean :: !Double-  , stddev :: !Double-  , alloc :: !Double-  , copied :: !Double-  , peak :: !Double-  }-  deriving (Show, Eq, Ord, Generic)-  deriving (Semigroup) via Semi.First Performance--toPerformance :: RawRow -> Performance-toPerformance RawRow {..} =-  Performance-    { mean = fromIntegral mean * 1e-9-    , stddev = fromIntegral stddev * 1e-9-    , alloc = fromIntegral alloc * 1e-6-    , copied = fromIntegral copied * 1e-6-    , peak = fromIntegral peak * 1e-6-    }--data PerformanceSet = PerformanceSet-  { intro :: !(First Performance)-  , sequential :: !(First Performance)-  , parallel :: !(MonoidalIntMap Performance)-  , worksteal :: !(MonoidalIntMap Performance)-  , others :: !(MonoidalMap T.Text Performance)-  }-  deriving (Show, Eq, Ord, Generic)-  deriving (Semigroup, Monoid) via Generically PerformanceSet--type Statistics = MonoidalIntMap PerformanceSet--data Target = Intro | Sequential | Parallel Int | Worksteal Int | Other T.Text-  deriving (Show, Eq, Ord, Generic)--lookupStat :: Target -> PerformanceSet -> Maybe Performance-lookupStat t ps =-  case t of-    Intro -> getFirst ps.intro-    Sequential -> getFirst ps.sequential-    Parallel n -> MIM.lookup n ps.parallel-    Worksteal n -> MIM.lookup n ps.worksteal-    Other name -> MonoidalMap.lookup name ps.others--toHeaders :: Statistics -> ([T.Text], [Target])-toHeaders stats =-  (headers, targets)-  where-    headers = "size" : [cat <> metric | cat <- categories, metric <- metrics]-    targets = Intro : Sequential : [Parallel n | n <- IS.toList parallels] ++ [Worksteal n | n <- IS.toList worksteals] ++ [Other name | name <- Set.toList miscs]-    (parallels, worksteals, miscs) =-      foldMap-        ( \ps ->-            ( MIM.keysSet ps.parallel-            , MIM.keysSet ps.worksteal-            , MonoidalMap.keysSet ps.others-            )-        )-        stats-    categories =-      "intro"-        : "sequential"-        : [T.pack $ "parallel" <> show n | n <- IS.toList parallels]-        ++ [T.pack $ "workSteal" <> show n | n <- IS.toList worksteals]-        ++ [name | name <- Set.toList miscs]--    metrics = ["Mean", "Stddev", "Alloc", "Copied", "Peak"]--fromRawRow :: RawRow -> Statistics-fromRawRow r@RawRow {..} = MIM.singleton size $-  case name of-    "intro" -> mempty {intro = First (Just $ toPerformance r)}-    "sequential" -> mempty {sequential = First (Just $ perf)}-    inp-      | Just rest <- T.stripPrefix "parallel (budget =" inp-      , [(n, _)] <- reads (T.unpack rest) ->-          mempty {parallel = MIM.singleton n perf}-      | Just rest <- T.stripPrefix "worksteal (workers =" inp-      , [(n, _)] <- reads (T.unpack rest) ->-          mempty {worksteal = MIM.singleton n perf}-    _ -> mempty {others = MonoidalMap.singleton name perf}-  where-    perf = toPerformance r

@@ -85,76 +85,76 @@ fromRawRow :: RawRow -> SizeDataMap fromRawRow RawRow {..} = fromMaybe mempty do   dat <- case name of-    "intro" -> pure mempty {introMean = Sum (fromIntegral mean * 1e-9), introStddev = Sum (fromIntegral stddev * 1e-9), introAlloc = Sum (fromIntegral alloc * 1e-6), introCopied = Sum (fromIntegral copied * 1e-6), introPeak = Sum (fromIntegral peak * 1e-6)}-    "sequential" -> pure mempty {sequentialMean = Sum (fromIntegral mean * 1e-9), sequentialStddev = Sum (fromIntegral stddev * 1e-9), sequentialAlloc = Sum (fromIntegral alloc * 1e-6), sequentialCopied = Sum (fromIntegral copied * 1e-6), sequentialPeak = Sum (fromIntegral peak * 1e-6)}-    "parallel (budget = 4)" -> pure mempty {parallel4Mean = Sum (fromIntegral mean * 1e-9), parallel4Stddev = Sum (fromIntegral stddev * 1e-9), parallel4Alloc = Sum (fromIntegral alloc * 1e-6), parallel4Copied = Sum (fromIntegral copied * 1e-6), parallel4Peak = Sum (fromIntegral peak * 1e-6)}-    "parallel (budget = 8)" -> pure mempty {parallel8Mean = Sum (fromIntegral mean * 1e-9), parallel8Stddev = Sum (fromIntegral stddev * 1e-9), parallel8Alloc = Sum (fromIntegral alloc * 1e-6), parallel8Copied = Sum (fromIntegral copied * 1e-6), parallel8Peak = Sum (fromIntegral peak * 1e-6)}-    "parallel (budget = 16)" -> pure mempty {parallel16Mean = Sum (fromIntegral mean * 1e-9), parallel16Stddev = Sum (fromIntegral stddev * 1e-9), parallel16Alloc = Sum (fromIntegral alloc * 1e-6), parallel16Copied = Sum (fromIntegral copied * 1e-6), parallel16Peak = Sum (fromIntegral peak * 1e-6)}-    "parallel (budget = 32)" -> pure mempty {parallel32Mean = Sum (fromIntegral mean * 1e-9), parallel32Stddev = Sum (fromIntegral stddev * 1e-9), parallel32Alloc = Sum (fromIntegral alloc * 1e-6), parallel32Copied = Sum (fromIntegral copied * 1e-6), parallel32Peak = Sum (fromIntegral peak * 1e-6)}-    "worksteal (workers = 2)" -> pure mempty {workSteal2Mean = Sum (fromIntegral mean * 1e-9), workSteal2Stddev = Sum (fromIntegral stddev * 1e-9), workSteal2Alloc = Sum (fromIntegral alloc * 1e-6), workSteal2Copied = Sum (fromIntegral copied * 1e-6), workSteal2Peak = Sum (fromIntegral peak * 1e-6)}-    "worksteal (workers = 4)" -> pure mempty {workSteal4Mean = Sum (fromIntegral mean * 1e-9), workSteal4Stddev = Sum (fromIntegral stddev * 1e-9), workSteal4Alloc = Sum (fromIntegral alloc * 1e-6), workSteal4Copied = Sum (fromIntegral copied * 1e-6), workSteal4Peak = Sum (fromIntegral peak * 1e-6)}-    "worksteal (workers = 6)" -> pure mempty {workSteal6Mean = Sum (fromIntegral mean * 1e-9), workSteal6Stddev = Sum (fromIntegral stddev * 1e-9), workSteal6Alloc = Sum (fromIntegral alloc * 1e-6), workSteal6Copied = Sum (fromIntegral copied * 1e-6), workSteal6Peak = Sum (fromIntegral peak * 1e-6)}-    "worksteal (workers = 8)" -> pure mempty {workSteal8Mean = Sum (fromIntegral mean * 1e-9), workSteal8Stddev = Sum (fromIntegral stddev * 1e-9), workSteal8Alloc = Sum (fromIntegral alloc * 1e-6), workSteal8Copied = Sum (fromIntegral copied * 1e-6), workSteal8Peak = Sum (fromIntegral peak * 1e-6)}-    "worksteal (workers = 10)" -> pure mempty {workSteal10Mean = Sum (fromIntegral mean * 1e-9), workSteal10Stddev = Sum (fromIntegral stddev * 1e-9), workSteal10Alloc = Sum (fromIntegral alloc * 1e-6), workSteal10Copied = Sum (fromIntegral copied * 1e-6), workSteal10Peak = Sum (fromIntegral peak * 1e-6)}+    "intro" -> pure mempty {introMean = Just $ Sum (fromIntegral mean * 1e-9), introStddev = Just $ Sum (fromIntegral stddev * 1e-9), introAlloc = Just $ Sum (fromIntegral alloc * 1e-6), introCopied = Just $ Sum (fromIntegral copied * 1e-6), introPeak = Just $ Sum (fromIntegral peak * 1e-6)}+    "sequential" -> pure mempty {sequentialMean = Just $ Sum (fromIntegral mean * 1e-9), sequentialStddev = Just $ Sum (fromIntegral stddev * 1e-9), sequentialAlloc = Just $ Sum (fromIntegral alloc * 1e-6), sequentialCopied = Just $ Sum (fromIntegral copied * 1e-6), sequentialPeak = Just $ Sum (fromIntegral peak * 1e-6)}+    "parallel (budget = 4)" -> pure mempty {parallel4Mean = Just $ Sum (fromIntegral mean * 1e-9), parallel4Stddev = Just $ Sum (fromIntegral stddev * 1e-9), parallel4Alloc = Just $ Sum (fromIntegral alloc * 1e-6), parallel4Copied = Just $ Sum (fromIntegral copied * 1e-6), parallel4Peak = Just $ Sum (fromIntegral peak * 1e-6)}+    "parallel (budget = 8)" -> pure mempty {parallel8Mean = Just $ Sum (fromIntegral mean * 1e-9), parallel8Stddev = Just $ Sum (fromIntegral stddev * 1e-9), parallel8Alloc = Just $ Sum (fromIntegral alloc * 1e-6), parallel8Copied = Just $ Sum (fromIntegral copied * 1e-6), parallel8Peak = Just $ Sum (fromIntegral peak * 1e-6)}+    "parallel (budget = 16)" -> pure mempty {parallel16Mean = Just $ Sum (fromIntegral mean * 1e-9), parallel16Stddev = Just $ Sum (fromIntegral stddev * 1e-9), parallel16Alloc = Just $ Sum (fromIntegral alloc * 1e-6), parallel16Copied = Just $ Sum (fromIntegral copied * 1e-6), parallel16Peak = Just $ Sum (fromIntegral peak * 1e-6)}+    "parallel (budget = 32)" -> pure mempty {parallel32Mean = Just $ Sum (fromIntegral mean * 1e-9), parallel32Stddev = Just $ Sum (fromIntegral stddev * 1e-9), parallel32Alloc = Just $ Sum (fromIntegral alloc * 1e-6), parallel32Copied = Just $ Sum (fromIntegral copied * 1e-6), parallel32Peak = Just $ Sum (fromIntegral peak * 1e-6)}+    "worksteal (workers = 2)" -> pure mempty {workSteal2Mean = Just $ Sum (fromIntegral mean * 1e-9), workSteal2Stddev = Just $ Sum (fromIntegral stddev * 1e-9), workSteal2Alloc = Just $ Sum (fromIntegral alloc * 1e-6), workSteal2Copied = Just $ Sum (fromIntegral copied * 1e-6), workSteal2Peak = Just $ Sum (fromIntegral peak * 1e-6)}+    "worksteal (workers = 4)" -> pure mempty {workSteal4Mean = Just $ Sum (fromIntegral mean * 1e-9), workSteal4Stddev = Just $ Sum (fromIntegral stddev * 1e-9), workSteal4Alloc = Just $ Sum (fromIntegral alloc * 1e-6), workSteal4Copied = Just $ Sum (fromIntegral copied * 1e-6), workSteal4Peak = Just $ Sum (fromIntegral peak * 1e-6)}+    "worksteal (workers = 6)" -> pure mempty {workSteal6Mean = Just $ Sum (fromIntegral mean * 1e-9), workSteal6Stddev = Just $ Sum (fromIntegral stddev * 1e-9), workSteal6Alloc = Just $ Sum (fromIntegral alloc * 1e-6), workSteal6Copied = Just $ Sum (fromIntegral copied * 1e-6), workSteal6Peak = Just $ Sum (fromIntegral peak * 1e-6)}+    "worksteal (workers = 8)" -> pure mempty {workSteal8Mean = Just $ Sum (fromIntegral mean * 1e-9), workSteal8Stddev = Just $ Sum (fromIntegral stddev * 1e-9), workSteal8Alloc = Just $ Sum (fromIntegral alloc * 1e-6), workSteal8Copied = Just $ Sum (fromIntegral copied * 1e-6), workSteal8Peak = Just $ Sum (fromIntegral peak * 1e-6)}+    "worksteal (workers = 10)" -> pure mempty {workSteal10Mean = Just $ Sum (fromIntegral mean * 1e-9), workSteal10Stddev = Just $ Sum (fromIntegral stddev * 1e-9), workSteal10Alloc = Just $ Sum (fromIntegral alloc * 1e-6), workSteal10Copied = Just $ Sum (fromIntegral copied * 1e-6), workSteal10Peak = Just $ Sum (fromIntegral peak * 1e-6)}     _ -> Nothing   pure (MIM.singleton size dat)  data SizeData = SizeData-  { introMean :: !(Sum Double)-  , introStddev :: !(Sum Double)-  , introAlloc :: !(Sum Double)-  , introCopied :: !(Sum Double)-  , introPeak :: !(Sum Double)-  , sequentialMean :: !(Sum Double)-  , sequentialStddev :: !(Sum Double)-  , sequentialAlloc :: !(Sum Double)-  , sequentialCopied :: !(Sum Double)-  , sequentialPeak :: !(Sum Double)-  , parallel4Mean :: !(Sum Double)-  , parallel4Stddev :: !(Sum Double)-  , parallel4Alloc :: !(Sum Double)-  , parallel4Copied :: !(Sum Double)-  , parallel4Peak :: !(Sum Double)-  , parallel8Mean :: !(Sum Double)-  , parallel8Stddev :: !(Sum Double)-  , parallel8Alloc :: !(Sum Double)-  , parallel8Copied :: !(Sum Double)-  , parallel8Peak :: !(Sum Double)-  , parallel16Mean :: !(Sum Double)-  , parallel16Stddev :: !(Sum Double)-  , parallel16Alloc :: !(Sum Double)-  , parallel16Copied :: !(Sum Double)-  , parallel16Peak :: !(Sum Double)-  , parallel32Mean :: !(Sum Double)-  , parallel32Stddev :: !(Sum Double)-  , parallel32Alloc :: !(Sum Double)-  , parallel32Copied :: !(Sum Double)-  , parallel32Peak :: !(Sum Double)-  , workSteal2Mean :: !(Sum Double)-  , workSteal2Stddev :: !(Sum Double)-  , workSteal2Alloc :: !(Sum Double)-  , workSteal2Copied :: !(Sum Double)-  , workSteal2Peak :: !(Sum Double)-  , workSteal4Mean :: !(Sum Double)-  , workSteal4Stddev :: !(Sum Double)-  , workSteal4Alloc :: !(Sum Double)-  , workSteal4Copied :: !(Sum Double)-  , workSteal4Peak :: !(Sum Double)-  , workSteal6Mean :: !(Sum Double)-  , workSteal6Stddev :: !(Sum Double)-  , workSteal6Alloc :: !(Sum Double)-  , workSteal6Copied :: !(Sum Double)-  , workSteal6Peak :: !(Sum Double)-  , workSteal8Mean :: !(Sum Double)-  , workSteal8Stddev :: !(Sum Double)-  , workSteal8Alloc :: !(Sum Double)-  , workSteal8Copied :: !(Sum Double)-  , workSteal8Peak :: !(Sum Double)-  , workSteal10Mean :: !(Sum Double)-  , workSteal10Stddev :: !(Sum Double)-  , workSteal10Alloc :: !(Sum Double)-  , workSteal10Copied :: !(Sum Double)-  , workSteal10Peak :: !(Sum Double)+  { introMean :: !(Maybe (Sum Double))+  , introStddev :: !(Maybe (Sum Double))+  , introAlloc :: !(Maybe (Sum Double))+  , introCopied :: !(Maybe (Sum Double))+  , introPeak :: !(Maybe (Sum Double))+  , sequentialMean :: !(Maybe (Sum Double))+  , sequentialStddev :: !(Maybe (Sum Double))+  , sequentialAlloc :: !(Maybe (Sum Double))+  , sequentialCopied :: !(Maybe (Sum Double))+  , sequentialPeak :: !(Maybe (Sum Double))+  , parallel4Mean :: !(Maybe (Sum Double))+  , parallel4Stddev :: !(Maybe (Sum Double))+  , parallel4Alloc :: !(Maybe (Sum Double))+  , parallel4Copied :: !(Maybe (Sum Double))+  , parallel4Peak :: !(Maybe (Sum Double))+  , parallel8Mean :: !(Maybe (Sum Double))+  , parallel8Stddev :: !(Maybe (Sum Double))+  , parallel8Alloc :: !(Maybe (Sum Double))+  , parallel8Copied :: !(Maybe (Sum Double))+  , parallel8Peak :: !(Maybe (Sum Double))+  , parallel16Mean :: !(Maybe (Sum Double))+  , parallel16Stddev :: !(Maybe (Sum Double))+  , parallel16Alloc :: !(Maybe (Sum Double))+  , parallel16Copied :: !(Maybe (Sum Double))+  , parallel16Peak :: !(Maybe (Sum Double))+  , parallel32Mean :: !(Maybe (Sum Double))+  , parallel32Stddev :: !(Maybe (Sum Double))+  , parallel32Alloc :: !(Maybe (Sum Double))+  , parallel32Copied :: !(Maybe (Sum Double))+  , parallel32Peak :: !(Maybe (Sum Double))+  , workSteal2Mean :: !(Maybe (Sum Double))+  , workSteal2Stddev :: !(Maybe (Sum Double))+  , workSteal2Alloc :: !(Maybe (Sum Double))+  , workSteal2Copied :: !(Maybe (Sum Double))+  , workSteal2Peak :: !(Maybe (Sum Double))+  , workSteal4Mean :: !(Maybe (Sum Double))+  , workSteal4Stddev :: !(Maybe (Sum Double))+  , workSteal4Alloc :: !(Maybe (Sum Double))+  , workSteal4Copied :: !(Maybe (Sum Double))+  , workSteal4Peak :: !(Maybe (Sum Double))+  , workSteal6Mean :: !(Maybe (Sum Double))+  , workSteal6Stddev :: !(Maybe (Sum Double))+  , workSteal6Alloc :: !(Maybe (Sum Double))+  , workSteal6Copied :: !(Maybe (Sum Double))+  , workSteal6Peak :: !(Maybe (Sum Double))+  , workSteal8Mean :: !(Maybe (Sum Double))+  , workSteal8Stddev :: !(Maybe (Sum Double))+  , workSteal8Alloc :: !(Maybe (Sum Double))+  , workSteal8Copied :: !(Maybe (Sum Double))+  , workSteal8Peak :: !(Maybe (Sum Double))+  , workSteal10Mean :: !(Maybe (Sum Double))+  , workSteal10Stddev :: !(Maybe (Sum Double))+  , workSteal10Alloc :: !(Maybe (Sum Double))+  , workSteal10Copied :: !(Maybe (Sum Double))+  , workSteal10Peak :: !(Maybe (Sum Double))   }   deriving (Show, Eq, Ord, Generic)   deriving anyclass (ToNamedRecord, DefaultOrdered)

@@ -0,0 +1,17 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module Main (main) where++import PureBorrow.Demo.Fft (defaultMain)++main :: IO ()+main = defaultMain

@@ -0,0 +1,139 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module Main (main) where++import Control.Concurrent (getNumCapabilities)+import Control.Concurrent.DivideConquer.Linear (+  DivideConquer,+  FftCoe,+  Pair,+  combineLoop,+  fftDC,+  fftDC',+  naiveDivideAndConquer,+  sequentialDivideAndConquer,+ )+import Control.Exception (evaluate)+import Control.Functor.Linear qualified as Control+import Control.Monad.Borrow.Pure.BO+import Control.Syntax.DataFlow qualified as DataFlow+import Data.Complex (Complex (..))+import Data.Proxy (Proxy (..))+import Data.Vector.Generic.Mutable.Linear.Borrow.Unrestricted qualified as VL+import Data.Vector.Unboxed qualified as V+import Prelude.Linear (dup, unur)+import Prelude.Linear qualified as PL+import System.Random.Stateful+import Test.Tasty (askOption, defaultMainWithIngredients)+import Test.Tasty.Bench+import Test.Tasty.Ingredients.Basic (includingOptions)+import Test.Tasty.Options+import Text.Read (readMaybe)+import Prelude as P++data Mode = NaiveDC | Worksteal Int | Sequential+  deriving (Show, Eq, Ord)++{-# SPECIALIZE fftDC' ::+  Int ->+  DivideConquer+    FftCoe+    α+    Pair+    (VL.Vector V.Vector (Complex Double))+    ()+  #-}++{-# SPECIALIZE combineLoop ::+  Int ->+  Complex Double ->+  Int ->+  Complex Double ->+  Mut α (VL.Vector V.Vector (Complex Double)) %1 ->+  BO α ()+  #-}++data BenchOpts = BenchOpts {numThreads :: !Int, sampleSize :: !Int}+  deriving (Show, Eq, Ord)++fun :: Double -> Double+fun x = sin (2 * pi * x) + 2 * cos (pi * x) + 3 * sin (0.5 * pi * x) + 5++sample :: Int -> (Double -> Double) -> V.Vector (Complex Double)+sample n f = V.generate n \i -> f (-4 + 8 * fromIntegral i / fromIntegral n) :+ 0++fftWith :: Mode -> V.Vector (Complex Double) -> V.Vector (Complex Double)+fftWith Sequential v =+  unur PL.$ linearly \lin ->+    DataFlow.do+      (lin, l2) <- dup lin+      runBO lin Control.do+        (v, lend) <- borrowM (VL.fromVector v l2)+        Control.void PL.$ sequentialDivideAndConquer (fftDC' 128) v+        pureAfter (VL.toVector PL.$ reclaim lend)+fftWith NaiveDC v =+  unur PL.$ linearly \lin ->+    DataFlow.do+      (lin, l2) <- dup lin+      runBO lin Control.do+        (v, lend) <- borrowM (VL.fromVector v l2)+        Control.void PL.$ naiveDivideAndConquer (fftDC' 128) v+        pureAfter (VL.toVector PL.$ reclaim lend)+fftWith (Worksteal p) v =+  unur PL.$ linearly \lin ->+    DataFlow.do+      (lin, l2) <- dup lin+      runBO lin Control.do+        (v, lend) <- borrowM (VL.fromVector v l2)+        Control.void PL.$ fftDC (mkStdGen 42) p 128 v+        pureAfter (VL.toVector PL.$ reclaim lend)++data SampleSize = SampleSize Int+  deriving (Show, Eq, Ord)++instance IsOption SampleSize where+  defaultValue = SampleSize 10+  parseValue s =+    case readMaybe s of+      Just n | n > 0, kMAX_SIZE `rem` n == 0 -> Just (SampleSize n)+      _ -> Nothing+  optionName = return "size"+  optionHelp = return "Number of logarithmic size steps (positive divisor of 10)"++main :: IO ()+main = do+  numThreads <- getNumCapabilities+  let customOpts = [Option (Proxy :: Proxy SampleSize)]+      ingredients = includingOptions customOpts : benchIngredients+  defaultMainWithIngredients ingredients $ askOption \(SampleSize sampleSize) ->+    bgroup "All" $ benches BenchOpts {..}++benches :: BenchOpts -> [Benchmark]+benches BenchOpts {..} =+  [ bgroup+      "fft"+      [ env+          (evaluate $ sample size fun)+          \vec ->+            bgroup+              (show size)+              ( bench "sequential" (nf (fftWith Sequential) vec)+                  : bench+                    ("parallel-dc (thresh = 128)")+                    (nf (fftWith NaiveDC) vec)+                  : [ bench ("worksteal (workers = " <> show n <> ")") $+                        nf (fftWith $ Worksteal n) vec+                    | n <- [2, 4 .. numThreads]+                    ]+              )+      | i <- [0 .. sampleSize]+      , let size = 2 ^ (10 + i * kMAX_SIZE `quot` sampleSize)+      ]+  ]++kMAX_SIZE :: Int+kMAX_SIZE = 10

@@ -1,11 +1,127 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-name-shadowing #-}  module Main (main) where -import PureBorrow.Internal.Bench.QSort (defaultMain)+import Control.Concurrent (getNumCapabilities)+import Control.Concurrent.DivideConquer.Linear (+  naiveDivideAndConquer,+  qsort,+  qsortDC,+  qsortDC',+ )+import Control.Functor.Linear qualified as Control+import Control.Monad.Borrow.Pure.BO+import Control.Syntax.DataFlow qualified as DataFlow+import Data.Proxy (Proxy (..))+import Data.Vector.Algorithms.Intro qualified as AI+import Data.Vector.Generic.Mutable.Linear.Borrow.Unrestricted qualified as VL+import Data.Vector.Unboxed qualified as V+import Prelude.Linear (dup, unur)+import Prelude.Linear qualified as PL+import System.Random.Stateful+import Test.Tasty (askOption, defaultMainWithIngredients)+import Test.Tasty.Bench+import Test.Tasty.Ingredients.Basic (includingOptions)+import Test.Tasty.Options+import Text.Read (readMaybe)+import Prelude as P +data Mode = Parallel Word | NaiveDC Int | Worksteal Int | Sequential | IntroSort+  deriving (Show, Eq, Ord)++data BenchOpts = BenchOpts {numThreads :: !Int, sampleSize :: !Int}+  deriving (Show, Eq, Ord)++qsortWith :: Mode -> V.Vector Int -> V.Vector Int+qsortWith IntroSort v = V.modify AI.sort v+qsortWith (Parallel budget) v =+  unur PL.$ linearly \lin ->+    DataFlow.do+      (lin, l2) <- dup lin+      runBO lin Control.do+        (v, lend) <- borrowM (VL.fromVector v l2)+        qsort budget v+        Control.pure PL.$ VL.toVector Control.<$> reclaim' lend+qsortWith Sequential v =+  unur PL.$ linearly \lin ->+    DataFlow.do+      (lin, l2) <- dup lin+      runBO lin Control.do+        (v, lend) <- borrowM (VL.fromVector v l2)+        qsort 0 v+        pureAfter (VL.toVector PL.$ reclaim lend)+qsortWith (NaiveDC p) v =+  unur PL.$ linearly \lin ->+    DataFlow.do+      (lin, l2) <- dup lin+      runBO lin Control.do+        (v, lend) <- borrowM (VL.fromVector v l2)+        Control.void PL.$ naiveDivideAndConquer (qsortDC' p) v+        pureAfter (VL.toVector PL.$ reclaim lend)+qsortWith (Worksteal p) v =+  unur PL.$ linearly \lin ->+    DataFlow.do+      (lin, l2) <- dup lin+      runBO lin Control.do+        (v, lend) <- borrowM (VL.fromVector v l2)+        Control.void PL.$ qsortDC (mkStdGen 42) p 128 v+        pureAfter (VL.toVector PL.$ reclaim lend)++data SampleSize = SampleSize Int+  deriving (Show, Eq, Ord)++instance IsOption SampleSize where+  defaultValue = SampleSize 32+  parseValue s =+    case readMaybe s of+      Just n | n > 0, kMAX_SIZE `rem` n == 0 -> Just (SampleSize n)+      _ -> Nothing+  optionName = return "size"+  optionHelp =+    return "Number of linear size steps (positive divisor of 32768)"+ main :: IO ()-main = defaultMain+main = do+  numThreads <- getNumCapabilities+  let customOpts = [Option (Proxy :: Proxy SampleSize)]+      ingredients = includingOptions customOpts : benchIngredients+  defaultMainWithIngredients ingredients $ askOption \(SampleSize sampleSize) ->+    bgroup "All" $ benches BenchOpts {..}++benches :: BenchOpts -> [Benchmark]+benches BenchOpts {..} =+  [ bgroup+      "qsort"+      [ env+          ( pure $ runStateGen_ (mkStdGen 42) \g -> do+              V.replicateM size (uniformM g)+          )+          \vec ->+            bgroup+              (show size)+              ( [ bench "intro" $ nf (qsortWith IntroSort) vec+                , bench "sequential" $ nf (qsortWith Sequential) vec+                ]+                  <> [ bench ("parallel (budget = " <> show n <> ")") $+                         nf (qsortWith $ Parallel n) vec+                     | n <- [4, 8, 16, 32]+                     ]+                  <> [ bench ("parallel-dc (thresh = 128)") $+                         nf (qsortWith $ NaiveDC 128) vec+                     ]+                  <> [ bench ("worksteal (workers = " <> show n <> ")") $+                         nf (qsortWith $ Worksteal n) vec+                     | n <- [2, 4 .. numThreads]+                     ]+              )+      | i <- [0 .. sampleSize]+      , let size = i * kMAX_SIZE `quot` sampleSize+      ]+  ]++kMAX_SIZE :: Int+kMAX_SIZE = 32 * 1024

@@ -0,0 +1,5 @@+-- The two @--ingredient@ flags rebuild 'Test.Tasty.Bench.benchIngredients':+-- @tasty-discover@ prepends each ingredient to 'Test.Tasty.defaultIngredients'+-- in reverse flag order, so @listingTests@ ends up first (keeping+-- @--list-tests@ working) and the composed bench reporter second.+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --ingredient=PureBorrow.Bench.Ingredients.benchReporter -optF --ingredient=Test.Tasty.Ingredients.Basic.listingTests #-}

@@ -0,0 +1,176 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module PureBorrow.Bench.CopyAt (+  test_copyAt,+  composedPureBorrowCopiedReadLoop,+  directCopiedReadLoop,+  pureBorrowCopiedReadLoop,+  pureBorrowUpdateLoop,+  reborrowingUpdateLoop,+) where++import Control.Exception (evaluate)+import Control.Functor.Linear qualified as Control+import Control.Monad.Borrow.Pure+import Control.Monad.ST.Strict (runST)+import Control.Syntax.DataFlow qualified as DataFlow+import Data.Vector qualified as V+import Data.Vector.Mutable qualified as MV+import Data.Vector.Mutable.Linear.Borrow qualified as VL+import Prelude.Linear+import Test.Tasty.Bench hiding (defaultMain)+import Prelude qualified as NonLinear++directCopiedReadLoop :: V.Vector Int -> (Int, V.Vector Int)+{-# NOINLINE directCopiedReadLoop #-}+directCopiedReadLoop input = runST do+  mutable <- V.thaw input+  total <- go mutable 0 0+  frozen <- V.unsafeFreeze mutable+  NonLinear.pure (total, frozen)+  where+    go mutable !i !total+      | i >= MV.length mutable = NonLinear.pure total+      | otherwise = do+          value <- MV.read mutable i+          go mutable (i + 1) (total + value)++pureBorrowCopiedReadLoop :: V.Vector Int -> (Int, V.Vector Int)+{-# NOINLINE pureBorrowCopiedReadLoop #-}+pureBorrowCopiedReadLoop input = unur $ linearly \linearlyToken -> DataFlow.do+  (runToken, vectorToken) <- dup linearlyToken+  runBO runToken Control.do+    (initialMutable, lend) <- borrowM (VL.fromVector input vectorToken)+    VL.size initialMutable & \(Ur length_, sizedMutable) ->+      go length_ 0 0 sizedMutable lend+  where+    go ::+      forall α.+      Int ->+      Int ->+      Int ->+      Mut α (VL.Vector Int) %1 ->+      Lend α (VL.Vector Int) %1 ->+      BO α (After α (Ur (Int, V.Vector Int)))+    go !length_ !i !total mutable lend+      | i >= length_ =+          consume mutable `lseq`+            Control.pure+              ( ( \vector -> case VL.toVector vector of+                    Ur frozen -> Ur (total, frozen)+                )+                  Control.<$> reclaim' lend+              )+      | otherwise = Control.do+          (Ur value, nextMutable) <- VL.copyAtMut i mutable+          go length_ (i + 1) (total + value) nextMutable lend++composedPureBorrowCopiedReadLoop :: V.Vector Int -> (Int, V.Vector Int)+{-# NOINLINE composedPureBorrowCopiedReadLoop #-}+composedPureBorrowCopiedReadLoop input = unur $ linearly \linearlyToken -> DataFlow.do+  (runToken, vectorToken) <- dup linearlyToken+  runBO runToken Control.do+    (initialMutable, lend) <- borrowM (VL.fromVector input vectorToken)+    VL.size initialMutable & \(Ur length_, sizedMutable) ->+      go length_ 0 0 sizedMutable lend+  where+    go ::+      forall α.+      Int ->+      Int ->+      Int ->+      Mut α (VL.Vector Int) %1 ->+      Lend α (VL.Vector Int) %1 ->+      BO α (After α (Ur (Int, V.Vector Int)))+    go !length_ !i !total mutable lend+      | i >= length_ =+          consume mutable `lseq`+            Control.pure+              ( ( \vector -> case VL.toVector vector of+                    Ur frozen -> Ur (total, frozen)+                )+                  Control.<$> reclaim' lend+              )+      | otherwise = Control.do+          (Ur value, nextMutable) <-+            sharing @α @α mutable \shared -> VL.copyAt i shared+          go length_ (i + 1) (total + value) nextMutable lend++pureBorrowUpdateLoop :: V.Vector Int -> V.Vector Int+{-# NOINLINE pureBorrowUpdateLoop #-}+pureBorrowUpdateLoop input = unur $ linearly \linearlyToken -> DataFlow.do+  (runToken, vectorToken) <- dup linearlyToken+  runBO runToken Control.do+    (initialMutable, lend) <- borrowM (VL.fromVector input vectorToken)+    VL.size initialMutable & \(Ur length_, sizedMutable) ->+      go length_ 0 sizedMutable lend+  where+    go ::+      forall α.+      Int ->+      Int ->+      Mut α (VL.Vector Int) %1 ->+      Lend α (VL.Vector Int) %1 ->+      BO α (After α (Ur (V.Vector Int)))+    go !length_ !i mutable lend+      | i >= length_ =+          consume mutable `lseq`+            Control.pure (VL.toVector Control.<$> reclaim' lend)+      | otherwise = Control.do+          nextMutable <- VL.modify i (+ 1) mutable+          go length_ (i + 1) nextMutable lend++reborrowingUpdateLoop :: V.Vector Int -> V.Vector Int+{-# NOINLINE reborrowingUpdateLoop #-}+reborrowingUpdateLoop input = unur $ linearly \linearlyToken -> DataFlow.do+  (runToken, vectorToken) <- dup linearlyToken+  runBO runToken Control.do+    (initialMutable, lend) <- borrowM (VL.fromVector input vectorToken)+    VL.size initialMutable & \(Ur length_, sizedMutable) ->+      go length_ 0 sizedMutable lend+  where+    go ::+      forall α.+      Int ->+      Int ->+      Mut α (VL.Vector Int) %1 ->+      Lend α (VL.Vector Int) %1 ->+      BO α (After α (Ur (V.Vector Int)))+    go !length_ !i mutable lend+      | i >= length_ =+          consume mutable `lseq`+            Control.pure (VL.toVector Control.<$> reclaim' lend)+      | otherwise = Control.do+          nextMutable <-+            reborrowing_ mutable \scopedMutable -> Control.do+              modifiedScoped <- VL.modify i (+ 1) scopedMutable+              Control.pure (consume modifiedScoped)+          go length_ (i + 1) nextMutable lend++test_copyAt :: [Benchmark]+test_copyAt =+  [ bgroup+      "copy-at"+      [ env+          (evaluate $ V.generate size (`NonLinear.rem` 1024))+          \input ->+            bgroup+              (NonLinear.show size)+              [ bench "direct-vector" $ nf directCopiedReadLoop input+              , bench "pure-borrow/direct-copy" $ nf pureBorrowCopiedReadLoop input+              , bench "pure-borrow/composed-copy" $ nf composedPureBorrowCopiedReadLoop input+              ]+      | size <- [4 * 1024, 64 * 1024, 1024 * 1024]+      ]+  , env+      (evaluate $ V.generate (1024 * 1024) (`NonLinear.rem` 1024))+      \input ->+        bgroup+          "discarding-scope/update"+          [ bench "pure-borrow/no-scope" $ nf pureBorrowUpdateLoop input+          , bench "reborrowing_" $ nf reborrowingUpdateLoop input+          ]+  ]

@@ -0,0 +1,97 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module PureBorrow.Bench.Growable (+  test_growable,+  directContentUpdateLoop,+  fixedContentUpdateLoop,+  growableContentUpdateLoop,+) where++import Control.Functor.Linear qualified as Control+import Control.Monad.Borrow.Pure+import Control.Syntax.DataFlow qualified as DataFlow+import Data.STRef (newSTRef, readSTRef)+import Data.Vector qualified as V+import Data.Vector.Mutable qualified as MV+import Data.Vector.Mutable.Growable.Linear.Borrow qualified as Growable+import Data.Vector.Mutable.Linear.Borrow qualified as Fixed+import Prelude.Linear+import Test.Tasty.Bench hiding (defaultMain)+import Prelude qualified as NonLinear++directContentUpdateLoop :: V.Vector Int -> V.Vector Int+{-# NOINLINE directContentUpdateLoop #-}+directContentUpdateLoop input =+  V.modify+    ( \mutable -> do+        -- The header ref mirrors the growable vector's indirection, so the+        -- baseline pays for the same extra load the measured variants do.+        header <- newSTRef (V.length input, mutable)+        (logicalSize, contents) <- readSTRef header+        go logicalSize 0 contents+    )+    input+  where+    go !logicalSize !index contents+      | index >= logicalSize = NonLinear.pure ()+      | otherwise = do+          value <- MV.unsafeRead contents index+          MV.unsafeWrite contents index (value + 1)+          go logicalSize (index + 1) contents++fixedContentUpdateLoop :: V.Vector Int -> V.Vector Int+{-# NOINLINE fixedContentUpdateLoop #-}+fixedContentUpdateLoop input =+  unur $ linearly \linear -> DataFlow.do+    (ownerLinear, runLinear) <- dup linear+    runBO runLinear Control.do+      (initialVector, lend) <- borrowM (Fixed.fromVector input ownerLinear)+      updatedVector <- updateContents (V.length input) 0 initialVector+      let !() = consume updatedVector+      pureAfter $ Fixed.toVector (reclaim lend)++growableContentUpdateLoop :: V.Vector Int -> V.Vector Int+{-# NOINLINE growableContentUpdateLoop #-}+growableContentUpdateLoop input =+  unur $ linearly \linear -> DataFlow.do+    (ownerLinear, runLinear) <- dup linear+    runBO runLinear Control.do+      (initialVector, lend) <- borrowM (Growable.fromVector input ownerLinear)+      updatedVector <- Growable.withContent_ initialVector \contents ->+        updateContents (V.length input) 0 contents+      let !() = consume updatedVector+      pureAfter $ Growable.toVector (reclaim lend)++updateContents ::+  forall α.+  Int ->+  Int ->+  Mut α (Fixed.Vector Int) %1 ->+  BO α ()+{-# INLINE updateContents #-}+updateContents !logicalSize !index contents+  | index >= logicalSize = Control.pure (consume contents)+  | otherwise = Control.do+      ((), nextContents) <-+        Fixed.unsafeUpdate+          index+          (\ !value -> Control.pure ((), value + 1))+          contents+      updateContents logicalSize (index + 1) nextContents++test_growable :: [Benchmark]+test_growable =+  [ env+      (NonLinear.pure $ V.generate (1024 * 1024) (`NonLinear.rem` 1024))+      \input ->+        bgroup+          "growable/content-update"+          [ bench "direct/header-open-once" $ nf directContentUpdateLoop input+          , bench "pure-borrow/fixed" $ nf fixedContentUpdateLoop input+          , bench "pure-borrow/withContent_" $ nf growableContentUpdateLoop input+          ]+  ]

@@ -0,0 +1,270 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++{- | Benchmarks of the Robin Hood hash table.++Each group measures the same workload three ways: this package's table (owned,+and through its borrow-aware wrapper), @linear-base@'s own linear hash map, and+the unrestricted @unordered-containers@ map. The expensive-key groups exist+because the table caches a fingerprint per slot: a key whose hash is cheap but+whose equality is not is exactly where that cache pays off, and the colliding+group is the extreme of that, where every key lands in one bucket and only the+fingerprint can reject a candidate without a full comparison.+-}+module PureBorrow.Bench.HashMap (+  test_hashMap,+  ExpensiveKey (..),+  benchInsertRobinHood,+  benchInsertRobinHoodBorrow,+  benchInsertLinearBase,+  benchInsertUnordered,+  benchFromListRobinHood,+  benchFromListLinearBase,+  benchFromListUnordered,+  benchLookupRobinHood,+  benchLookupRobinHoodBorrow,+  benchLookupLinearBase,+  benchLookupUnordered,+  testData,+  expensiveTestData,+  collidingExpensiveTestData,+) where++import Control.DeepSeq (NFData, force)+import Control.Exception (evaluate)+import Control.Functor.Linear qualified as Control+import Control.Monad.Borrow.Pure+import Control.Syntax.DataFlow qualified as DataFlow+import Data.HashMap.Mutable.Linear qualified as LB+import Data.HashMap.RobinHood.Mutable.Linear qualified as RH+import Data.HashMap.RobinHood.Mutable.Linear.Borrow qualified as RHB+import Data.HashMap.Strict qualified as UCHM+import Data.Hashable (Hashable (..))+import GHC.Generics (Generic)+import Prelude.Linear (lseq, unur, (&))+import Prelude.Linear qualified as PL+import Test.Tasty.Bench++{- | A key with a cheap hash and an expensive equality.++The hash reads only the prefix, so two keys sharing a prefix collide and force+the payloads to be compared.+-}+data ExpensiveKey = ExpensiveKey+  { ekPrefix :: {-# UNPACK #-} !Int+  , ekPayload :: ![Int]+  }+  deriving (Show, Generic, NFData)++instance Eq ExpensiveKey where+  ExpensiveKey p1 payload1 == ExpensiveKey p2 payload2 =+    p1 == p2 && payload1 == payload2+  {-# INLINE (==) #-}++instance Hashable ExpensiveKey where+  hashWithSalt s (ExpensiveKey p _) = hashWithSalt s p+  {-# INLINE hashWithSalt #-}++-- * Insertion into an empty table++benchInsertRobinHood :: (Hashable k) => [(k, v)] -> [(k, v)]+benchInsertRobinHood kvs = unur PL.$ linearly \lin ->+  let %1 !hm = RH.new (length kvs) lin+   in RH.toList (RH.insertMany kvs hm)++benchInsertRobinHoodBorrow :: (Hashable k) => [(k, v)] -> [(k, v)]+benchInsertRobinHoodBorrow kvs = unur PL.$ linearly \lin -> DataFlow.do+  (ownerLinear, runLinear) <- PL.dup lin+  runBO runLinear Control.do+    (table, lend) <- borrowM (RHB.empty (length kvs) ownerLinear)+    table <- insertAllBorrow kvs table+    (Ur entries, table) <- RHB.toList table+    PL.consume table `lseq`+      pureAfter (PL.consume (reclaim lend) `lseq` Ur entries)++insertAllBorrow ::+  (Hashable k) =>+  [(k, v)] ->+  Mut α (RHB.HashMap k v) %1 ->+  BO α (Mut α (RHB.HashMap k v))+insertAllBorrow [] table = Control.pure table+insertAllBorrow ((k, v) : rest) table = Control.do+  (Ur _, table) <- RHB.insert k v table+  insertAllBorrow rest table++benchInsertLinearBase :: (LB.Keyed k) => [(k, v)] -> [(k, v)]+benchInsertLinearBase kvs = unur PL.$ LB.empty (length kvs) \hm ->+  LB.toList (insertManyLinearBase kvs hm)++insertManyLinearBase :: (LB.Keyed k) => [(k, v)] -> LB.HashMap k v %1 -> LB.HashMap k v+insertManyLinearBase [] hm = hm+insertManyLinearBase ((k, v) : rest) hm = insertManyLinearBase rest (LB.insert k v hm)++benchInsertUnordered :: (Hashable k) => [(k, v)] -> [(k, v)]+benchInsertUnordered kvs = UCHM.toList (foldr (uncurry UCHM.insert) UCHM.empty kvs)++-- * Bulk construction++benchFromListRobinHood :: (Hashable k) => [(k, v)] -> [(k, v)]+benchFromListRobinHood kvs = unur PL.$ linearly \lin ->+  RH.toList (RH.fromList kvs lin)++benchFromListLinearBase :: (LB.Keyed k) => [(k, v)] -> [(k, v)]+benchFromListLinearBase kvs = unur PL.$ LB.fromList kvs LB.toList++benchFromListUnordered :: (Hashable k) => [(k, v)] -> [(k, v)]+benchFromListUnordered kvs = UCHM.toList (UCHM.fromList kvs)++-- * Lookup after a bulk insertion++benchLookupRobinHood :: forall k v. (Hashable k) => [(k, v)] -> [k] -> Int+benchLookupRobinHood kvs keys = unur PL.$ linearly \lin ->+  let %1 !hm = RH.insertMany kvs (RH.new (length kvs) lin)+   in go 0 keys hm+  where+    go :: Int -> [k] -> RH.HashMap k v %1 -> Ur Int+    go !acc [] hm = hm `lseq` Ur acc+    go !acc (k : ks) hm =+      RH.lookup k hm & \(Ur mv, hm') ->+        go (acc + maybe 0 (const 1) mv) ks hm'++benchLookupRobinHoodBorrow :: forall k v. (Hashable k) => [(k, v)] -> [k] -> Int+benchLookupRobinHoodBorrow kvs keys = unur PL.$ linearly \lin -> DataFlow.do+  (ownerLinear, runLinear) <- PL.dup lin+  runBO runLinear Control.do+    (table, lend) <- borrowM (RHB.fromList kvs ownerLinear)+    (Ur found, table) <- go 0 keys table+    PL.consume table `lseq`+      pureAfter (PL.consume (reclaim lend) `lseq` Ur found)+  where+    go ::+      Int ->+      [k] ->+      Mut α (RHB.HashMap k v) %1 ->+      BO α (Ur Int, Mut α (RHB.HashMap k v))+    go !acc [] table = Control.pure (Ur acc, table)+    go !acc (k : ks) table = Control.do+      (Ur mv, table) <- RHB.lookup k table+      go (acc + maybe 0 (const 1) mv) ks table++benchLookupLinearBase :: forall k v. (LB.Keyed k) => [(k, v)] -> [k] -> Int+benchLookupLinearBase kvs keys = unur PL.$ LB.empty (length kvs) \hm ->+  let %1 !hm' = insertManyLinearBase kvs hm+   in go 0 keys hm'+  where+    go :: Int -> [k] -> LB.HashMap k v %1 -> Ur Int+    go !acc [] hm = hm `lseq` Ur acc+    go !acc (k : ks) hm =+      LB.lookup k hm & \(Ur mv, hm') ->+        go (acc + maybe 0 (const 1) mv) ks hm'++benchLookupUnordered :: forall k v. (Hashable k) => [(k, v)] -> [k] -> Int+benchLookupUnordered kvs keys = go 0 keys (foldr (uncurry UCHM.insert) UCHM.empty kvs)+  where+    go !acc [] _ = acc+    go !acc (k : ks) hm =+      go (acc + maybe 0 (const 1) (UCHM.lookup k hm)) ks hm++-- * Inputs++-- | Distinct integer keys.+testData :: Int -> [(Int, Int)]+testData n = [(i, i) | i <- [1 .. n]]++-- | Distinct expensive keys: unique prefixes, hundred-element payloads.+expensiveTestData :: Int -> [(ExpensiveKey, Int)]+expensiveTestData n =+  [ (ExpensiveKey i [i .. i + 99], i)+  | i <- [1 .. n]+  ]++-- | Expensive keys that all hash to one bucket.+collidingExpensiveTestData :: Int -> [(ExpensiveKey, Int)]+collidingExpensiveTestData n =+  [ (ExpensiveKey 42 [i .. i + 99], i)+  | i <- [1 .. n]+  ]++test_hashMap :: [Benchmark]+test_hashMap =+  [ bgroup+      "hashmap/insert"+      [ env (evaluate (force (testData n))) \kvs ->+          bgroup+            (show n)+            [ bench "robin-hood" $ nf benchInsertRobinHood kvs+            , bench "robin-hood/borrow" $ nf benchInsertRobinHoodBorrow kvs+            , bench "linear-base" $ nf benchInsertLinearBase kvs+            , bench "unordered-containers" $ nf benchInsertUnordered kvs+            ]+      | n <- sizes+      ]+  , bgroup+      "hashmap/from-list"+      [ env (evaluate (force (testData n))) \kvs ->+          bgroup+            (show n)+            [ bench "robin-hood" $ nf benchFromListRobinHood kvs+            , bench "linear-base" $ nf benchFromListLinearBase kvs+            , bench "unordered-containers" $ nf benchFromListUnordered kvs+            ]+      | n <- sizes+      ]+  , bgroup+      "hashmap/lookup"+      [ env (evaluate (force (testData n))) \kvs ->+          bgroup+            (show n)+            [ bench "robin-hood" $ nf (benchLookupRobinHood kvs) (map fst kvs)+            , bench "robin-hood/borrow" $ nf (benchLookupRobinHoodBorrow kvs) (map fst kvs)+            , bench "linear-base" $ nf (benchLookupLinearBase kvs) (map fst kvs)+            , bench "unordered-containers" $ nf (benchLookupUnordered kvs) (map fst kvs)+            ]+      | n <- sizes+      ]+  , bgroup+      "hashmap/expensive-key-insert"+      [ env (evaluate (force (expensiveTestData n))) \kvs ->+          bgroup+            (show n)+            [ bench "robin-hood" $ nf benchInsertRobinHood kvs+            , bench "linear-base" $ nf benchInsertLinearBase kvs+            , bench "unordered-containers" $ nf benchInsertUnordered kvs+            ]+      | n <- sizes+      ]+  , bgroup+      "hashmap/expensive-key-lookup"+      [ env (evaluate (force (expensiveTestData n))) \kvs ->+          bgroup+            (show n)+            [ bench "robin-hood" $ nf (benchLookupRobinHood kvs) (map fst kvs)+            , bench "linear-base" $ nf (benchLookupLinearBase kvs) (map fst kvs)+            , bench "unordered-containers" $ nf (benchLookupUnordered kvs) (map fst kvs)+            ]+      | n <- sizes+      ]+  , bgroup+      "hashmap/colliding-expensive-key-lookup"+      [ env (evaluate (force (collidingExpensiveTestData n))) \kvs ->+          bgroup+            (show n)+            [ bench "robin-hood" $ nf (benchLookupRobinHood kvs) (map fst kvs)+            , bench "linear-base" $ nf (benchLookupLinearBase kvs) (map fst kvs)+            , bench "unordered-containers" $ nf (benchLookupUnordered kvs) (map fst kvs)+            ]+      | -- Every key lands in one bucket, so the workload is quadratic; the+      -- large size would dominate the whole suite's wall clock.+      n <- collidingSizes+      ]+  ]++sizes :: [Int]+sizes = [100, 1000, 10000]++collidingSizes :: [Int]+collidingSizes = [100, 1000]

@@ -0,0 +1,21 @@+module PureBorrow.Bench.Ingredients (benchReporter) where++import Test.Tasty.Bench (consoleBenchReporter, csvReporter, svgReporter)+import Test.Tasty.Ingredients (Ingredient, composeReporters)++{- | The reporting half of 'Test.Tasty.Bench.benchIngredients', as a single+composed ingredient.++Composition matters: 'Test.Tasty.defaultMainWithIngredients' runs the first+ingredient that accepts the given options, and 'consoleBenchReporter' accepts+every invocation. Listing the reporters separately would therefore make+@--csv@ and @--svg@ unreachable.++This is a separate ingredient rather than the whole 'benchIngredients' list so+that it can be named by @tasty-discover@'s @--ingredient@ flag; see+@bench/suite/Main.hs@. Discovery skips this module: @tasty-discover@ imports+only the modules that export a discovered binding.+-}+benchReporter :: Ingredient+benchReporter =+  consoleBenchReporter `composeReporters` (csvReporter `composeReporters` svgReporter)

@@ -0,0 +1,12 @@+{- | Exposes the benchmarks of "PureBorrow.Internal.Bench.MultiStoreScan" to+@tasty-discover@. The kernels themselves stay in the @bench-suites@ internal+library because @pure-borrow-test@ and @pure-borrow-inspection@ exercise them+too.+-}+module PureBorrow.Bench.MultiStoreScan (test_multiStoreScan) where++import PureBorrow.Internal.Bench.MultiStoreScan qualified as MultiStoreScan+import Test.Tasty.Bench (Benchmark)++test_multiStoreScan :: [Benchmark]+test_multiStoreScan = MultiStoreScan.benches

@@ -0,0 +1,478 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE NoImplicitPrelude #-}+-- Rebinding a threaded linear borrow under its own name is the idiom these+-- loops are written in, as it is in the library itself.+{-# OPTIONS_GHC -Wno-name-shadowing #-}++{- |+R4 --- the scope-density regression.++Every other benchmark in this package is dominated by what happens /inside/ a+borrow scope. This one is dominated by the scopes themselves: one owner, one+@'Ref.Ref' 'Int'@, and a loop whose body is a single read-modify-write, crossed+by exactly one scope per iteration. The arms differ only in which delimiter+that crossing goes through, so the difference between an arm and the+scope-free control is the cost of one crossing, and the sweep over iteration+counts turns that difference into a slope rather than a single number.++The fixture exists because nothing here could see the two things that matter+most about the delimiters:++  * @c35dace@ removed the runtime construction of the sublifetime and a+    downstream e-graph engine measured 6.9--10.3% less allocation across+    12 cases, while this package measured nothing at all; and+  * @ebba572@ then put one out-of-line @reviveAlias@ on every scope exit, and+    recorded that no benchmark shipped here resolves it --- @copy-at@ is+    byte-identical with a timing difference inside machine noise,+    @qsort-bench@ takes one @reborrowing'@ per @divideAndConquer'@ call rather+    than per node, and the FFT recursion amortises one exit over+    @O(log n)@ butterfly work.++So the loop below is deliberately the artificial worst case: an L1-resident+counter whose body is small enough that a per-exit call is a visible fraction+of it. That is the only shape in which a per-scope cost is observable, and it+is not a claim about any real workload. Read it as a lower bound on how much a+scope can cost and an early-warning gate on that cost changing, never as a+prediction of what a scope costs an application.++Two conventions keep the arms comparable.++Every arm performs exactly the same mutation the same number of times: one+@'Ref.modify' (+1)@ per iteration for the single-owner arms, and one per owner+for the two-owner arms. The plural arms therefore have their own matched+control rather than being compared against the single-owner one.++The plural arms build their @'Muts'@ bundle once, outside the loop, and thread+it. A bundle rebuilt per iteration would measure @(':-')@ allocation, which is+a real cost of some call sites but not a cost of the delimiter.+-}+module PureBorrow.Bench.ScopeDensity (+  test_scopeDensity,++  -- * Single-owner mutable arms+  scopeFreeLoop,+  reborrowingLoop,+  reborrowingDiscardingLoop,+  reborrowingFinalizingLoop,+  locallyDiscardingLoop,++  -- * Single-owner shared arms+  sharingHoistedLoop,+  sharingPerIterationLoop,++  -- * Two-owner arms+  scopeFreePairLoop,+  bundleThreadedPairLoop,+  reborrowingsDiscardingLoop,+  reborrowingsRespineLoop,+  reborrowingsLoop,+) where++import Control.Functor.Linear qualified as Control+import Control.Monad.Borrow.Pure+import Control.Monad.Borrow.Pure.Experimental.Borrows+import Control.Monad.Borrow.Pure.Experimental.Reborrowable (locally_)+import Control.Syntax.DataFlow qualified as DataFlow+import Data.Ref.Linear qualified as Ref+import Data.Ref.Linear.Borrow qualified as RefBorrow+import Prelude.Linear+import Test.Tasty.Bench hiding (defaultMain)+import Prelude qualified as NonLinear++{- $setup+Each arm is 'NOINLINE' and takes its iteration count as an argument, so that a+count chosen by the benchmark driver cannot be constant-folded into the body.+-}++-- | Allocate one owner, borrow it, run @k@, and return the final counter.+withCounter ::+  (forall α. Mut α (Ref.Ref Int) %1 -> Lend α (Ref.Ref Int) %1 -> BO α (After α (Ur Int))) %1 ->+  Int+{-# INLINE withCounter #-}+withCounter k = unur $ linearly \linear -> DataFlow.do+  (runToken, refToken) <- dup linear+  runBO runToken Control.do+    (mut, lend) <- borrowM (Ref.new (0 :: Int) refToken)+    k mut lend++-- | The same with two independent owners.+withCounterPair ::+  ( forall α.+    Mut α (Ref.Ref Int) %1 ->+    Mut α (Ref.Ref Int) %1 ->+    Lend α (Ref.Ref Int) %1 ->+    Lend α (Ref.Ref Int) %1 ->+    BO α (After α (Ur Int))+  ) %1 ->+  Int+{-# INLINE withCounterPair #-}+withCounterPair k = unur $ linearly \linear -> DataFlow.do+  (runToken, ownerToken) <- dup linear+  (leftToken, rightToken) <- dup ownerToken+  runBO runToken Control.do+    (leftMut, leftLend) <- borrowM (Ref.new (0 :: Int) leftToken)+    (rightMut, rightLend) <- borrowM (Ref.new (0 :: Int) rightToken)+    k leftMut rightMut leftLend rightLend++-- | Reclaim one owner and move its final counter out.+finishCounter ::+  Lend α (Ref.Ref Int) %1 ->+  After α (Ur Int)+{-# INLINE finishCounter #-}+finishCounter lend = (move . Ref.free) Control.<$> reclaim' lend++{- | Reclaim both owners and move the sum of their counters out.++The sum, rather than one of the two, so that neither owner's updates can be+dropped as dead.+-}+finishCounterPair ::+  Lend α (Ref.Ref Int) %1 ->+  Lend α (Ref.Ref Int) %1 ->+  After α (Ur Int)+{-# INLINE finishCounterPair #-}+finishCounterPair leftLend rightLend =+  ( \left right -> case (move (Ref.free left), move (Ref.free right)) of+      (Ur left, Ur right) -> Ur (left + right)+  )+    Control.<$> reclaim' leftLend+    Control.<*> reclaim' rightLend++-- | The control: the mutation without a scope, with the borrow threaded by hand.+scopeFreeLoop :: Int -> Int+{-# NOINLINE scopeFreeLoop #-}+scopeFreeLoop iterations = withCounter (go iterations)+  where+    go ::+      forall α.+      Int ->+      Mut α (Ref.Ref Int) %1 ->+      Lend α (Ref.Ref Int) %1 ->+      BO α (After α (Ur Int))+    go !i mut lend+      | i <= 0 = consume mut `lseq` Control.pure (finishCounter lend)+      | otherwise = Control.do+          mut <- RefBorrow.modify (+ 1) mut+          go (i - 1) mut lend++-- | One result-discarding mutable scope per iteration.+reborrowingDiscardingLoop :: Int -> Int+{-# NOINLINE reborrowingDiscardingLoop #-}+reborrowingDiscardingLoop iterations = withCounter (go iterations)+  where+    go ::+      forall α.+      Int ->+      Mut α (Ref.Ref Int) %1 ->+      Lend α (Ref.Ref Int) %1 ->+      BO α (After α (Ur Int))+    go !i mut lend+      | i <= 0 = consume mut `lseq` Control.pure (finishCounter lend)+      | otherwise = Control.do+          mut <- reborrowing_ mut \scoped ->+            consume Control.<$> RefBorrow.modify (+ 1) scoped+          go (i - 1) mut lend++-- | One result-returning mutable scope per iteration.+reborrowingLoop :: Int -> Int+{-# NOINLINE reborrowingLoop #-}+reborrowingLoop iterations = withCounter (go iterations)+  where+    go ::+      forall α.+      Int ->+      Mut α (Ref.Ref Int) %1 ->+      Lend α (Ref.Ref Int) %1 ->+      BO α (After α (Ur Int))+    go !i mut lend+      | i <= 0 = consume mut `lseq` Control.pure (finishCounter lend)+      | otherwise = Control.do+          ((), mut) <- reborrowing mut \scoped ->+            consume Control.<$> RefBorrow.modify (+ 1) scoped+          go (i - 1) mut lend++-- | One finalizing mutable scope per iteration, whose continuation returns an 'After'.+reborrowingFinalizingLoop :: Int -> Int+{-# NOINLINE reborrowingFinalizingLoop #-}+reborrowingFinalizingLoop iterations = withCounter (go iterations)+  where+    go ::+      forall α.+      Int ->+      Mut α (Ref.Ref Int) %1 ->+      Lend α (Ref.Ref Int) %1 ->+      BO α (After α (Ur Int))+    go !i mut lend+      | i <= 0 = consume mut `lseq` Control.pure (finishCounter lend)+      | otherwise = Control.do+          ((), mut) <- reborrowing' mut \scoped -> Control.do+            scoped <- RefBorrow.modify (+ 1) scoped+            -- The inner 'Control.pure' is the @'After' β@ applicative's.+            Control.pure (Control.pure (consume scoped))+          go (i - 1) mut lend++{- | The shared control: @n@ reads under a single hoisted 'sharing' scope.++A shared borrow cannot mutate, so the shared arms read rather than write, and+their control cannot be scope-free: 'share' consumes the mutable occurrence, so+the only way to read through a 'Share' and still get the owner back is a scope.+The honest comparison is therefore against the share-once idiom the library+documents — one scope hoisted out of the loop, the 'Share' moved to an+unrestricted occurrence, and @n@ reads inside — which is what this arm is.+-}+sharingHoistedLoop :: Int -> Int+{-# NOINLINE sharingHoistedLoop #-}+sharingHoistedLoop iterations = withCounter \mut lend -> Control.do+  (Ur seen, mut) <- sharing mut \shared ->+    move shared & \(Ur shared) -> go iterations 0 shared+  consume mut `lseq`+    Control.pure ((\(Ur final) -> Ur (final + seen)) Control.<$> finishCounter lend)+  where+    go :: Int -> Int -> Share β (Ref.Ref Int) -> BO β (Ur Int)+    go !i !seen shared+      | i <= 0 = Control.pure (Ur seen)+      | otherwise = Control.do+          Ur observed <- move Control.<$> RefBorrow.copyRef shared+          go (i - 1) (seen + observed) shared++-- | The same @n@ reads, each under its own 'sharing' scope.+sharingPerIterationLoop :: Int -> Int+{-# NOINLINE sharingPerIterationLoop #-}+sharingPerIterationLoop iterations = withCounter (go iterations 0)+  where+    go ::+      forall α.+      Int ->+      Int ->+      Mut α (Ref.Ref Int) %1 ->+      Lend α (Ref.Ref Int) %1 ->+      BO α (After α (Ur Int))+    go !i !seen mut lend+      | i <= 0 =+          consume mut `lseq`+            Control.pure ((\(Ur final) -> Ur (final + seen)) Control.<$> finishCounter lend)+      | otherwise = Control.do+          (Ur observed, mut) <- sharing mut \shared ->+            move Control.<$> RefBorrow.copyRef shared+          go (i - 1) (seen + observed) mut lend++-- | One result-discarding scope per iteration, through the generic 'locally_'.+locallyDiscardingLoop :: Int -> Int+{-# NOINLINE locallyDiscardingLoop #-}+locallyDiscardingLoop iterations = withCounter (go iterations)+  where+    go ::+      forall α.+      Int ->+      Mut α (Ref.Ref Int) %1 ->+      Lend α (Ref.Ref Int) %1 ->+      BO α (After α (Ur Int))+    go !i mut lend+      | i <= 0 = consume mut `lseq` Control.pure (finishCounter lend)+      | otherwise = Control.do+          mut <- locally_ mut \scoped ->+            consume Control.<$> RefBorrow.modify (+ 1) scoped+          go (i - 1) mut lend++-- | The two-owner control: two mutations per iteration, no scope, no bundle.+scopeFreePairLoop :: Int -> Int+{-# NOINLINE scopeFreePairLoop #-}+scopeFreePairLoop iterations = withCounterPair (go iterations)+  where+    go ::+      forall α.+      Int ->+      Mut α (Ref.Ref Int) %1 ->+      Mut α (Ref.Ref Int) %1 ->+      Lend α (Ref.Ref Int) %1 ->+      Lend α (Ref.Ref Int) %1 ->+      BO α (After α (Ur Int))+    go !i leftMut rightMut leftLend rightLend+      | i <= 0 =+          consume leftMut `lseq`+            consume rightMut `lseq`+              Control.pure (finishCounterPair leftLend rightLend)+      | otherwise = Control.do+          leftMut <- RefBorrow.modify (+ 1) leftMut+          rightMut <- RefBorrow.modify (+ 1) rightMut+          go (i - 1) leftMut rightMut leftLend rightLend++{- | A bundle threaded and rebuilt each iteration, crossing no scope.++This was written to separate the spine cost from the delimiter cost, and it+does not do that — the arithmetic does not work, and saying so is cheaper than+letting a reader rederive it. It allocates about 80 bytes per iteration over+'scopeFreePairLoop' where the delimiter arms allocate 40 before erasure and 0+after, because its rebuilt spine is loop-carried and genuinely allocated, while+a delimiter hands back the bundle it was given and never rebuilds one. It is+not a point between 'scopeFreePairLoop' and the delimiter arms, so+@delimiter = reborrowings_ − bundled@ would come out negative.++What it does measure is a caller-side cost: what threading and rebuilding a+bundle per iteration costs someone who writes that. Keep it for that, and+compare the delimiter arms against 'scopeFreePairLoop' only. That comparison+charges the delimiter for the bundle destructure as well, so it is an upper+bound on the delimiter's own cost rather than an estimate — which is the+conservative direction.+-}+bundleThreadedPairLoop :: Int -> Int+{-# NOINLINE bundleThreadedPairLoop #-}+bundleThreadedPairLoop iterations =+  withCounterPair \leftMut rightMut leftLend rightLend ->+    go iterations (leftMut :- rightMut :- BNil) leftLend rightLend+  where+    go ::+      forall α.+      Int ->+      Muts α '[Ref.Ref Int, Ref.Ref Int] %1 ->+      Lend α (Ref.Ref Int) %1 ->+      Lend α (Ref.Ref Int) %1 ->+      BO α (After α (Ur Int))+    go !i bundle leftLend rightLend+      | i <= 0 =+          consume bundle `lseq`+            Control.pure (finishCounterPair leftLend rightLend)+      | otherwise = case bundle of+          leftMut :- rightMut :- BNil -> Control.do+            leftMut <- RefBorrow.modify (+ 1) leftMut+            rightMut <- RefBorrow.modify (+ 1) rightMut+            go (i - 1) (leftMut :- rightMut :- BNil) leftLend rightLend++{- | One result-discarding plural scope per iteration, over a two-member bundle.++The continuation consumes its two members individually rather than rebuilding a+bundle to consume, so this arm measures the delimiter and not the caller's+@(':-')@ cells. Compare it against 'scopeFreePairLoop'; see+'bundleThreadedPairLoop' for why the bundled arm is not the comparator.+-}+reborrowingsDiscardingLoop :: Int -> Int+{-# NOINLINE reborrowingsDiscardingLoop #-}+reborrowingsDiscardingLoop iterations =+  withCounterPair \leftMut rightMut leftLend rightLend ->+    go iterations (leftMut :- rightMut :- BNil) leftLend rightLend+  where+    go ::+      forall α.+      Int ->+      Muts α '[Ref.Ref Int, Ref.Ref Int] %1 ->+      Lend α (Ref.Ref Int) %1 ->+      Lend α (Ref.Ref Int) %1 ->+      BO α (After α (Ur Int))+    go !i bundle leftLend rightLend+      | i <= 0 =+          consume bundle `lseq`+            Control.pure (finishCounterPair leftLend rightLend)+      | otherwise = Control.do+          bundle <- reborrowings_ bundle \case+            leftScoped :- rightScoped :- BNil -> Control.do+              leftScoped <- RefBorrow.modify (+ 1) leftScoped+              rightScoped <- RefBorrow.modify (+ 1) rightScoped+              Control.pure (consume leftScoped `lseq` consume rightScoped)+          go (i - 1) bundle leftLend rightLend++{- | 'reborrowingsDiscardingLoop' with the shortened bundle rebuilt before it is consumed.++Measured, this arm is byte-identical to 'reborrowingsDiscardingLoop' in every+configuration: building a bundle only to consume it is case-of-known-constructor+and GHC removes it entirely. So it does not measure "the rebuild put back" —+there is nothing to put back. It is retained as a regression on that+elimination, since a caller who pattern-matches and rebuilds is the shape most+plural call sites actually have, and it would be worth knowing if it ever+started costing something.+-}+reborrowingsRespineLoop :: Int -> Int+{-# NOINLINE reborrowingsRespineLoop #-}+reborrowingsRespineLoop iterations =+  withCounterPair \leftMut rightMut leftLend rightLend ->+    go iterations (leftMut :- rightMut :- BNil) leftLend rightLend+  where+    go ::+      forall α.+      Int ->+      Muts α '[Ref.Ref Int, Ref.Ref Int] %1 ->+      Lend α (Ref.Ref Int) %1 ->+      Lend α (Ref.Ref Int) %1 ->+      BO α (After α (Ur Int))+    go !i bundle leftLend rightLend+      | i <= 0 =+          consume bundle `lseq`+            Control.pure (finishCounterPair leftLend rightLend)+      | otherwise = Control.do+          bundle <- reborrowings_ bundle \case+            leftScoped :- rightScoped :- BNil -> Control.do+              leftScoped <- RefBorrow.modify (+ 1) leftScoped+              rightScoped <- RefBorrow.modify (+ 1) rightScoped+              Control.pure (consume (leftScoped :- rightScoped :- BNil))+          go (i - 1) bundle leftLend rightLend++-- | One result-returning plural scope per iteration, over a two-member bundle.+reborrowingsLoop :: Int -> Int+{-# NOINLINE reborrowingsLoop #-}+reborrowingsLoop iterations =+  withCounterPair \leftMut rightMut leftLend rightLend ->+    go iterations (leftMut :- rightMut :- BNil) leftLend rightLend+  where+    go ::+      forall α.+      Int ->+      Muts α '[Ref.Ref Int, Ref.Ref Int] %1 ->+      Lend α (Ref.Ref Int) %1 ->+      Lend α (Ref.Ref Int) %1 ->+      BO α (After α (Ur Int))+    go !i bundle leftLend rightLend+      | i <= 0 =+          consume bundle `lseq`+            Control.pure (finishCounterPair leftLend rightLend)+      | otherwise = Control.do+          ((), bundle) <- reborrowings bundle \case+            leftScoped :- rightScoped :- BNil -> Control.do+              leftScoped <- RefBorrow.modify (+ 1) leftScoped+              rightScoped <- RefBorrow.modify (+ 1) rightScoped+              Control.pure (consume leftScoped `lseq` consume rightScoped)+          go (i - 1) bundle leftLend rightLend++{- | The iteration counts swept.++Three points, an order of magnitude apart, so that the per-crossing cost comes+out as a slope. One point could not tell a per-crossing cost from the fixture's+own setup.+-}+iterationCounts :: [Int]+iterationCounts = [1024, 16384, 262144]++test_scopeDensity :: [Benchmark]+test_scopeDensity =+  [ bgroup+      "scope-density"+      [ bgroup+          (NonLinear.show iterations)+          [ bgroup+              "mutable"+              [ bench "direct" $ nf scopeFreeLoop iterations+              , bench "reborrowing_" $ nf reborrowingDiscardingLoop iterations+              , bench "reborrowing" $ nf reborrowingLoop iterations+              , bench "reborrowing'" $ nf reborrowingFinalizingLoop iterations+              , bench "locally_" $ nf locallyDiscardingLoop iterations+              ]+          , bgroup+              "shared"+              [ bench "share-once" $ nf sharingHoistedLoop iterations+              , bench "sharing" $ nf sharingPerIterationLoop iterations+              ]+          , bgroup+              "plural"+              [ bench "direct" $ nf scopeFreePairLoop iterations+              , bench "bundled" $ nf bundleThreadedPairLoop iterations+              , bench "reborrowings_" $ nf reborrowingsDiscardingLoop iterations+              , bench "reborrowings_/respine" $ nf reborrowingsRespineLoop iterations+              , bench "reborrowings" $ nf reborrowingsLoop iterations+              ]+          ]+      | iterations <- iterationCounts+      ]+  ]

@@ -0,0 +1,11 @@+{- | Exposes the benchmarks of "PureBorrow.Internal.Bench.Unboxed" to+@tasty-discover@. The kernels themselves stay in the @bench-suites@ internal+library because @pure-borrow-test@ exercises them too.+-}+module PureBorrow.Bench.Unboxed (test_unboxed) where++import PureBorrow.Internal.Bench.Unboxed qualified as Unboxed+import Test.Tasty.Bench (Benchmark)++test_unboxed :: [Benchmark]+test_unboxed = Unboxed.benches

@@ -0,0 +1,12 @@+{- | Exposes the benchmarks of "PureBorrow.Internal.Bench.Worklist.Resume" to+@tasty-discover@. The kernels themselves stay in the @bench-suites@ internal+library because @pure-borrow-test@ and @pure-borrow-inspection@ exercise them+too.+-}+module PureBorrow.Bench.Worklist.Resume (test_worklistResume) where++import PureBorrow.Internal.Bench.Worklist.Resume qualified as Resume+import Test.Tasty.Bench (Benchmark)++test_worklistResume :: [Benchmark]+test_worklistResume = Resume.benches

@@ -1,44 +0,0 @@-FROM debian:bookworm AS build--RUN apt-get update && apt-get install -y build-essential curl libffi-dev libffi8ubuntu1 libgmp-dev libgmp10 libncurses-dev gnupg2 git--# install ghcup-RUN echo ${ARCH}-RUN curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh-RUN cp ~/.ghcup/bin/ghcup /usr/local/bin/ghcup--ARG GHC=9.10.3-RUN ghcup install ghc   --isolate /usr/local --force ${GHC}-ARG CABAL=3.14.2.0-RUN ghcup install cabal --isolate /usr/local/bin --force ${CABAL}--RUN mkdir -p /workspace-ARG PURE_BORROW_COMMIT=e5b027fb84663d2fc2b92956bbc32a09dfeda272-RUN git clone https://github.com/SoftwareFoundationGroupAtKyotoU/pure-borrow.git /workspace/pure-borrow && \-  cd /workspace/pure-borrow && \-  git fetch --all && \-  git checkout ${PURE_BORROW_COMMIT}--WORKDIR /workspace/pure-borrow-ENV PATH="/usr/local/bin:${PATH}"-ENV LANG=C.UTF-8--ARG CABAL_INDEX_STATE=2026-02-16T11:32:42Z-RUN cabal update --index-state=${CABAL_INDEX_STATE}-ARG NUM_CPUS=8-RUN cabal configure --enable-tests --enable-benchmarks --semaphore -j${NUM_CPUS} -fartifact-RUN cabal build all --only-dependencies-RUN cabal build all-RUN mkdir -p /opt/pure-borrow-RUN cp "$(cabal list-bin artifact-runner)" /opt/pure-borrow-RUN apt-get update && apt-get install -y gnuplot--FROM debian:bookworm-slim--ENV PATH="/opt/pure-borrow:${PATH}"-RUN mkdir -p /workspace-WORKDIR /workspace-COPY --from=build /opt/pure-borrow /opt/pure-borrow-RUN apt-get update && apt-get install -y gnuplot--ENTRYPOINT ["/opt/pure-borrow/artifact-runner"]

@@ -0,0 +1,158 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module PureBorrow.Demo.Fft (+  defaultMain,+  defaultMainWith,+  CLIOpts (..),+  optionsP,+) where++import Control.Applicative ((<**>))+import Control.Concurrent (getNumCapabilities)+import Control.Concurrent.DivideConquer.Linear (fftDC)+import Control.DeepSeq (NFData (..), force)+import Control.Exception (evaluate)+import Control.Functor.Linear qualified as Control+import Control.Monad.Borrow.Pure.BO+import Control.Syntax.DataFlow qualified as DataFlow+import Data.Bits (popCount)+import Data.Complex+import Data.FMList qualified as FML+import Data.Vector qualified as V+import Data.Vector.Generic.Mutable.Linear.Borrow.Unrestricted qualified as UV+import Data.Vector.Unboxed qualified as U+import Options.Applicative qualified as Opts+import Prelude.Linear (dup, unur)+import Prelude.Linear qualified as PL+import System.Directory (createDirectoryIfMissing)+import System.FilePath (takeDirectory)+import System.Random+import Text.Read (readEither)+import Prelude++data CLIOpts = CLIOpts+  { threshold :: !Int+  , size :: !Int+  , seed :: !(Maybe Int)+  , output :: !(Maybe FilePath)+  }+  deriving (Show, Eq, Ord)++optionsP :: Opts.ParserInfo CLIOpts+optionsP = Opts.info (p <**> Opts.helper) $ Opts.progDesc "Parallel FFT"+  where+    p = do+      threshold <-+        Opts.option Opts.auto $+          Opts.short 'w'+            <> Opts.long "workstreal"+            <> Opts.value 1024+            <> Opts.showDefault+            <> Opts.help "Worksteal threshold to calculate sequentially below this length."+      size <-+        Opts.option power2 $+          Opts.short 'n'+            <> Opts.long "size"+            <> Opts.value kN+            <> Opts.showDefault+            <> Opts.help "Sample Size (must be a power of 2)"+      output <-+        Opts.optional $+          Opts.strOption $+            Opts.short 'o'+              <> Opts.metavar "FILE"+              <> Opts.help "Output TSV path"+      seed <-+        Opts.optional $+          Opts.option Opts.auto $+            Opts.short 's'+              <> Opts.long "seed"+              <> Opts.metavar "INT"+              <> Opts.help "Random seed"+      pure CLIOpts {..}++power2 :: Opts.ReadM Int+power2 = Opts.eitherReader \s ->+  case readEither s of+    Right n+      | n > 0 && popCount n == 1 -> Right n+      | otherwise -> Left $ "Must be a positive power of 2, but got: " <> s+    Left err -> Left err++sample :: Int -> (Double -> Double) -> V.Vector Double+sample n f = V.generate n \i -> f (-4 + 8 * fromIntegral i / fromIntegral n)++-- | Convert to the vector of complex numbers, with real part even element and imaginary part odd.+compress :: V.Vector Double -> V.Vector (Complex Double)+compress v =+  V.generate (V.length v `quot` 2) \i ->+    let re = v V.! (2 * i)+        im = v V.! (2 * i + 1)+     in re :+ im++kN :: Int+kN = 2 ^ (20 :: Int)++fun :: Double -> Double+fun x = sin (2 * pi * x) + 2 * cos (pi * x) + 3 * sin (0.5 * pi * x) + 5++defaultMain :: IO ()+defaultMain = do+  opts <- Opts.execParser optionsP+  defaultMainWith opts++defaultMainWith :: CLIOpts -> IO ()+defaultMainWith CLIOpts {..} = do+  numCap <- getNumCapabilities+  !v <- evaluate $ force $ compress $ sample size fun+  g <- maybe newStdGen (pure . mkStdGen) seed+  let !kM = size `quot` 2+      toFreq i = fromIntegral ((i + kM) `rem` size - kM) / 8+      decodeComp !i (!c :: Complex Double)+        | i == (0 :: Int) = (realPart c / fromIntegral size, 0)+        | otherwise =+            let re :+ im = 2 * c / fromIntegral size+             in (re, im)+      retrv = case output of+        Nothing -> evaluate . rnf+        Just fp -> \vs -> do+          createDirectoryIfMissing True $ takeDirectory fp+          writeFile fp+            $ unlines+            $ FML.toList+            $ FML.cons "Frequency\tcos\tsin"+            $ U.foldMap+              ( \(i, c) ->+                  let (co, si) = decodeComp i c+                   in FML.singleton $ show (toFreq i :: Double) <> "\t" <> show co <> "\t" <> show si+              )+            $ U.indexed+            $ V.convert vs+          putStrLn $ "Written to: " <> fp+  retrv $+    postprocess size $+      unur PL.$ linearly \lin -> DataFlow.do+        (lin, l2) <- dup lin+        runBO lin Control.do+          (vec, lend) <- borrowM (UV.fromVector v l2)+          Control.void PL.$ fftDC g numCap threshold vec+          pureAfter (UV.toVector PL.$ reclaim lend)++postprocess :: Int -> V.Vector (Complex Double) -> V.Vector (Complex Double)+postprocess kN hs =+  let !kM = kN `quot` 2+   in V.generate (kM + 1) \((`rem` kM) -> k) ->+        let !m = (kM - k) `rem` kM+         in 0.5 * ((hs V.! k) + conjugate (hs V.! m))+              - (0 :+ 0.5) * (hs V.! k - conjugate (hs V.! m)) * exp (0 :+ (2 * pi * fromIntegral k / fromIntegral kN))

@@ -0,0 +1,121 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module PureBorrow.Demo.QSort (+  defaultMain,+  defaultMainWith,+  CLIOpts (..),+  optionsP,+) where++import Control.Applicative ((<**>), (<|>))+import Control.Concurrent (getNumCapabilities)+import Control.Concurrent.DivideConquer.Linear (naiveDivideAndConquer, qsortDC, qsortDC')+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Control.Functor.Linear qualified as Control+import Control.Monad.Borrow.Pure.BO+import Control.Syntax.DataFlow qualified as DataFlow+import Data.Functor (void)+import Data.Vector qualified as V+import Data.Vector.Algorithms.Intro qualified as AI+import Data.Vector.Generic.Mutable.Linear.Borrow.Unrestricted qualified as UV+import Data.Vector.Mutable.Linear.Borrow qualified as VL+import GHC.Generics (Generic)+import Options.Applicative qualified as Opts+import Prelude.Linear hiding (Eq, Ord, Semigroup (..), ($), ($!))+import Prelude.Linear qualified as PL hiding (($!))+import System.Mem (performGC)+import System.Random+import System.Random.Stateful (runStateGen_, uniformM)++data Mode = Parallel Word | Naive Int | Worksteal Int Int | Sequential | IntroSort+  deriving (Show, Eq, Ord, Generic)++data CLIOpts = CLIOpts {mode :: Mode, size :: Int, seed :: Maybe Int}+  deriving (Show, Eq, Ord, Generic)++optionsP :: Int -> Opts.ParserInfo CLIOpts+optionsP numCap = Opts.info (p <**> Opts.helper) $ Opts.progDesc "Parallel quicksort with linear borrows"+  where+    p = do+      mode <-+        Parallel <$> Opts.option Opts.auto (Opts.long "parallel" <> Opts.short 'p' <> Opts.help "Use parallel quicksort with specified capacity (default: 8)")+          <|> Opts.flag' Sequential (Opts.long "sequential" <> Opts.short 'S' <> Opts.help "Use sequential quicksort")+          <|> Opts.flag' (Worksteal numCap 512) (Opts.long "worksteal" <> Opts.short 'w' <> Opts.help "Use work-stealing quicksort")+          <|> Opts.flag' (Naive 512) (Opts.long "naive" <> Opts.short 'Z' <> Opts.help "Use naive divide-and-conquer quicksort")+          <|> Opts.flag (Parallel 8) IntroSort (Opts.long "intro" <> Opts.short 'i' <> Opts.help "Use intro sort")+      size <-+        Opts.option+          Opts.auto+          ( Opts.long "size"+              <> Opts.short 'n'+              <> Opts.value 256+              <> Opts.showDefault+              <> Opts.help "Size of the vector to sort"+          )+      seed <- Opts.optional $ Opts.option Opts.auto (Opts.long "seed" <> Opts.short 's' <> Opts.help "Random seed for vector generation (default: random)")+      pure CLIOpts {..}++qsortWith :: Mode -> StdGen -> V.Vector Int -> V.Vector Int+qsortWith IntroSort _ v = V.modify AI.sort v+qsortWith (Parallel bud) _ v =+  unur PL.$ linearly \lin ->+    DataFlow.do+      (lin, l2) <- dup lin+      runBO lin Control.do+        (v, lend) <- borrowM (VL.fromVector v l2)+        VL.qsort bud v+        pureAfter (VL.toVector PL.$ reclaim lend)+qsortWith Sequential _ v =+  unur PL.$ linearly \lin ->+    DataFlow.do+      (lin, l2) <- dup lin+      runBO lin Control.do+        (v, lend) <- borrowM (VL.fromVector v l2)+        VL.qsort 0 v+        pureAfter (VL.toVector PL.$ reclaim lend)+qsortWith (Worksteal workers thresh) g v =+  unur PL.$ linearly \lin ->+    DataFlow.do+      (lin, l2) <- dup lin+      runBO lin Control.do+        (v, lend) <- borrowM (UV.fromVector v l2)+        Control.void PL.$ qsortDC g workers thresh v+        pureAfter (UV.toVector PL.$ reclaim lend)+qsortWith (Naive thresh) _ v =+  unur PL.$ linearly \lin ->+    DataFlow.do+      (lin, l2) <- dup lin+      runBO lin Control.do+        (v, lend) <- borrowM (UV.fromVector v l2)+        Control.void PL.$ naiveDivideAndConquer (qsortDC' thresh) v+        pureAfter (UV.toVector PL.$ reclaim lend)++defaultMainWith :: CLIOpts -> IO ()+defaultMainWith CLIOpts {..} = do+  putStrLn $ "Sorting " <> show size <> " elements with mode: " <> show mode+  gen <- case seed of+    Just s -> return $ mkStdGen s+    Nothing -> newStdGen+  let !vec =+        runStateGen_ gen \g -> do+          V.replicateM size (uniformM g)+  gen <- newStdGen+  performGC+  void $ evaluate $ force $ qsortWith mode gen vec++defaultMain :: IO ()+defaultMain = do+  numCap <- getNumCapabilities+  opts <- Opts.execParser $ optionsP numCap+  defaultMainWith opts

@@ -1,169 +0,0 @@-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeApplications #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}--module PureBorrow.Internal.Bench.QSort (-  defaultMain,-  defaultMainWith,-  optionsP,-  rawOptsP,-  BenchOpts (..),-  benches,-  kMAX_SIZE,-) where--import Control.Applicative-import Control.Concurrent (getNumCapabilities)-import Control.Concurrent.DivideConquer.Linear (qsortDC)-import Control.Functor.Linear qualified as Control-import Control.Monad.Borrow.Pure.BO-import Control.Syntax.DataFlow qualified as DataFlow-import Data.Proxy (Proxy (..))-import Data.Vector qualified as V-import Data.Vector.Algorithms.Intro qualified as AI-import Data.Vector.Mutable.Linear.Borrow qualified as VL-import Options.Applicative qualified as Opts-import Prelude.Linear (dup, unur)-import Prelude.Linear qualified as PL-import System.Random.Stateful-import Test.Tasty (askOption, defaultMainWithIngredients)-import Test.Tasty.Bench hiding (defaultMain)-import Test.Tasty.Bench qualified as Bench-import Test.Tasty.Ingredients.Basic (includingOptions)-import Test.Tasty.Options-import Text.Read (readMaybe)-import Prelude as P--data Mode = Parallel Word | Worksteal Int | Sequential | IntroSort-  deriving (Show, Eq, Ord)--data BenchOpts = BenchOpts {numThreads :: !Int, sampleSize :: !Int}-  deriving (Show, Eq, Ord)--optionsP :: Opts.ParserInfo BenchOpts-optionsP =-  Opts.info (p <**> Opts.helper) $-    Opts.fullDesc-      <> Opts.progDesc "Options for qsort benchmark"-  where-    p :: Opts.Parser BenchOpts-    p =-      BenchOpts-        <$> Opts.option-          Opts.auto-          ( Opts.long "threads"-              <> Opts.short 'N'-              <> Opts.metavar "NUM_THREADS"-              <> Opts.help "Number of threads to use for parallel benchmarks"-          )-        <*> Opts.option-          Opts.auto-          ( Opts.long "size"-              <> Opts.short 's'-              <> Opts.metavar "SAMPLE_SIZE"-              <> Opts.help "Number of samples to take (must divide 32768)"-          )--rawOptsP :: Opts.Parser BenchOpts-rawOptsP =-  BenchOpts-    <$> Opts.option-      Opts.auto-      ( Opts.long "threads"-          <> Opts.short 'N'-          <> Opts.value 10-          <> Opts.metavar "NUM_THREADS"-          <> Opts.help "Number of threads to use for parallel benchmarks"-      )-    <*> Opts.option-      Opts.auto-      ( Opts.long "size"-          <> Opts.short 's'-          <> Opts.metavar "SAMPLE_SIZE"-          <> Opts.value 32-          <> Opts.help "Number of samples to take (must divide 32768)"-      )--qsortWith :: Mode -> V.Vector Int -> V.Vector Int-qsortWith IntroSort v = V.modify AI.sort v-qsortWith (Parallel budget) v =-  unur PL.$ linearly \lin ->-    DataFlow.do-      (lin, l2) <- dup lin-      runBO lin Control.do-        (v, lend) <- borrowM (VL.fromVector v l2)-        VL.qsort budget v-        Control.pure PL.$ VL.toVector Control.<$> reclaim' lend-qsortWith Sequential v =-  unur PL.$ linearly \lin ->-    DataFlow.do-      (lin, l2) <- dup lin-      runBO lin Control.do-        (v, lend) <- borrowM (VL.fromVector v l2)-        VL.qsort 0 v-        pureAfter (VL.toVector PL.$ reclaim lend)-qsortWith (Worksteal p) v =-  unur PL.$ linearly \lin ->-    DataFlow.do-      (lin, l2) <- dup lin-      runBO lin Control.do-        (v, lend) <- borrowM (VL.fromVector v l2)-        Control.void PL.$ qsortDC p 128 v-        pureAfter (VL.toVector PL.$ reclaim lend)--data SampleSize = SampleSize Int-  deriving (Show, Eq, Ord)--instance IsOption SampleSize where-  defaultValue = SampleSize 32-  parseValue s =-    case readMaybe s of-      Just n | kMAX_SIZE `rem` n == 0 -> Just (SampleSize n)-      _ -> Nothing-  optionName = return "size"-  optionHelp = return "Step size to take a sample (must divide 32768)"--defaultMain :: IO ()-defaultMain = do-  numThreads <- getNumCapabilities-  let customOpts = [Option (Proxy :: Proxy SampleSize)]-      ingredients = includingOptions customOpts : benchIngredients-  defaultMainWithIngredients ingredients $ askOption \(SampleSize sampleSize) ->-    bgroup "All" $ benches BenchOpts {..}--defaultMainWith :: BenchOpts -> IO ()-defaultMainWith opts = do-  Bench.defaultMain $ benches opts--benches :: BenchOpts -> [Benchmark]-benches BenchOpts {..} =-  [ bgroup-      "qsort"-      [ env-          ( pure $ runStateGen_ (mkStdGen 42) \g -> do-              V.replicateM size (uniformM g)-          )-          \vec ->-            bgroup-              (show size)-              ( [ bench "intro" $ nf (qsortWith IntroSort) vec-                , bench "sequential" $ nf (qsortWith Sequential) vec-                ]-                  ++ [ bench ("parallel (budget = " <> show n <> ")") $-                         nf (qsortWith $ Parallel n) vec-                     | n <- [4, 8, 16, 32]-                     ]-                  ++ [ bench ("worksteal (workers = " <> show n <> ")") $-                         nf (qsortWith $ Worksteal n) vec-                     | n <- [2, 4 .. numThreads]-                     ]-              )-      | i <- [0 .. sampleSize]-      , let size = i * kMAX_SIZE `quot` sampleSize-      ]-  ]--kMAX_SIZE :: Int-kMAX_SIZE = 32 * 1024

@@ -1,111 +0,0 @@-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# OPTIONS_GHC -Wno-name-shadowing #-}--module PureBorrow.Demo.QSort (-  defaultMain,-  defaultMainWith,-  CLIOpts (..),-  optionsP,-) where--import Control.Applicative ((<**>), (<|>))-import Control.Concurrent (getNumCapabilities)-import Control.Concurrent.DivideConquer.Linear (qsortDC)-import Control.DeepSeq (force)-import Control.Exception (evaluate)-import Control.Functor.Linear qualified as Control-import Control.Monad.Borrow.Pure.BO-import Control.Syntax.DataFlow qualified as DataFlow-import Data.Functor (void)-import Data.Vector qualified as V-import Data.Vector.Algorithms.Intro qualified as AI-import Data.Vector.Mutable.Linear.Borrow qualified as VL-import GHC.Generics (Generic)-import Options.Applicative qualified as Opts-import Prelude.Linear hiding (Eq, Ord, Semigroup (..), ($), ($!))-import Prelude.Linear qualified as PL hiding (($!))-import System.Mem (performGC)-import System.Random-import System.Random.Stateful (runStateGen_, uniformM)--data Mode = Parallel Word | Worksteal Int Int | Sequential | IntroSort-  deriving (Show, Eq, Ord, Generic)--data CLIOpts = CLIOpts {mode :: Mode, size :: Int, seed :: Maybe Int}-  deriving (Show, Eq, Ord, Generic)--optionsP :: Int -> Opts.ParserInfo CLIOpts-optionsP numCap = Opts.info (p <**> Opts.helper) $ Opts.progDesc "Parallel quicksort with linear borrows"-  where-    p = do-      mode <--        Parallel <$> Opts.option Opts.auto (Opts.long "parallel" <> Opts.short 'p' <> Opts.help "Use parallel quicksort with specified capacity (default: 8)")-          <|> Opts.flag' Sequential (Opts.long "sequential" <> Opts.short 'S' <> Opts.help "Use sequential quicksort")-          <|> Opts.flag' (Worksteal numCap 512) (Opts.long "worksteal" <> Opts.short 'w' <> Opts.help "Use work-stealing quicksort")-          <|> Opts.flag (Parallel 8) IntroSort (Opts.long "intro" <> Opts.short 'i' <> Opts.help "Use intro sort")-      size <--        Opts.option-          Opts.auto-          ( Opts.long "size"-              <> Opts.short 'n'-              <> Opts.value 256-              <> Opts.showDefault-              <> Opts.help "Size of the vector to sort"-          )-      seed <- Opts.optional $ Opts.option Opts.auto (Opts.long "seed" <> Opts.short 's' <> Opts.help "Random seed for vector generation (default: random)")-      pure CLIOpts {..}--qsortWith :: Mode -> StdGen -> V.Vector Int -> V.Vector Int-qsortWith IntroSort _ v = V.modify AI.sort v-qsortWith (Parallel bud) _ v =-  unur PL.$ linearly \lin ->-    DataFlow.do-      (lin, l2) <- dup lin-      runBO lin Control.do-        (v, lend) <- borrowM (VL.fromVector v l2)-        VL.qsort bud v-        pureAfter (VL.toVector PL.$ reclaim lend)-qsortWith Sequential _ v =-  unur PL.$ linearly \lin ->-    DataFlow.do-      (lin, l2) <- dup lin-      runBO lin Control.do-        (v, lend) <- borrowM (VL.fromVector v l2)-        VL.qsort 0 v-        pureAfter (VL.toVector PL.$ reclaim lend)-qsortWith (Worksteal workers thresh) _ v =-  unur PL.$ linearly \lin ->-    DataFlow.do-      (lin, l2) <- dup lin-      runBO lin Control.do-        (v, lend) <- borrowM (VL.fromVector v l2)-        Control.void PL.$ qsortDC workers thresh v-        pureAfter (VL.toVector PL.$ reclaim lend)--defaultMainWith :: CLIOpts -> IO ()-defaultMainWith CLIOpts {..} = do-  putStrLn $ "Sorting " <> show size <> " elements with mode: " <> show mode-  gen <- case seed of-    Just s -> return $ mkStdGen s-    Nothing -> newStdGen-  let !vec =-        runStateGen_ gen \g -> do-          V.replicateM size (uniformM g)-  gen <- newStdGen-  performGC-  void $ evaluate $ force $ qsortWith mode gen vec--defaultMain :: IO ()-defaultMain = do-  numCap <- getNumCapabilities-  opts <- Opts.execParser $ optionsP numCap-  defaultMainWith opts

@@ -0,0 +1,1866 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE QualifiedDo #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module PureBorrow.Internal.Bench.MultiStoreScan (+  MultiStoreScanInput (..),+  MultiStoreScanOutput (..),+  MultiStoreScanResult (..),+  MultiStoreScanSummary (..),+  TraceEvent,+  multiStoreScanDirectInput,+  multiStoreScanDirectBenchmarkRoot,+  multiStoreScanDirectHeaderMatchedBenchmarkRoot,+  multiStoreScanDirectRoot,+  multiStoreScanNodeCount,+  multiStoreScanBoxedContentProjection,+  multiStoreScanPureBorrowDirectBenchmarkRoot,+  multiStoreScanPureBorrowDirectRoot,+  multiStoreScanPureBorrowFixedUnrestrictedBenchmarkRoot,+  multiStoreScanPureBorrowFixedUnrestrictedWorker,+  multiStoreScanPureBorrowNestedBenchmarkRoot,+  multiStoreScanPureBorrowNestedRoot,+  multiStoreScanPureBorrowOwningBenchmarkRoot,+  multiStoreScanPureBorrowOwningWorker,+  multiStoreScanPureBorrowWorker,+  multiStoreScanUnboxedContentProjection,+  benches,+  defaultMain,+) where++import Control.DeepSeq (NFData)+import Control.Functor.Linear qualified as Control+import Control.Monad.Borrow.Pure+import Control.Monad.Borrow.Pure.Experimental.Borrows (+  Aliases (..),+  reborrowings,+ )+import Control.Monad.ST.Strict (ST, runST)+import Control.Syntax.DataFlow qualified as DataFlow+import Data.List qualified as List+import Data.Record.Linear.Borrow.Experimental.PatternMatch (+  RecordLabel,+  (.@),+ )+import Data.STRef (STRef, newSTRef, readSTRef)+import Data.Vector qualified as V+import Data.Vector.Generic.Mutable.Growable.Linear.Borrow.Unrestricted qualified as Growable+import Data.Vector.Generic.Mutable.Linear.Borrow.Unrestricted qualified as Fixed+import Data.Vector.Mutable qualified as MV+import Data.Vector.Mutable.Growable.Linear.Borrow qualified as OwningBoxedGrowable+import Data.Vector.Mutable.Linear.Borrow qualified as OwningBoxedFixed+import Data.Vector.Unboxed qualified as U+import Data.Vector.Unboxed.Mutable qualified as UM+import Data.Vector.Unboxed.Mutable.Growable.Linear.Borrow qualified as OwningUnboxedGrowable+import Data.Vector.Unboxed.Mutable.Linear.Borrow qualified as OwningUnboxedFixed+import GHC.Exts qualified as GHC+import GHC.Generics (Generic)+import GHC.Int (Int64 (I64#))+import Prelude.Linear (+  lseq,+  unur,+  (&),+ )+import Test.Tasty.Bench (Benchmark, bench, bgroup, env, nf)+import Test.Tasty.Bench qualified as Bench++data MultiStoreScanInput = MultiStoreScanInput+  { inputNext :: !(U.Vector Int)+  , inputWeight :: !(U.Vector Int)+  , inputMark :: !(U.Vector Int)+  , inputPayload :: !(V.Vector (Int, Int))+  , inputScore :: !(U.Vector Int)+  , inputLink :: !(U.Vector Int)+  }+  deriving stock (Generic)+  deriving anyclass (NFData)++data MultiStoreScanSummary = MultiStoreScanSummary+  { visitedNodes :: !Int+  , elementReads :: !Int+  , elementWrites :: !Int+  , headerReads :: !Int+  , validationReads :: !Int+  , finalDigest :: !Int64+  }+  deriving stock (Eq, Generic, Show)+  deriving anyclass (NFData)++data MultiStoreScanResult = MultiStoreScanResult+  { resultSummary :: !MultiStoreScanSummary+  , resultVisitedIndices :: !(U.Vector Int)+  , resultEvents :: !(V.Vector TraceEvent)+  , resultEventDigest :: !Int64+  , resultMarks :: !(U.Vector Int)+  , resultScores :: !(U.Vector Int)+  }+  deriving stock (Eq, Generic, Show)+  deriving anyclass (NFData)++data MultiStoreScanOutput = MultiStoreScanOutput+  { outputDigest :: !Int64+  , outputMarks :: !(U.Vector Int)+  , outputScores :: !(U.Vector Int)+  }+  deriving stock (Eq, Generic, Show)+  deriving anyclass (NFData)++data TraceStore+  = NextStore+  | WeightStore+  | MarkStore+  | ScoreStore+  | LinkStore+  deriving stock (Eq, Generic, Show)+  deriving anyclass (NFData)++data TraceEvent+  = ReadIntEvent !TraceStore !Int !Int+  | ReadPayloadEvent !Int !Int !Int+  | WriteIntEvent !TraceStore !Int !Int+  deriving stock (Eq, Generic, Show)+  deriving anyclass (NFData)++data AccessTrace = AccessTrace+  { traceVisitedIndicesRev :: ![Int]+  , traceEventsRev :: ![TraceEvent]+  , traceEventDigest :: !Int64+  , traceVisitedNodes :: !Int+  , traceElementReads :: !Int+  , traceElementWrites :: !Int+  , traceHeaderReads :: !Int+  , traceReadDigest :: !Int64+  }++data FixedRoots = FixedRoots+  { next :: !(Fixed.Vector U.Vector Int)+  , weight :: !(Fixed.Vector U.Vector Int)+  , mark :: !(Fixed.Vector U.Vector Int)+  }++data GrowableRoots = GrowableRoots+  { payload :: !(Growable.GrowableVector V.Vector (Int, Int))+  , score :: !(Growable.GrowableVector U.Vector Int)+  , link :: !(Growable.GrowableVector U.Vector Int)+  }++data MultiStore = MultiStore+  { fixedRoots :: !FixedRoots+  , growableRoots :: !GrowableRoots+  }++data OwningFixedRoots = OwningFixedRoots+  { owningNext :: !(OwningUnboxedFixed.Vector Int)+  , owningWeight :: !(OwningUnboxedFixed.Vector Int)+  , owningMark :: !(OwningUnboxedFixed.Vector Int)+  }++data OwningGrowableRoots = OwningGrowableRoots+  { owningPayload :: !(OwningBoxedGrowable.GrowableVector (Int, Int))+  , owningScore :: !(OwningUnboxedGrowable.GrowableVector Int)+  , owningLink :: !(OwningUnboxedGrowable.GrowableVector Int)+  }++data OwningMultiStore = OwningMultiStore+  { owningFixedRoots :: !OwningFixedRoots+  , owningGrowableRoots :: !OwningGrowableRoots+  }++data FixedUnrestrictedStore = FixedUnrestrictedStore+  { fixedUnrestrictedRoots :: !FixedRoots+  , fixedUnrestrictedGrowableRoots :: !OwningGrowableRoots+  }++multiStoreScanBoxedContentProjection ::+  Mut α (Growable.GrowableVector V.Vector (Int, Int)) %1 ->+  Mut α (Fixed.Vector V.Vector (Int, Int))+{-# INLINE multiStoreScanBoxedContentProjection #-}+multiStoreScanBoxedContentProjection = Growable.getContents++multiStoreScanUnboxedContentProjection ::+  Mut α (Growable.GrowableVector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int)+{-# INLINE multiStoreScanUnboxedContentProjection #-}+multiStoreScanUnboxedContentProjection = Growable.getContents++multiStoreScanNodeCount :: Int+multiStoreScanNodeCount = 4096++multiStoreScanDirectInput :: MultiStoreScanInput+multiStoreScanDirectInput =+  MultiStoreScanInput+    { inputNext = U.generate multiStoreScanNodeCount \index -> (index + 1) `rem` multiStoreScanNodeCount+    , inputWeight = U.generate multiStoreScanNodeCount \index -> (index * 17 + 3) `rem` 101+    , inputMark = U.replicate multiStoreScanNodeCount 0+    , inputPayload =+        V.generate multiStoreScanNodeCount \index ->+          (index `rem` 7, index `rem` 13)+    , inputScore = U.generate multiStoreScanNodeCount \index -> (index * 5 + 11) `rem` 97+    , inputLink = U.replicate multiStoreScanNodeCount 0+    }++validateInput :: MultiStoreScanInput -> Int+{-# NOINLINE validateInput #-}+validateInput input+  | U.length (inputNext input)+      == multiStoreScanNodeCount+      && U.length (inputWeight input)+        == multiStoreScanNodeCount+      && U.length (inputMark input)+        == multiStoreScanNodeCount+      && V.length (inputPayload input)+        == multiStoreScanNodeCount+      && U.length (inputScore input)+        == multiStoreScanNodeCount+      && U.length (inputLink input)+        == multiStoreScanNodeCount+      && nextReads+        == multiStoreScanNodeCount+      && linkReads+        == multiStoreScanNodeCount =+      6 + nextReads + linkReads+  | otherwise =+      error+        "multi-store scan requires six 4096-element vectors, in-range next indices, and zero links"+  where+    !nextReads =+      U.foldl'+        ( \count value ->+            if value >= 0 && value < multiStoreScanNodeCount+              then count + 1+              else -multiStoreScanNodeCount+        )+        0+        (inputNext input)+    !linkReads =+      U.foldl'+        ( \count value ->+            if value == 0+              then count + 1+              else -multiStoreScanNodeCount+        )+        0+        (inputLink input)++multiStoreScanDirectRoot :: MultiStoreScanInput -> MultiStoreScanResult+{-# NOINLINE multiStoreScanDirectRoot #-}+multiStoreScanDirectRoot input =+  let !inputValidationReads = validateInput input+   in runST do+        next <- U.thaw (inputNext input)+        weight <- U.thaw (inputWeight input)+        mark <- U.thaw (inputMark input)+        payloadBuffer <- V.thaw (inputPayload input)+        scoreBuffer <- U.thaw (inputScore input)+        linkBuffer <- U.thaw (inputLink input)++        payloadHeader <- newSTRef (multiStoreScanNodeCount, payloadBuffer)+        scoreHeader <- newSTRef (multiStoreScanNodeCount, scoreBuffer)+        linkHeader <- newSTRef (multiStoreScanNodeCount, linkBuffer)+        (_, payload) <- readSTRef payloadHeader+        (_, score) <- readSTRef scoreHeader+        (_, link) <- readSTRef linkHeader++        trace <-+          multiStoreScanTraceWorker+            multiStoreScanNodeCount+            0+            0+            emptyAccessTrace {traceHeaderReads = 3}+            next+            weight+            mark+            payload+            score+            link+        frozenMarks <- U.unsafeFreeze mark+        frozenScores <- U.unsafeFreeze score+        let !digest =+              digestVectors+                (traceReadDigest trace)+                frozenMarks+                frozenScores+        pure+          MultiStoreScanResult+            { resultSummary =+                MultiStoreScanSummary+                  { visitedNodes = traceVisitedNodes trace+                  , elementReads = traceElementReads trace+                  , elementWrites = traceElementWrites trace+                  , headerReads = traceHeaderReads trace+                  , validationReads = inputValidationReads+                  , finalDigest = digest+                  }+            , resultVisitedIndices =+                U.fromListN+                  multiStoreScanNodeCount+                  (reverse (traceVisitedIndicesRev trace))+            , resultEvents =+                V.fromListN+                  (traceElementReads trace + traceElementWrites trace)+                  (reverse (traceEventsRev trace))+            , resultEventDigest = traceEventDigest trace+            , resultMarks = frozenMarks+            , resultScores = frozenScores+            }++emptyAccessTrace :: AccessTrace+emptyAccessTrace =+  AccessTrace+    { traceVisitedIndicesRev = []+    , traceEventsRev = []+    , traceEventDigest = 1_469_598_103_934_665_603+    , traceVisitedNodes = 0+    , traceElementReads = 0+    , traceElementWrites = 0+    , traceHeaderReads = 0+    , traceReadDigest = 0+    }++multiStoreScanTraceWorker ::+  Int ->+  Int ->+  Int ->+  AccessTrace ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  MV.MVector s (Int, Int) ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  ST s AccessTrace+multiStoreScanTraceWorker !remaining !index !visits trace next weight mark payload score link+  | remaining <= 0 = pure trace+  | otherwise = do+      nextIndex <- UM.unsafeRead next index+      weightValue <- UM.unsafeRead weight index+      markValue <- UM.unsafeRead mark index+      (payloadTag, payloadDelta) <- MV.unsafeRead payload index+      scoreValue <- UM.unsafeRead score index+      linkValue <- UM.unsafeRead link index+      let !shouldWrite =+            (weightValue + scoreValue + payloadTag + visits) `rem` 5 == 0+          !nextTrace =+            recordTraceVisit+              index+              nextIndex+              weightValue+              markValue+              payloadTag+              payloadDelta+              scoreValue+              linkValue+              shouldWrite+              trace+      if shouldWrite+        then do+          UM.unsafeWrite mark index (markValue + 1)+          UM.unsafeWrite score index (scoreValue + payloadDelta + 1)+        else pure ()+      multiStoreScanTraceWorker+        (remaining - 1)+        ((nextIndex + linkValue) `rem` multiStoreScanNodeCount)+        (visits + 1)+        nextTrace+        next+        weight+        mark+        payload+        score+        link++recordTraceVisit ::+  Int ->+  Int ->+  Int ->+  Int ->+  Int ->+  Int ->+  Int ->+  Int ->+  Bool ->+  AccessTrace ->+  AccessTrace+recordTraceVisit index nextIndex weightValue markValue payloadTag payloadDelta scoreValue linkValue shouldWrite trace =+  let !readEvents =+        [ ReadIntEvent NextStore index nextIndex+        , ReadIntEvent WeightStore index weightValue+        , ReadIntEvent MarkStore index markValue+        , ReadPayloadEvent index payloadTag payloadDelta+        , ReadIntEvent ScoreStore index scoreValue+        , ReadIntEvent LinkStore index linkValue+        ]+      !writeEvents =+        if shouldWrite+          then+            [ WriteIntEvent MarkStore index (markValue + 1)+            , WriteIntEvent+                ScoreStore+                index+                (scoreValue + payloadDelta + 1)+            ]+          else []+      !events = readEvents <> writeEvents+   in AccessTrace+        { traceVisitedIndicesRev =+            index : traceVisitedIndicesRev trace+        , traceEventsRev =+            List.foldl'+              (flip (:))+              (traceEventsRev trace)+              events+        , traceEventDigest =+            List.foldl' hashTraceEvent (traceEventDigest trace) events+        , traceVisitedNodes = traceVisitedNodes trace + 1+        , traceElementReads = traceElementReads trace + 6+        , traceElementWrites =+            traceElementWrites trace + if shouldWrite then 2 else 0+        , traceHeaderReads = traceHeaderReads trace+        , traceReadDigest =+            traceReadDigest trace+              + fromIntegral+                ( nextIndex+                    + weightValue+                    + markValue+                    + payloadTag+                    + payloadDelta+                    + scoreValue+                    + linkValue+                )+        }++hashTraceEvent :: Int64 -> TraceEvent -> Int64+hashTraceEvent digest event =+  List.foldl' hashTraceWord digest case event of+    ReadIntEvent store index value ->+      [1, traceStoreCode store, index, value]+    ReadPayloadEvent index tag delta ->+      [2, index, tag, delta]+    WriteIntEvent store index value ->+      [3, traceStoreCode store, index, value]++hashTraceWord :: Int64 -> Int -> Int64+hashTraceWord digest value =+  digest * 1_099_511_628_211 + fromIntegral value++traceStoreCode :: TraceStore -> Int+traceStoreCode = \case+  NextStore -> 1+  WeightStore -> 2+  MarkStore -> 3+  ScoreStore -> 4+  LinkStore -> 5++multiStoreScanDirectBenchmarkRoot ::+  MultiStoreScanInput ->+  MultiStoreScanOutput+{-# NOINLINE multiStoreScanDirectBenchmarkRoot #-}+multiStoreScanDirectBenchmarkRoot input =+  validateInput input `seq` runST do+    next <- U.thaw (inputNext input)+    weight <- U.thaw (inputWeight input)+    mark <- U.thaw (inputMark input)+    payloadBuffer <- V.thaw (inputPayload input)+    scoreBuffer <- U.thaw (inputScore input)+    linkBuffer <- U.thaw (inputLink input)++    payloadHeader <- newSTRef (multiStoreScanNodeCount, payloadBuffer)+    scoreHeader <- newSTRef (multiStoreScanNodeCount, scoreBuffer)+    linkHeader <- newSTRef (multiStoreScanNodeCount, linkBuffer)+    (_, payload) <- readSTRef payloadHeader+    (_, score) <- readSTRef scoreHeader+    (_, link) <- readSTRef linkHeader++    readDigest <-+      multiStoreScanDirectWorker+        multiStoreScanNodeCount+        0+        0+        0+        next+        weight+        mark+        payload+        score+        link+    frozenMarks <- U.unsafeFreeze mark+    frozenScores <- U.unsafeFreeze score+    pure+      MultiStoreScanOutput+        { outputDigest =+            digestVectors readDigest frozenMarks frozenScores+        , outputMarks = frozenMarks+        , outputScores = frozenScores+        }++multiStoreScanDirectHeaderMatchedBenchmarkRoot ::+  MultiStoreScanInput ->+  MultiStoreScanOutput+{-# NOINLINE multiStoreScanDirectHeaderMatchedBenchmarkRoot #-}+multiStoreScanDirectHeaderMatchedBenchmarkRoot input =+  validateInput input `seq` runST do+    next <- U.thaw (inputNext input)+    weight <- U.thaw (inputWeight input)+    mark <- U.thaw (inputMark input)+    payloadBuffer <- V.thaw (inputPayload input)+    scoreBuffer <- U.thaw (inputScore input)+    linkBuffer <- U.thaw (inputLink input)++    payloadHeader <- newSTRef (multiStoreScanNodeCount, payloadBuffer)+    scoreHeader <- newSTRef (multiStoreScanNodeCount, scoreBuffer)+    linkHeader <- newSTRef (multiStoreScanNodeCount, linkBuffer)+    payload <- readHeaderOpaque payloadHeader+    score <- readHeaderOpaque scoreHeader+    link <- readHeaderOpaque linkHeader++    readDigest <-+      multiStoreScanDirectWorker+        multiStoreScanNodeCount+        0+        0+        0+        next+        weight+        mark+        payload+        score+        link+    frozenMarks <- U.unsafeFreeze mark+    frozenScores <- U.unsafeFreeze score+    pure+      MultiStoreScanOutput+        { outputDigest =+            digestVectors readDigest frozenMarks frozenScores+        , outputMarks = frozenMarks+        , outputScores = frozenScores+        }++readHeaderOpaque :: STRef s (Int, vector) -> ST s vector+{-# NOINLINE readHeaderOpaque #-}+-- Keep the comparator's three header reads observable. If this helper inlines,+-- GHC can cancel each locally allocated STRef against its read and turn the+-- control back into the deliberately retained lower-bound root.+readHeaderOpaque header = do+  (_, vector) <- readSTRef header+  pure vector++multiStoreScanDirectWorker ::+  Int ->+  Int ->+  Int ->+  Int64 ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  MV.MVector s (Int, Int) ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  ST s Int64+{-# NOINLINE multiStoreScanDirectWorker #-}+multiStoreScanDirectWorker !remaining !index !visits !digest next weight mark payload score link+  | remaining <= 0 = pure digest+  | otherwise = do+      nextIndex <- UM.unsafeRead next index+      weightValue <- UM.unsafeRead weight index+      markValue <- UM.unsafeRead mark index+      (payloadTag, payloadDelta) <- MV.unsafeRead payload index+      scoreValue <- UM.unsafeRead score index+      linkValue <- UM.unsafeRead link index+      let !shouldWrite =+            (weightValue + scoreValue + payloadTag + visits) `rem` 5 == 0+          !nextDigest =+            digest+              + fromIntegral+                ( nextIndex+                    + weightValue+                    + markValue+                    + payloadTag+                    + payloadDelta+                    + scoreValue+                    + linkValue+                )+      if shouldWrite+        then do+          UM.unsafeWrite mark index (markValue + 1)+          UM.unsafeWrite score index (scoreValue + payloadDelta + 1)+        else pure ()+      multiStoreScanDirectWorker+        (remaining - 1)+        ((nextIndex + linkValue) `rem` multiStoreScanNodeCount)+        (visits + 1)+        nextDigest+        next+        weight+        mark+        payload+        score+        link++multiStoreScanPureBorrowOwningBenchmarkRoot ::+  MultiStoreScanInput ->+  MultiStoreScanOutput+{-# NOINLINE multiStoreScanPureBorrowOwningBenchmarkRoot #-}+multiStoreScanPureBorrowOwningBenchmarkRoot input =+  validateInput input `seq`+    unur+      ( linearly \linear -> DataFlow.do+          (allocationLinear, borrowLinear) <- dup linear+          store <- newOwningMultiStore input allocationLinear+          runBO borrowLinear Control.do+            (storeBorrow, lender) <- borrowM store+            (Ur digest, storeBorrow) <-+              reborrowing storeBorrow \local -> Control.do+                let %1 !(fixedRootBorrows, growableRootBorrows) =+                      local+                        .@ (owningFixedRootsField, owningGrowableRootsField)+                let %1 !(nextBorrow, weightBorrow, markBorrow) =+                      fixedRootBorrows+                        .@ (owningNextField, owningWeightField, owningMarkField)+                let %1 !(payloadBorrow, scoreBorrow, linkBorrow) =+                      growableRootBorrows+                        .@ (owningPayloadField, owningScoreField, owningLinkField)+                let %1 !payloadContent =+                      OwningBoxedGrowable.getContents payloadBorrow+                let %1 !scoreContent =+                      OwningUnboxedGrowable.getContents scoreBorrow+                let %1 !linkContent =+                      OwningUnboxedGrowable.getContents linkBorrow+                ( Ur digest+                  , nextBorrow+                  , weightBorrow+                  , markBorrow+                  , payloadContent+                  , scoreContent+                  , linkContent+                  ) <-+                  multiStoreScanPureBorrowOwningWorker+                    multiStoreScanNodeCount+                    0+                    0+                    0+                    nextBorrow+                    weightBorrow+                    markBorrow+                    payloadContent+                    scoreContent+                    linkContent+                let !(Ur _) = share nextBorrow+                let !(Ur _) = share weightBorrow+                let !(Ur _) = share markBorrow+                let !(Ur _) = share payloadContent+                let !(Ur _) = share scoreContent+                let !(Ur _) = share linkContent+                Control.pure (Ur digest)+            let !(Ur _) = share storeBorrow+            pureAfter+              (finishOwningMultiStoreOutput digest (reclaim lender))+      )++multiStoreScanPureBorrowFixedUnrestrictedBenchmarkRoot ::+  MultiStoreScanInput ->+  MultiStoreScanOutput+{-# NOINLINE multiStoreScanPureBorrowFixedUnrestrictedBenchmarkRoot #-}+multiStoreScanPureBorrowFixedUnrestrictedBenchmarkRoot input =+  validateInput input `seq`+    unur+      ( linearly \linear -> DataFlow.do+          (allocationLinear, borrowLinear) <- dup linear+          store <- newFixedUnrestrictedStore input allocationLinear+          runBO borrowLinear Control.do+            (storeBorrow, lender) <- borrowM store+            (Ur digest, storeBorrow) <-+              reborrowing storeBorrow \local -> Control.do+                let %1 !(fixedRootBorrows, growableRootBorrows) =+                      local+                        .@ ( fixedUnrestrictedRootsField+                           , fixedUnrestrictedGrowableRootsField+                           )+                let %1 !(nextBorrow, weightBorrow, markBorrow) =+                      fixedRootBorrows .@ (nextField, weightField, markField)+                let %1 !(payloadBorrow, scoreBorrow, linkBorrow) =+                      growableRootBorrows+                        .@ (owningPayloadField, owningScoreField, owningLinkField)+                let %1 !payloadContent =+                      OwningBoxedGrowable.getContents payloadBorrow+                let %1 !scoreContent =+                      OwningUnboxedGrowable.getContents scoreBorrow+                let %1 !linkContent =+                      OwningUnboxedGrowable.getContents linkBorrow+                ( Ur digest+                  , nextBorrow+                  , weightBorrow+                  , markBorrow+                  , payloadContent+                  , scoreContent+                  , linkContent+                  ) <-+                  multiStoreScanPureBorrowFixedUnrestrictedWorker+                    multiStoreScanNodeCount+                    0+                    0+                    0+                    nextBorrow+                    weightBorrow+                    markBorrow+                    payloadContent+                    scoreContent+                    linkContent+                let !(Ur _) = share nextBorrow+                let !(Ur _) = share weightBorrow+                let !(Ur _) = share markBorrow+                let !(Ur _) = share payloadContent+                let !(Ur _) = share scoreContent+                let !(Ur _) = share linkContent+                Control.pure (Ur digest)+            let !(Ur _) = share storeBorrow+            pureAfter+              ( finishFixedUnrestrictedStoreOutput+                  digest+                  (reclaim lender)+              )+      )++multiStoreScanPureBorrowOwningWorker ::+  Int ->+  Int ->+  Int ->+  Int64 ->+  Mut α (OwningUnboxedFixed.Vector Int) %1 ->+  Mut α (OwningUnboxedFixed.Vector Int) %1 ->+  Mut α (OwningUnboxedFixed.Vector Int) %1 ->+  Mut α (OwningBoxedFixed.Vector (Int, Int)) %1 ->+  Mut α (OwningUnboxedFixed.Vector Int) %1 ->+  Mut α (OwningUnboxedFixed.Vector Int) %1 ->+  BO+    α+    ( Ur Int64+    , Mut α (OwningUnboxedFixed.Vector Int)+    , Mut α (OwningUnboxedFixed.Vector Int)+    , Mut α (OwningUnboxedFixed.Vector Int)+    , Mut α (OwningBoxedFixed.Vector (Int, Int))+    , Mut α (OwningUnboxedFixed.Vector Int)+    , Mut α (OwningUnboxedFixed.Vector Int)+    )+{-# NOINLINE multiStoreScanPureBorrowOwningWorker #-}+multiStoreScanPureBorrowOwningWorker !remaining !index !visits !digest nextBorrow weightBorrow markBorrow payloadContent scoreContent linkContent+  | remaining <= 0 =+      Control.pure+        ( Ur digest+        , nextBorrow+        , weightBorrow+        , markBorrow+        , payloadContent+        , scoreContent+        , linkContent+        )+  | otherwise = Control.do+      (Ur nextIndex, nextBorrow) <-+        OwningUnboxedFixed.copyAtMut index nextBorrow+      (Ur weightValue, weightBorrow) <-+        OwningUnboxedFixed.copyAtMut index weightBorrow+      (Ur markValue, markBorrow) <-+        OwningUnboxedFixed.copyAtMut index markBorrow+      (Ur (payloadTag, payloadDelta), payloadContent) <-+        OwningBoxedFixed.copyAtMut index payloadContent+      (Ur scoreValue, scoreContent) <-+        OwningUnboxedFixed.copyAtMut index scoreContent+      (Ur linkValue, linkContent) <-+        OwningUnboxedFixed.copyAtMut index linkContent+      let !shouldWrite =+            (weightValue + scoreValue + payloadTag + visits) `rem` 5 == 0+          !nextDigest =+            digest+              + fromIntegral+                ( nextIndex+                    + weightValue+                    + markValue+                    + payloadTag+                    + payloadDelta+                    + scoreValue+                    + linkValue+                )+      if shouldWrite+        then Control.do+          (oldMark, markBorrow) <-+            OwningUnboxedFixed.unsafeSet+              index+              (markValue + 1)+              markBorrow+          (oldScore, scoreContent) <-+            OwningUnboxedFixed.unsafeSet+              index+              (scoreValue + payloadDelta + 1)+              scoreContent+          multiStoreScanPureBorrowOwningWorker+            (remaining - 1)+            ((nextIndex + linkValue) `rem` multiStoreScanNodeCount)+            (visits + 1)+            nextDigest+            nextBorrow+            weightBorrow+            (consume oldMark `lseq` markBorrow)+            payloadContent+            (consume oldScore `lseq` scoreContent)+            linkContent+        else+          multiStoreScanPureBorrowOwningWorker+            (remaining - 1)+            ((nextIndex + linkValue) `rem` multiStoreScanNodeCount)+            (visits + 1)+            nextDigest+            nextBorrow+            weightBorrow+            markBorrow+            payloadContent+            scoreContent+            linkContent++multiStoreScanPureBorrowFixedUnrestrictedWorker ::+  Int ->+  Int ->+  Int ->+  Int64 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (OwningBoxedFixed.Vector (Int, Int)) %1 ->+  Mut α (OwningUnboxedFixed.Vector Int) %1 ->+  Mut α (OwningUnboxedFixed.Vector Int) %1 ->+  BO+    α+    ( Ur Int64+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (OwningBoxedFixed.Vector (Int, Int))+    , Mut α (OwningUnboxedFixed.Vector Int)+    , Mut α (OwningUnboxedFixed.Vector Int)+    )+{-# NOINLINE multiStoreScanPureBorrowFixedUnrestrictedWorker #-}+multiStoreScanPureBorrowFixedUnrestrictedWorker !remaining !index !visits !digest nextBorrow weightBorrow markBorrow payloadContent scoreContent linkContent+  | remaining <= 0 =+      Control.pure+        ( Ur digest+        , nextBorrow+        , weightBorrow+        , markBorrow+        , payloadContent+        , scoreContent+        , linkContent+        )+  | otherwise = Control.do+      (Ur nextIndex, nextBorrow) <-+        Fixed.unsafeGet index nextBorrow+      (Ur weightValue, weightBorrow) <-+        Fixed.unsafeGet index weightBorrow+      (Ur markValue, markBorrow) <-+        Fixed.unsafeGet index markBorrow+      (Ur (payloadTag, payloadDelta), payloadContent) <-+        OwningBoxedFixed.copyAtMut index payloadContent+      (Ur scoreValue, scoreContent) <-+        OwningUnboxedFixed.copyAtMut index scoreContent+      (Ur linkValue, linkContent) <-+        OwningUnboxedFixed.copyAtMut index linkContent+      let !shouldWrite =+            (weightValue + scoreValue + payloadTag + visits) `rem` 5 == 0+          !nextDigest =+            digest+              + fromIntegral+                ( nextIndex+                    + weightValue+                    + markValue+                    + payloadTag+                    + payloadDelta+                    + scoreValue+                    + linkValue+                )+      if shouldWrite+        then Control.do+          markBorrow <-+            Fixed.unsafeWrite index (markValue + 1) markBorrow+          (oldScore, scoreContent) <-+            OwningUnboxedFixed.unsafeSet+              index+              (scoreValue + payloadDelta + 1)+              scoreContent+          multiStoreScanPureBorrowFixedUnrestrictedWorker+            (remaining - 1)+            ((nextIndex + linkValue) `rem` multiStoreScanNodeCount)+            (visits + 1)+            nextDigest+            nextBorrow+            weightBorrow+            markBorrow+            payloadContent+            (consume oldScore `lseq` scoreContent)+            linkContent+        else+          multiStoreScanPureBorrowFixedUnrestrictedWorker+            (remaining - 1)+            ((nextIndex + linkValue) `rem` multiStoreScanNodeCount)+            (visits + 1)+            nextDigest+            nextBorrow+            weightBorrow+            markBorrow+            payloadContent+            scoreContent+            linkContent++multiStoreScanPureBorrowDirectBenchmarkRoot ::+  MultiStoreScanInput ->+  MultiStoreScanOutput+{-# NOINLINE multiStoreScanPureBorrowDirectBenchmarkRoot #-}+multiStoreScanPureBorrowDirectBenchmarkRoot input =+  validateInput input `seq`+    unur+      ( linearly \linear -> DataFlow.do+          (allocationLinear, borrowLinear) <- dup linear+          store <- newMultiStore input allocationLinear+          runBO borrowLinear Control.do+            (storeBorrow, lender) <- borrowM store+            (Ur digest, storeBorrow) <-+              reborrowing storeBorrow \local -> Control.do+                let %1 !(fixedRootBorrows, growableRootBorrows) =+                      local .@ (fixedRootsField, growableRootsField)+                let %1 !(nextBorrow, weightBorrow, markBorrow) =+                      fixedRootBorrows .@ (nextField, weightField, markField)+                let %1 !(payloadBorrow, scoreBorrow, linkBorrow) =+                      growableRootBorrows .@ (payloadField, scoreField, linkField)+                let %1 !payloadContent = Growable.getContents payloadBorrow+                let %1 !scoreContent = Growable.getContents scoreBorrow+                let %1 !linkContent = Growable.getContents linkBorrow+                ( Ur digest+                  , nextBorrow+                  , weightBorrow+                  , markBorrow+                  , payloadContent+                  , scoreContent+                  , linkContent+                  ) <-+                  multiStoreScanPureBorrowWorker+                    multiStoreScanNodeCount+                    0+                    0+                    0+                    nextBorrow+                    weightBorrow+                    markBorrow+                    payloadContent+                    scoreContent+                    linkContent+                let !() =+                      consumeViews+                        nextBorrow+                        weightBorrow+                        markBorrow+                        payloadContent+                        scoreContent+                        linkContent+                Control.pure (Ur digest)+            let !(Ur _) = share storeBorrow+            pureAfter (finishMultiStoreOutput digest (reclaim lender))+      )++multiStoreScanPureBorrowNestedBenchmarkRoot ::+  MultiStoreScanInput ->+  MultiStoreScanOutput+{-# NOINLINE multiStoreScanPureBorrowNestedBenchmarkRoot #-}+multiStoreScanPureBorrowNestedBenchmarkRoot input =+  validateInput input `seq`+    unur+      ( linearly \linear -> DataFlow.do+          (allocationLinear, borrowLinear) <- dup linear+          store <- newMultiStore input allocationLinear+          runBO borrowLinear Control.do+            (storeBorrow, lender) <- borrowM store+            (Ur digest, storeBorrow) <-+              reborrowing storeBorrow \local -> Control.do+                let %1 !(fixedRootBorrows, growableRootBorrows) =+                      local .@ (fixedRootsField, growableRootsField)+                let %1 !(nextBorrow, weightBorrow, markBorrow) =+                      fixedRootBorrows .@ (nextField, weightField, markField)+                let %1 !(payloadBorrow, scoreBorrow, linkBorrow) =+                      growableRootBorrows .@ (payloadField, scoreField, linkField)+                (Ur digest, fields) <-+                  reborrowings+                    ( nextBorrow+                        :- weightBorrow+                        :- markBorrow+                        :- payloadBorrow+                        :- scoreBorrow+                        :- linkBorrow+                        :- BNil+                    )+                    \case+                      nextBorrow+                        :- weightBorrow+                        :- markBorrow+                        :- payloadBorrow+                        :- scoreBorrow+                        :- linkBorrow+                        :- BNil -> Control.do+                          let %1 !payloadContent =+                                Growable.getContents payloadBorrow+                          let %1 !scoreContent =+                                Growable.getContents scoreBorrow+                          let %1 !linkContent =+                                Growable.getContents linkBorrow+                          ( Ur digest+                            , nextBorrow+                            , weightBorrow+                            , markBorrow+                            , payloadContent+                            , scoreContent+                            , linkContent+                            ) <-+                            multiStoreScanPureBorrowWorker+                              multiStoreScanNodeCount+                              0+                              0+                              0+                              nextBorrow+                              weightBorrow+                              markBorrow+                              payloadContent+                              scoreContent+                              linkContent+                          let !() =+                                consumeViews+                                  nextBorrow+                                  weightBorrow+                                  markBorrow+                                  payloadContent+                                  scoreContent+                                  linkContent+                          Control.pure (Ur digest)+                let !() = consume fields+                Control.pure (Ur digest)+            let !(Ur _) = share storeBorrow+            pureAfter (finishMultiStoreOutput digest (reclaim lender))+      )++multiStoreScanPureBorrowDirectRoot ::+  MultiStoreScanInput ->+  MultiStoreScanResult+{-# NOINLINE multiStoreScanPureBorrowDirectRoot #-}+multiStoreScanPureBorrowDirectRoot input =+  let !inputValidationReads = validateInput input+   in unur+        ( linearly \linear -> DataFlow.do+            (allocationLinear, borrowLinear) <- dup linear+            store <- newMultiStore input allocationLinear+            runBO borrowLinear Control.do+              (storeBorrow, lender) <- borrowM store+              (Ur trace, storeBorrow) <-+                reborrowing storeBorrow \local -> Control.do+                  let %1 !(fixedRootBorrows, growableRootBorrows) =+                        local .@ (fixedRootsField, growableRootsField)+                  let %1 !(nextBorrow, weightBorrow, markBorrow) =+                        fixedRootBorrows .@ (nextField, weightField, markField)+                  let %1 !(payloadBorrow, scoreBorrow, linkBorrow) =+                        growableRootBorrows .@ (payloadField, scoreField, linkField)+                  let %1 !payloadContent = Growable.getContents payloadBorrow+                  let %1 !scoreContent = Growable.getContents scoreBorrow+                  let %1 !linkContent = Growable.getContents linkBorrow+                  ( Ur trace+                    , nextBorrow+                    , weightBorrow+                    , markBorrow+                    , payloadContent+                    , scoreContent+                    , linkContent+                    ) <-+                    multiStoreScanPureBorrowTraceWorker+                      multiStoreScanNodeCount+                      0+                      0+                      emptyAccessTrace {traceHeaderReads = 3}+                      nextBorrow+                      weightBorrow+                      markBorrow+                      payloadContent+                      scoreContent+                      linkContent+                  let !() =+                        consumeViews+                          nextBorrow+                          weightBorrow+                          markBorrow+                          payloadContent+                          scoreContent+                          linkContent+                  Control.pure (Ur trace)+              let !(Ur _) = share storeBorrow+              pureAfter+                ( finishMultiStoreResult+                    inputValidationReads+                    trace+                    (reclaim lender)+                )+        )++multiStoreScanPureBorrowNestedRoot ::+  MultiStoreScanInput ->+  MultiStoreScanResult+{-# NOINLINE multiStoreScanPureBorrowNestedRoot #-}+multiStoreScanPureBorrowNestedRoot input =+  let !inputValidationReads = validateInput input+   in unur+        ( linearly \linear -> DataFlow.do+            (allocationLinear, borrowLinear) <- dup linear+            store <- newMultiStore input allocationLinear+            runBO borrowLinear Control.do+              (storeBorrow, lender) <- borrowM store+              (Ur trace, storeBorrow) <-+                reborrowing storeBorrow \local -> Control.do+                  let %1 !(fixedRootBorrows, growableRootBorrows) =+                        local .@ (fixedRootsField, growableRootsField)+                  let %1 !(nextBorrow, weightBorrow, markBorrow) =+                        fixedRootBorrows .@ (nextField, weightField, markField)+                  let %1 !(payloadBorrow, scoreBorrow, linkBorrow) =+                        growableRootBorrows .@ (payloadField, scoreField, linkField)+                  (Ur trace, fields) <-+                    reborrowings+                      ( nextBorrow+                          :- weightBorrow+                          :- markBorrow+                          :- payloadBorrow+                          :- scoreBorrow+                          :- linkBorrow+                          :- BNil+                      )+                      \case+                        nextBorrow+                          :- weightBorrow+                          :- markBorrow+                          :- payloadBorrow+                          :- scoreBorrow+                          :- linkBorrow+                          :- BNil -> Control.do+                            let %1 !payloadContent =+                                  Growable.getContents payloadBorrow+                            let %1 !scoreContent =+                                  Growable.getContents scoreBorrow+                            let %1 !linkContent =+                                  Growable.getContents linkBorrow+                            ( Ur trace+                              , nextBorrow+                              , weightBorrow+                              , markBorrow+                              , payloadContent+                              , scoreContent+                              , linkContent+                              ) <-+                              multiStoreScanPureBorrowTraceWorker+                                multiStoreScanNodeCount+                                0+                                0+                                emptyAccessTrace {traceHeaderReads = 3}+                                nextBorrow+                                weightBorrow+                                markBorrow+                                payloadContent+                                scoreContent+                                linkContent+                            let !() =+                                  consumeViews+                                    nextBorrow+                                    weightBorrow+                                    markBorrow+                                    payloadContent+                                    scoreContent+                                    linkContent+                            Control.pure (Ur trace)+                  let !() = consume fields+                  Control.pure (Ur trace)+              let !(Ur _) = share storeBorrow+              pureAfter+                ( finishMultiStoreResult+                    inputValidationReads+                    trace+                    (reclaim lender)+                )+        )++multiStoreScanPureBorrowWorker ::+  Int ->+  Int ->+  Int ->+  Int64 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector V.Vector (Int, Int)) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  BO+    α+    ( Ur Int64+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector V.Vector (Int, Int))+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    )+{-# INLINEABLE multiStoreScanPureBorrowWorker #-}+multiStoreScanPureBorrowWorker !remaining !index !visits !digest nextBorrow weightBorrow markBorrow payloadContent scoreContent linkContent =+  -- An ordinary strict Int64 accumulator is still rebuilt as I64# at every+  -- recursive call because the BO result also returns six linear borrows.+  -- Entering an explicitly unboxed local loop keeps the accumulator in+  -- Int64# until the single ownership boundary below.+  case digest of+    I64# digest# ->+      go+        remaining+        index+        visits+        digest#+        nextBorrow+        weightBorrow+        markBorrow+        payloadContent+        scoreContent+        linkContent+  where+    go ::+      Int ->+      Int ->+      Int ->+      GHC.Int64# ->+      Mut α (Fixed.Vector U.Vector Int) %1 ->+      Mut α (Fixed.Vector U.Vector Int) %1 ->+      Mut α (Fixed.Vector U.Vector Int) %1 ->+      Mut α (Fixed.Vector V.Vector (Int, Int)) %1 ->+      Mut α (Fixed.Vector U.Vector Int) %1 ->+      Mut α (Fixed.Vector U.Vector Int) %1 ->+      BO+        α+        ( Ur Int64+        , Mut α (Fixed.Vector U.Vector Int)+        , Mut α (Fixed.Vector U.Vector Int)+        , Mut α (Fixed.Vector U.Vector Int)+        , Mut α (Fixed.Vector V.Vector (Int, Int))+        , Mut α (Fixed.Vector U.Vector Int)+        , Mut α (Fixed.Vector U.Vector Int)+        )+    go !remaining !index !visits digest# nextBorrow weightBorrow markBorrow payloadContent scoreContent linkContent+      | remaining <= 0 =+          Control.pure+            ( Ur (I64# digest#)+            , nextBorrow+            , weightBorrow+            , markBorrow+            , payloadContent+            , scoreContent+            , linkContent+            )+      | otherwise = Control.do+          (Ur nextIndex, nextBorrow) <-+            Fixed.unsafeGet index nextBorrow+          (Ur weightValue, weightBorrow) <-+            Fixed.unsafeGet index weightBorrow+          (Ur markValue, markBorrow) <-+            Fixed.unsafeGet index markBorrow+          (Ur (payloadTag, payloadDelta), payloadContent) <-+            Fixed.unsafeGet index payloadContent+          (Ur scoreValue, scoreContent) <-+            Fixed.unsafeGet index scoreContent+          (Ur linkValue, linkContent) <-+            Fixed.unsafeGet index linkContent+          let !shouldWrite =+                (weightValue + scoreValue + payloadTag + visits) `rem` 5 == 0+              !nextDigest =+                I64# digest#+                  + fromIntegral+                    ( nextIndex+                        + weightValue+                        + markValue+                        + payloadTag+                        + payloadDelta+                        + scoreValue+                        + linkValue+                    )+          case nextDigest of+            I64# nextDigest# ->+              if shouldWrite+                then Control.do+                  markBorrow <-+                    Fixed.unsafeWrite index (markValue + 1) markBorrow+                  scoreContent <-+                    Fixed.unsafeWrite+                      index+                      (scoreValue + payloadDelta + 1)+                      scoreContent+                  go+                    (remaining - 1)+                    ((nextIndex + linkValue) `rem` multiStoreScanNodeCount)+                    (visits + 1)+                    nextDigest#+                    nextBorrow+                    weightBorrow+                    markBorrow+                    payloadContent+                    scoreContent+                    linkContent+                else+                  go+                    (remaining - 1)+                    ((nextIndex + linkValue) `rem` multiStoreScanNodeCount)+                    (visits + 1)+                    nextDigest#+                    nextBorrow+                    weightBorrow+                    markBorrow+                    payloadContent+                    scoreContent+                    linkContent++multiStoreScanPureBorrowTraceWorker ::+  Int ->+  Int ->+  Int ->+  AccessTrace ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector V.Vector (Int, Int)) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  BO+    α+    ( Ur AccessTrace+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector V.Vector (Int, Int))+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    )+{-# NOINLINE multiStoreScanPureBorrowTraceWorker #-}+multiStoreScanPureBorrowTraceWorker !remaining !index !visits !trace nextBorrow weightBorrow markBorrow payloadContent scoreContent linkContent+  | remaining <= 0 =+      Control.pure+        ( Ur trace+        , nextBorrow+        , weightBorrow+        , markBorrow+        , payloadContent+        , scoreContent+        , linkContent+        )+  | otherwise = Control.do+      (Ur nextIndex, nextBorrow) <-+        Fixed.unsafeGet index nextBorrow+      (Ur weightValue, weightBorrow) <-+        Fixed.unsafeGet index weightBorrow+      (Ur markValue, markBorrow) <-+        Fixed.unsafeGet index markBorrow+      (Ur (payloadTag, payloadDelta), payloadContent) <-+        Fixed.unsafeGet index payloadContent+      (Ur scoreValue, scoreContent) <-+        Fixed.unsafeGet index scoreContent+      (Ur linkValue, linkContent) <-+        Fixed.unsafeGet index linkContent+      let !shouldWrite =+            (weightValue + scoreValue + payloadTag + visits) `rem` 5 == 0+          !nextTrace =+            recordTraceVisit+              index+              nextIndex+              weightValue+              markValue+              payloadTag+              payloadDelta+              scoreValue+              linkValue+              shouldWrite+              trace+      if shouldWrite+        then Control.do+          markBorrow <-+            Fixed.unsafeWrite index (markValue + 1) markBorrow+          scoreContent <-+            Fixed.unsafeWrite+              index+              (scoreValue + payloadDelta + 1)+              scoreContent+          multiStoreScanPureBorrowTraceWorker+            (remaining - 1)+            ((nextIndex + linkValue) `rem` multiStoreScanNodeCount)+            (visits + 1)+            nextTrace+            nextBorrow+            weightBorrow+            markBorrow+            payloadContent+            scoreContent+            linkContent+        else+          multiStoreScanPureBorrowTraceWorker+            (remaining - 1)+            ((nextIndex + linkValue) `rem` multiStoreScanNodeCount)+            (visits + 1)+            nextTrace+            nextBorrow+            weightBorrow+            markBorrow+            payloadContent+            scoreContent+            linkContent++consumeViews ::+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector V.Vector (Int, Int)) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  ()+consumeViews nextBorrow weightBorrow markBorrow payloadContent scoreContent linkContent =+  let !(Ur _) = share nextBorrow+      !(Ur _) = share weightBorrow+      !(Ur _) = share markBorrow+      !(Ur _) = share payloadContent+      !(Ur _) = share scoreContent+      !(Ur _) = share linkContent+   in ()++newOwningMultiStore ::+  MultiStoreScanInput ->+  Linearly %1 ->+  OwningMultiStore+{-# NOINLINE newOwningMultiStore #-}+newOwningMultiStore =+  GHC.noinline \input linear ->+    dup linear & \(nextLinear, rest1) ->+      dup rest1 & \(weightLinear, rest2) ->+        dup rest2 & \(markLinear, rest3) ->+          dup rest3 & \(payloadLinear, rest4) ->+            dup rest4 & \(scoreLinear, linkLinear) ->+              OwningMultiStore+                { owningFixedRoots =+                    OwningFixedRoots+                      { owningNext =+                          OwningUnboxedFixed.fromVector+                            (inputNext input)+                            nextLinear+                      , owningWeight =+                          OwningUnboxedFixed.fromVector+                            (inputWeight input)+                            weightLinear+                      , owningMark =+                          OwningUnboxedFixed.fromVector+                            (inputMark input)+                            markLinear+                      }+                , owningGrowableRoots =+                    OwningGrowableRoots+                      { owningPayload =+                          OwningBoxedGrowable.fromVector+                            (inputPayload input)+                            payloadLinear+                      , owningScore =+                          OwningUnboxedGrowable.fromVector+                            (inputScore input)+                            scoreLinear+                      , owningLink =+                          OwningUnboxedGrowable.fromVector+                            (inputLink input)+                            linkLinear+                      }+                }++newFixedUnrestrictedStore ::+  MultiStoreScanInput ->+  Linearly %1 ->+  FixedUnrestrictedStore+{-# NOINLINE newFixedUnrestrictedStore #-}+newFixedUnrestrictedStore =+  GHC.noinline \input linear ->+    dup linear & \(nextLinear, rest1) ->+      dup rest1 & \(weightLinear, rest2) ->+        dup rest2 & \(markLinear, rest3) ->+          dup rest3 & \(payloadLinear, rest4) ->+            dup rest4 & \(scoreLinear, linkLinear) ->+              FixedUnrestrictedStore+                { fixedUnrestrictedRoots =+                    FixedRoots+                      { next =+                          Fixed.fromVector+                            (inputNext input)+                            nextLinear+                      , weight =+                          Fixed.fromVector+                            (inputWeight input)+                            weightLinear+                      , mark =+                          Fixed.fromVector+                            (inputMark input)+                            markLinear+                      }+                , fixedUnrestrictedGrowableRoots =+                    OwningGrowableRoots+                      { owningPayload =+                          OwningBoxedGrowable.fromVector+                            (inputPayload input)+                            payloadLinear+                      , owningScore =+                          OwningUnboxedGrowable.fromVector+                            (inputScore input)+                            scoreLinear+                      , owningLink =+                          OwningUnboxedGrowable.fromVector+                            (inputLink input)+                            linkLinear+                      }+                }++newMultiStore :: MultiStoreScanInput -> Linearly %1 -> MultiStore+{-# NOINLINE newMultiStore #-}+newMultiStore =+  GHC.noinline \input linear ->+    dup linear & \(nextLinear, rest1) ->+      dup rest1 & \(weightLinear, rest2) ->+        dup rest2 & \(markLinear, rest3) ->+          dup rest3 & \(payloadLinear, rest4) ->+            dup rest4 & \(scoreLinear, linkLinear) ->+              MultiStore+                { fixedRoots =+                    FixedRoots+                      { next =+                          Fixed.fromVector+                            (inputNext input)+                            nextLinear+                      , weight =+                          Fixed.fromVector+                            (inputWeight input)+                            weightLinear+                      , mark =+                          Fixed.fromVector+                            (inputMark input)+                            markLinear+                      }+                , growableRoots =+                    GrowableRoots+                      { payload =+                          Growable.fromVector+                            (inputPayload input)+                            payloadLinear+                      , score =+                          Growable.fromVector+                            (inputScore input)+                            scoreLinear+                      , link =+                          Growable.fromVector+                            (inputLink input)+                            linkLinear+                      }+                }++finishOwningMultiStoreOutput ::+  Int64 ->+  OwningMultiStore %1 ->+  Ur MultiStoreScanOutput+{-# NOINLINE finishOwningMultiStoreOutput #-}+finishOwningMultiStoreOutput+  digest+  ( OwningMultiStore+      (OwningFixedRoots nextOwner weightOwner markOwner)+      (OwningGrowableRoots payloadOwner scoreOwner linkOwner)+    ) =+    case OwningUnboxedFixed.toVector nextOwner of+      Ur nextVector ->+        case OwningUnboxedFixed.toVector weightOwner of+          Ur weightVector ->+            case OwningUnboxedFixed.toVector markOwner of+              Ur markVector ->+                case OwningBoxedGrowable.toVector payloadOwner of+                  Ur payloadVector ->+                    case OwningUnboxedGrowable.toVector scoreOwner of+                      Ur scoreVector ->+                        case OwningUnboxedGrowable.toVector linkOwner of+                          Ur linkVector ->+                            U.length nextVector `lseq`+                              U.length weightVector `lseq`+                                V.length payloadVector `lseq`+                                  U.length linkVector `lseq`+                                    Ur+                                      MultiStoreScanOutput+                                        { outputDigest =+                                            digestVectors+                                              digest+                                              markVector+                                              scoreVector+                                        , outputMarks = markVector+                                        , outputScores = scoreVector+                                        }++finishFixedUnrestrictedStoreOutput ::+  Int64 ->+  FixedUnrestrictedStore %1 ->+  Ur MultiStoreScanOutput+{-# NOINLINE finishFixedUnrestrictedStoreOutput #-}+finishFixedUnrestrictedStoreOutput+  digest+  ( FixedUnrestrictedStore+      (FixedRoots nextOwner weightOwner markOwner)+      (OwningGrowableRoots payloadOwner scoreOwner linkOwner)+    ) =+    case Fixed.toVector nextOwner of+      Ur nextVector ->+        case Fixed.toVector weightOwner of+          Ur weightVector ->+            case Fixed.toVector markOwner of+              Ur markVector ->+                case OwningBoxedGrowable.toVector payloadOwner of+                  Ur payloadVector ->+                    case OwningUnboxedGrowable.toVector scoreOwner of+                      Ur scoreVector ->+                        case OwningUnboxedGrowable.toVector linkOwner of+                          Ur linkVector ->+                            U.length nextVector `lseq`+                              U.length weightVector `lseq`+                                V.length payloadVector `lseq`+                                  U.length linkVector `lseq`+                                    Ur+                                      MultiStoreScanOutput+                                        { outputDigest =+                                            digestVectors+                                              digest+                                              markVector+                                              scoreVector+                                        , outputMarks = markVector+                                        , outputScores = scoreVector+                                        }++finishMultiStoreOutput ::+  Int64 ->+  MultiStore %1 ->+  Ur MultiStoreScanOutput+{-# NOINLINE finishMultiStoreOutput #-}+finishMultiStoreOutput+  digest+  ( MultiStore+      (FixedRoots nextOwner weightOwner markOwner)+      (GrowableRoots payloadOwner scoreOwner linkOwner)+    ) =+    case Fixed.toVector nextOwner of+      Ur nextVector ->+        case Fixed.toVector weightOwner of+          Ur weightVector ->+            case Fixed.toVector markOwner of+              Ur markVector ->+                case Growable.toVector payloadOwner of+                  Ur payloadVector ->+                    case Growable.toVector scoreOwner of+                      Ur scoreVector ->+                        case Growable.toVector linkOwner of+                          Ur linkVector ->+                            U.length nextVector `lseq`+                              U.length weightVector `lseq`+                                V.length payloadVector `lseq`+                                  U.length linkVector `lseq`+                                    Ur+                                      MultiStoreScanOutput+                                        { outputDigest =+                                            digestVectors+                                              digest+                                              markVector+                                              scoreVector+                                        , outputMarks = markVector+                                        , outputScores = scoreVector+                                        }++finishMultiStoreResult ::+  Int ->+  AccessTrace ->+  MultiStore %1 ->+  Ur MultiStoreScanResult+finishMultiStoreResult inputValidationReads trace store =+  case finishMultiStoreOutput (traceReadDigest trace) store of+    Ur output ->+      Ur+        MultiStoreScanResult+          { resultSummary =+              MultiStoreScanSummary+                { visitedNodes = traceVisitedNodes trace+                , elementReads = traceElementReads trace+                , elementWrites = traceElementWrites trace+                , headerReads = traceHeaderReads trace+                , validationReads = inputValidationReads+                , finalDigest = outputDigest output+                }+          , resultVisitedIndices =+              U.fromListN+                multiStoreScanNodeCount+                (reverse (traceVisitedIndicesRev trace))+          , resultEvents =+              V.fromListN+                (traceElementReads trace + traceElementWrites trace)+                (reverse (traceEventsRev trace))+          , resultEventDigest = traceEventDigest trace+          , resultMarks = outputMarks output+          , resultScores = outputScores output+          }++owningFixedRootsField ::+  RecordLabel+    OwningMultiStore+    "owningFixedRoots"+    OwningFixedRoots+owningFixedRootsField = #owningFixedRoots++owningGrowableRootsField ::+  RecordLabel+    OwningMultiStore+    "owningGrowableRoots"+    OwningGrowableRoots+owningGrowableRootsField = #owningGrowableRoots++owningNextField ::+  RecordLabel+    OwningFixedRoots+    "owningNext"+    (OwningUnboxedFixed.Vector Int)+owningNextField = #owningNext++owningWeightField ::+  RecordLabel+    OwningFixedRoots+    "owningWeight"+    (OwningUnboxedFixed.Vector Int)+owningWeightField = #owningWeight++owningMarkField ::+  RecordLabel+    OwningFixedRoots+    "owningMark"+    (OwningUnboxedFixed.Vector Int)+owningMarkField = #owningMark++owningPayloadField ::+  RecordLabel+    OwningGrowableRoots+    "owningPayload"+    (OwningBoxedGrowable.GrowableVector (Int, Int))+owningPayloadField = #owningPayload++owningScoreField ::+  RecordLabel+    OwningGrowableRoots+    "owningScore"+    (OwningUnboxedGrowable.GrowableVector Int)+owningScoreField = #owningScore++owningLinkField ::+  RecordLabel+    OwningGrowableRoots+    "owningLink"+    (OwningUnboxedGrowable.GrowableVector Int)+owningLinkField = #owningLink++fixedUnrestrictedRootsField ::+  RecordLabel+    FixedUnrestrictedStore+    "fixedUnrestrictedRoots"+    FixedRoots+fixedUnrestrictedRootsField = #fixedUnrestrictedRoots++fixedUnrestrictedGrowableRootsField ::+  RecordLabel+    FixedUnrestrictedStore+    "fixedUnrestrictedGrowableRoots"+    OwningGrowableRoots+fixedUnrestrictedGrowableRootsField = #fixedUnrestrictedGrowableRoots++fixedRootsField ::+  RecordLabel MultiStore "fixedRoots" FixedRoots+fixedRootsField = #fixedRoots++growableRootsField ::+  RecordLabel MultiStore "growableRoots" GrowableRoots+growableRootsField = #growableRoots++nextField ::+  RecordLabel FixedRoots "next" (Fixed.Vector U.Vector Int)+nextField = #next++weightField ::+  RecordLabel FixedRoots "weight" (Fixed.Vector U.Vector Int)+weightField = #weight++markField ::+  RecordLabel FixedRoots "mark" (Fixed.Vector U.Vector Int)+markField = #mark++payloadField ::+  RecordLabel+    GrowableRoots+    "payload"+    (Growable.GrowableVector V.Vector (Int, Int))+payloadField = #payload++scoreField ::+  RecordLabel+    GrowableRoots+    "score"+    (Growable.GrowableVector U.Vector Int)+scoreField = #score++linkField ::+  RecordLabel+    GrowableRoots+    "link"+    (Growable.GrowableVector U.Vector Int)+linkField = #link++digestVectors :: Int64 -> U.Vector Int -> U.Vector Int -> Int64+digestVectors initial marks scores =+  let !marksDigest =+        U.ifoldl'+          (\digest index value -> mixDigest digest (index * 17 + value))+          initial+          marks+   in U.ifoldl'+        (\digest index value -> mixDigest digest (index * 31 + value))+        marksDigest+        scores++mixDigest :: Int64 -> Int -> Int64+mixDigest digest value =+  digest * 1_099_511_628_211 + fromIntegral value++benches :: [Benchmark]+benches =+  [ env (pure multiStoreScanDirectInput) \input ->+      bgroup+        "multi-store-scan"+        [ bench "direct" $ nf multiStoreScanDirectBenchmarkRoot input+        , bench "direct/header-matched" $+            nf multiStoreScanDirectHeaderMatchedBenchmarkRoot input+        , bench "pure-borrow/all-owning" $+            nf multiStoreScanPureBorrowOwningBenchmarkRoot input+        , bench "pure-borrow/fixed-unrestricted" $+            nf+              multiStoreScanPureBorrowFixedUnrestrictedBenchmarkRoot+              input+        , bench "pure-borrow/all-unrestricted/direct-shape" $+            nf multiStoreScanPureBorrowDirectBenchmarkRoot input+        , bench "pure-borrow/all-unrestricted/nested-shape" $+            nf multiStoreScanPureBorrowNestedBenchmarkRoot input+        ]+  ]++defaultMain :: IO ()+defaultMain = Bench.defaultMain benches

@@ -0,0 +1,421 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module PureBorrow.Internal.Bench.Unboxed (+  defaultMain,+  benches,+  directFixedUnboxedKernel,+  directFixedUnboxedMaterialization,+  directGrowableUnboxedGrowthKernel,+  directGrowableUnboxedMaterialization,+  directGrowableUnboxedNoGrowthKernel,+  owningBoxedQsortKernel,+  pureBorrowFixedUnboxedKernel,+  pureBorrowFixedUnboxedMaterialization,+  pureBorrowGrowableUnboxedGrowthKernel,+  pureBorrowGrowableUnboxedMaterialization,+  pureBorrowGrowableUnboxedNoGrowthKernel,+  unrestrictedBoxedFftKernel,+  unrestrictedBoxedQsortKernel,+  unrestrictedUnboxedFftKernel,+  unrestrictedUnboxedQsortKernel,+) where++import Control.Concurrent.DivideConquer.Linear qualified as DC+import Control.Functor.Linear qualified as Control+import Control.Monad.Borrow.Pure+import Control.Monad.ST.Strict (ST, runST)+import Control.Syntax.DataFlow qualified as DataFlow+import Data.Complex (Complex (..))+import Data.Ref.Linear qualified as Ref+import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)+import Data.Vector qualified as B+import Data.Vector.Generic qualified as G+import Data.Vector.Generic.Mutable.Linear.Borrow.Unrestricted qualified as UnrestrictedVector+import Data.Vector.Mutable.Linear.Borrow qualified as OwningVector+import Data.Vector.Unboxed qualified as U+import Data.Vector.Unboxed.Mutable qualified as UM+import Data.Vector.Unboxed.Mutable.Growable.Linear.Borrow qualified as Growable+import Data.Vector.Unboxed.Mutable.Growable.Linear.Borrow.Internal qualified as GrowableInternal+import Data.Vector.Unboxed.Mutable.Linear.Borrow qualified as Vector+import Data.Vector.Unboxed.Mutable.Linear.Borrow.Internal qualified as VectorInternal+import GHC.IO (unsafePerformIO)+import Prelude.Linear+import Test.Tasty.Bench hiding (defaultMain)+import Test.Tasty.Bench qualified as Bench+import Unsafe.Linear qualified as Unsafe+import Prelude qualified as NonLinear++directFixedUnboxedKernel :: U.Vector Int -> U.Vector Int+{-# NOINLINE directFixedUnboxedKernel #-}+directFixedUnboxedKernel input =+  U.modify (\vector -> directWorker (UM.length vector) 0 vector) input++directWorker :: Int -> Int -> UM.MVector s Int -> ST s ()+{-# NOINLINE directWorker #-}+directWorker !length_ !index vector+  | index >= length_ = NonLinear.pure ()+  | otherwise = do+      value <- UM.unsafeRead vector index+      UM.unsafeWrite vector index (value + 1)+      directWorker length_ (index + 1) vector++{- | Benchmark-only monomorphic finalization for the fixed-vector kernels.++For 'Int', 'move' is observationally the identity. Bypassing the public+materialization loop isolates the update worker; this is not an API-performance+root.+-}+unsafeBenchmarkFreezeFixedInt :: Vector.Vector Int %1 -> Ur (U.Vector Int)+{-# NOINLINE unsafeBenchmarkFreezeFixedInt #-}+unsafeBenchmarkFreezeFixedInt =+  Unsafe.toLinear \(VectorInternal.Vector vector) ->+    Ur (unsafePerformIO (U.unsafeFreeze vector))++directFixedUnboxedMaterialization :: U.Vector Int -> U.Vector Int+{-# NOINLINE directFixedUnboxedMaterialization #-}+directFixedUnboxedMaterialization input =+  U.modify (\_ -> NonLinear.pure ()) input++pureBorrowFixedUnboxedMaterialization :: U.Vector Int -> U.Vector Int+{-# NOINLINE pureBorrowFixedUnboxedMaterialization #-}+pureBorrowFixedUnboxedMaterialization input =+  unur $+    linearly \linear ->+      Vector.toVector (Vector.fromVector input linear)++pureBorrowFixedUnboxedKernel :: U.Vector Int -> U.Vector Int+{-# NOINLINE pureBorrowFixedUnboxedKernel #-}+pureBorrowFixedUnboxedKernel input =+  unur $ linearly \linear -> DataFlow.do+    (ownerLinear, runLinear) <- dup linear+    runBO runLinear Control.do+      (vector, lend) <- borrowM (Vector.fromVector input ownerLinear)+      pureBorrowWorker (U.length input) 0 vector+      pureAfter (unsafeBenchmarkFreezeFixedInt (reclaim lend))++directGrowableUnboxedNoGrowthKernel :: U.Vector Int -> U.Vector Int+{-# NOINLINE directGrowableUnboxedNoGrowthKernel #-}+directGrowableUnboxedNoGrowthKernel input =+  U.modify+    ( \vector -> do+        -- The header ref mirrors the growable owner's indirection, so the+        -- baseline pays for the same loads the measured variant does.+        header <- newSTRef (U.length input, vector)+        (_, content) <- readSTRef header+        directWorker (UM.length content) 0 content+        -- Match the growable owner's final header access.+        (_, _) <- readSTRef header+        NonLinear.pure ()+    )+    input++{- | Benchmark-only monomorphic finalization for the growable-vector kernels.++The reclaimed owner is consumed exactly once and only its initialized prefix is+frozen. As with 'unsafeBenchmarkFreezeFixedInt', this isolates the kernel and+must not be interpreted as public materialization cost.+-}+unsafeBenchmarkFreezeGrowableInt ::+  Growable.GrowableVector Int %1 ->+  Ur (U.Vector Int)+{-# NOINLINE unsafeBenchmarkFreezeGrowableInt #-}+unsafeBenchmarkFreezeGrowableInt =+  Unsafe.toLinear \(GrowableInternal.GrowableVector ref) ->+    case Ref.free ref of+      GrowableInternal.Header logicalSize vector ->+        Ur+          ( unsafePerformIO+              (U.unsafeFreeze (UM.unsafeTake logicalSize vector))+          )++directGrowableUnboxedMaterialization :: U.Vector Int -> U.Vector Int+{-# NOINLINE directGrowableUnboxedMaterialization #-}+directGrowableUnboxedMaterialization input =+  U.modify+    ( \vector -> do+        header <- newSTRef (U.length input, vector)+        (_, _) <- readSTRef header+        NonLinear.pure ()+    )+    input++pureBorrowGrowableUnboxedMaterialization :: U.Vector Int -> U.Vector Int+{-# NOINLINE pureBorrowGrowableUnboxedMaterialization #-}+pureBorrowGrowableUnboxedMaterialization input =+  unur $+    linearly \linear ->+      Growable.toVector (Growable.fromVector input linear)++pureBorrowGrowableUnboxedNoGrowthKernel :: U.Vector Int -> U.Vector Int+{-# NOINLINE pureBorrowGrowableUnboxedNoGrowthKernel #-}+pureBorrowGrowableUnboxedNoGrowthKernel input =+  unur $ linearly \linear -> DataFlow.do+    (ownerLinear, runLinear) <- dup linear+    runBO runLinear Control.do+      (vector, lend) <-+        borrowM+          ( Growable.unsafeFromMutable+              (unsafePerformIO (U.thaw input))+              ownerLinear+          )+      vector <-+        Growable.withContent_ vector \content ->+          pureBorrowWorker (U.length input) 0 content+      let !() = consume vector+      pureAfter (unsafeBenchmarkFreezeGrowableInt (reclaim lend))++directGrowableUnboxedGrowthKernel :: U.Vector Int -> (U.Vector Int, Int)+{-# NOINLINE directGrowableUnboxedGrowthKernel #-}+-- The result length differs from the input's, so this one cannot go through+-- 'U.modify'; 'runST' keeps it equally safe, and the buffer never escapes.+directGrowableUnboxedGrowthKernel input = runST do+  initial <- UM.unsafeNew 0+  header <- newSTRef (0, initial)+  directGrowthWorker input 0 header+  (_, capacityContent) <- readSTRef header+  (logicalSize, content) <- readSTRef header+  frozen <- U.freeze (UM.unsafeTake logicalSize content)+  NonLinear.pure (frozen, UM.length capacityContent)++directGrowthWorker ::+  U.Vector Int ->+  Int ->+  STRef s (Int, UM.MVector s Int) ->+  ST s ()+{-# NOINLINE directGrowthWorker #-}+directGrowthWorker input !index header+  | index >= U.length input = NonLinear.pure ()+  | otherwise = do+      (logicalSize, content) <- readSTRef header+      grown <-+        if logicalSize < UM.length content+          then NonLinear.pure content+          else do+            let !capacity = growthTarget (UM.length content) (logicalSize + 1)+            target <- UM.unsafeNew capacity+            UM.unsafeCopy+              (UM.unsafeTake logicalSize target)+              (UM.unsafeTake logicalSize content)+            NonLinear.pure target+      UM.unsafeWrite grown logicalSize (U.unsafeIndex input index)+      writeSTRef header (logicalSize + 1, grown)+      directGrowthWorker input (index + 1) header++pureBorrowGrowableUnboxedGrowthKernel :: U.Vector Int -> (U.Vector Int, Int)+{-# NOINLINE pureBorrowGrowableUnboxedGrowthKernel #-}+pureBorrowGrowableUnboxedGrowthKernel input =+  unur $ linearly \linear -> DataFlow.do+    (ownerLinear, runLinear) <- dup linear+    runBO runLinear Control.do+      (vector, lend) <- borrowM (Growable.empty ownerLinear)+      vector <- pureBorrowGrowthWorker input 0 vector+      Growable.capacity vector & \(Ur finalCapacity, vector) -> DataFlow.do+        consume vector+        pureAfter+          (attachCapacity finalCapacity (unsafeBenchmarkFreezeGrowableInt (reclaim lend)))++attachCapacity :: Int -> Ur (U.Vector Int) %1 -> Ur (U.Vector Int, Int)+attachCapacity =+  Unsafe.toLinear2 \finalCapacity (Ur frozen) ->+    Ur (frozen, finalCapacity)++pureBorrowGrowthWorker ::+  forall α.+  U.Vector Int ->+  Int ->+  Mut α (Growable.GrowableVector Int) %1 ->+  BO α (Mut α (Growable.GrowableVector Int))+{-# NOINLINE pureBorrowGrowthWorker #-}+pureBorrowGrowthWorker input !index vector+  | index >= U.length input = Control.pure vector+  | otherwise = Control.do+      vector <- Growable.push (U.unsafeIndex input index) vector+      pureBorrowGrowthWorker input (index + 1) vector++growthTarget :: Int -> Int -> Int+{-# INLINE growthTarget #-}+growthTarget oldCapacity required+  | required <= oldCapacity = oldCapacity+  | oldCapacity <= 0 = required `max` 1+  | oldCapacity > maxBound `quot` 2 = required+  | otherwise = required `max` (oldCapacity * 2)++pureBorrowWorker ::+  forall α.+  Int ->+  Int ->+  Mut α (Vector.Vector Int) %1 ->+  BO α ()+{-# NOINLINE pureBorrowWorker #-}+pureBorrowWorker !length_ !index vector+  | index >= length_ = Control.pure (consume vector)+  | otherwise = Control.do+      ((), vector) <-+        Vector.unsafeUpdate+          index+          (\ !value -> Control.pure ((), value + 1))+          vector+      pureBorrowWorker length_ (index + 1) vector++owningBoxedQsortKernel :: B.Vector Int -> B.Vector Int+{-# NOINLINE owningBoxedQsortKernel #-}+owningBoxedQsortKernel input =+  unur $ linearly \linear -> DataFlow.do+    (ownerLinear, runLinear) <- dup linear+    runBO runLinear Control.do+      (vector, lend) <-+        borrowM (OwningVector.fromVector input ownerLinear)+      OwningVector.qsort 0 vector+      pureAfter (OwningVector.toVector (reclaim lend))++unrestrictedQsortKernel ::+  (G.Vector v Int) =>+  v Int ->+  v Int+{-# INLINEABLE unrestrictedQsortKernel #-}+unrestrictedQsortKernel input =+  unur $ linearly \linear -> DataFlow.do+    (ownerLinear, runLinear) <- dup linear+    runBO runLinear Control.do+      (vector, lend) <-+        borrowM (UnrestrictedVector.fromVector input ownerLinear)+      DC.qsort 0 vector+      pureAfter (UnrestrictedVector.toVector (reclaim lend))++unrestrictedBoxedQsortKernel :: B.Vector Int -> B.Vector Int+{-# NOINLINE unrestrictedBoxedQsortKernel #-}+unrestrictedBoxedQsortKernel = unrestrictedQsortKernel++unrestrictedUnboxedQsortKernel :: U.Vector Int -> U.Vector Int+{-# NOINLINE unrestrictedUnboxedQsortKernel #-}+unrestrictedUnboxedQsortKernel = unrestrictedQsortKernel++unrestrictedFftKernel ::+  (G.Vector v (Complex Double)) =>+  v (Complex Double) ->+  v (Complex Double)+{-# INLINEABLE unrestrictedFftKernel #-}+unrestrictedFftKernel input =+  unur $ linearly \linear -> DataFlow.do+    (ownerLinear, runLinear) <- dup linear+    runBO runLinear Control.do+      (vector, lend) <-+        borrowM (UnrestrictedVector.fromVector input ownerLinear)+      Control.void $+        DC.sequentialDivideAndConquer+          (DC.fftDC' 128)+          vector+      pureAfter (UnrestrictedVector.toVector (reclaim lend))++unrestrictedBoxedFftKernel ::+  B.Vector (Complex Double) ->+  B.Vector (Complex Double)+{-# NOINLINE unrestrictedBoxedFftKernel #-}+unrestrictedBoxedFftKernel = unrestrictedFftKernel++unrestrictedUnboxedFftKernel ::+  U.Vector (Complex Double) ->+  U.Vector (Complex Double)+{-# NOINLINE unrestrictedUnboxedFftKernel #-}+unrestrictedUnboxedFftKernel = unrestrictedFftKernel++defaultMain :: IO ()+defaultMain = Bench.defaultMain benches++benches :: [Benchmark]+benches =+  NonLinear.concat+    [ [ env+          (NonLinear.pure $ U.generate length_ (`NonLinear.rem` 1024))+          \input ->+            bgroup+              ("kernel/fixed-unboxed/" <> show length_)+              [ bench "direct" $ nf directFixedUnboxedKernel input+              , bench "pure-borrow" $ nf pureBorrowFixedUnboxedKernel input+              ]+      , env+          (NonLinear.pure $ U.generate length_ (`NonLinear.rem` 1024))+          \input ->+            bgroup+              ("kernel/growable-unboxed/no-growth/" <> show length_)+              [ bench "direct" $ nf directGrowableUnboxedNoGrowthKernel input+              , bench "pure-borrow" $ nf pureBorrowGrowableUnboxedNoGrowthKernel input+              ]+      , env+          (NonLinear.pure $ U.generate length_ (`NonLinear.rem` 1024))+          \input ->+            bgroup+              ("kernel/growable-unboxed/growth/" <> show length_)+              [ bench "direct" $ nf directGrowableUnboxedGrowthKernel input+              , bench "pure-borrow" $ nf pureBorrowGrowableUnboxedGrowthKernel input+              ]+      , env+          (NonLinear.pure $ U.generate length_ (`NonLinear.rem` 1024))+          \input ->+            bgroup+              ("public-materialization/fixed-unboxed/" <> show length_)+              [ bench "direct" $ nf directFixedUnboxedMaterialization input+              , bench "pure-borrow" $ nf pureBorrowFixedUnboxedMaterialization input+              ]+      , env+          (NonLinear.pure $ U.generate length_ (`NonLinear.rem` 1024))+          \input ->+            bgroup+              ("public-materialization/growable-unboxed/" <> show length_)+              [ bench "direct" $ nf directGrowableUnboxedMaterialization input+              , bench "pure-borrow" $ nf pureBorrowGrowableUnboxedMaterialization input+              ]+      ]+    | length_ <- [0, 1, 1024, 1024 * 1024]+    ]+    <> [ env+           ( NonLinear.pure+               ( B.generate length_ (comparisonQsortValue length_)+               , U.generate length_ (comparisonQsortValue length_)+               )+           )+           \ ~(boxedInput, unboxedInput) ->+             bgroup+               ( "algorithm/qsort/storage-and-element-ownership/"+                   <> show length_+               )+               [ bench "owning/boxed" $+                   nf owningBoxedQsortKernel boxedInput+               , bench "unrestricted/boxed" $+                   nf unrestrictedBoxedQsortKernel boxedInput+               , bench "unrestricted/unboxed" $+                   nf unrestrictedUnboxedQsortKernel unboxedInput+               ]+       | length_ <- [8 * 1024, 32 * 1024]+       ]+    <> [ env+           ( NonLinear.pure+               ( B.generate length_ comparisonFftValue+               , U.generate length_ comparisonFftValue+               )+           )+           \ ~(boxedInput, unboxedInput) ->+             bgroup+               ( "algorithm/fft/storage-and-element-ownership/"+                   <> show length_+               )+               [ bench "unrestricted/boxed" $+                   nf unrestrictedBoxedFftKernel boxedInput+               , bench "unrestricted/unboxed" $+                   nf unrestrictedUnboxedFftKernel unboxedInput+               ]+       | length_ <- [64 * 1024, 1024 * 1024]+       ]++comparisonQsortValue :: Int -> Int -> Int+comparisonQsortValue length_ index =+  (index * 1103515245 + 12345) `NonLinear.rem` (length_ + 1)++comparisonFftValue :: Int -> Complex Double+comparisonFftValue index =+  let position = fromIntegral index+   in (sin (position / 17) + cos (position / 31)) :+ 0

@@ -0,0 +1,2688 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module PureBorrow.Internal.Bench.Worklist.Resume (+  WorklistGrowth (..),+  WorklistOutcome (..),+  WorklistReopenShape (..),+  WorklistTarget (..),+  WorklistSummary (..),+  WorklistOutput (..),+  worklistBatchSize,+  worklistInitialCapacity,+  worklistNodeCount,+  worklistDirectOpenOnceRoot,+  worklistDirectOpenOnceRootWithSeed,+  worklistDirectReopenRoot,+  worklistDirectReopenRootWithSeed,+  worklistPureBorrowOpenOnceRoot,+  worklistPureBorrowOpenOnceRootWithSeed,+  worklistPureBorrowOpenOnceWorker,+  worklistPureBorrowOpenOnceEdgeWorker,+  worklistPureBorrowCheckedOpenOnceRoot,+  worklistPureBorrowCheckedOpenOnceRootWithSeed,+  worklistPureBorrowCheckedOpenOnceWorker,+  worklistPureBorrowCheckedOpenOnceEdgeWorker,+  worklistPureBorrowFlatReopenRoot,+  worklistPureBorrowFlatReopenRootWithSeed,+  worklistPureBorrowNestedReopenRoot,+  worklistPureBorrowNestedReopenRootWithSeed,+  worklistPureBorrowResumeWorker,+  worklistPureBorrowResumeEdgeWorker,+  benches,+  defaultMain,+) where++import Control.DeepSeq (NFData)+import Control.Functor.Linear qualified as Control+import Control.Monad (when)+import Control.Monad.Borrow.Pure+import Control.Monad.Borrow.Pure.Experimental.Borrows (+  Aliases (..),+  Muts,+  reborrowings,+ )+import Control.Monad.ST.Strict (ST, runST)+import Control.Syntax.DataFlow qualified as DataFlow+import Data.Int (Int64)+import Data.Record.Linear.Borrow.Experimental.PatternMatch (+  RecordLabel,+  (.@),+ )+import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)+import Data.Vector qualified as V+import Data.Vector.Generic.Mutable.Growable.Linear.Borrow.Unrestricted qualified as Growable+import Data.Vector.Generic.Mutable.Linear.Borrow.Unrestricted qualified as Fixed+import Data.Vector.Mutable qualified as MV+import Data.Vector.Unboxed qualified as U+import Data.Vector.Unboxed.Mutable qualified as UM+import GHC.Exts qualified as GHC+import GHC.Generics (Generic)+import Prelude.Linear (+  lseq,+  unur,+  (&),+ )+import Test.Tasty.Bench (Benchmark, bench, bgroup, nf)+import Test.Tasty.Bench qualified as Bench++data WorklistGrowth+  = NoGrowth+  | NoGrowthBatch64+  | NoGrowthBatch8+  | SparseGrowth+  | DenseGrowth+  deriving stock (Bounded, Enum, Eq, Generic, Show)+  deriving anyclass (NFData)++data WorklistTarget+  = Drain+  | StopEarly+  deriving stock (Bounded, Enum, Eq, Generic, Show)+  deriving anyclass (NFData)++data WorklistReopenShape+  = FlatReopen+  | NestedReopen+  deriving stock (Bounded, Enum, Eq, Generic, Show)+  deriving anyclass (NFData)++data WorklistOutcome+  = Drained+  | Stopped+  deriving stock (Eq, Generic, Show)+  deriving anyclass (NFData)++data WorklistSummary = WorklistSummary+  { outcome :: !WorklistOutcome+  , visitedNodes :: !Int+  , enqueueTransitions :: !Int+  , offsetReads :: !Int+  , adjacencyReads :: !Int+  , payloadReads :: !Int+  , markReads :: !Int+  , markWrites :: !Int+  , queueReads :: !Int+  , queueWrites :: !Int+  , logWrites :: !Int+  , contentOpens :: !Int+  , resumeBoundaries :: !Int+  , headerUpdates :: !Int+  , bufferGrowths :: !Int+  , finalDigest :: !Int64+  }+  deriving stock (Eq, Generic, Show)+  deriving anyclass (NFData)++data WorklistOutput = WorklistOutput+  { summary :: !WorklistSummary+  , finalMarks :: !(U.Vector Int)+  , finalState :: !(U.Vector Int)+  , finalQueue :: !(U.Vector Int)+  , finalLog :: !(U.Vector Int)+  }+  deriving stock (Eq, Generic, Show)+  deriving anyclass (NFData)++data UnboxedHeader s+  = UnboxedHeader !Int !(UM.MVector s Int)++data BoxedHeader s+  = BoxedHeader !Int !(MV.MVector s (Int, Int))++data TraversalState = TraversalState+  { stateHead :: !Int+  , stateTail :: !Int+  , stateVisits :: !Int+  , stateEnqueues :: !Int+  , stateLogSize :: !Int+  , stateDigest :: !Int64+  }++data SegmentResult = SegmentResult+  { segmentState :: !TraversalState+  , segmentPendingRev :: ![Int]+  , segmentLogRev :: ![Int]+  , segmentStopped :: !Bool+  }++data ReopenEvidence = ReopenEvidence+  { reopenTraversal :: !TraversalState+  , reopenScopeCount :: !Int+  , reopenHeaderUpdates :: !Int+  , reopenGrowthCount :: !Int+  , reopenOutcome :: !WorklistOutcome+  }++data WorklistFixedRoots = WorklistFixedRoots+  { fixedOffsets :: !(Fixed.Vector U.Vector Int)+  , fixedMarks :: !(Fixed.Vector U.Vector Int)+  , fixedState :: !(Fixed.Vector U.Vector Int)+  }++data WorklistGraphRoots = WorklistGraphRoots+  { graphAdjacency :: !(Growable.GrowableVector U.Vector Int)+  , graphPayload :: !(Growable.GrowableVector V.Vector (Int, Int))+  }++data WorklistFrontierRoots = WorklistFrontierRoots+  { frontierQueue :: !(Growable.GrowableVector U.Vector Int)+  , frontierLog :: !(Growable.GrowableVector U.Vector Int)+  }++data WorklistStore = WorklistStore+  { worklistFixedRoots :: !WorklistFixedRoots+  , worklistGraphRoots :: !WorklistGraphRoots+  , worklistFrontierRoots :: !WorklistFrontierRoots+  }++type FlatWorklist α =+  Muts+    α+    '[ Fixed.Vector U.Vector Int+     , Fixed.Vector U.Vector Int+     , Fixed.Vector U.Vector Int+     , Growable.GrowableVector U.Vector Int+     , Growable.GrowableVector V.Vector (Int, Int)+     , Growable.GrowableVector U.Vector Int+     , Growable.GrowableVector U.Vector Int+     ]++type NestedFrontierWorklist α =+  Muts+    α+    '[ Growable.GrowableVector U.Vector Int+     , Growable.GrowableVector U.Vector Int+     ]++worklistNodeCount :: Int+worklistNodeCount = 4096++worklistDegree :: Int+worklistDegree = 3++worklistEdgeCount :: Int+worklistEdgeCount = worklistNodeCount * worklistDegree++worklistEarlyStop :: Int+worklistEarlyStop = 1365++defaultMain :: IO ()+defaultMain = Bench.defaultMain benches++benches :: [Benchmark]+benches =+  [ bgroup+      "worklist-open-once"+      [ bgroup+          (show target)+          [ bench "direct" $+              nf worklistDirectOpenOnceRoot target+          , bench "pure-borrow" $+              nf worklistPureBorrowOpenOnceRoot target+          , -- Same traversal through the checked public element surface. The+            -- difference against "pure-borrow" is the cost of the checked+            -- facade alone, and is reported separately from the+            -- safe-minus-direct excess.+            bench "pure-borrow-checked" $+              nf worklistPureBorrowCheckedOpenOnceRoot target+          ]+      | target <- [minBound .. maxBound]+      ]+  , bgroup+      "worklist-push-extend-reopen"+      [ bgroup+          (show growth)+          [ bgroup+              (show target)+              [ bench "direct-flat" $+                  nf+                    (worklistDirectReopenRoot FlatReopen growth)+                    target+              , bench "pure-borrow-flat" $+                  nf+                    (worklistPureBorrowFlatReopenRoot growth)+                    target+              , bench "direct-nested" $+                  nf+                    (worklistDirectReopenRoot NestedReopen growth)+                    target+              , bench "pure-borrow-nested" $+                  nf+                    (worklistPureBorrowNestedReopenRoot growth)+                    target+              ]+          | target <- [minBound .. maxBound]+          ]+      | growth <- [minBound .. maxBound]+      ]+  ]++worklistOffsets :: U.Vector Int+worklistOffsets =+  U.generate (worklistNodeCount + 1) \node ->+    node * worklistDegree++worklistAdjacency :: U.Vector Int+worklistAdjacency =+  U.generate worklistEdgeCount \edge ->+    let (node, slot) = edge `quotRem` worklistDegree+     in case slot of+          0 -> (node + 1) `rem` worklistNodeCount+          1 -> (node * 17 + 13) `rem` worklistNodeCount+          _ -> (node * 31 + 7) `rem` worklistNodeCount++worklistPayload :: V.Vector (Int, Int)+worklistPayload =+  V.generate worklistEdgeCount \edge ->+    let !node = edge `quot` worklistDegree+        !neighbor = worklistAdjacency U.! edge+     in (edge `rem` 11, (node + neighbor) `rem` 17)++targetVisits :: WorklistTarget -> Int+targetVisits Drain = worklistNodeCount+targetVisits StopEarly = worklistEarlyStop++initialMarks :: U.Vector Int+initialMarks =+  U.replicate worklistNodeCount 0 U.// [(0, 1)]++initialState :: U.Vector Int+initialState = U.fromListN 5 [0, 1, 0, 0, 0]++data WorklistStorage+  = OpenOnceStorage+  | ReopenStorage !WorklistGrowth++newWorklistStore :: WorklistStorage -> Linearly %1 -> WorklistStore+{-# NOINLINE newWorklistStore #-}+newWorklistStore =+  GHC.noinline \storage linear ->+    dup linear & \(offsetsLinear, rest1) ->+      dup rest1 & \(marksLinear, rest2) ->+        dup rest2 & \(stateLinear, rest3) ->+          dup rest3 & \(adjacencyLinear, rest4) ->+            dup rest4 & \(payloadLinear, rest5) ->+              dup rest5 & \(queueLinear, logLinear) ->+                WorklistStore+                  { worklistFixedRoots =+                      WorklistFixedRoots+                        { fixedOffsets =+                            Fixed.fromVector+                              worklistOffsets+                              offsetsLinear+                        , fixedMarks =+                            Fixed.fromVector+                              initialMarks+                              marksLinear+                        , fixedState =+                            Fixed.fromVector+                              initialState+                              stateLinear+                        }+                  , worklistGraphRoots =+                      WorklistGraphRoots+                        { graphAdjacency =+                            Growable.fromVector+                              worklistAdjacency+                              adjacencyLinear+                        , graphPayload =+                            Growable.fromVector+                              worklistPayload+                              payloadLinear+                        }+                  , worklistFrontierRoots =+                      WorklistFrontierRoots+                        { frontierQueue =+                            case storage of+                              OpenOnceStorage ->+                                Growable.fromVector+                                  ( U.cons+                                      0+                                      ( U.replicate+                                          (worklistNodeCount - 1)+                                          0+                                      )+                                  )+                                  queueLinear+                              ReopenStorage growth ->+                                Growable.withCapacity+                                  (worklistInitialCapacity growth)+                                  queueLinear+                        , frontierLog =+                            case storage of+                              OpenOnceStorage ->+                                Growable.fromVector+                                  (U.replicate worklistNodeCount 0)+                                  logLinear+                              ReopenStorage growth ->+                                Growable.withCapacity+                                  (worklistInitialCapacity growth)+                                  logLinear+                        }+                  }++worklistFixedRootsField ::+  RecordLabel WorklistStore "worklistFixedRoots" WorklistFixedRoots+worklistFixedRootsField = #worklistFixedRoots++worklistGraphRootsField ::+  RecordLabel WorklistStore "worklistGraphRoots" WorklistGraphRoots+worklistGraphRootsField = #worklistGraphRoots++worklistFrontierRootsField ::+  RecordLabel WorklistStore "worklistFrontierRoots" WorklistFrontierRoots+worklistFrontierRootsField = #worklistFrontierRoots++fixedOffsetsField ::+  RecordLabel+    WorklistFixedRoots+    "fixedOffsets"+    (Fixed.Vector U.Vector Int)+fixedOffsetsField = #fixedOffsets++fixedMarksField ::+  RecordLabel+    WorklistFixedRoots+    "fixedMarks"+    (Fixed.Vector U.Vector Int)+fixedMarksField = #fixedMarks++fixedStateField ::+  RecordLabel+    WorklistFixedRoots+    "fixedState"+    (Fixed.Vector U.Vector Int)+fixedStateField = #fixedState++graphAdjacencyField ::+  RecordLabel+    WorklistGraphRoots+    "graphAdjacency"+    (Growable.GrowableVector U.Vector Int)+graphAdjacencyField = #graphAdjacency++graphPayloadField ::+  RecordLabel+    WorklistGraphRoots+    "graphPayload"+    (Growable.GrowableVector V.Vector (Int, Int))+graphPayloadField = #graphPayload++frontierQueueField ::+  RecordLabel+    WorklistFrontierRoots+    "frontierQueue"+    (Growable.GrowableVector U.Vector Int)+frontierQueueField = #frontierQueue++frontierLogField ::+  RecordLabel+    WorklistFrontierRoots+    "frontierLog"+    (Growable.GrowableVector U.Vector Int)+frontierLogField = #frontierLog++worklistDirectOpenOnceRoot ::+  WorklistTarget ->+  WorklistOutput+{-# NOINLINE worklistDirectOpenOnceRoot #-}+worklistDirectOpenOnceRoot =+  worklistDirectOpenOnceRootWithSeed 0++worklistDirectOpenOnceRootWithSeed ::+  Int ->+  WorklistTarget ->+  WorklistOutput+{-# NOINLINE worklistDirectOpenOnceRootWithSeed #-}+worklistDirectOpenOnceRootWithSeed seed target =+  runST do+    offsets <- U.thaw worklistOffsets+    marks <- U.thaw initialMarks+    state <- U.thaw initialState+    adjacencyHeader <- newUnboxedHeaderFromVector worklistAdjacency+    payloadHeader <- newBoxedHeaderFromVector worklistPayload+    queueHeader <-+      newUnboxedHeaderFromVector+        (U.cons 0 (U.replicate (worklistNodeCount - 1) 0))+    logHeader <-+      newUnboxedHeaderFromVector+        (U.replicate worklistNodeCount 0)+    UnboxedHeader _ adjacency <- readSTRef adjacencyHeader+    BoxedHeader _ payload <- readSTRef payloadHeader+    UnboxedHeader _ queue <- readSTRef queueHeader+    UnboxedHeader _ outputLog <- readSTRef logHeader+    finalTraversal <-+      runOpenOnce+        (targetVisits target)+        offsets+        adjacency+        payload+        marks+        queue+        outputLog+        (TraversalState 0 1 0 0 0 (initialDigestForSeed seed))+    writeTraversalState state finalTraversal+    finishDirect+      (if stateVisits finalTraversal == targetVisits target && target == StopEarly then Stopped else Drained)+      4+      0+      0+      0+      offsets+      adjacency+      payload+      marks+      state+      queue+      outputLog+      finalTraversal++worklistDirectReopenRoot ::+  WorklistReopenShape ->+  WorklistGrowth ->+  WorklistTarget ->+  WorklistOutput+{-# NOINLINE worklistDirectReopenRoot #-}+worklistDirectReopenRoot =+  worklistDirectReopenRootWithSeed 0++worklistDirectReopenRootWithSeed ::+  Int ->+  WorklistReopenShape ->+  WorklistGrowth ->+  WorklistTarget ->+  WorklistOutput+{-# NOINLINE worklistDirectReopenRootWithSeed #-}+worklistDirectReopenRootWithSeed seed reopenShape growth target =+  runST do+    offsets <- U.thaw worklistOffsets+    marks <- U.thaw initialMarks+    state <- U.thaw initialState+    adjacencyHeader <- newUnboxedHeaderFromVector worklistAdjacency+    payloadHeader <- newBoxedHeaderFromVector worklistPayload+    queueHeader <- newUnboxedHeader (worklistInitialCapacity growth) U.empty+    _ <- appendUnboxed queueHeader (U.singleton 0)+    logHeader <- newUnboxedHeader (worklistInitialCapacity growth) U.empty+    (finalTraversal, scopeCount, headerUpdateCount, growthCount, finalOutcome) <-+      case reopenShape of+        FlatReopen ->+          runFlatReopenDirect+            growth+            target+            offsets+            marks+            state+            adjacencyHeader+            payloadHeader+            queueHeader+            logHeader+            (TraversalState 0 1 0 0 0 (initialDigestForSeed seed))+            0+            0+            0+        NestedReopen -> do+          UnboxedHeader _ adjacency <- readSTRef adjacencyHeader+          BoxedHeader _ payload <- readSTRef payloadHeader+          runNestedReopenDirect+            growth+            target+            offsets+            adjacency+            payload+            marks+            state+            queueHeader+            logHeader+            (TraversalState 0 1 0 0 0 (initialDigestForSeed seed))+            0+            0+            0+    UnboxedHeader _ adjacency <- readSTRef adjacencyHeader+    BoxedHeader _ payload <- readSTRef payloadHeader+    UnboxedHeader queueSize queue <- readSTRef queueHeader+    UnboxedHeader logSize outputLog <- readSTRef logHeader+    finishDirect+      finalOutcome+      ( case reopenShape of+          FlatReopen -> 4 * scopeCount+          NestedReopen -> 2 + 2 * scopeCount+      )+      (max 0 (scopeCount - 1))+      headerUpdateCount+      growthCount+      offsets+      adjacency+      payload+      marks+      state+      (UM.unsafeTake queueSize queue)+      (UM.unsafeTake logSize outputLog)+      finalTraversal++worklistPureBorrowOpenOnceRoot ::+  WorklistTarget ->+  WorklistOutput+{-# NOINLINE worklistPureBorrowOpenOnceRoot #-}+worklistPureBorrowOpenOnceRoot =+  worklistPureBorrowOpenOnceRootWithSeed 0++worklistPureBorrowOpenOnceRootWithSeed ::+  Int ->+  WorklistTarget ->+  WorklistOutput+{-# NOINLINE worklistPureBorrowOpenOnceRootWithSeed #-}+worklistPureBorrowOpenOnceRootWithSeed seed target =+  unur+    ( linearly \linear -> DataFlow.do+        (allocationLinear, borrowLinear) <- dup linear+        store <- newWorklistStore OpenOnceStorage allocationLinear+        runBO borrowLinear Control.do+          (storeBorrow, lender) <- borrowM store+          (Ur traversal, storeBorrow) <-+            reborrowing storeBorrow \local -> Control.do+              let %1 !(fixedRootBorrows, graphRootBorrows, frontierRootBorrows) =+                    local+                      .@ ( worklistFixedRootsField+                         , worklistGraphRootsField+                         , worklistFrontierRootsField+                         )+              let %1 !(offsetsBorrow, marksBorrow, stateBorrow) =+                    fixedRootBorrows+                      .@ (fixedOffsetsField, fixedMarksField, fixedStateField)+              let %1 !(adjacencyBorrow, payloadBorrow) =+                    graphRootBorrows+                      .@ (graphAdjacencyField, graphPayloadField)+              let %1 !(queueBorrow, logBorrow) =+                    frontierRootBorrows+                      .@ (frontierQueueField, frontierLogField)+              let %1 !adjacencyContent =+                    Growable.getContents adjacencyBorrow+              let %1 !payloadContent =+                    Growable.getContents payloadBorrow+              let %1 !queueContent =+                    Growable.getContents queueBorrow+              let %1 !logContent =+                    Growable.getContents logBorrow+              (Ur initial, stateBorrow) <-+                readTraversalState stateBorrow+              let !seededInitial =+                    initial+                      { stateDigest = initialDigestForSeed seed+                      }+              ( Ur traversal+                , offsetsBorrow+                , marksBorrow+                , stateBorrow+                , adjacencyContent+                , payloadContent+                , queueContent+                , logContent+                ) <-+                worklistPureBorrowOpenOnceWorker+                  (targetVisits target)+                  seededInitial+                  offsetsBorrow+                  marksBorrow+                  stateBorrow+                  adjacencyContent+                  payloadContent+                  queueContent+                  logContent+              let !() =+                    consumeWorklistViews+                      offsetsBorrow+                      marksBorrow+                      stateBorrow+                      adjacencyContent+                      payloadContent+                      queueContent+                      logContent+              Control.pure (Ur traversal)+          let !(Ur _) = share storeBorrow+          pureAfter+            ( finishWorklistStore+                (outcomeFor target traversal)+                4+                0+                0+                0+                traversal+                (reclaim lender)+            )+    )++{- | The open-once traversal, reading and writing through the /checked/ public+element surface instead of the unchecked one.++This is the copied-read attribution control. It differs from+'worklistPureBorrowOpenOnceRoot' in exactly one respect: every element access+goes through 'Fixed.copyAtMut' and 'Fixed.write' rather than+'Fixed.unsafeGet' and 'Fixed.unsafeWrite'. Ownership, lifetimes, projection+structure, transition counts and the final digest are identical, so the+allocation difference between the two roots is the cost of the public checked+facade alone: the bounds check, the @size@ call, the @Ur@ boxing, and whatever+survives of the @HasCallStack@ obligation those operations carry.++Both roots must therefore produce equal 'WorklistOutput'. Note that+@copyAtMut@ on this non-element-owning family is defined as @get@; it is not a+@Copyable@ copy, and this control deliberately does not switch to an+element-owning family, which would change the ownership mode and make the+allocation numbers incomparable.+-}+worklistPureBorrowCheckedOpenOnceRoot ::+  WorklistTarget ->+  WorklistOutput+{-# NOINLINE worklistPureBorrowCheckedOpenOnceRoot #-}+worklistPureBorrowCheckedOpenOnceRoot =+  worklistPureBorrowCheckedOpenOnceRootWithSeed 0++worklistPureBorrowCheckedOpenOnceRootWithSeed ::+  Int ->+  WorklistTarget ->+  WorklistOutput+{-# NOINLINE worklistPureBorrowCheckedOpenOnceRootWithSeed #-}+worklistPureBorrowCheckedOpenOnceRootWithSeed seed target =+  unur+    ( linearly \linear -> DataFlow.do+        (allocationLinear, borrowLinear) <- dup linear+        store <- newWorklistStore OpenOnceStorage allocationLinear+        runBO borrowLinear Control.do+          (storeBorrow, lender) <- borrowM store+          (Ur traversal, storeBorrow) <-+            reborrowing storeBorrow \local -> Control.do+              let %1 !(fixedRootBorrows, graphRootBorrows, frontierRootBorrows) =+                    local+                      .@ ( worklistFixedRootsField+                         , worklistGraphRootsField+                         , worklistFrontierRootsField+                         )+              let %1 !(offsetsBorrow, marksBorrow, stateBorrow) =+                    fixedRootBorrows+                      .@ (fixedOffsetsField, fixedMarksField, fixedStateField)+              let %1 !(adjacencyBorrow, payloadBorrow) =+                    graphRootBorrows+                      .@ (graphAdjacencyField, graphPayloadField)+              let %1 !(queueBorrow, logBorrow) =+                    frontierRootBorrows+                      .@ (frontierQueueField, frontierLogField)+              let %1 !adjacencyContent =+                    Growable.getContents adjacencyBorrow+              let %1 !payloadContent =+                    Growable.getContents payloadBorrow+              let %1 !queueContent =+                    Growable.getContents queueBorrow+              let %1 !logContent =+                    Growable.getContents logBorrow+              (Ur initial, stateBorrow) <-+                readTraversalStateChecked stateBorrow+              let !seededInitial =+                    initial+                      { stateDigest = initialDigestForSeed seed+                      }+              ( Ur traversal+                , offsetsBorrow+                , marksBorrow+                , stateBorrow+                , adjacencyContent+                , payloadContent+                , queueContent+                , logContent+                ) <-+                worklistPureBorrowCheckedOpenOnceWorker+                  (targetVisits target)+                  seededInitial+                  offsetsBorrow+                  marksBorrow+                  stateBorrow+                  adjacencyContent+                  payloadContent+                  queueContent+                  logContent+              let !() =+                    consumeWorklistViews+                      offsetsBorrow+                      marksBorrow+                      stateBorrow+                      adjacencyContent+                      payloadContent+                      queueContent+                      logContent+              Control.pure (Ur traversal)+          let !(Ur _) = share storeBorrow+          pureAfter+            ( finishWorklistStore+                (outcomeFor target traversal)+                4+                0+                0+                0+                traversal+                (reclaim lender)+            )+    )++worklistPureBorrowFlatReopenRoot ::+  WorklistGrowth ->+  WorklistTarget ->+  WorklistOutput+{-# NOINLINE worklistPureBorrowFlatReopenRoot #-}+worklistPureBorrowFlatReopenRoot =+  worklistPureBorrowReopenRoot FlatReopen++worklistPureBorrowFlatReopenRootWithSeed ::+  Int ->+  WorklistGrowth ->+  WorklistTarget ->+  WorklistOutput+{-# NOINLINE worklistPureBorrowFlatReopenRootWithSeed #-}+worklistPureBorrowFlatReopenRootWithSeed seed =+  worklistPureBorrowReopenRootWithSeed seed FlatReopen++worklistPureBorrowNestedReopenRoot ::+  WorklistGrowth ->+  WorklistTarget ->+  WorklistOutput+{-# NOINLINE worklistPureBorrowNestedReopenRoot #-}+worklistPureBorrowNestedReopenRoot =+  worklistPureBorrowReopenRoot NestedReopen++worklistPureBorrowNestedReopenRootWithSeed ::+  Int ->+  WorklistGrowth ->+  WorklistTarget ->+  WorklistOutput+{-# NOINLINE worklistPureBorrowNestedReopenRootWithSeed #-}+worklistPureBorrowNestedReopenRootWithSeed seed =+  worklistPureBorrowReopenRootWithSeed seed NestedReopen++worklistPureBorrowReopenRoot ::+  WorklistReopenShape ->+  WorklistGrowth ->+  WorklistTarget ->+  WorklistOutput+{-# NOINLINE worklistPureBorrowReopenRoot #-}+worklistPureBorrowReopenRoot =+  worklistPureBorrowReopenRootWithSeed 0++worklistPureBorrowReopenRootWithSeed ::+  Int ->+  WorklistReopenShape ->+  WorklistGrowth ->+  WorklistTarget ->+  WorklistOutput+{-# NOINLINE worklistPureBorrowReopenRootWithSeed #-}+worklistPureBorrowReopenRootWithSeed seed reopenShape growth target =+  unur+    ( linearly \linear -> DataFlow.do+        (allocationLinear, borrowLinear) <- dup linear+        store <-+          newWorklistStore+            (ReopenStorage growth)+            allocationLinear+        runBO borrowLinear Control.do+          (storeBorrow, lender) <- borrowM store+          (Ur evidence, storeBorrow) <-+            reborrowing storeBorrow \local -> Control.do+              let %1 !(fixedRootBorrows, graphRootBorrows, frontierRootBorrows) =+                    local+                      .@ ( worklistFixedRootsField+                         , worklistGraphRootsField+                         , worklistFrontierRootsField+                         )+              let %1 !(offsetsBorrow, marksBorrow, stateBorrow) =+                    fixedRootBorrows+                      .@ (fixedOffsetsField, fixedMarksField, fixedStateField)+              let %1 !(adjacencyBorrow, payloadBorrow) =+                    graphRootBorrows+                      .@ (graphAdjacencyField, graphPayloadField)+              let %1 !(queueBorrow, logBorrow) =+                    frontierRootBorrows+                      .@ (frontierQueueField, frontierLogField)+              queueBorrow <- Growable.push 0 queueBorrow+              (Ur initial, stateBorrow) <-+                readTraversalState stateBorrow+              let !seededInitial =+                    initial+                      { stateDigest = initialDigestForSeed seed+                      }+              case reopenShape of+                FlatReopen -> Control.do+                  (Ur evidence, fields) <-+                    runFlatReopenPureBorrow+                      growth+                      target+                      seededInitial+                      (worklistInitialCapacity growth)+                      (worklistInitialCapacity growth)+                      0+                      0+                      0+                      ( offsetsBorrow+                          :- marksBorrow+                          :- stateBorrow+                          :- adjacencyBorrow+                          :- payloadBorrow+                          :- queueBorrow+                          :- logBorrow+                          :- BNil+                      )+                  let !() = consume fields+                  Control.pure (Ur evidence)+                NestedReopen -> Control.do+                  let !(Ur sharedOffsets) = share offsetsBorrow+                  let !(Ur sharedAdjacency) = share adjacencyBorrow+                  let !(Ur sharedPayload) = share payloadBorrow+                  let !adjacencyContent =+                        Growable.getContents sharedAdjacency+                  let !payloadContent =+                        Growable.getContents sharedPayload+                  (Ur evidence, fixedFields) <-+                    reborrowings+                      (marksBorrow :- stateBorrow :- BNil)+                      \case+                        marks :- state :- BNil -> Control.do+                          ( Ur evidence+                            , marks+                            , state+                            , frontierFields+                            ) <-+                            runNestedReopenPureBorrow+                              growth+                              target+                              seededInitial+                              (worklistInitialCapacity growth)+                              (worklistInitialCapacity growth)+                              0+                              0+                              0+                              (subShare sharedOffsets)+                              (subShare adjacencyContent)+                              (subShare payloadContent)+                              marks+                              state+                              (upcast (queueBorrow :- logBorrow :- BNil))+                          let !(Ur _) = share marks+                              !(Ur _) = share state+                              !() = consume frontierFields+                          Control.pure (Ur evidence)+                  let !() = consume fixedFields+                  Control.pure (Ur evidence)+          let !(Ur _) = share storeBorrow+          pureAfter+            ( finishWorklistStore+                (reopenOutcome evidence)+                ( case reopenShape of+                    FlatReopen ->+                      4 * reopenScopeCount evidence+                    NestedReopen ->+                      2 + 2 * reopenScopeCount evidence+                )+                (max 0 (reopenScopeCount evidence - 1))+                (reopenHeaderUpdates evidence)+                (reopenGrowthCount evidence)+                (reopenTraversal evidence)+                (reclaim lender)+            )+    )++runFlatReopenPureBorrow ::+  WorklistGrowth ->+  WorklistTarget ->+  TraversalState ->+  Int ->+  Int ->+  Int ->+  Int ->+  Int ->+  FlatWorklist α %1 ->+  BO α (Ur ReopenEvidence, FlatWorklist α)+runFlatReopenPureBorrow+  growth+  target+  current+  queueCapacity+  logCapacity+  scopes+  updates+  growths+  fields+    | stateVisits current >= targetVisits target =+        Control.pure+          ( Ur+              ( reopenEvidence+                  target+                  current+                  scopes+                  updates+                  growths+              )+          , fields+          )+    | stateHead current >= stateTail current =+        Control.pure+          ( Ur+              ReopenEvidence+                { reopenTraversal = current+                , reopenScopeCount = scopes+                , reopenHeaderUpdates = updates+                , reopenGrowthCount = growths+                , reopenOutcome = Drained+                }+          , fields+          )+    | otherwise = Control.do+        (Ur segment, fields) <-+          reborrowings fields \case+            offsets+              :- marks+              :- state+              :- adjacency+              :- payload+              :- queue+              :- outputLog+              :- BNil -> Control.do+                let %1 !adjacencyContent =+                      Growable.getContents adjacency+                let %1 !payloadContent =+                      Growable.getContents payload+                let %1 !queueContent =+                      Growable.getContents queue+                let %1 !logContent =+                      Growable.getContents outputLog+                ( Ur segment+                  , offsets+                  , marks+                  , state+                  , adjacencyContent+                  , payloadContent+                  , queueContent+                  , logContent+                  ) <-+                  worklistPureBorrowResumeWorker+                    (targetVisits target)+                    ( min+                        (stateTail current)+                        (stateHead current + worklistBatchSize growth)+                    )+                    current+                    []+                    []+                    offsets+                    marks+                    state+                    adjacencyContent+                    payloadContent+                    queueContent+                    logContent+                let !() =+                      consumeWorklistViews+                        offsets+                        marks+                        state+                        adjacencyContent+                        payloadContent+                        queueContent+                        logContent+                Control.pure (Ur segment)+        let %1 !( offsets+                    :- marks+                    :- state+                    :- adjacency+                    :- payload+                    :- queue+                    :- outputLog+                    :- BNil+                  ) = fields+        let !pending =+              U.fromList (reverse (segmentPendingRev segment))+            !newLogs =+              U.fromList (reverse (segmentLogRev segment))+            !nextTraversal = segmentState segment+            !( nextQueueCapacity+               , nextLogCapacity+               , nextGrowths+               ) =+                nextCapacities+                  queueCapacity+                  logCapacity+                  growths+                  pending+                  nextTraversal+            !nextUpdates =+              updates+                + (if U.null pending then 0 else 1)+                + 1+            !nextScopes = scopes + 1+        queue <-+          if U.null pending+            then Control.pure queue+            else Growable.extend pending queue+        outputLog <- Growable.extend newLogs outputLog+        state <-+          writeTraversalStatePureBorrow nextTraversal state+        let %1 !nextFields =+              offsets+                :- marks+                :- state+                :- adjacency+                :- payload+                :- queue+                :- outputLog+                :- BNil+        if segmentStopped segment+          then+            Control.pure+              ( Ur+                  ( reopenEvidence+                      target+                      nextTraversal+                      nextScopes+                      nextUpdates+                      nextGrowths+                  )+              , nextFields+              )+          else+            runFlatReopenPureBorrow+              growth+              target+              nextTraversal+              nextQueueCapacity+              nextLogCapacity+              nextScopes+              nextUpdates+              nextGrowths+              nextFields++runNestedReopenPureBorrow ::+  WorklistGrowth ->+  WorklistTarget ->+  TraversalState ->+  Int ->+  Int ->+  Int ->+  Int ->+  Int ->+  Share α (Fixed.Vector U.Vector Int) ->+  Share α (Fixed.Vector U.Vector Int) ->+  Share α (Fixed.Vector V.Vector (Int, Int)) ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  NestedFrontierWorklist α %1 ->+  BO+    α+    ( Ur ReopenEvidence+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    , NestedFrontierWorklist α+    )+runNestedReopenPureBorrow+  growth+  target+  current+  queueCapacity+  logCapacity+  scopes+  updates+  growths+  offsets+  adjacency+  payload+  marks+  state+  fields+    | stateVisits current >= targetVisits target =+        Control.pure+          ( Ur+              ( reopenEvidence+                  target+                  current+                  scopes+                  updates+                  growths+              )+          , marks+          , state+          , fields+          )+    | stateHead current >= stateTail current =+        Control.pure+          ( Ur+              ReopenEvidence+                { reopenTraversal = current+                , reopenScopeCount = scopes+                , reopenHeaderUpdates = updates+                , reopenGrowthCount = growths+                , reopenOutcome = Drained+                }+          , marks+          , state+          , fields+          )+    | otherwise = Control.do+        ((Ur segment, marks, state), fields) <-+          reborrowings fields \case+            queue :- outputLog :- BNil -> Control.do+              let %1 !queueContent =+                    Growable.getContents queue+              let %1 !logContent =+                    Growable.getContents outputLog+              ( Ur segment+                , offsetsOccurrence+                , marks+                , state+                , adjacencyOccurrence+                , payloadOccurrence+                , queueContent+                , logContent+                ) <-+                worklistPureBorrowResumeWorker+                  (targetVisits target)+                  ( min+                      (stateTail current)+                      (stateHead current + worklistBatchSize growth)+                  )+                  current+                  []+                  []+                  offsets+                  marks+                  state+                  adjacency+                  payload+                  queueContent+                  logContent+              let !() = consume offsetsOccurrence+                  !() = consume adjacencyOccurrence+                  !() = consume payloadOccurrence+                  !(Ur _) = share queueContent+                  !(Ur _) = share logContent+              Control.pure (Ur segment, marks, state)+        let %1 !(queue :- outputLog :- BNil) =+              fields+        let !pending =+              U.fromList (reverse (segmentPendingRev segment))+            !newLogs =+              U.fromList (reverse (segmentLogRev segment))+            !nextTraversal = segmentState segment+            !( nextQueueCapacity+               , nextLogCapacity+               , nextGrowths+               ) =+                nextCapacities+                  queueCapacity+                  logCapacity+                  growths+                  pending+                  nextTraversal+            !nextUpdates =+              updates+                + (if U.null pending then 0 else 1)+                + 1+            !nextScopes = scopes + 1+        queue <-+          if U.null pending+            then Control.pure queue+            else Growable.extend pending queue+        outputLog <- Growable.extend newLogs outputLog+        state <-+          writeTraversalStatePureBorrow nextTraversal state+        let %1 !nextFields =+              queue :- outputLog :- BNil+        if segmentStopped segment+          then+            Control.pure+              ( Ur+                  ( reopenEvidence+                      target+                      nextTraversal+                      nextScopes+                      nextUpdates+                      nextGrowths+                  )+              , marks+              , state+              , nextFields+              )+          else+            runNestedReopenPureBorrow+              growth+              target+              nextTraversal+              nextQueueCapacity+              nextLogCapacity+              nextScopes+              nextUpdates+              nextGrowths+              offsets+              adjacency+              payload+              marks+              state+              nextFields++reopenEvidence ::+  WorklistTarget ->+  TraversalState ->+  Int ->+  Int ->+  Int ->+  ReopenEvidence+reopenEvidence target traversal scopes updates growths =+  ReopenEvidence+    { reopenTraversal = traversal+    , reopenScopeCount = scopes+    , reopenHeaderUpdates = updates+    , reopenGrowthCount = growths+    , reopenOutcome =+        case target of+          Drain -> Drained+          StopEarly -> Stopped+    }++nextCapacities ::+  Int ->+  Int ->+  Int ->+  U.Vector Int ->+  TraversalState ->+  (Int, Int, Int)+nextCapacities+  queueCapacity+  logCapacity+  growths+  pending+  traversal =+    let !nextQueueCapacity =+          if U.null pending+            then queueCapacity+            else growthTarget queueCapacity (stateTail traversal)+        !nextLogCapacity =+          growthTarget logCapacity (stateLogSize traversal)+        !nextGrowths =+          growths+            + fromEnum (nextQueueCapacity > queueCapacity)+            + fromEnum (nextLogCapacity > logCapacity)+     in (nextQueueCapacity, nextLogCapacity, nextGrowths)++worklistPureBorrowResumeWorker ::+  ( α >= ζ+  , β >= ζ+  , γ >= ζ+  , δ >= ζ+  , ε >= ζ+  ) =>+  Int ->+  Int ->+  TraversalState ->+  [Int] ->+  [Int] ->+  Borrow bk1 α (Fixed.Vector U.Vector Int) %1 ->+  Mut β (Fixed.Vector U.Vector Int) %1 ->+  Mut γ (Fixed.Vector U.Vector Int) %1 ->+  Borrow bk2 δ (Fixed.Vector U.Vector Int) %1 ->+  Borrow bk3 ε (Fixed.Vector V.Vector (Int, Int)) %1 ->+  Mut ζ (Fixed.Vector U.Vector Int) %1 ->+  Mut ζ (Fixed.Vector U.Vector Int) %1 ->+  BO+    ζ+    ( Ur SegmentResult+    , Borrow bk1 α (Fixed.Vector U.Vector Int)+    , Mut β (Fixed.Vector U.Vector Int)+    , Mut γ (Fixed.Vector U.Vector Int)+    , Borrow bk2 δ (Fixed.Vector U.Vector Int)+    , Borrow bk3 ε (Fixed.Vector V.Vector (Int, Int))+    , Mut ζ (Fixed.Vector U.Vector Int)+    , Mut ζ (Fixed.Vector U.Vector Int)+    )+{-# NOINLINE worklistPureBorrowResumeWorker #-}+worklistPureBorrowResumeWorker+  stopAfter+  snapshotTail+  current+  pendingRev+  logRev+  offsets+  marks+  state+  adjacency+  payload+  queue+  outputLog+    | stateVisits current >= stopAfter =+        Control.pure+          ( Ur (SegmentResult current pendingRev logRev True)+          , offsets+          , marks+          , state+          , adjacency+          , payload+          , queue+          , outputLog+          )+    | stateHead current >= snapshotTail =+        Control.pure+          ( Ur (SegmentResult current pendingRev logRev False)+          , offsets+          , marks+          , state+          , adjacency+          , payload+          , queue+          , outputLog+          )+    | otherwise = Control.do+        (Ur node, queue) <-+          Fixed.unsafeGet (stateHead current) queue+        (Ur start, offsets) <-+          Fixed.unsafeGet node offsets+        (Ur end, offsets) <-+          Fixed.unsafeGet (node + 1) offsets+        ( Ur (nextTail, nextEnqueues, nextPendingRev, nodeDigest)+          , adjacency+          , payload+          , marks+          ) <-+          worklistPureBorrowResumeEdgeWorker+            start+            end+            (stateTail current)+            (stateEnqueues current)+            pendingRev+            (stateDigest current)+            adjacency+            payload+            marks+        let !logValue = digestToLogValue nodeDigest node+            !nextState =+              TraversalState+                { stateHead = stateHead current + 1+                , stateTail = nextTail+                , stateVisits = stateVisits current + 1+                , stateEnqueues = nextEnqueues+                , stateLogSize = stateLogSize current + 1+                , stateDigest = mixDigest nodeDigest logValue+                }+        worklistPureBorrowResumeWorker+          stopAfter+          snapshotTail+          nextState+          nextPendingRev+          (logValue : logRev)+          offsets+          marks+          state+          adjacency+          payload+          queue+          outputLog++worklistPureBorrowResumeEdgeWorker ::+  (α >= δ, β >= δ, γ >= δ) =>+  Int ->+  Int ->+  Int ->+  Int ->+  [Int] ->+  Int64 ->+  Borrow bk1 α (Fixed.Vector U.Vector Int) %1 ->+  Borrow bk2 β (Fixed.Vector V.Vector (Int, Int)) %1 ->+  Mut γ (Fixed.Vector U.Vector Int) %1 ->+  BO+    δ+    ( Ur (Int, Int, [Int], Int64)+    , Borrow bk1 α (Fixed.Vector U.Vector Int)+    , Borrow bk2 β (Fixed.Vector V.Vector (Int, Int))+    , Mut γ (Fixed.Vector U.Vector Int)+    )+-- This benchmark-internal export exists only to anchor optimized-Core+-- inspection. Its indices are unchecked; only the benchmark roots establish+-- the offset and neighbor bounds required by the unsafe element operations.+{-# INLINEABLE worklistPureBorrowResumeEdgeWorker #-}+worklistPureBorrowResumeEdgeWorker+  edge+  end+  tailIndex+  enqueues+  pendingRev+  digest+  adjacency+  payload+  marks+    | edge >= end =+        Control.pure+          ( Ur (tailIndex, enqueues, pendingRev, digest)+          , adjacency+          , payload+          , marks+          )+    | otherwise = Control.do+        (Ur neighbor, adjacency) <-+          Fixed.unsafeGet edge adjacency+        (Ur (tag, delta), payload) <-+          Fixed.unsafeGet edge payload+        (Ur marked, marks) <-+          Fixed.unsafeGet neighbor marks+        let !nextDigest =+              mixDigest+                digest+                (neighbor * 31 + tag * 17 + delta + marked)+        if marked == 0+          then Control.do+            marks <- Fixed.unsafeWrite neighbor 1 marks+            worklistPureBorrowResumeEdgeWorker+              (edge + 1)+              end+              (tailIndex + 1)+              (enqueues + 1)+              (neighbor : pendingRev)+              nextDigest+              adjacency+              payload+              marks+          else+            worklistPureBorrowResumeEdgeWorker+              (edge + 1)+              end+              tailIndex+              enqueues+              pendingRev+              nextDigest+              adjacency+              payload+              marks++worklistPureBorrowOpenOnceWorker ::+  Int ->+  TraversalState ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector V.Vector (Int, Int)) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  BO+    α+    ( Ur TraversalState+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector V.Vector (Int, Int))+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    )+{-# NOINLINE worklistPureBorrowOpenOnceWorker #-}+worklistPureBorrowOpenOnceWorker+  stopAfter+  current+  offsets+  marks+  state+  adjacency+  payload+  queue+  outputLog+    | stateVisits current >= stopAfter+        || stateHead current >= stateTail current = Control.do+        state <- writeTraversalStatePureBorrow current state+        Control.pure+          ( Ur current+          , offsets+          , marks+          , state+          , adjacency+          , payload+          , queue+          , outputLog+          )+    | otherwise = Control.do+        (Ur node, queue) <-+          Fixed.unsafeGet (stateHead current) queue+        (Ur start, offsets) <-+          Fixed.unsafeGet node offsets+        (Ur end, offsets) <-+          Fixed.unsafeGet (node + 1) offsets+        ( Ur (nextTail, nextEnqueues, nodeDigest)+          , adjacency+          , payload+          , marks+          , queue+          ) <-+          worklistPureBorrowOpenOnceEdgeWorker+            start+            end+            (stateTail current)+            (stateEnqueues current)+            (stateDigest current)+            adjacency+            payload+            marks+            queue+        let !logValue = digestToLogValue nodeDigest node+        outputLog <-+          Fixed.unsafeWrite+            (stateLogSize current)+            logValue+            outputLog+        let !nextState =+              TraversalState+                { stateHead = stateHead current + 1+                , stateTail = nextTail+                , stateVisits = stateVisits current + 1+                , stateEnqueues = nextEnqueues+                , stateLogSize = stateLogSize current + 1+                , stateDigest = mixDigest nodeDigest logValue+                }+        worklistPureBorrowOpenOnceWorker+          stopAfter+          nextState+          offsets+          marks+          state+          adjacency+          payload+          queue+          outputLog++worklistPureBorrowOpenOnceEdgeWorker ::+  Int ->+  Int ->+  Int ->+  Int ->+  Int64 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector V.Vector (Int, Int)) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  BO+    α+    ( Ur (Int, Int, Int64)+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector V.Vector (Int, Int))+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    )+-- This benchmark-internal export exists only to anchor optimized-Core+-- inspection. Its indices are unchecked; only the benchmark roots establish+-- the edge, neighbor, and queue-capacity bounds required by the unsafe element+-- operations.+{-# INLINEABLE worklistPureBorrowOpenOnceEdgeWorker #-}+worklistPureBorrowOpenOnceEdgeWorker+  edge+  end+  tailIndex+  enqueues+  digest+  adjacency+  payload+  marks+  queue+    | edge >= end =+        Control.pure+          ( Ur (tailIndex, enqueues, digest)+          , adjacency+          , payload+          , marks+          , queue+          )+    | otherwise = Control.do+        (Ur neighbor, adjacency) <-+          Fixed.unsafeGet edge adjacency+        (Ur (tag, delta), payload) <-+          Fixed.unsafeGet edge payload+        (Ur marked, marks) <-+          Fixed.unsafeGet neighbor marks+        let !nextDigest =+              mixDigest+                digest+                (neighbor * 31 + tag * 17 + delta + marked)+        if marked == 0+          then Control.do+            marks <-+              Fixed.unsafeWrite neighbor 1 marks+            queue <-+              Fixed.unsafeWrite tailIndex neighbor queue+            worklistPureBorrowOpenOnceEdgeWorker+              (edge + 1)+              end+              (tailIndex + 1)+              (enqueues + 1)+              nextDigest+              adjacency+              payload+              marks+              queue+          else+            worklistPureBorrowOpenOnceEdgeWorker+              (edge + 1)+              end+              tailIndex+              enqueues+              nextDigest+              adjacency+              payload+              marks+              queue++{- | Checked counterpart of 'worklistPureBorrowOpenOnceWorker'.++Every element access uses the checked public entry point. The traversal,+transition counts and digest are identical to the unchecked worker; only the+element-access surface differs.+-}+worklistPureBorrowCheckedOpenOnceWorker ::+  Int ->+  TraversalState ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector V.Vector (Int, Int)) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  BO+    α+    ( Ur TraversalState+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector V.Vector (Int, Int))+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    )+{-# NOINLINE worklistPureBorrowCheckedOpenOnceWorker #-}+worklistPureBorrowCheckedOpenOnceWorker+  stopAfter+  current+  offsets+  marks+  state+  adjacency+  payload+  queue+  outputLog+    | stateVisits current >= stopAfter+        || stateHead current >= stateTail current = Control.do+        state <- writeTraversalStateCheckedPureBorrow current state+        Control.pure+          ( Ur current+          , offsets+          , marks+          , state+          , adjacency+          , payload+          , queue+          , outputLog+          )+    | otherwise = Control.do+        (Ur node, queue) <-+          Fixed.copyAtMut (stateHead current) queue+        (Ur start, offsets) <-+          Fixed.copyAtMut node offsets+        (Ur end, offsets) <-+          Fixed.copyAtMut (node + 1) offsets+        ( Ur (nextTail, nextEnqueues, nodeDigest)+          , adjacency+          , payload+          , marks+          , queue+          ) <-+          worklistPureBorrowCheckedOpenOnceEdgeWorker+            start+            end+            (stateTail current)+            (stateEnqueues current)+            (stateDigest current)+            adjacency+            payload+            marks+            queue+        let !logValue = digestToLogValue nodeDigest node+        outputLog <-+          Fixed.write+            (stateLogSize current)+            logValue+            outputLog+        let !nextState =+              TraversalState+                { stateHead = stateHead current + 1+                , stateTail = nextTail+                , stateVisits = stateVisits current + 1+                , stateEnqueues = nextEnqueues+                , stateLogSize = stateLogSize current + 1+                , stateDigest = mixDigest nodeDigest logValue+                }+        worklistPureBorrowCheckedOpenOnceWorker+          stopAfter+          nextState+          offsets+          marks+          state+          adjacency+          payload+          queue+          outputLog++{- | Checked counterpart of 'worklistPureBorrowOpenOnceEdgeWorker'.++Unlike its unchecked sibling this worker establishes its own bounds, so it+carries no unchecked-access proof obligation. It exists to anchor the+checked-surface attribution measurement.+-}+worklistPureBorrowCheckedOpenOnceEdgeWorker ::+  Int ->+  Int ->+  Int ->+  Int ->+  Int64 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector V.Vector (Int, Int)) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  BO+    α+    ( Ur (Int, Int, Int64)+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector V.Vector (Int, Int))+    , Mut α (Fixed.Vector U.Vector Int)+    , Mut α (Fixed.Vector U.Vector Int)+    )+{-# INLINEABLE worklistPureBorrowCheckedOpenOnceEdgeWorker #-}+worklistPureBorrowCheckedOpenOnceEdgeWorker+  edge+  end+  tailIndex+  enqueues+  digest+  adjacency+  payload+  marks+  queue+    | edge >= end =+        Control.pure+          ( Ur (tailIndex, enqueues, digest)+          , adjacency+          , payload+          , marks+          , queue+          )+    | otherwise = Control.do+        (Ur neighbor, adjacency) <-+          Fixed.copyAtMut edge adjacency+        (Ur (tag, delta), payload) <-+          Fixed.copyAtMut edge payload+        (Ur marked, marks) <-+          Fixed.copyAtMut neighbor marks+        let !nextDigest =+              mixDigest+                digest+                (neighbor * 31 + tag * 17 + delta + marked)+        if marked == 0+          then Control.do+            marks <-+              Fixed.write neighbor 1 marks+            queue <-+              Fixed.write tailIndex neighbor queue+            worklistPureBorrowCheckedOpenOnceEdgeWorker+              (edge + 1)+              end+              (tailIndex + 1)+              (enqueues + 1)+              nextDigest+              adjacency+              payload+              marks+              queue+          else+            worklistPureBorrowCheckedOpenOnceEdgeWorker+              (edge + 1)+              end+              tailIndex+              enqueues+              nextDigest+              adjacency+              payload+              marks+              queue++readTraversalStateChecked ::+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  BO+    α+    ( Ur TraversalState+    , Mut α (Fixed.Vector U.Vector Int)+    )+readTraversalStateChecked state = Control.do+  (Ur headIndex, state) <- Fixed.copyAtMut 0 state+  (Ur tailIndex, state) <- Fixed.copyAtMut 1 state+  (Ur visits, state) <- Fixed.copyAtMut 2 state+  (Ur enqueues, state) <- Fixed.copyAtMut 3 state+  (Ur logSize, state) <- Fixed.copyAtMut 4 state+  Control.pure+    ( Ur+        TraversalState+          { stateHead = headIndex+          , stateTail = tailIndex+          , stateVisits = visits+          , stateEnqueues = enqueues+          , stateLogSize = logSize+          , stateDigest = initialDigest+          }+    , state+    )++writeTraversalStateCheckedPureBorrow ::+  TraversalState ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  BO α (Mut α (Fixed.Vector U.Vector Int))+writeTraversalStateCheckedPureBorrow traversal state = Control.do+  state <- Fixed.write 0 (stateHead traversal) state+  state <- Fixed.write 1 (stateTail traversal) state+  state <- Fixed.write 2 (stateVisits traversal) state+  state <- Fixed.write 3 (stateEnqueues traversal) state+  Fixed.write 4 (stateLogSize traversal) state++readTraversalState ::+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  BO+    α+    ( Ur TraversalState+    , Mut α (Fixed.Vector U.Vector Int)+    )+readTraversalState state = Control.do+  (Ur headIndex, state) <- Fixed.unsafeGet 0 state+  (Ur tailIndex, state) <- Fixed.unsafeGet 1 state+  (Ur visits, state) <- Fixed.unsafeGet 2 state+  (Ur enqueues, state) <- Fixed.unsafeGet 3 state+  (Ur logSize, state) <- Fixed.unsafeGet 4 state+  Control.pure+    ( Ur+        TraversalState+          { stateHead = headIndex+          , stateTail = tailIndex+          , stateVisits = visits+          , stateEnqueues = enqueues+          , stateLogSize = logSize+          , stateDigest = initialDigest+          }+    , state+    )++writeTraversalStatePureBorrow ::+  TraversalState ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  BO α (Mut α (Fixed.Vector U.Vector Int))+writeTraversalStatePureBorrow traversal state = Control.do+  state <- Fixed.unsafeWrite 0 (stateHead traversal) state+  state <- Fixed.unsafeWrite 1 (stateTail traversal) state+  state <- Fixed.unsafeWrite 2 (stateVisits traversal) state+  state <- Fixed.unsafeWrite 3 (stateEnqueues traversal) state+  Fixed.unsafeWrite 4 (stateLogSize traversal) state++consumeWorklistViews ::+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector V.Vector (Int, Int)) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  Mut α (Fixed.Vector U.Vector Int) %1 ->+  ()+consumeWorklistViews+  offsets+  marks+  state+  adjacency+  payload+  queue+  outputLog =+    let !(Ur _) = share offsets+        !(Ur _) = share marks+        !(Ur _) = share state+        !(Ur _) = share adjacency+        !(Ur _) = share payload+        !(Ur _) = share queue+        !(Ur _) = share outputLog+     in ()++outcomeFor :: WorklistTarget -> TraversalState -> WorklistOutcome+outcomeFor target traversal+  | target == StopEarly+      && stateVisits traversal >= targetVisits target =+      Stopped+  | otherwise =+      Drained++runOpenOnce ::+  Int ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  MV.MVector s (Int, Int) ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  TraversalState ->+  ST s TraversalState+runOpenOnce stopAfter offsets adjacency payload marks queue outputLog current+  | stateVisits current >= stopAfter =+      pure current+  | stateHead current >= stateTail current =+      pure current+  | otherwise = do+      node <- UM.unsafeRead queue (stateHead current)+      start <- UM.unsafeRead offsets node+      end <- UM.unsafeRead offsets (node + 1)+      (nextTail, nextEnqueues, nodeDigest) <-+        scanEdgesOpenOnce+          start+          end+          adjacency+          payload+          marks+          queue+          (stateTail current)+          (stateEnqueues current)+          (stateDigest current)+      let !logValue = digestToLogValue nodeDigest node+      UM.unsafeWrite outputLog (stateLogSize current) logValue+      let !nextState =+            TraversalState+              { stateHead = stateHead current + 1+              , stateTail = nextTail+              , stateVisits = stateVisits current + 1+              , stateEnqueues = nextEnqueues+              , stateLogSize = stateLogSize current + 1+              , stateDigest = mixDigest nodeDigest logValue+              }+      runOpenOnce+        stopAfter+        offsets+        adjacency+        payload+        marks+        queue+        outputLog+        nextState++scanEdgesOpenOnce ::+  Int ->+  Int ->+  UM.MVector s Int ->+  MV.MVector s (Int, Int) ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  Int ->+  Int ->+  Int64 ->+  ST s (Int, Int, Int64)+scanEdgesOpenOnce edge end adjacency payload marks queue tailIndex enqueues digest+  | edge >= end =+      pure (tailIndex, enqueues, digest)+  | otherwise = do+      neighbor <- UM.unsafeRead adjacency edge+      (tag, delta) <- MV.unsafeRead payload edge+      marked <- UM.unsafeRead marks neighbor+      let !nextDigest =+            mixDigest+              digest+              (neighbor * 31 + tag * 17 + delta + marked)+      if marked == 0+        then do+          UM.unsafeWrite marks neighbor 1+          UM.unsafeWrite queue tailIndex neighbor+          scanEdgesOpenOnce+            (edge + 1)+            end+            adjacency+            payload+            marks+            queue+            (tailIndex + 1)+            (enqueues + 1)+            nextDigest+        else+          scanEdgesOpenOnce+            (edge + 1)+            end+            adjacency+            payload+            marks+            queue+            tailIndex+            enqueues+            nextDigest++runFlatReopenDirect ::+  WorklistGrowth ->+  WorklistTarget ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  STRef s (UnboxedHeader s) ->+  STRef s (BoxedHeader s) ->+  STRef s (UnboxedHeader s) ->+  STRef s (UnboxedHeader s) ->+  TraversalState ->+  Int ->+  Int ->+  Int ->+  ST s (TraversalState, Int, Int, Int, WorklistOutcome)+runFlatReopenDirect+  growth+  target+  offsets+  marks+  state+  adjacencyHeader+  payloadHeader+  queueHeader+  logHeader+  current+  scopes+  updates+  growths+    | stateVisits current >= targetVisits target =+        pure+          ( current+          , scopes+          , updates+          , growths+          , case target of+              Drain -> Drained+              StopEarly -> Stopped+          )+    | stateHead current >= stateTail current =+        pure (current, scopes, updates, growths, Drained)+    | otherwise = do+        UnboxedHeader _ adjacency <- readSTRef adjacencyHeader+        BoxedHeader _ payload <- readSTRef payloadHeader+        (segment, nextScopes, nextUpdates, nextGrowths) <-+          runReopenSegmentDirect+            growth+            target+            offsets+            adjacency+            payload+            marks+            state+            queueHeader+            logHeader+            current+            scopes+            updates+            growths+        if segmentStopped segment+          then+            pure+              ( segmentState segment+              , nextScopes+              , nextUpdates+              , nextGrowths+              , case target of+                  Drain -> Drained+                  StopEarly -> Stopped+              )+          else+            runFlatReopenDirect+              growth+              target+              offsets+              marks+              state+              adjacencyHeader+              payloadHeader+              queueHeader+              logHeader+              (segmentState segment)+              nextScopes+              nextUpdates+              nextGrowths++runNestedReopenDirect ::+  WorklistGrowth ->+  WorklistTarget ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  MV.MVector s (Int, Int) ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  STRef s (UnboxedHeader s) ->+  STRef s (UnboxedHeader s) ->+  TraversalState ->+  Int ->+  Int ->+  Int ->+  ST s (TraversalState, Int, Int, Int, WorklistOutcome)+runNestedReopenDirect+  growth+  target+  offsets+  adjacency+  payload+  marks+  state+  queueHeader+  logHeader+  current+  scopes+  updates+  growths+    | stateVisits current >= targetVisits target =+        pure+          ( current+          , scopes+          , updates+          , growths+          , case target of+              Drain -> Drained+              StopEarly -> Stopped+          )+    | stateHead current >= stateTail current =+        pure (current, scopes, updates, growths, Drained)+    | otherwise = do+        (segment, nextScopes, nextUpdates, nextGrowths) <-+          runReopenSegmentDirect+            growth+            target+            offsets+            adjacency+            payload+            marks+            state+            queueHeader+            logHeader+            current+            scopes+            updates+            growths+        if segmentStopped segment+          then+            pure+              ( segmentState segment+              , nextScopes+              , nextUpdates+              , nextGrowths+              , case target of+                  Drain -> Drained+                  StopEarly -> Stopped+              )+          else+            runNestedReopenDirect+              growth+              target+              offsets+              adjacency+              payload+              marks+              state+              queueHeader+              logHeader+              (segmentState segment)+              nextScopes+              nextUpdates+              nextGrowths++runReopenSegmentDirect ::+  WorklistGrowth ->+  WorklistTarget ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  MV.MVector s (Int, Int) ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  STRef s (UnboxedHeader s) ->+  STRef s (UnboxedHeader s) ->+  TraversalState ->+  Int ->+  Int ->+  Int ->+  ST s (SegmentResult, Int, Int, Int)+{-# INLINE runReopenSegmentDirect #-}+runReopenSegmentDirect+  growth+  target+  offsets+  adjacency+  payload+  marks+  state+  queueHeader+  logHeader+  current+  scopes+  updates+  growths = do+    UnboxedHeader queueSize queue <- readSTRef queueHeader+    UnboxedHeader _ outputLog <- readSTRef logHeader+    when (queueSize /= stateTail current) $+      error "worklist queue header and scalar tail diverged"+    when (UM.length outputLog < stateLogSize current) $+      error "worklist log header and scalar frontier diverged"+    segment <-+      runSegment+        (targetVisits target)+        (min queueSize (stateHead current + worklistBatchSize growth))+        offsets+        adjacency+        payload+        marks+        queue+        current+        []+        []+    let !pending = U.fromList (reverse (segmentPendingRev segment))+        !newLogs = U.fromList (reverse (segmentLogRev segment))+    queueGrew <-+      if U.null pending+        then pure False+        else appendUnboxed queueHeader pending+    logGrew <- appendUnboxed logHeader newLogs+    writeTraversalState state (segmentState segment)+    let !nextScopes = scopes + 1+        !nextUpdates =+          updates+            + (if U.null pending then 0 else 1)+            + 1+        !nextGrowths =+          growths+            + fromEnum queueGrew+            + fromEnum logGrew+    pure (segment, nextScopes, nextUpdates, nextGrowths)++runSegment ::+  Int ->+  Int ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  MV.MVector s (Int, Int) ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  TraversalState ->+  [Int] ->+  [Int] ->+  ST s SegmentResult+runSegment stopAfter snapshotTail offsets adjacency payload marks queue current queueRev logRev+  | stateVisits current >= stopAfter =+      pure (SegmentResult current queueRev logRev True)+  | stateHead current >= snapshotTail =+      pure (SegmentResult current queueRev logRev False)+  | otherwise = do+      node <- UM.unsafeRead queue (stateHead current)+      start <- UM.unsafeRead offsets node+      end <- UM.unsafeRead offsets (node + 1)+      (nextTail, nextEnqueues, nextQueueRev, nodeDigest) <-+        scanEdgesSegment+          start+          end+          adjacency+          payload+          marks+          (stateTail current)+          (stateEnqueues current)+          queueRev+          (stateDigest current)+      let !logValue = digestToLogValue nodeDigest node+          !nextState =+            TraversalState+              { stateHead = stateHead current + 1+              , stateTail = nextTail+              , stateVisits = stateVisits current + 1+              , stateEnqueues = nextEnqueues+              , stateLogSize = stateLogSize current + 1+              , stateDigest = mixDigest nodeDigest logValue+              }+      runSegment+        stopAfter+        snapshotTail+        offsets+        adjacency+        payload+        marks+        queue+        nextState+        nextQueueRev+        (logValue : logRev)++scanEdgesSegment ::+  Int ->+  Int ->+  UM.MVector s Int ->+  MV.MVector s (Int, Int) ->+  UM.MVector s Int ->+  Int ->+  Int ->+  [Int] ->+  Int64 ->+  ST s (Int, Int, [Int], Int64)+scanEdgesSegment edge end adjacency payload marks tailIndex enqueues queueRev digest+  | edge >= end =+      pure (tailIndex, enqueues, queueRev, digest)+  | otherwise = do+      neighbor <- UM.unsafeRead adjacency edge+      (tag, delta) <- MV.unsafeRead payload edge+      marked <- UM.unsafeRead marks neighbor+      let !nextDigest =+            mixDigest+              digest+              (neighbor * 31 + tag * 17 + delta + marked)+      if marked == 0+        then do+          UM.unsafeWrite marks neighbor 1+          scanEdgesSegment+            (edge + 1)+            end+            adjacency+            payload+            marks+            (tailIndex + 1)+            (enqueues + 1)+            (neighbor : queueRev)+            nextDigest+        else+          scanEdgesSegment+            (edge + 1)+            end+            adjacency+            payload+            marks+            tailIndex+            enqueues+            queueRev+            nextDigest++finishDirect ::+  WorklistOutcome ->+  Int ->+  Int ->+  Int ->+  Int ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  MV.MVector s (Int, Int) ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  UM.MVector s Int ->+  TraversalState ->+  ST s WorklistOutput+finishDirect+  finalOutcome+  opens+  resumes+  updates+  growths+  offsets+  adjacency+  payload+  marks+  state+  queue+  outputLog+  traversal = do+    offsetsVector <- U.unsafeFreeze offsets+    adjacencyVector <- U.unsafeFreeze adjacency+    payloadVector <- V.unsafeFreeze payload+    marksVector <- U.unsafeFreeze marks+    stateVector <- U.unsafeFreeze state+    queueVector <-+      U.unsafeFreeze (UM.unsafeTake (stateTail traversal) queue)+    logVector <-+      U.unsafeFreeze (UM.unsafeTake (stateLogSize traversal) outputLog)+    U.length offsetsVector `seq`+      U.length adjacencyVector `seq`+        V.length payloadVector `seq`+          pure+            ( makeWorklistOutput+                finalOutcome+                opens+                resumes+                updates+                growths+                traversal+                marksVector+                stateVector+                queueVector+                logVector+            )++finishWorklistStore ::+  WorklistOutcome ->+  Int ->+  Int ->+  Int ->+  Int ->+  TraversalState ->+  WorklistStore %1 ->+  Ur WorklistOutput+{-# NOINLINE finishWorklistStore #-}+finishWorklistStore+  finalOutcome+  opens+  resumes+  updates+  growths+  traversal+  ( WorklistStore+      (WorklistFixedRoots offsetsOwner marksOwner stateOwner)+      (WorklistGraphRoots adjacencyOwner payloadOwner)+      (WorklistFrontierRoots queueOwner logOwner)+    ) =+    case Fixed.toVector offsetsOwner of+      Ur offsetsVector ->+        case Fixed.toVector marksOwner of+          Ur marksVector ->+            case Fixed.toVector stateOwner of+              Ur stateVector ->+                case Growable.toVector adjacencyOwner of+                  Ur adjacencyVector ->+                    case Growable.toVector payloadOwner of+                      Ur payloadVector ->+                        case Growable.toVector queueOwner of+                          Ur queueVector ->+                            case Growable.toVector logOwner of+                              Ur logVector ->+                                U.length offsetsVector `lseq`+                                  U.length adjacencyVector `lseq`+                                    V.length payloadVector `lseq`+                                      Ur+                                        ( makeWorklistOutput+                                            finalOutcome+                                            opens+                                            resumes+                                            updates+                                            growths+                                            traversal+                                            marksVector+                                            stateVector+                                            ( U.take+                                                (stateTail traversal)+                                                queueVector+                                            )+                                            ( U.take+                                                (stateLogSize traversal)+                                                logVector+                                            )+                                        )++makeWorklistOutput ::+  WorklistOutcome ->+  Int ->+  Int ->+  Int ->+  Int ->+  TraversalState ->+  U.Vector Int ->+  U.Vector Int ->+  U.Vector Int ->+  U.Vector Int ->+  WorklistOutput+makeWorklistOutput+  finalOutcome+  opens+  resumes+  updates+  growths+  traversal+  marksVector+  stateVector+  queueVector+  logVector =+    let !digest =+          digestOutput+            (stateDigest traversal)+            marksVector+            stateVector+            queueVector+            logVector+        !visits = stateVisits traversal+        !enqueues = stateEnqueues traversal+     in WorklistOutput+          { summary =+              WorklistSummary+                { outcome = finalOutcome+                , visitedNodes = visits+                , enqueueTransitions = enqueues+                , offsetReads = visits * 2+                , adjacencyReads = visits * worklistDegree+                , payloadReads = visits * worklistDegree+                , markReads = visits * worklistDegree+                , markWrites = enqueues+                , queueReads = visits+                , queueWrites = enqueues+                , logWrites = visits+                , contentOpens = opens+                , resumeBoundaries = resumes+                , headerUpdates = updates+                , bufferGrowths = growths+                , finalDigest = digest+                }+          , finalMarks = marksVector+          , finalState = stateVector+          , finalQueue = queueVector+          , finalLog = logVector+          }++writeTraversalState :: UM.MVector s Int -> TraversalState -> ST s ()+writeTraversalState state traversal = do+  UM.unsafeWrite state 0 (stateHead traversal)+  UM.unsafeWrite state 1 (stateTail traversal)+  UM.unsafeWrite state 2 (stateVisits traversal)+  UM.unsafeWrite state 3 (stateEnqueues traversal)+  UM.unsafeWrite state 4 (stateLogSize traversal)++newUnboxedHeaderFromVector :: U.Vector Int -> ST s (STRef s (UnboxedHeader s))+newUnboxedHeaderFromVector vector = do+  buffer <- U.thaw vector+  newSTRef (UnboxedHeader (U.length vector) buffer)++newBoxedHeaderFromVector :: V.Vector (Int, Int) -> ST s (STRef s (BoxedHeader s))+newBoxedHeaderFromVector vector = do+  buffer <- V.thaw vector+  newSTRef (BoxedHeader (V.length vector) buffer)++newUnboxedHeader :: Int -> U.Vector Int -> ST s (STRef s (UnboxedHeader s))+newUnboxedHeader requested initial = do+  let !capacity = max requested (U.length initial)+  buffer <- UM.new capacity+  U.copy (UM.unsafeTake (U.length initial) buffer) initial+  newSTRef (UnboxedHeader (U.length initial) buffer)++appendUnboxed :: STRef s (UnboxedHeader s) -> U.Vector Int -> ST s Bool+appendUnboxed header values = do+  UnboxedHeader logicalSize buffer <- readSTRef header+  let !required = logicalSize + U.length values+      !oldCapacity = UM.length buffer+      !target = growthTarget oldCapacity required+  (grown, didGrow) <-+    if target <= oldCapacity+      then pure (buffer, False)+      else do+        grown <- UM.new target+        UM.unsafeCopy+          (UM.unsafeTake logicalSize grown)+          (UM.unsafeTake logicalSize buffer)+        pure (grown, True)+  U.copy (UM.unsafeSlice logicalSize (U.length values) grown) values+  writeSTRef header (UnboxedHeader required grown)+  pure didGrow++worklistInitialCapacity :: WorklistGrowth -> Int+worklistInitialCapacity NoGrowth = worklistNodeCount+worklistInitialCapacity NoGrowthBatch64 = worklistNodeCount+worklistInitialCapacity NoGrowthBatch8 = worklistNodeCount+worklistInitialCapacity SparseGrowth = 256+worklistInitialCapacity DenseGrowth = 1++worklistBatchSize :: WorklistGrowth -> Int+worklistBatchSize NoGrowth = 256+worklistBatchSize NoGrowthBatch64 = 64+worklistBatchSize NoGrowthBatch8 = 8+worklistBatchSize SparseGrowth = 64+worklistBatchSize DenseGrowth = 8++growthTarget :: Int -> Int -> Int+growthTarget oldCapacity required+  | required <= oldCapacity = oldCapacity+  | oldCapacity <= 0 = max required 1+  | oldCapacity > maxBound `quot` 2 = required+  | otherwise = max required (oldCapacity * 2)++initialDigest :: Int64+initialDigest = 0x51A7C0DE++initialDigestForSeed :: Int -> Int64+initialDigestForSeed seed =+  initialDigest + fromIntegral seed++digestToLogValue :: Int64 -> Int -> Int+digestToLogValue digest node =+  fromIntegral+    ((digest + fromIntegral (node * 97 + 11)) `rem` 1000000007)++digestOutput ::+  Int64 ->+  U.Vector Int ->+  U.Vector Int ->+  U.Vector Int ->+  U.Vector Int ->+  Int64+digestOutput initial marks state queue outputLog =+  let !marksDigest =+        U.ifoldl'+          (\digest index value -> mixDigest digest (index * 17 + value))+          initial+          marks+      !stateDigest =+        U.ifoldl'+          (\digest index value -> mixDigest digest (index * 19 + value))+          marksDigest+          state+      !queueDigest =+        U.ifoldl'+          (\digest index value -> mixDigest digest (index * 23 + value))+          stateDigest+          queue+   in U.ifoldl'+        (\digest index value -> mixDigest digest (index * 29 + value))+        queueDigest+        outputLog++mixDigest :: Int64 -> Int -> Int64+mixDigest digest value =+  (digest * 6364136223846793005)+    + fromIntegral value+    + 1442695040888963407