[WIP] Write data to compact regions through destination "filling"

.ghcid

@@ -0,0 +1 @@
+--command "cabal repl --enable-multi-repl"

.gitattributes

@@ -0,0 +1 @@
+ghc*.tar.xz filter=lfs diff=lfs merge=lfs -text

.github/workflows/ci.yaml

@@ -4,6 +4,10 @@ env:
   # Bump this number to invalidate the Github-actions cache
   cache-invalidation-key: 0
   nixpkgs-url: https://github.com/NixOS/nixpkgs/archive/574d1eac1c200690e27b8eb4e24887f8df7ac27c.tar.gz
+  NIX_PATH: https://github.com/NixOS/nixpkgs/archive/574d1eac1c200690e27b8eb4e24887f8df7ac27c.tar.gz
+  ghc-exe: $(pwd)/ghc-dps-compact-95615577d7/bin/ghc
+  ghc-name: ghc-dps-compact-95615577d7
+  ghc-internal-name: ghc-9.11.20241002-x86_64-unknown-linux
 
 jobs:
   cabal-test:
@@ -13,7 +17,9 @@ jobs:
         ghc-version: [96, 98, 910]
     runs-on: ubuntu-latest
     steps:
-    - uses: actions/checkout@v2
+    - uses: actions/checkout@v3
+      with:
+        lfs: false
     - uses: cachix/install-nix-action@v15
       with:
         nix_path: "${{ env.nixpkgs-url }}"
@@ -33,19 +39,71 @@ jobs:
     - name: Update Cabal's database
       run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal update"
     - name: Build Cabal's dependencies
-      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal build --allow-newer --disable-tests --disable-benchmarks --dependencies-only"
+      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal build --dependencies-only"
+    - name: Build
+      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal build --run-tests"
+    - name: Haddock
+      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal haddock"
+    - name: cabal-docspec
+      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal-docspec"
+    - name: Build benchmarks
+      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal build linear-base:bench:bench"
+    - name: Run benchmarks in isolation
+      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "echo $'=== Benchmarks (isolation) ===\n\n' > benchmark_ghc${{ matrix.ghc-version }}.txt && cabal run -v0 linear-base:bench:bench -- -l | while read -r name; do cabal run -v0 linear-base:bench:bench -- -p '"'$'"0 == \"'\""'$'"name\"'\"' 2>&1 | tee -a benchmark_ghc${{ matrix.ghc-version }}.txt; done"
+    - name: Upload benchmark results
+      uses: actions/upload-artifact@v3
+      with:
+        name: linear-base_benchmarks_ghc${{ matrix.ghc-version }}
+        path: |
+          **/*.dump-simpl
+          benchmark_ghc${{ matrix.ghc-version }}.txt
+        retention-days: 90
+
+  cabal-test-ghc-dps-compact:
+    name: cabal test - ghc-dps-compact
+    runs-on: [self-hosted, Linux, X64]
+    steps:
+    - uses: actions/checkout@v3
+      with:
+        lfs: true
+    - name: Checkout LFS objects
+      run: git lfs checkout
+    - name: Build Nix dependencies
+      run: nix-shell --arg installHls 'false' --pure --run "echo '=== Nix dependencies installed ==='"
+    - name: Install custom GHC
+      run: nix-shell --pure --run "rm -rf ${{ env.ghc-name }} ${{ env.ghc-internal-name }} && tar xJf ${{ env.ghc-name }}.tar.xz && mv ${{ env.ghc-internal-name }} ${{ env.ghc-name }}"
+    - name: Init Cabal's config file
+      run: nix-shell --arg installHls 'false' --pure --run "cabal --config-file=$HOME/.cabal/config user-config -f init"
+    - name: Update Cabal's database
+      run: nix-shell --arg installHls 'false' --pure --run "cabal update"
+    - name: Build Cabal's dependencies
+      run: nix-shell --arg installHls 'false' --pure --run "cabal build -w ${{ env.ghc-exe }} --dependencies-only"
     - name: Build
-      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal build --allow-newer --disable-tests --disable-benchmarks"
+      run: nix-shell --arg installHls 'false' --pure --run "cabal build -w ${{ env.ghc-exe }} --run-tests"
     - name: Haddock
-      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run "cabal --allow-newer haddock"
+      run: nix-shell --arg installHls 'false' --pure --run "cabal haddock -w ${{ env.ghc-exe }}"
     - name: cabal-docspec
-      run: nix-shell --arg ghcVersion '"${{ matrix.ghc-version }}"' --arg installHls 'false' --pure --run cabal-docspec
+      run: nix-shell --arg installHls 'false' --pure --run "echo '# [DISABLED because of https://github.com/phadej/cabal-extras/issues/160]' cabal-docspec -w ${{ env.ghc-exe }}"
+    - name: Build benchmarks
+      run: nix-shell --arg installHls 'false' --pure --run "cabal build -w ${{ env.ghc-exe }} linear-base:bench:bench"
+    - name: Run benchmarks in isolation
+      run: nix-shell --arg installHls 'false' --pure --run "echo $'=== Benchmarks (isolation) ===\n\n' > benchmark_${{ env.ghc-name }}.txt && cabal run -w ${{ env.ghc-exe }} -v0 linear-base:bench:bench -- -l | while read -r name; do cabal run -w ${{ env.ghc-exe }} -v0 linear-base:bench:bench -- -p '"'$'"0 == \"'\""'$'"name\"'\"' 2>&1 | tee -a benchmark_${{ env.ghc-name }}.txt; done"
+    - name: Upload benchmark results
+      uses: actions/upload-artifact@v3
+      with:
+        name: linear-base_benchmarks_${{ env.ghc-name }}
+        path: |
+          **/*.dump-simpl
+          benchmark_${{ env.ghc-name }}.txt
+        retention-days: 90
 
   ormolu:
     name: check formatting with ormolu
     runs-on: ubuntu-latest
     steps:
-    - uses: actions/checkout@v2
+    - uses: actions/checkout@v3
+      with:
+        lfs: false
     - uses: cachix/install-nix-action@v15
       with:
         nix_path: "${{ env.nixpkgs-url }}"
@@ -64,7 +122,9 @@ jobs:
     name: stack build
     runs-on: ubuntu-latest
     steps:
-    - uses: actions/checkout@v2
+    - uses: actions/checkout@v3
+      with:
+        lfs: false
     - uses: cachix/install-nix-action@v15
       with:
         nix_path: "${{ env.nixpkgs-url }}"

.gitignore

@@ -22,3 +22,7 @@ cabal.sandbox.config
 .stack-work/
 cabal.project.local
 .HTF/
+
+**/*.dump-simpl
+ghc-dps-compact-95615577d7
+benchmark_*.txt

bench-version-changes/ghc-dps-compact/after/Bench/Compact.hs

@@ -0,0 +1,19 @@
+module Bench.Compact where
+
+import Bench.Compact.BFTraversal (bftraversalBenchgroup)
+import Bench.Compact.DList (dlistBenchgroup)
+import Bench.Compact.Map (mapBenchgroup)
+import Bench.Compact.Queue (queueBenchgroup)
+import Bench.Compact.SExpr (sexprBenchgroup)
+import Test.Tasty.Bench
+
+benchmarks :: Benchmark
+benchmarks =
+  bgroup
+    "DPS interface for compact regions"
+    [ bftraversalBenchgroup,
+      mapBenchgroup,
+      dlistBenchgroup,
+      queueBenchgroup,
+      sexprBenchgroup
+    ]

bench-version-changes/ghc-dps-compact/after/Bench/Compact/BFTraversal.hs

@@ -0,0 +1,25 @@
+module Bench.Compact.BFTraversal where
+
+import Bench.Compact.Utils as Utils
+import Compact.BFTraversal as BFTraversal
+import Control.DeepSeq (force)
+import Control.Exception (evaluate)
+import Test.Tasty.Bench (Benchmark)
+
+dataSets :: [(IO (BinTree ()), String)]
+dataSets =
+  [ (evaluate $ force (go 0 10), "2^10"),
+    (evaluate $ force (go 0 13), "2^13"),
+    (evaluate $ force (go 0 16), "2^16"),
+    (evaluate $ force (go 0 19), "2^19"),
+    (evaluate $ force (go 0 22), "2^22")
+  ]
+  where
+    go :: Int -> Int -> BinTree ()
+    go currentDepth maxDepth =
+      if currentDepth >= maxDepth
+        then Nil
+        else Node () (go (currentDepth + 1) maxDepth) (go (currentDepth + 1) maxDepth)
+
+bftraversalBenchgroup :: Benchmark
+bftraversalBenchgroup = Utils.benchImpls "Breadth-first tree traversal" BFTraversal.impls dataSets

bench-version-changes/ghc-dps-compact/after/Bench/Compact/DList.hs

@@ -0,0 +1,21 @@
+{-# OPTIONS_GHC -Wno-type-defaults #-}
+
+module Bench.Compact.DList where
+
+import Bench.Compact.Utils as Utils
+import Compact.DList as DList
+import Control.DeepSeq (force)
+import Control.Exception (evaluate)
+import Test.Tasty.Bench (Benchmark)
+
+dataSets :: [(IO [[Int]], String)]
+dataSets =
+  [ (evaluate $ force (fmap (\i -> [(10 * i + 0) .. (10 * i + 9)]) [0 .. (((2 ^ 10) `div` 10) - 1)]), "2^10"),
+    (evaluate $ force (fmap (\i -> [(10 * i + 0) .. (10 * i + 9)]) [0 .. (((2 ^ 13) `div` 10) - 1)]), "2^13"),
+    (evaluate $ force (fmap (\i -> [(10 * i + 0) .. (10 * i + 9)]) [0 .. (((2 ^ 16) `div` 10) - 1)]), "2^16"),
+    (evaluate $ force (fmap (\i -> [(10 * i + 0) .. (10 * i + 9)]) [0 .. (((2 ^ 19) `div` 10) - 1)]), "2^19"),
+    (evaluate $ force (fmap (\i -> [(10 * i + 0) .. (10 * i + 9)]) [0 .. (((2 ^ 22) `div` 10) - 1)]), "2^22")
+  ]
+
+dlistBenchgroup :: Benchmark
+dlistBenchgroup = benchImpls "List and DList concatenation" DList.impls dataSets

bench-version-changes/ghc-dps-compact/after/Bench/Compact/Map.hs

@@ -0,0 +1,23 @@
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -Wno-type-defaults #-}
+
+module Bench.Compact.Map where
+
+import Bench.Compact.Utils as Utils
+import Compact.Map as Map
+import Control.DeepSeq (force)
+import Control.Exception (evaluate)
+import Test.Tasty.Bench (Benchmark)
+
+dataSets :: [(IO [Int], String)]
+dataSets =
+  [ ((evaluate $ force [1 .. 2 ^ 10]), "2^10"),
+    ((evaluate $ force [1 .. 2 ^ 13]), "2^13"),
+    ((evaluate $ force [1 .. 2 ^ 16]), "2^16"),
+    ((evaluate $ force [1 .. 2 ^ 19]), "2^19"),
+    ((evaluate $ force [1 .. 2 ^ 22]), "2^22")
+  ]
+
+mapBenchgroup :: Benchmark
+mapBenchgroup = benchImpls "map on List" Map.impls dataSets

bench-version-changes/ghc-dps-compact/after/Bench/Compact/Queue.hs

@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -Wno-type-defaults #-}
+
+module Bench.Compact.Queue where
+
+import Bench.Compact.Utils as Utils
+import Compact.Queue as Queue
+import Data.Word (Word64)
+import Test.Tasty.Bench (Benchmark)
+
+dataSets :: [(IO Word64, String)]
+dataSets =
+  [ (return $ 2 ^ 10, "2^10"),
+    (return $ 2 ^ 13, "2^13"),
+    (return $ 2 ^ 16, "2^16"),
+    (return $ 2 ^ 19, "2^19"),
+    (return $ 2 ^ 22, "2^22")
+  ]
+
+queueBenchgroup :: Benchmark
+queueBenchgroup = benchImpls "Queue enqueue operations" Queue.impls dataSets

bench-version-changes/ghc-dps-compact/after/Bench/Compact/SExpr.hs

@@ -0,0 +1,23 @@
+module Bench.Compact.SExpr where
+
+import Bench.Compact.Utils as Utils
+import Compact.SExpr as SExpr
+import Control.DeepSeq (force)
+import Control.Exception (evaluate)
+import qualified Data.ByteString.Char8 as BSC
+import Test.Tasty.Bench (Benchmark)
+
+dataSetDir :: String
+dataSetDir = "bench-version-changes/ghc-dps-compact/after/datasets/"
+
+dataSets :: [(IO BSC.ByteString, String)]
+dataSets =
+  [ (evaluate . force =<< BSC.readFile (dataSetDir ++ "data_2_10.sexpr"), "2^10"),
+    (evaluate . force =<< BSC.readFile (dataSetDir ++ "data_2_13.sexpr"), "2^13"),
+    (evaluate . force =<< BSC.readFile (dataSetDir ++ "data_2_16.sexpr"), "2^16"),
+    (evaluate . force =<< BSC.readFile (dataSetDir ++ "data_2_19.sexpr"), "2^19"),
+    (evaluate . force =<< BSC.readFile (dataSetDir ++ "data_2_22.sexpr"), "2^22")
+  ]
+
+sexprBenchgroup :: Benchmark
+sexprBenchgroup = Utils.benchImpls "S-expression parser" SExpr.impls dataSets

bench-version-changes/ghc-dps-compact/after/Bench/Compact/Utils.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -Wno-name-shadowing #-}
+
+module Bench.Compact.Utils where
+
+import Control.DeepSeq
+import Control.Exception (evaluate)
+import Data.Functor ((<&>))
+import GHC.Compact (compact, getCompact)
+import Test.Tasty (testGroup)
+import Test.Tasty.Bench
+
+-- import qualified Compact.Map as Map
+-- import qualified Compact.BFTraversal as BFTraversal
+-- import qualified Compact.DList as DList
+-- import qualified Compact.Queue as Queue
+-- import qualified Compact.SExpr as SExpr
+
+-- import qualified Bench.Compact.Map as Map
+-- import qualified Bench.Compact.BFTraversal as BFTraversal
+-- import qualified Bench.Compact.DList as DList
+-- import qualified Bench.Compact.Queue as Queue
+-- import qualified Bench.Compact.SExpr as SExpr
+
+benchImpls :: forall m a r. (NFData a, NFData r) => String -> [(a %m -> r, String, Bool)] -> [(IO a, String)] -> Benchmark
+benchImpls name impls datasets = do
+  bgroup
+    name
+    ( datasets <&> \(loadSampleData, sizeName) -> env loadSampleData $ \sampleData ->
+        testGroup sizeName $
+          concat $
+            impls <&> \(impl, implName, isLazy) ->
+              if isLazy
+                then
+                  [ bench (implName ++ ".force") $ (flip whnfAppIO) sampleData $ \sampleData -> evaluate $ force $ impl sampleData,
+                    bench (implName ++ ".copyIntoReg") $ (flip whnfAppIO) sampleData $ \sampleData -> do
+                      resInRegion <- compact $ impl sampleData
+                      evaluate $ getCompact $ resInRegion
+                  ]
+                else [bench implName $ (flip whnfAppIO) sampleData $ \sampleData -> evaluate $ impl sampleData]
+    )
+
+-- launchImpl :: String -> IO ()
+-- launchImpl s =
+--   let (_all, dotModuleName) = span (/= '.') s
+--       (moduleName, dotBenchmark) = span (/= '.') (tail dotModuleName)
+--       (_benchmark, dotImplSizeSpec) = span (/= '.') (tail dotBenchmark)
+--       implSizeSpec = tail dotImplSizeSpec
+--    in case (_all ++ "." ++ moduleName ++ "." ++ _benchmark) of
+--         "All.Bench.Compact.Map.benchmark" -> Utils.launchImpl' implSizeSpec Map.impls Map.dataSets
+--         "All.Bench.Compact.BFTraversal.benchmark" -> Utils.launchImpl' implSizeSpec BFTraversal.impls BFTraversal.dataSets
+--         "All.Bench.Compact.DList.benchmark" -> Utils.launchImpl' implSizeSpec DList.impls DList.dataSets
+--         "All.Bench.Compact.Queue.benchmark" -> Utils.launchImpl' implSizeSpec Queue.impls Queue.dataSets
+--         "All.Bench.Compact.SExpr.benchmark" -> Utils.launchImpl' implSizeSpec SExpr.impls SExpr.dataSets
+--         s' -> error ("benchmark group '" ++ s' ++ "' not found")
+
+-- launchImpl' :: forall m a r. (NFData r) => String -> [(a %m -> r, String, Bool)] -> [(IO a, String)] -> IO ()
+-- launchImpl' requestedImplDataSetspec impls datasets = go impls (go' datasets) where
+--   (requestedSize, dotRequestedImplSpec) = span (/= '.') requestedImplDataSetspec
+--   (requestedImplRadical, requestedImplVariant) = span (/= '.') (tail dotRequestedImplSpec)
+--   go [] _ = error ("requested implementation '" ++ requestedImplRadical ++ "' not found")
+--   go ((impl, implName, isLazy):_) loadSampleData | implName == requestedImplRadical = do
+--     sampleData <- loadSampleData
+--     if isLazy
+--       then case requestedImplVariant of
+--         ".force" -> evaluate $ rwhnf $ force $ impl sampleData
+--         ".copyIntoReg" -> do
+--           resInRegion <- compact $ impl sampleData
+--           evaluate $ rwhnf $ getCompact $ resInRegion
+--         _ -> error ("variant '" ++ requestedImplVariant ++ "' not found (required for lazy impl)")
+--     else
+--       evaluate $ rwhnf $ impl sampleData
+--     putStrLn "Done!"
+--   go (_:xs) loadSampleData = go xs loadSampleData
+
+--   go' [] = error ("requested size '" ++ requestedSize ++ "' not found")
+--   go' ((loadSampleData, sizeName):_) | sizeName == requestedSize = loadSampleData
+--   go' (_:xs) = go' xs

bench-version-changes/ghc-dps-compact/after/datasets/data_2_10.sexpr

@@ -0,0 +1,46 @@
+(
+(ert-deftest company-shows-keywords-alongside-completions-alphabetically ()
+  :tags '(company)
+  (switch-to-buffer "*TESTING COMPANY MODE ~ Python*")
+  (python-mode)
+
+
+  (erase-buffer)
+  (insert "\n def first(x): pass")
+  (insert "\n def fierce(a, b): pass")
+
+
+  (insert "\n fi")
+  (company-manual-begin)
+  (should (equal company-candidates '("fierce" "first" #("finally" 0 7 (company-backend company-keywords)))))
+
+
+  (execute-kbd-macro (kbd "C-g C-/ M-2")) 
+  (should (looking-back "finally"))
+
+  (kill-buffer))
+
+
+(ert-deftest company-shows-keywords-alongside-completions-alphabetically ()
+  :tags '(company)
+  (switch-to-buffer "*TESTING COMPANY MODE ~ Python*")
+  (python-mode)
+
+
+  (erase-buffer)
+  (insert "\n def first(x): pass")
+  (insert "\n def fierce(a, b): pass")
+
+
+  (insert "\n fi")
+  (company-manual-begin)
+  (should (equal company-candidates '("fierce" "first" #("finally" 0 7 (company-backend company-keywords)))))
+
+
+  (execute-kbd-macro (kbd "C-g C-/ M-2")) 
+  (should (looking-back "finally"))
+
+  (kill-buffer))
+
+
+)