From 4894b77c5a927fd28971d59f30eb96ee9916ed07 Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Wed, 27 Sep 2023 14:30:33 +0200
Subject: [PATCH 01/15] Refactor mallocator test some more

---
 eclair-lang.cabal                             |   1 +
 .../Test/Eclair/LLVM/Allocator/MallocSpec.hs  | 163 ++++++------------
 .../Test/Eclair/LLVM/Allocator/Utils.hs       |  91 ++++++++++
 3 files changed, 142 insertions(+), 113 deletions(-)
 create mode 100644 tests/eclair/Test/Eclair/LLVM/Allocator/Utils.hs

diff --git a/eclair-lang.cabal b/eclair-lang.cabal
index 183ab38..5e10b8b 100644
--- a/eclair-lang.cabal
+++ b/eclair-lang.cabal
@@ -257,6 +257,7 @@ test-suite eclair-test
     Test.Eclair.ArgParserSpec
     Test.Eclair.JSONSpec
     Test.Eclair.LLVM.Allocator.MallocSpec
+    Test.Eclair.LLVM.Allocator.Utils
     Test.Eclair.LLVM.HashSpec
     Test.Eclair.LSP.HandlersSpec
     Test.Eclair.LSP.JSONSpec
diff --git a/tests/eclair/Test/Eclair/LLVM/Allocator/MallocSpec.hs b/tests/eclair/Test/Eclair/LLVM/Allocator/MallocSpec.hs
index a315590..567962a 100644
--- a/tests/eclair/Test/Eclair/LLVM/Allocator/MallocSpec.hs
+++ b/tests/eclair/Test/Eclair/LLVM/Allocator/MallocSpec.hs
@@ -4,137 +4,74 @@ module Test.Eclair.LLVM.Allocator.MallocSpec
   ) where
 
 import Prelude hiding (void)
-import Control.Monad.Morph
 import Eclair.LLVM.Allocator.Malloc
 import Eclair.LLVM.Allocator.Common
-import Eclair.LLVM.Codegen hiding (retVoid)
-import System.FilePath
+import Eclair.LLVM.Codegen hiding (retVoid, nullPtr)
 import System.Directory.Extra
-import System.Process.Extra
 import System.Posix.DynamicLinker
-import Foreign.LibFFI
-import Test.Hspec
-import Control.Exception (bracket)
+import Control.Exception
 import Foreign.Ptr
-import Foreign.C
-import Foreign (Storable(peek, poke))
-
+import Foreign hiding (void)
+import Test.Eclair.LLVM.Allocator.Utils
+import Test.Hspec
 
-type I8 = CUChar
 
 data Mallocator
 
-data Bindings
-  = Bindings
-  { dynamicLib :: DL
-  , withAlloc :: (Ptr Mallocator -> IO ()) -> IO ()
-  , fnAlloc :: Ptr Mallocator -> CSize -> IO (Ptr I8)
-  , fnFree :: Ptr Mallocator -> Ptr I8 -> CSize -> IO ()
-  , fnInit :: Ptr Mallocator -> IO ()
-  , fnDestroy :: Ptr Mallocator -> IO ()
-  }
-
 spec :: Spec
-spec = describe "Mallocator" $
-  aroundAll (setupAndTeardown testDir) $ parallel $ do
-    it "can be initialized and destroyed" $ \bindings ->
-      withAlloc bindings $ \obj -> do
-        fnInit bindings obj
-        fnDestroy bindings obj
-
-    it "can allocate and free memory" $ \bindings -> do
-      let numBytes = 1
-          value = 42
-      withAlloc bindings $ \obj -> do
-        fnInit bindings obj
-        memory <- fnAlloc bindings obj numBytes
-        poke memory value
-        value' <- peek memory
-        fnFree bindings obj memory numBytes
-        fnDestroy bindings obj
-        value' `shouldBe` value
-
-setupAndTeardown :: FilePath -> ActionWith Bindings -> IO ()
+spec = describe "Mallocator" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
+  it "can be initialized and destroyed" $ \bindings ->
+    withAlloc bindings $ \obj -> do
+      fnInit bindings obj
+      fnDestroy bindings obj
+
+  it "can allocate and free memory" $ \bindings -> do
+    let numBytes = 1
+        value = 42
+    withAlloc bindings $ \obj -> do
+      fnInit bindings obj
+      memory <- fnAlloc bindings obj numBytes
+      memory `shouldNotBe` nullPtr
+      poke memory value
+      value' <- peek memory
+      fnFree bindings obj memory numBytes
+      fnDestroy bindings obj
+      value' `shouldBe` value
+
+setupAndTeardown :: FilePath -> ActionWith (Bindings Mallocator) -> IO ()
 setupAndTeardown dir =
   bracket (setup dir) teardown
 
-setup :: FilePath -> IO Bindings
+setup :: FilePath -> IO (Bindings Mallocator)
 setup dir = do
   createDirectoryIfMissing False dir
-  compileAllocatorCode dir
-  loadNativeCode dir
-
-teardown :: Bindings -> IO ()
-teardown (Bindings lib _ _ _ _ _) =
-  dlclose lib
-
-compileAllocatorCode :: FilePath -> IO ()
-compileAllocatorCode dir = do
-  llvmIR <- runModuleBuilderT $ do
-    mallocFn <- extern "malloc" [i32] (ptr i8)
-    freeFn <- extern "free" [ptr i8] void
-    let exts = Externals mallocFn freeFn notUsed notUsed notUsed notUsed notUsed
-        cgBlueprint = flip evalStateT exts $ cgAlloc "mallocator" allocator
-    Blueprint ty _ _ _ _ <- hoist intoIO cgBlueprint
-    -- Helper test code for initializing and freeing a struct from native code:
-    _ <- function "mallocator_new" [] (ptr ty) $ \[] ->
-      ret =<< call mallocFn [int32 1]
-    _ <- function "mallocator_delete" [(ptr ty, "allocator")] void $ \[alloc] ->
-      call freeFn [alloc]
-    pass
-  let llvmIRText = ppllvm llvmIR
-  writeFileText (llFile dir) llvmIRText
-  callProcess "clang" ["-fPIC", "-shared", "-O0", "-o", soFile dir, llFile dir]
+  compileAllocatorCode allocator prefix cgExternals cgTestCode dir
+  loadNativeCode prefix dir
+
+teardown :: Bindings Mallocator -> IO ()
+teardown =
+  dlclose . dynamicLib
+
+cgExternals :: ModuleBuilderT IO Externals
+cgExternals = do
+  mallocFn <- extern "malloc" [i32] (ptr i8)
+  freeFn <- extern "free" [ptr i8] void
+  pure $ Externals mallocFn freeFn notUsed notUsed notUsed notUsed notUsed
+
+-- Helper test code for initializing and freeing a struct from native code:
+cgTestCode :: Type -> Operand -> Operand -> ModuleBuilderT IO ()
+cgTestCode ty mallocFn freeFn = do
+  _ <- function "mallocator_new" [] (ptr ty) $ \[] ->
+    ret =<< call mallocFn [int32 1]
+  _ <- function "mallocator_delete" [(ptr ty, "allocator")] void $ \[alloc] ->
+    call freeFn [alloc]
+  pass
+
+prefix :: Text
+prefix = "mallocator"
 
 testDir :: FilePath
 testDir = "/tmp/eclair-mallocator"
 
-llFile, soFile :: FilePath -> FilePath
-llFile dir = dir </> "allocator.ll"
-soFile dir = dir </> "allocator.so"
-
-loadNativeCode :: FilePath -> IO Bindings
-loadNativeCode dir = do
-  lib <- dlopen (soFile dir) [RTLD_LAZY]
-  newFn <- dlsym lib "mallocator_new"
-  deleteFn <- dlsym lib "mallocator_delete"
-  allocFn <- dlsym lib "mallocator_alloc"
-  freeFn <- dlsym lib "mallocator_free"
-  initFn <- dlsym lib "mallocator_init"
-  destroyFn <- dlsym lib "mallocator_destroy"
-  pure $ Bindings
-    { dynamicLib = lib
-    , withAlloc = mkWithAlloc newFn deleteFn
-    , fnAlloc = mkAlloc allocFn
-    , fnFree = mkFree freeFn
-    , fnInit = mkInit initFn
-    , fnDestroy = mkDestroy destroyFn
-    }
-  where
-    mkAlloc fn mallocator numBytes =
-      callFFI fn (retPtr retCUChar)
-        [ argPtr mallocator
-        , argCSize $ fromIntegral numBytes
-        ]
-    mkFree fn mallocator memory numBytes =
-      callFFI fn retVoid
-        [ argPtr mallocator
-        , argPtr memory
-        , argCSize $ fromIntegral numBytes
-        ]
-    mkInit fn mallocator =
-      callFFI fn retVoid [argPtr mallocator]
-    mkDestroy fn mallocator =
-      callFFI fn retVoid [argPtr mallocator]
-    mkNew fn =
-      callFFI fn (retPtr retVoid) []
-    mkDelete fn mallocator =
-      callFFI fn retVoid [argPtr mallocator]
-    mkWithAlloc newFn deleteFn =
-      bracket (castPtr <$> mkNew newFn) (mkDelete deleteFn)
-
 notUsed :: a
 notUsed = undefined
-
-intoIO :: Identity a -> IO a
-intoIO = pure . runIdentity
diff --git a/tests/eclair/Test/Eclair/LLVM/Allocator/Utils.hs b/tests/eclair/Test/Eclair/LLVM/Allocator/Utils.hs
new file mode 100644
index 0000000..352d5c6
--- /dev/null
+++ b/tests/eclair/Test/Eclair/LLVM/Allocator/Utils.hs
@@ -0,0 +1,91 @@
+module Test.Eclair.LLVM.Allocator.Utils
+  ( Bindings(..)
+  , compileAllocatorCode
+  , loadNativeCode
+  ) where
+
+import System.Process.Extra
+import System.FilePath
+import System.Posix.DynamicLinker
+import Eclair.LLVM.Codegen hiding (retVoid, nullPtr)
+import Eclair.LLVM.Allocator.Common
+import Control.Monad.Morph
+import Control.Exception
+import Foreign.LibFFI
+import Foreign.Ptr
+import Foreign.C
+
+type I8 = CUChar
+
+data Bindings a
+  = Bindings
+  { dynamicLib :: DL
+  , withAlloc :: (Ptr a -> IO ()) -> IO ()
+  , fnAlloc :: Ptr a -> CSize -> IO (Ptr I8)
+  , fnFree :: Ptr a -> Ptr I8 -> CSize -> IO ()
+  , fnInit :: Ptr a -> IO ()
+  , fnDestroy :: Ptr a -> IO ()
+  }
+
+compileAllocatorCode
+  :: Allocator a
+  -> Text
+  -> ModuleBuilderT IO Externals
+  -> (Type -> Operand -> Operand -> ModuleBuilderT IO ())
+  -> FilePath -> IO ()
+compileAllocatorCode allocator prefix cgExts cgHelperCode dir = do
+  llvmIR <- runModuleBuilderT $ do
+    exts <- cgExts
+    let cgBlueprint = flip evalStateT exts $ cgAlloc prefix allocator
+    blueprint <- hoist intoIO cgBlueprint
+    cgHelperCode (bpType blueprint) (extMalloc exts) (extFree exts)
+  let llvmIRText = ppllvm llvmIR
+  writeFileText (llFile dir) llvmIRText
+  callProcess "clang" ["-fPIC", "-shared", "-O0", "-o", soFile dir, llFile dir]
+
+intoIO :: Identity a -> IO a
+intoIO = pure . runIdentity
+
+llFile, soFile :: FilePath -> FilePath
+llFile dir = dir </> "allocator.ll"
+soFile dir = dir </> "allocator.so"
+
+loadNativeCode :: Text -> FilePath -> IO (Bindings a)
+loadNativeCode (toString -> pfx) dir = do
+  lib <- dlopen (soFile dir) [RTLD_LAZY]
+  newFn <- dlsym lib (pfx <> "_new")
+  deleteFn <- dlsym lib (pfx <> "_delete")
+  allocFn <- dlsym lib (pfx <> "_alloc")
+  freeFn <- dlsym lib (pfx <> "_free")
+  initFn <- dlsym lib (pfx <> "_init")
+  destroyFn <- dlsym lib (pfx <> "_destroy")
+  pure $ Bindings
+    { dynamicLib = lib
+    , withAlloc = mkWithAlloc newFn deleteFn
+    , fnAlloc = mkAlloc allocFn
+    , fnFree = mkFree freeFn
+    , fnInit = mkInit initFn
+    , fnDestroy = mkDestroy destroyFn
+    }
+  where
+    mkAlloc fn mallocator numBytes =
+      callFFI fn (retPtr retCUChar)
+        [ argPtr mallocator
+        , argCSize $ fromIntegral numBytes
+        ]
+    mkFree fn mallocator memory numBytes =
+      callFFI fn retVoid
+        [ argPtr mallocator
+        , argPtr memory
+        , argCSize $ fromIntegral numBytes
+        ]
+    mkInit fn mallocator =
+      callFFI fn retVoid [argPtr mallocator]
+    mkDestroy fn mallocator =
+      callFFI fn retVoid [argPtr mallocator]
+    mkNew fn =
+      callFFI fn (retPtr retVoid) []
+    mkDelete fn mallocator =
+      callFFI fn retVoid [argPtr mallocator]
+    mkWithAlloc newFn deleteFn =
+      bracket (castPtr <$> mkNew newFn) (mkDelete deleteFn)

From 6cdafc7f5527c1d286cb152afe277af6946ce8f3 Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Sat, 30 Sep 2023 09:33:03 +0200
Subject: [PATCH 02/15] Add setup code for btree unit tests

---
 eclair-lang.cabal                             |   1 +
 .../Test/Eclair/LLVM/Allocator/MallocSpec.hs  |   4 +-
 tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs    | 174 ++++++++++++++++++
 3 files changed, 177 insertions(+), 2 deletions(-)
 create mode 100644 tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs

diff --git a/eclair-lang.cabal b/eclair-lang.cabal
index 5e10b8b..b5630ab 100644
--- a/eclair-lang.cabal
+++ b/eclair-lang.cabal
@@ -258,6 +258,7 @@ test-suite eclair-test
     Test.Eclair.JSONSpec
     Test.Eclair.LLVM.Allocator.MallocSpec
     Test.Eclair.LLVM.Allocator.Utils
+    Test.Eclair.LLVM.BTreeSpec
     Test.Eclair.LLVM.HashSpec
     Test.Eclair.LSP.HandlersSpec
     Test.Eclair.LSP.JSONSpec
diff --git a/tests/eclair/Test/Eclair/LLVM/Allocator/MallocSpec.hs b/tests/eclair/Test/Eclair/LLVM/Allocator/MallocSpec.hs
index 567962a..a9ffe30 100644
--- a/tests/eclair/Test/Eclair/LLVM/Allocator/MallocSpec.hs
+++ b/tests/eclair/Test/Eclair/LLVM/Allocator/MallocSpec.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -Wno-deprecations -Wno-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 module Test.Eclair.LLVM.Allocator.MallocSpec
   ( module Test.Eclair.LLVM.Allocator.MallocSpec
   ) where
@@ -74,4 +74,4 @@ testDir :: FilePath
 testDir = "/tmp/eclair-mallocator"
 
 notUsed :: a
-notUsed = undefined
+notUsed = panic "Not used"
diff --git a/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs b/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
new file mode 100644
index 0000000..274cc8e
--- /dev/null
+++ b/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
@@ -0,0 +1,174 @@
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+module Test.Eclair.LLVM.BTreeSpec
+  ( module Test.Eclair.LLVM.BTreeSpec
+  ) where
+
+import Prelude hiding (void)
+import System.Directory.Extra (createDirectoryIfMissing)
+import System.Process.Extra
+import System.Posix.DynamicLinker
+import System.FilePath
+import Eclair.LLVM.BTree
+import Eclair.LLVM.Table
+import Eclair.LLVM.Externals
+import Eclair.LLVM.Codegen hiding (retVoid, nullPtr)
+import qualified LLVM.C.API as LibLLVM
+import Foreign.Ptr
+import Control.Exception
+import Test.Hspec
+import Foreign.LibFFI
+
+
+data BTree
+data Iter
+data Value
+
+data Bindings
+  = Bindings
+  { dynamicLib :: DL
+  , withTree :: (Ptr BTree -> IO ()) -> IO ()
+  , withIter :: (Ptr Iter -> IO ()) -> IO ()
+  , withValue :: (Ptr Value -> IO ()) -> IO ()
+  , bInit :: Ptr BTree -> IO ()
+  , bDestroy :: Ptr BTree -> IO ()
+  , bPurge :: Ptr BTree -> IO ()
+  , bSwap :: Ptr BTree -> Ptr BTree -> IO ()
+  , bBegin :: Ptr BTree -> Ptr Iter -> IO ()
+  , bEnd :: Ptr BTree -> Ptr Iter -> IO ()
+  , bInsert :: Ptr BTree -> Ptr Value -> IO Bool
+  , bEmpty :: Ptr BTree -> IO Bool
+  , bSize :: Ptr BTree -> IO Word64
+  , bContains :: Ptr BTree -> Ptr Value -> IO Bool
+  }
+
+
+spec :: Spec
+spec = describe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
+  it "TODO" $ \btree -> pending
+  -- TODO actual tests
+
+setupAndTeardown :: FilePath -> ActionWith Bindings -> IO ()
+setupAndTeardown dir =
+  bracket (setup dir) teardown
+
+setup :: FilePath -> IO Bindings
+setup dir = do
+  createDirectoryIfMissing False dir
+  let meta = Meta
+        { numColumns = 1
+        , index = [0]
+        , blockSize = 16
+        , searchType = Linear
+        }
+  cgBTree dir meta
+  loadNativeCode dir
+
+teardown :: Bindings -> IO ()
+teardown =
+  dlclose . dynamicLib
+
+cgBTree :: FilePath -> Meta -> IO ()
+cgBTree dir meta = do
+  ctx <- LibLLVM.mkContext
+  llvmMod <- LibLLVM.mkModule ctx "eclair"
+  td <- LibLLVM.getTargetData llvmMod
+  let cfg = Config Nothing ctx td
+  llvmIR <- runModuleBuilderT $ do
+    exts <- cgExternals
+    table <- instantiate "test" meta $ runConfigT cfg $ codegen exts
+    cgHelperCode table (extMalloc exts) (extFree exts)
+  let llvmIRText = ppllvm llvmIR
+  writeFileText (llFile dir) llvmIRText
+  callProcess "clang" ["-fPIC", "-shared", "-O0", "-o", soFile dir, llFile dir]
+
+cgExternals :: ModuleBuilderT IO Externals
+cgExternals = do
+  mallocFn <- extern "malloc" [i32] (ptr i8)
+  freeFn <- extern "free" [ptr i8] void
+  pure $ Externals mallocFn freeFn notUsed notUsed notUsed notUsed notUsed
+
+-- Helper test code for initializing and freeing a struct from native code:
+cgHelperCode :: Table -> Operand -> Operand -> ModuleBuilderT IO ()
+cgHelperCode table mallocFn freeFn = do
+  let treeTy = typeObj table
+      iterTy = typeIter table
+      valueTy = typeValue table
+  _ <- function "eclair_btree_new" [] (ptr treeTy) $ \[] ->
+    ret =<< call mallocFn [int32 1]
+  _ <- function "eclair_btree_delete" [(ptr treeTy, "btree")] void $ \[btree] ->
+    call freeFn [btree]
+  _ <- function "eclair_iter_new" [] (ptr iterTy) $ \[] ->
+    ret =<< call mallocFn [int32 16]
+  _ <- function "eclair_iter_delete" [(ptr iterTy, "iter")] void $ \[iter] ->
+    call freeFn [iter]
+  _ <- function "eclair_value_new" [] (ptr valueTy) $ \[] ->
+    ret =<< call mallocFn [int32 4] -- Hardcoded for 1x i32
+  _ <- function "eclair_value_delete" [(ptr valueTy, "value")] void $ \[value] ->
+    call freeFn [value]
+  pass
+
+loadNativeCode :: FilePath -> IO Bindings
+loadNativeCode dir = do
+  lib <- dlopen (soFile dir) [RTLD_LAZY]
+  funcNewTree <- dlsym lib "eclair_btree_new"
+  funcDeleteTree <- dlsym lib "eclair_btree_delete"
+  funcNewIter <- dlsym lib "eclair_iter_new"
+  funcDeleteIter <- dlsym lib "eclair_iter_delete"
+  funcNewValue <- dlsym lib "eclair_value_new"
+  funcDeleteValue <- dlsym lib "eclair_value_delete"
+  funcInit <- dlsym lib "eclair_btree_init_empty"
+  funcDestroy <- dlsym lib "eclair_btree_destroy"
+  funcPurge <- dlsym lib "eclair_btree_clear"
+  funcSwap <- dlsym lib "eclair_btree_swap"
+  funcBegin <- dlsym lib "eclair_btree_begin"
+  funcEnd <- dlsym lib "eclair_btree_end"
+  funcInsert <- dlsym lib "eclair_btree_insert_value"
+  funcEmpty <- dlsym lib "eclair_btree_is_empty"
+  funcSize <- dlsym lib "eclair_btree_size"
+  funcContains <- dlsym lib "eclair_btree_contains"
+  pure $ Bindings
+    { dynamicLib = lib
+    , withTree = mkWithX funcNewTree funcDeleteTree
+    , withIter = mkWithX funcNewIter funcDeleteIter
+    , withValue = mkWithX funcNewValue funcDeleteValue
+    , bInit = mkInit funcInit
+    , bDestroy = mkDestroy funcDestroy
+    , bPurge = mkPurge funcPurge
+    , bSwap = mkSwap funcSwap
+    , bBegin = mkBegin funcBegin
+    , bEnd = mkEnd funcEnd
+    , bInsert = mkInsert funcInsert
+    , bEmpty = mkIsEmpty funcEmpty
+    , bSize = mkSize funcSize
+    , bContains = mkContains funcContains
+    }
+  where
+    mkInit fn tree = callFFI fn retVoid [argPtr tree]
+    mkDestroy fn tree = callFFI fn retVoid [argPtr tree]
+    mkPurge fn tree = callFFI fn retVoid [argPtr tree]
+    mkSwap fn tree1 tree2 = callFFI fn retVoid [argPtr tree1, argPtr tree2]
+    mkBegin fn tree resultIter = callFFI fn retVoid [argPtr tree, argPtr resultIter]
+    mkEnd fn tree resultIter = callFFI fn retVoid [argPtr tree, argPtr resultIter]
+    mkInsert fn tree value = do
+      result <- callFFI fn retCUChar [argPtr tree, argPtr value]
+      pure $ result == 1
+    mkIsEmpty fn tree = do
+      result <- callFFI fn retCUChar [argPtr tree]
+      pure $ result == 1
+    mkSize fn tree = fromIntegral <$> callFFI fn retCULong [argPtr tree]
+    mkContains fn tree value = do
+      result <- callFFI fn retCUChar [argPtr tree, argPtr value]
+      pure $ result == 1
+    mkNew fn = callFFI fn (retPtr retVoid) []
+    mkDelete fn obj = callFFI fn retVoid [argPtr obj]
+    mkWithX newFn deleteFn = bracket (castPtr <$> mkNew newFn) (mkDelete deleteFn)
+
+llFile, soFile :: FilePath -> FilePath
+llFile dir = dir </> "btree.ll"
+soFile dir = dir </> "btree.so"
+
+testDir :: FilePath
+testDir = "/tmp/eclair-btree"
+
+notUsed :: a
+notUsed = panic "Not used"

From bcc8c37af4a970a380137593c4cb663ad230c7a1 Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Sun, 1 Oct 2023 10:43:51 +0200
Subject: [PATCH 03/15] Add more btree tests

---
 eclair-lang.cabal                             |   2 +
 .../Test/Eclair/LLVM/Allocator/Utils.hs       |   2 +-
 tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs    | 442 +++++++++++++++++-
 3 files changed, 425 insertions(+), 21 deletions(-)

diff --git a/eclair-lang.cabal b/eclair-lang.cabal
index b5630ab..0dec7c0 100644
--- a/eclair-lang.cabal
+++ b/eclair-lang.cabal
@@ -295,6 +295,7 @@ test-suite eclair-test
   cxx-options:        -std=c++17 -D__EMBEDDED_SOUFFLE__
   build-depends:
     , algebraic-graphs             <1
+    , array                        >=0.5   && <1
     , base                         >=4.7   && <5
     , bytestring                   >=0.11  && <0.12
     , comonad                      >=5     && <6
@@ -320,6 +321,7 @@ test-suite eclair-test
     , parser-combinators           >=1.3   && <1.4
     , prettyprinter                >=1.7   && <1.8
     , prettyprinter-ansi-terminal  >=1     && <2
+    , random                       >=1.2   && <2
     , recursion-schemes            >=5     && <6
     , relude                       >=1.2   && <1.3
     , rock                         >=0.3   && <0.4
diff --git a/tests/eclair/Test/Eclair/LLVM/Allocator/Utils.hs b/tests/eclair/Test/Eclair/LLVM/Allocator/Utils.hs
index 352d5c6..e0f836a 100644
--- a/tests/eclair/Test/Eclair/LLVM/Allocator/Utils.hs
+++ b/tests/eclair/Test/Eclair/LLVM/Allocator/Utils.hs
@@ -71,7 +71,7 @@ loadNativeCode (toString -> pfx) dir = do
     mkAlloc fn mallocator numBytes =
       callFFI fn (retPtr retCUChar)
         [ argPtr mallocator
-        , argCSize $ fromIntegral numBytes
+        , argCUInt $ fromIntegral numBytes
         ]
     mkFree fn mallocator memory numBytes =
       callFFI fn retVoid
diff --git a/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs b/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
index 274cc8e..1d26dd4 100644
--- a/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
+++ b/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
@@ -4,7 +4,8 @@ module Test.Eclair.LLVM.BTreeSpec
   ) where
 
 import Prelude hiding (void)
-import System.Directory.Extra (createDirectoryIfMissing)
+import qualified Relude as R
+import System.Directory.Extra
 import System.Process.Extra
 import System.Posix.DynamicLinker
 import System.FilePath
@@ -15,20 +16,23 @@ import Eclair.LLVM.Codegen hiding (retVoid, nullPtr)
 import qualified LLVM.C.API as LibLLVM
 import Foreign.Ptr
 import Control.Exception
-import Test.Hspec
 import Foreign.LibFFI
+import Foreign hiding (void, newArray)
+import System.Random
+import Data.Array.IO hiding (index)
+import Test.Hspec
 
 
 data BTree
 data Iter
-data Value
+type Value = Word32
 
 data Bindings
   = Bindings
   { dynamicLib :: DL
   , withTree :: (Ptr BTree -> IO ()) -> IO ()
-  , withIter :: (Ptr Iter -> IO ()) -> IO ()
-  , withValue :: (Ptr Value -> IO ()) -> IO ()
+  , withIter :: forall a. (Ptr Iter -> IO a) -> IO a
+  , withValue :: forall a. Value -> (Ptr Value -> IO a) -> IO a
   , bInit :: Ptr BTree -> IO ()
   , bDestroy :: Ptr BTree -> IO ()
   , bPurge :: Ptr BTree -> IO ()
@@ -38,14 +42,368 @@ data Bindings
   , bInsert :: Ptr BTree -> Ptr Value -> IO Bool
   , bEmpty :: Ptr BTree -> IO Bool
   , bSize :: Ptr BTree -> IO Word64
+  , bLowerBound :: forall a. Ptr BTree -> Ptr Value -> (Ptr Iter -> IO a) -> IO a
+  , bUpperBound :: forall a. Ptr BTree -> Ptr Value -> (Ptr Iter -> IO a) -> IO a
   , bContains :: Ptr BTree -> Ptr Value -> IO Bool
+  , bIterCurrent :: Ptr Iter -> IO (Ptr Value)
+  , bIterIsEqual :: Ptr Iter -> Ptr Iter -> IO Bool
   }
 
 
 spec :: Spec
 spec = describe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
-  it "TODO" $ \btree -> pending
-  -- TODO actual tests
+  it "can be initialized and destroyed" $ \bindings -> do
+    withTree bindings $ \tree -> do
+      bInit bindings tree
+      bDestroy bindings tree
+
+  it "is possible to remove all elements from the tree" $ \bindings ->
+    withTree bindings $ \tree -> do
+      bInit bindings tree
+
+      bPurge bindings tree -- empty trees
+      empty1 <- bEmpty bindings tree
+      bPurge bindings tree -- calling it again
+      empty2 <- bEmpty bindings tree
+
+      withValue bindings 1 $ R.void . bInsert bindings tree
+
+      empty3 <- bEmpty bindings tree
+      bPurge bindings tree -- non-empty tree
+      empty4 <- bEmpty bindings tree
+      bPurge bindings tree -- calling it again
+      empty5 <- bEmpty bindings tree
+
+      for_ [1..100] $ \i ->
+        withValue bindings i $ R.void . bInsert bindings tree
+      bPurge bindings tree -- calling it again
+      empty6 <- bEmpty bindings tree
+
+      bDestroy bindings tree
+
+      empty1 `shouldBe` True
+      empty2 `shouldBe` True
+      empty3 `shouldBe` False
+      empty4 `shouldBe` True
+      empty5 `shouldBe` True
+      empty6 `shouldBe` True
+
+  it "should be possible to merge one tree into another" $ \bindings ->
+    pending -- TODO look at souffle tests
+
+  it "is possible to swap two trees" $ \bindings -> do
+    withTree bindings $ \tree1 -> do
+      withTree bindings $ \tree2 -> do
+        bInit bindings tree1
+        bInit bindings tree2
+
+        for_ [1..100] $ \i -> do
+          withValue bindings i $ \value -> do
+            _ <- bInsert bindings tree1 value
+            pass
+          withValue bindings (i + 100) $ \value -> do
+            _ <- bInsert bindings tree2 value
+            pass
+
+        c1 <- withValue bindings 42 $ bContains bindings tree1
+        c2 <- withValue bindings 78 $ bContains bindings tree1
+        c3 <- withValue bindings 142 $ bContains bindings tree2
+        c4 <- withValue bindings 178 $ bContains bindings tree2
+
+        bSwap bindings tree1 tree2
+
+        c5 <- withValue bindings 42 $ bContains bindings tree2
+        c6 <- withValue bindings 78 $ bContains bindings tree2
+        c7 <- withValue bindings 142 $ bContains bindings tree1
+        c8 <- withValue bindings 178 $ bContains bindings tree1
+
+        bDestroy bindings tree1
+        bDestroy bindings tree2
+
+        let result = R.and [c1, c2, c3, c4, c5, c6, c7, c8]
+        result `shouldBe` True
+
+  it "is possible to get begin and end iterators" $ \bindings ->
+    withTree bindings $ \tree -> do
+      withIters bindings $ \beginIter endIter -> do
+        bInit bindings tree
+        bBegin bindings tree beginIter
+        bEnd bindings tree endIter
+        beginIter `shouldNotBe` nullPtr
+        endIter `shouldNotBe` nullPtr
+        bDestroy bindings tree
+
+  it "is possible to iterate over the tree" $ \bindings ->
+    pending  -- TODO + begin != end check
+
+  it "should have equal begin and end iterators if tree is empty" $ \bindings ->
+    withTree bindings $ \tree -> do
+      withIters bindings $ \beginIter endIter -> do
+        bInit bindings tree
+        bBegin bindings tree beginIter
+        bEnd bindings tree endIter
+        isEqual <- bIterIsEqual bindings beginIter endIter
+        isEqual `shouldBe` True
+        bDestroy bindings tree
+
+  it "is possible to insert a value" $ \bindings ->
+    withTree bindings $ \tree -> do
+      withValue bindings 1 $ \value -> do
+        bInit bindings tree
+        didInsert <- bInsert bindings tree value
+        didInsert' <- bInsert bindings tree value
+        didInsert `shouldBe` True
+        didInsert' `shouldBe` False
+        bDestroy bindings tree
+
+  it "is possible to check if the tree is empty" $ \bindings ->
+    withTree bindings $ \tree -> do
+      bInit bindings tree
+
+      empty1 <- bEmpty bindings tree
+      withValue bindings 1 $ R.void . bInsert bindings tree
+      empty2 <- bEmpty bindings tree
+      withValue bindings 2 $ R.void . bInsert bindings tree
+      empty3 <- bEmpty bindings tree
+
+      bDestroy bindings tree
+
+      empty1 `shouldBe` True
+      empty2 `shouldBe` False
+      empty3 `shouldBe` False
+
+  it "is possible to lookup the size of the tree" $ \bindings ->
+    withTree bindings $ \tree -> do
+      bInit bindings tree
+      size1 <- bSize bindings tree
+      withValue bindings 1 $ \value -> do
+        _ <- bInsert bindings tree value
+        pass
+      size2 <- bSize bindings tree
+      for_ [2..100] $ \i -> do
+        withValue bindings i $ \value -> do
+          _ <- bInsert bindings tree value
+          pass
+      size3 <- bSize bindings tree
+      bDestroy bindings tree
+      size1 `shouldBe` 0
+      size2 `shouldBe` 1
+      size3 `shouldBe` 100
+
+  it "is possible to check if the tree contains a certain value" $ \bindings ->
+    withTree bindings $ \tree -> do
+      bInit bindings tree
+
+      c1 <- withValue bindings 1000 $ bContains bindings tree
+      withValue bindings 1000 $ \value -> do
+        _ <- bInsert bindings tree value
+        pass
+      c2 <- withValue bindings 1000 $ bContains bindings tree
+
+      for_ [1..100] $ \i ->
+        withValue bindings i $ \value -> do
+          _ <- bInsert bindings tree value
+          pass
+
+      c3 <- withValue bindings 42 $ bContains bindings tree
+      c4 <- withValue bindings 78 $ bContains bindings tree
+      c5 <- withValue bindings 132 $ bContains bindings tree
+
+      c1 `shouldBe` False
+      c2 `shouldBe` True
+      c3 `shouldBe` True
+      c4 `shouldBe` True
+      c5 `shouldBe` False
+
+      bDestroy bindings tree
+
+  -- Tests below are taken from Souffle's test suite
+
+  it "should support basic operations on the btree" $ \bindings ->
+    withTree bindings $ \tree -> do
+      bInit bindings tree
+
+      -- check initial conditions
+      bSize bindings tree >>= (`shouldBe` 0)
+      withValue bindings 10 (bContains bindings tree) >>= (`shouldBe` False)
+      withValue bindings 12 (bContains bindings tree) >>= (`shouldBe` False)
+      withValue bindings 14 (bContains bindings tree) >>= (`shouldBe` False)
+
+      -- add an element
+
+      R.void $ withValue bindings 12 (bInsert bindings tree)
+      bSize bindings tree >>= (`shouldBe` 1)
+      withValue bindings 10 (bContains bindings tree) >>= (`shouldBe` False)
+      withValue bindings 12 (bContains bindings tree) >>= (`shouldBe` True)
+      withValue bindings 14 (bContains bindings tree) >>= (`shouldBe` False)
+
+      -- add a larger element
+      R.void $ withValue bindings 14 (bInsert bindings tree)
+      bSize bindings tree >>= (`shouldBe` 2)
+      withValue bindings 10 (bContains bindings tree) >>= (`shouldBe` False)
+      withValue bindings 12 (bContains bindings tree) >>= (`shouldBe` True)
+      withValue bindings 14 (bContains bindings tree) >>= (`shouldBe` True)
+
+      -- add a smaller element
+      R.void $ withValue bindings 10 (bInsert bindings tree)
+      bSize bindings tree >>= (`shouldBe` 3)
+      withValue bindings 10 (bContains bindings tree) >>= (`shouldBe` True)
+      withValue bindings 12 (bContains bindings tree) >>= (`shouldBe` True)
+      withValue bindings 14 (bContains bindings tree) >>= (`shouldBe` True)
+
+      -- cause a split
+      R.void $ withValue bindings 11 (bInsert bindings tree)
+      bSize bindings tree >>= (`shouldBe` 4)
+      withValue bindings 10 (bContains bindings tree) >>= (`shouldBe` True)
+      withValue bindings 11 (bContains bindings tree) >>= (`shouldBe` True)
+      withValue bindings 12 (bContains bindings tree) >>= (`shouldBe` True)
+      withValue bindings 14 (bContains bindings tree) >>= (`shouldBe` True)
+
+      -- adding duplicates
+      R.void $ withValue bindings 12 (bInsert bindings tree)
+      bSize bindings tree >>= (`shouldBe` 4)
+      R.void $ withValue bindings 12 (bInsert bindings tree)
+      bSize bindings tree >>= (`shouldBe` 4)
+      R.void $ withValue bindings 10 (bInsert bindings tree)
+      bSize bindings tree >>= (`shouldBe` 4)
+
+      R.void $ withValue bindings 15 (bInsert bindings tree)
+      bSize bindings tree >>= (`shouldBe` 5)
+
+      R.void $ withValue bindings 16 (bInsert bindings tree)
+      bSize bindings tree >>= (`shouldBe` 6)
+
+      bDestroy bindings tree
+
+      -- TODO manually check this:   EXPECT_EQ(3, test_set::max_keys_per_node);
+      -- TODO check depth + number of nodes (test code only)
+
+  it "should automatically remove duplicates" $ \bindings ->
+    withTree bindings $ \tree -> do
+      bInit bindings tree
+
+      replicateM_ 10 $ withValue bindings 0 $ bInsert bindings tree
+
+      size <- bSize bindings tree
+      value <- withIter bindings $ \iter -> do
+        bBegin bindings tree iter
+        valuePtr <- bIterCurrent bindings iter
+        peek valuePtr
+
+      bDestroy bindings tree
+
+      size `shouldBe` 1
+      value `shouldBe` 0
+
+  it "should contain the value after it is inserted" $ \bindings ->
+    withTree bindings $ \tree -> do
+      bInit bindings tree
+
+      let n = 1000
+      for_ [0..n] $ \i -> do
+        R.void $ withValue bindings i (bInsert bindings tree)
+
+        for_ [0..n] $ \j -> do
+          contains <- withValue bindings j (bContains bindings tree)
+          contains `shouldBe` (j <= i)
+
+      bDestroy bindings tree
+
+
+  it "should contain the value after it is inserted (reverse)" $ \bindings ->
+    withTree bindings $ \tree -> do
+      bInit bindings tree
+
+      let n = 1000
+      for_ [n, (n - 1) .. 0] $ \i -> do
+        R.void $ withValue bindings i (bInsert bindings tree)
+
+        for_ [0..n] $ \j -> do
+          contains <- withValue bindings j (bContains bindings tree)
+          contains `shouldBe` (j >= i)
+
+      bDestroy bindings tree
+
+  it "should the contain the value after is inserted (shuffled)" $ \bindings -> do
+    let list = [1..10000]
+    shuffled <- shuffle list
+
+    withTree bindings $ \tree -> do
+      bInit bindings tree
+
+      for_ shuffled $ \i -> do
+        R.void $ withValue bindings i (bInsert bindings tree)
+
+      for_ list $ \j -> do
+        contains <- withValue bindings j (bContains bindings tree)
+        contains `shouldBe` True
+
+      bDestroy bindings tree
+
+  it "should withstand iterator stress test" $ \bindings ->
+    pending
+
+  it "should calculate correct lower and upper bounds of a value" $ \bindings ->
+    withTree bindings $ \tree -> do
+      let getBound f = flip (f bindings tree) (peek <=< bIterCurrent bindings)
+          getLB = getBound bLowerBound
+          getUB = getBound bUpperBound
+
+      bInit bindings tree
+
+      for_ [0..10] $ \i -> do
+        R.void $ withValue bindings i (bInsert bindings tree)
+
+      lb1 <- withValue bindings 5 getLB
+      ub1 <- withValue bindings 5 getUB
+      lb1 `shouldBe` 5
+      ub1 `shouldBe` 6
+
+      -- add duplicates and check again
+      replicateM_ 3 $ R.void $ withValue bindings 5 $ bInsert bindings tree
+
+      lb2 <- withValue bindings 5 getLB
+      ub2 <- withValue bindings 5 getUB
+      lb2 `shouldBe` 5
+      ub2 `shouldBe` 6
+
+      bDestroy bindings tree
+
+  it "should calculate correct lower and upper bound for empty trees" $ \bindings ->
+    withTree bindings $ \tree ->
+      withIter bindings $ \endIter -> do
+        bInit bindings tree
+        bEnd bindings tree endIter
+
+        -- empty
+        lbIsEnd1 <- withValue bindings 5 $ flip (bLowerBound bindings tree) $
+          bIterIsEqual bindings endIter
+        ubIsEnd1 <- withValue bindings 5 $ flip (bUpperBound bindings tree) $
+          bIterIsEqual bindings endIter
+        lbIsEnd1 `shouldBe` True
+        ubIsEnd1 `shouldBe` True
+
+        let checkBounds expected3 expected5 = do
+              withValue bindings 3 $ flip (bLowerBound bindings tree) $ \lbIter ->
+                withValue bindings 3 $ flip (bUpperBound bindings tree) $ \ubIter -> do
+                  isEqual <- bIterIsEqual bindings lbIter ubIter
+                  isEqual `shouldBe` expected3
+              withValue bindings 5 $ flip (bLowerBound bindings tree) $ \lbIter ->
+                withValue bindings 5 $ flip (bUpperBound bindings tree) $ \ubIter -> do
+                  isEqual <- bIterIsEqual bindings lbIter ubIter
+                  isEqual `shouldBe` expected5
+
+        -- insert 4
+        R.void $ withValue bindings 4 (bInsert bindings tree)
+        checkBounds True True
+        -- insert 6
+        R.void $ withValue bindings 6 (bInsert bindings tree)
+        checkBounds True True
+        -- insert 5
+        R.void $ withValue bindings 5 (bInsert bindings tree)
+        checkBounds True False
+
+        bDestroy bindings tree
 
 setupAndTeardown :: FilePath -> ActionWith Bindings -> IO ()
 setupAndTeardown dir =
@@ -85,7 +443,8 @@ cgExternals :: ModuleBuilderT IO Externals
 cgExternals = do
   mallocFn <- extern "malloc" [i32] (ptr i8)
   freeFn <- extern "free" [ptr i8] void
-  pure $ Externals mallocFn freeFn notUsed notUsed notUsed notUsed notUsed
+  memsetFn <- extern "llvm.memset.p0i8.i64" [ptr i8, i8, i64, i1] void
+  pure $ Externals mallocFn freeFn memsetFn notUsed notUsed notUsed notUsed
 
 -- Helper test code for initializing and freeing a struct from native code:
 cgHelperCode :: Table -> Operand -> Operand -> ModuleBuilderT IO ()
@@ -116,21 +475,31 @@ loadNativeCode dir = do
   funcDeleteIter <- dlsym lib "eclair_iter_delete"
   funcNewValue <- dlsym lib "eclair_value_new"
   funcDeleteValue <- dlsym lib "eclair_value_delete"
-  funcInit <- dlsym lib "eclair_btree_init_empty"
-  funcDestroy <- dlsym lib "eclair_btree_destroy"
-  funcPurge <- dlsym lib "eclair_btree_clear"
-  funcSwap <- dlsym lib "eclair_btree_swap"
-  funcBegin <- dlsym lib "eclair_btree_begin"
-  funcEnd <- dlsym lib "eclair_btree_end"
-  funcInsert <- dlsym lib "eclair_btree_insert_value"
-  funcEmpty <- dlsym lib "eclair_btree_is_empty"
-  funcSize <- dlsym lib "eclair_btree_size"
-  funcContains <- dlsym lib "eclair_btree_contains"
+  funcInit <- dlsym lib "eclair_btree_init_empty_test"
+  funcDestroy <- dlsym lib "eclair_btree_destroy_test"
+  funcPurge <- dlsym lib "eclair_btree_clear_test"
+  funcSwap <- dlsym lib "eclair_btree_swap_test"
+  funcBegin <- dlsym lib "eclair_btree_begin_test"
+  funcEnd <- dlsym lib "eclair_btree_end_test"
+  funcInsert <- dlsym lib "eclair_btree_insert_value_test"
+  funcEmpty <- dlsym lib "eclair_btree_is_empty_test"
+  funcSize <- dlsym lib "eclair_btree_size_test"
+  funcContains <- dlsym lib "eclair_btree_contains_test"
+  funcLB <- dlsym lib "eclair_btree_lower_bound_test"
+  funcUB <- dlsym lib "eclair_btree_upper_bound_test"
+  funcIterCurrent <- dlsym lib "eclair_btree_iterator_current_test"
+  funcIterIsEqual <- dlsym lib "eclair_btree_iterator_is_equal_test"
+  let withIter' :: forall a. (Ptr Iter -> IO a) -> IO a
+      withIter' = mkWithX funcNewIter funcDeleteIter
+      iterCurrent = mkIterCurrent funcIterCurrent
   pure $ Bindings
     { dynamicLib = lib
     , withTree = mkWithX funcNewTree funcDeleteTree
-    , withIter = mkWithX funcNewIter funcDeleteIter
-    , withValue = mkWithX funcNewValue funcDeleteValue
+    , withIter = withIter'
+    , withValue = \value f -> do
+        mkWithX funcNewValue funcDeleteValue $ \valuePtr -> do
+          poke valuePtr value
+          f valuePtr
     , bInit = mkInit funcInit
     , bDestroy = mkDestroy funcDestroy
     , bPurge = mkPurge funcPurge
@@ -141,6 +510,10 @@ loadNativeCode dir = do
     , bEmpty = mkIsEmpty funcEmpty
     , bSize = mkSize funcSize
     , bContains = mkContains funcContains
+    , bIterCurrent = iterCurrent
+    , bIterIsEqual = mkIterIsEqual funcIterIsEqual
+    , bLowerBound = mkBound funcLB withIter'
+    , bUpperBound = mkBound funcUB withIter'
     }
   where
     mkInit fn tree = callFFI fn retVoid [argPtr tree]
@@ -162,6 +535,21 @@ loadNativeCode dir = do
     mkNew fn = callFFI fn (retPtr retVoid) []
     mkDelete fn obj = callFFI fn retVoid [argPtr obj]
     mkWithX newFn deleteFn = bracket (castPtr <$> mkNew newFn) (mkDelete deleteFn)
+    mkIterCurrent fn iter = do
+      castPtr <$> callFFI fn (retPtr retVoid) [argPtr iter]
+    mkIterIsEqual fn beginIter endIter = do
+      result <- callFFI fn retCUChar [argPtr beginIter, argPtr endIter]
+      pure $ result == 1
+    mkBound fn withIter' tree value f = do
+      withIter' $ \iter -> do
+        callFFI fn retVoid [argPtr tree, argPtr value, argPtr iter]
+        f iter
+
+withIters :: Bindings -> (Ptr Iter -> Ptr Iter -> IO ()) -> IO ()
+withIters bindings f =
+  withIter bindings $ \beginIter ->
+    withIter bindings $ \endIter ->
+      f beginIter endIter
 
 llFile, soFile :: FilePath -> FilePath
 llFile dir = dir </> "btree.ll"
@@ -172,3 +560,17 @@ testDir = "/tmp/eclair-btree"
 
 notUsed :: a
 notUsed = panic "Not used"
+
+shuffle :: [a] -> IO [a]
+shuffle xs = do
+  array <- mkArray n xs
+  forM [1..n] $ \i -> do
+    j <- randomRIO (i,n)
+    vi <- readArray array i
+    vj <- readArray array j
+    writeArray array j vi
+    pure vj
+  where
+    n = length xs
+    mkArray :: Int -> [a] -> IO (IOArray Int a)
+    mkArray m = newListArray (1,m)

From 1d8d1975802bcfceb9ebafd61ca558c653fa1aa7 Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Mon, 2 Oct 2023 10:08:59 +0200
Subject: [PATCH 04/15] Add iterator test + function to convert btree to list

---
 tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs | 56 ++++++++++++++++++++--
 1 file changed, 52 insertions(+), 4 deletions(-)

diff --git a/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs b/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
index 1d26dd4..6d201d8 100644
--- a/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
+++ b/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
@@ -46,12 +46,13 @@ data Bindings
   , bUpperBound :: forall a. Ptr BTree -> Ptr Value -> (Ptr Iter -> IO a) -> IO a
   , bContains :: Ptr BTree -> Ptr Value -> IO Bool
   , bIterCurrent :: Ptr Iter -> IO (Ptr Value)
+  , bIterNext :: Ptr Iter -> IO ()
   , bIterIsEqual :: Ptr Iter -> Ptr Iter -> IO Bool
   }
 
 
 spec :: Spec
-spec = describe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
+spec = fdescribe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
   it "can be initialized and destroyed" $ \bindings -> do
     withTree bindings $ \tree -> do
       bInit bindings tree
@@ -134,7 +135,25 @@ spec = describe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
         bDestroy bindings tree
 
   it "is possible to iterate over the tree" $ \bindings ->
-    pending  -- TODO + begin != end check
+    withTree bindings $ \tree -> do
+      bInit bindings tree
+
+      withValue bindings 4 $ R.void . bInsert bindings tree
+      withValue bindings 2 $ R.void . bInsert bindings tree
+      withValue bindings 5 $ R.void . bInsert bindings tree
+      withValue bindings 1 $ R.void . bInsert bindings tree
+      withValue bindings 3 $ R.void . bInsert bindings tree
+
+      withIters bindings $ \beginIter endIter -> do
+        bBegin bindings tree beginIter
+        bEnd bindings tree endIter
+        isEqual <- bIterIsEqual bindings beginIter endIter
+        isEqual `shouldBe` False
+
+      values <- treeToList bindings tree
+
+      bDestroy bindings tree
+      values `shouldBe` [1, 2, 3, 4, 5]
 
   it "should have equal begin and end iterators if tree is empty" $ \bindings ->
     withTree bindings $ \tree -> do
@@ -488,6 +507,7 @@ loadNativeCode dir = do
   funcLB <- dlsym lib "eclair_btree_lower_bound_test"
   funcUB <- dlsym lib "eclair_btree_upper_bound_test"
   funcIterCurrent <- dlsym lib "eclair_btree_iterator_current_test"
+  funcIterNext <- dlsym lib "eclair_btree_iterator_next_test"
   funcIterIsEqual <- dlsym lib "eclair_btree_iterator_is_equal_test"
   let withIter' :: forall a. (Ptr Iter -> IO a) -> IO a
       withIter' = mkWithX funcNewIter funcDeleteIter
@@ -511,6 +531,7 @@ loadNativeCode dir = do
     , bSize = mkSize funcSize
     , bContains = mkContains funcContains
     , bIterCurrent = iterCurrent
+    , bIterNext = mkIterNext funcIterNext
     , bIterIsEqual = mkIterIsEqual funcIterIsEqual
     , bLowerBound = mkBound funcLB withIter'
     , bUpperBound = mkBound funcUB withIter'
@@ -535,8 +556,10 @@ loadNativeCode dir = do
     mkNew fn = callFFI fn (retPtr retVoid) []
     mkDelete fn obj = callFFI fn retVoid [argPtr obj]
     mkWithX newFn deleteFn = bracket (castPtr <$> mkNew newFn) (mkDelete deleteFn)
-    mkIterCurrent fn iter = do
+    mkIterCurrent fn iter =
       castPtr <$> callFFI fn (retPtr retVoid) [argPtr iter]
+    mkIterNext fn iter =
+      callFFI fn retVoid [argPtr iter]
     mkIterIsEqual fn beginIter endIter = do
       result <- callFFI fn retCUChar [argPtr beginIter, argPtr endIter]
       pure $ result == 1
@@ -545,12 +568,26 @@ loadNativeCode dir = do
         callFFI fn retVoid [argPtr tree, argPtr value, argPtr iter]
         f iter
 
-withIters :: Bindings -> (Ptr Iter -> Ptr Iter -> IO ()) -> IO ()
+withIters :: Bindings -> (Ptr Iter -> Ptr Iter -> IO a) -> IO a
 withIters bindings f =
   withIter bindings $ \beginIter ->
     withIter bindings $ \endIter ->
       f beginIter endIter
 
+treeToList :: Bindings -> Ptr BTree -> IO [Value]
+treeToList bindings tree =
+  withIters bindings $ \beginIter endIter -> do
+    bBegin bindings tree beginIter
+    bEnd bindings tree endIter
+
+    whileM (isNotEqualIter beginIter endIter) $ do
+      value <- bIterCurrent bindings beginIter
+      bIterNext bindings beginIter
+      peek value
+  where
+    isNotEqualIter beginIter endIter = do
+      not <$> bIterIsEqual bindings beginIter endIter
+
 llFile, soFile :: FilePath -> FilePath
 llFile dir = dir </> "btree.ll"
 soFile dir = dir </> "btree.so"
@@ -561,6 +598,17 @@ testDir = "/tmp/eclair-btree"
 notUsed :: a
 notUsed = panic "Not used"
 
+whileM :: Monad m => m Bool -> m a -> m [a]
+whileM cond action = go
+  where
+    go = cond >>= \case
+      True -> do
+        x <- action
+        xs <- go
+        pure $ x:xs
+      False ->
+        pure []
+
 shuffle :: [a] -> IO [a]
 shuffle xs = do
   array <- mkArray n xs

From b9e025d6a1a798a833fb62f7f203f4f290c9af93 Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Mon, 2 Oct 2023 10:57:23 +0200
Subject: [PATCH 05/15] Add more btree tests

---
 tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs | 81 ++++++++++++++++++----
 1 file changed, 66 insertions(+), 15 deletions(-)

diff --git a/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs b/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
index 6d201d8..6ebcd36 100644
--- a/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
+++ b/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
@@ -9,17 +9,17 @@ import System.Directory.Extra
 import System.Process.Extra
 import System.Posix.DynamicLinker
 import System.FilePath
+import Control.Exception
+import Control.Monad.Morph
+import System.Random
+import Data.Array.IO hiding (index)
+import Foreign.LibFFI
+import Foreign hiding (void, newArray)
 import Eclair.LLVM.BTree
 import Eclair.LLVM.Table
 import Eclair.LLVM.Externals
 import Eclair.LLVM.Codegen hiding (retVoid, nullPtr)
 import qualified LLVM.C.API as LibLLVM
-import Foreign.Ptr
-import Control.Exception
-import Foreign.LibFFI
-import Foreign hiding (void, newArray)
-import System.Random
-import Data.Array.IO hiding (index)
 import Test.Hspec
 
 
@@ -40,6 +40,7 @@ data Bindings
   , bBegin :: Ptr BTree -> Ptr Iter -> IO ()
   , bEnd :: Ptr BTree -> Ptr Iter -> IO ()
   , bInsert :: Ptr BTree -> Ptr Value -> IO Bool
+  , bMerge :: Ptr BTree -> Ptr BTree -> IO ()
   , bEmpty :: Ptr BTree -> IO Bool
   , bSize :: Ptr BTree -> IO Word64
   , bLowerBound :: forall a. Ptr BTree -> Ptr Value -> (Ptr Iter -> IO a) -> IO a
@@ -90,7 +91,24 @@ spec = fdescribe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
       empty6 `shouldBe` True
 
   it "should be possible to merge one tree into another" $ \bindings ->
-    pending -- TODO look at souffle tests
+    withTree bindings $ \tree1 -> do
+      withTree bindings $ \tree2 -> do
+        bInit bindings tree1
+        bInit bindings tree2
+
+        for_ [1..4] $ \i -> do
+          withValue bindings i $ bInsert bindings tree1
+        for_ [2, 4, 6] $ \i -> do
+          withValue bindings i $ bInsert bindings tree2
+
+        -- tree1 = "destination", tree2 = "source"
+        bMerge bindings tree1 tree2
+        list <- treeToList bindings tree1
+
+        bDestroy bindings tree1
+        bDestroy bindings tree2
+
+        list `shouldBe` [1, 2, 3, 4, 6]
 
   it "is possible to swap two trees" $ \bindings -> do
     withTree bindings $ \tree1 -> do
@@ -359,8 +377,22 @@ spec = fdescribe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
 
       bDestroy bindings tree
 
-  it "should withstand iterator stress test" $ \bindings ->
-    pending
+  it "should withstand iterator stress test" $ \bindings -> do
+    let isSorted xs = sort xs == xs
+        list = [1..1000]
+    shuffled <- shuffle list
+
+    withTree bindings $ \tree -> do
+      bInit bindings tree
+
+      for_ shuffled $ \i -> do
+        values <- treeToList bindings tree
+        -- this is the main check if iterators are working correctly:
+        isSorted values `shouldBe` True
+
+        R.void $ withValue bindings i (bInsert bindings tree)
+
+      bDestroy bindings tree
 
   it "should calculate correct lower and upper bounds of a value" $ \bindings ->
     withTree bindings $ \tree -> do
@@ -453,6 +485,14 @@ cgBTree dir meta = do
   llvmIR <- runModuleBuilderT $ do
     exts <- cgExternals
     table <- instantiate "test" meta $ runConfigT cfg $ codegen exts
+    let iterParams = IteratorParams
+          { ipIterCurrent = fnIterCurrent table
+          , ipIterNext = fnIterNext table
+          , ipIterIsEqual = fnIterIsEqual table
+          , ipTypeIter = typeIter table
+          }
+    R.void $ hoist intoIO $ instantiate "test" iterParams $
+      fnInsertRangeTemplate table
     cgHelperCode table (extMalloc exts) (extFree exts)
   let llvmIRText = ppllvm llvmIR
   writeFileText (llFile dir) llvmIRText
@@ -501,6 +541,7 @@ loadNativeCode dir = do
   funcBegin <- dlsym lib "eclair_btree_begin_test"
   funcEnd <- dlsym lib "eclair_btree_end_test"
   funcInsert <- dlsym lib "eclair_btree_insert_value_test"
+  funcMerge <- dlsym lib "eclair_btree_insert_range_test"
   funcEmpty <- dlsym lib "eclair_btree_is_empty_test"
   funcSize <- dlsym lib "eclair_btree_size_test"
   funcContains <- dlsym lib "eclair_btree_contains_test"
@@ -512,6 +553,8 @@ loadNativeCode dir = do
   let withIter' :: forall a. (Ptr Iter -> IO a) -> IO a
       withIter' = mkWithX funcNewIter funcDeleteIter
       iterCurrent = mkIterCurrent funcIterCurrent
+      begin' = mkBegin funcBegin
+      end' = mkEnd funcEnd
   pure $ Bindings
     { dynamicLib = lib
     , withTree = mkWithX funcNewTree funcDeleteTree
@@ -524,9 +567,10 @@ loadNativeCode dir = do
     , bDestroy = mkDestroy funcDestroy
     , bPurge = mkPurge funcPurge
     , bSwap = mkSwap funcSwap
-    , bBegin = mkBegin funcBegin
-    , bEnd = mkEnd funcEnd
+    , bBegin = begin'
+    , bEnd = end'
     , bInsert = mkInsert funcInsert
+    , bMerge = mkMerge funcMerge withIter' begin' end'
     , bEmpty = mkIsEmpty funcEmpty
     , bSize = mkSize funcSize
     , bContains = mkContains funcContains
@@ -546,6 +590,12 @@ loadNativeCode dir = do
     mkInsert fn tree value = do
       result <- callFFI fn retCUChar [argPtr tree, argPtr value]
       pure $ result == 1
+    mkMerge fn withIter' begin' end' tree1 tree2 = do
+      withIter' $ \beginIter ->
+        withIter' $ \endIter -> do
+          R.void $ begin' tree2 beginIter
+          R.void $ end' tree2 endIter
+          callFFI fn retVoid [argPtr tree1, argPtr beginIter, argPtr endIter]
     mkIsEmpty fn tree = do
       result <- callFFI fn retCUChar [argPtr tree]
       pure $ result == 1
@@ -556,10 +606,8 @@ loadNativeCode dir = do
     mkNew fn = callFFI fn (retPtr retVoid) []
     mkDelete fn obj = callFFI fn retVoid [argPtr obj]
     mkWithX newFn deleteFn = bracket (castPtr <$> mkNew newFn) (mkDelete deleteFn)
-    mkIterCurrent fn iter =
-      castPtr <$> callFFI fn (retPtr retVoid) [argPtr iter]
-    mkIterNext fn iter =
-      callFFI fn retVoid [argPtr iter]
+    mkIterCurrent fn iter = castPtr <$> callFFI fn (retPtr retVoid) [argPtr iter]
+    mkIterNext fn iter = callFFI fn retVoid [argPtr iter]
     mkIterIsEqual fn beginIter endIter = do
       result <- callFFI fn retCUChar [argPtr beginIter, argPtr endIter]
       pure $ result == 1
@@ -622,3 +670,6 @@ shuffle xs = do
     n = length xs
     mkArray :: Int -> [a] -> IO (IOArray Int a)
     mkArray m = newListArray (1,m)
+
+intoIO :: Identity a -> IO a
+intoIO = pure . runIdentity

From 2f0792e1db5f29dc635894e6576834d407e64d8d Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Tue, 3 Oct 2023 12:36:19 +0200
Subject: [PATCH 06/15] Add depth and num node checks to basic btree test

---
 .gitignore                                 |   2 +
 tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs | 108 +++++++++++++++++++--
 2 files changed, 103 insertions(+), 7 deletions(-)

diff --git a/.gitignore b/.gitignore
index ef13abc..3ce19b5 100644
--- a/.gitignore
+++ b/.gitignore
@@ -22,3 +22,5 @@ eclair.hp
 perf.data
 perf.data.old
 perf.svg
+
+TODO*
diff --git a/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs b/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
index 6ebcd36..b38ef7f 100644
--- a/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
+++ b/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
@@ -43,6 +43,8 @@ data Bindings
   , bMerge :: Ptr BTree -> Ptr BTree -> IO ()
   , bEmpty :: Ptr BTree -> IO Bool
   , bSize :: Ptr BTree -> IO Word64
+  , bNodeCount :: Ptr BTree -> IO Word64
+  , bDepth :: Ptr BTree -> IO Word32
   , bLowerBound :: forall a. Ptr BTree -> Ptr Value -> (Ptr Iter -> IO a) -> IO a
   , bUpperBound :: forall a. Ptr BTree -> Ptr Value -> (Ptr Iter -> IO a) -> IO a
   , bContains :: Ptr BTree -> Ptr Value -> IO Bool
@@ -53,7 +55,7 @@ data Bindings
 
 
 spec :: Spec
-spec = fdescribe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
+spec = describe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
   it "can be initialized and destroyed" $ \bindings -> do
     withTree bindings $ \tree -> do
       bInit bindings tree
@@ -256,12 +258,14 @@ spec = fdescribe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
 
   -- Tests below are taken from Souffle's test suite
 
-  it "should support basic operations on the btree" $ \bindings ->
+  fit "should support basic operations on the btree" $ \bindings ->
     withTree bindings $ \tree -> do
       bInit bindings tree
 
       -- check initial conditions
       bSize bindings tree >>= (`shouldBe` 0)
+      bNodeCount bindings tree >>= (`shouldBe` 0)
+      bDepth bindings tree >>= (`shouldBe` 0)
       withValue bindings 10 (bContains bindings tree) >>= (`shouldBe` False)
       withValue bindings 12 (bContains bindings tree) >>= (`shouldBe` False)
       withValue bindings 14 (bContains bindings tree) >>= (`shouldBe` False)
@@ -270,13 +274,17 @@ spec = fdescribe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
 
       R.void $ withValue bindings 12 (bInsert bindings tree)
       bSize bindings tree >>= (`shouldBe` 1)
+      bNodeCount bindings tree >>= (`shouldBe` 1)
+      bDepth bindings tree >>= (`shouldBe` 1)
       withValue bindings 10 (bContains bindings tree) >>= (`shouldBe` False)
-      withValue bindings 12 (bContains bindings tree) >>= (`shouldBe` True)
+      withValue bindings 12 (bContains bindings tree) >>= (`shouldBe` True) -- TODO failing
       withValue bindings 14 (bContains bindings tree) >>= (`shouldBe` False)
 
       -- add a larger element
       R.void $ withValue bindings 14 (bInsert bindings tree)
       bSize bindings tree >>= (`shouldBe` 2)
+      bNodeCount bindings tree >>= (`shouldBe` 1)
+      bDepth bindings tree >>= (`shouldBe` 1)
       withValue bindings 10 (bContains bindings tree) >>= (`shouldBe` False)
       withValue bindings 12 (bContains bindings tree) >>= (`shouldBe` True)
       withValue bindings 14 (bContains bindings tree) >>= (`shouldBe` True)
@@ -284,6 +292,8 @@ spec = fdescribe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
       -- add a smaller element
       R.void $ withValue bindings 10 (bInsert bindings tree)
       bSize bindings tree >>= (`shouldBe` 3)
+      bNodeCount bindings tree >>= (`shouldBe` 1)
+      bDepth bindings tree >>= (`shouldBe` 1)
       withValue bindings 10 (bContains bindings tree) >>= (`shouldBe` True)
       withValue bindings 12 (bContains bindings tree) >>= (`shouldBe` True)
       withValue bindings 14 (bContains bindings tree) >>= (`shouldBe` True)
@@ -306,15 +316,14 @@ spec = fdescribe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
 
       R.void $ withValue bindings 15 (bInsert bindings tree)
       bSize bindings tree >>= (`shouldBe` 5)
+      bNodeCount bindings tree >>= (`shouldBe` 3)
+      bDepth bindings tree >>= (`shouldBe` 2)
 
       R.void $ withValue bindings 16 (bInsert bindings tree)
       bSize bindings tree >>= (`shouldBe` 6)
 
       bDestroy bindings tree
 
-      -- TODO manually check this:   EXPECT_EQ(3, test_set::max_keys_per_node);
-      -- TODO check depth + number of nodes (test code only)
-
   it "should automatically remove duplicates" $ \bindings ->
     withTree bindings $ \tree -> do
       bInit bindings tree
@@ -496,6 +505,8 @@ cgBTree dir meta = do
     cgHelperCode table (extMalloc exts) (extFree exts)
   let llvmIRText = ppllvm llvmIR
   writeFileText (llFile dir) llvmIRText
+  -- Next line is a hack, because we can't access node types from the test:
+  appendFileText (llFile dir) helperCodeAppendix
   callProcess "clang" ["-fPIC", "-shared", "-O0", "-o", soFile dir, llFile dir]
 
 cgExternals :: ModuleBuilderT IO Externals
@@ -506,7 +517,7 @@ cgExternals = do
   pure $ Externals mallocFn freeFn memsetFn notUsed notUsed notUsed notUsed
 
 -- Helper test code for initializing and freeing a struct from native code:
-cgHelperCode :: Table -> Operand -> Operand -> ModuleBuilderT IO ()
+cgHelperCode :: Monad m => Table -> Operand -> Operand -> ModuleBuilderT m ()
 cgHelperCode table mallocFn freeFn = do
   let treeTy = typeObj table
       iterTy = typeIter table
@@ -525,6 +536,83 @@ cgHelperCode table mallocFn freeFn = do
     call freeFn [value]
   pass
 
+helperCodeAppendix :: Text
+helperCodeAppendix = unlines
+  [ "define external ccc i64 @node_count(ptr %node_0) {"
+  , "start:"
+  , "  %stack.ptr_0 = alloca i64"  -- count
+  , "  store i64 1, ptr %stack.ptr_0"
+  , "  %0 = getelementptr %node_t_test, ptr %node_0, i32 0, i32 0, i32 3"
+  , "  %1 = load i1, ptr %0" -- node type
+  , "  %2 = icmp eq i1 %1, 0" -- is leaf?
+  , "  br i1 %2, label %if_0, label %end_if_0"
+  , "if_0:"
+  , "  ret i64 1"
+  , "end_if_0:"
+  , "  %3 = getelementptr %node_t_test, ptr %node_0, i32 0, i32 0, i32 2"
+  , "  %4 = load i16, ptr %3"
+  , "  br label %for_begin_0"
+  , "for_begin_0:"
+  , "  %5 = phi i16 [0, %end_if_0], [%12, %for_body_0]"
+  , "  %6 = icmp ule i16 %5, %4"
+  , "  br i1 %6, label %for_body_0, label %for_end_0"
+  , "for_body_0:"
+  , "  %7 = load i64, ptr %stack.ptr_0" -- count
+  , "  %8 = getelementptr %inner_node_t_test, ptr %node_0, i32 0, i32 1, i16 %5" -- child ptr
+  , "  %9 = load ptr, ptr %8" -- child
+  , "  %10 = call ccc i64 @node_count(ptr %9)"
+  , "  %11 = add i64 %7, %10"
+  , "  store i64 %11, ptr %stack.ptr_0"
+  , "  %12 = add i16 1, %5"
+  , "  br label %for_begin_0"
+  , "for_end_0:"
+  , "  %13 = load i64, ptr %stack.ptr_0"
+  , "  ret i64 %13"
+  , "}"
+  , ""
+  , "define external ccc i64 @eclair_btree_node_count_test(ptr %tree_0) {"
+  , "start:"
+  , "  %0 = getelementptr %btree_t_test, ptr %tree_0, i32 0, i32 0"
+  , "  %1 = load ptr, ptr %0"
+  , "  %2 = icmp eq ptr %1, zeroinitializer"
+  , "  br i1 %2, label %null_0, label %not_null_0"
+  , "null_0:"
+  , "  ret i64 0"
+  , "not_null_0:"
+  , "  %3 = call ccc i64 @node_count(ptr %1)"
+  , "  ret i64 %3"
+  , "}"
+  , ""
+  , "define external ccc i32 @node_depth(ptr %node_0) {"
+  , "start:"
+  , "  %0 = getelementptr %node_t_test, ptr %node_0, i32 0, i32 0, i32 3"
+  , "  %1 = load i1, ptr %0" -- node type
+  , "  %2 = icmp eq i1 %1, 0" -- is leaf?
+  , "  br i1 %2, label %if_0, label %end_if_0"
+  , "if_0:"
+  , "  ret i32 1"
+  , "end_if_0:"
+  , "  %3 = getelementptr %inner_node_t_test, ptr %node_0, i32 0, i32 1, i16 0" -- child ptr
+  , "  %4 = load ptr, ptr %3" -- child
+  , "  %5 = call ccc i32 @node_depth(ptr %4)"
+  , "  %6 = add i32 %5, 1"
+  , "  ret i32 %6"
+  , "}"
+  , ""
+  , "define external ccc i32 @eclair_btree_depth_test(ptr %tree_0) {"
+  , "start:"
+  , "  %0 = getelementptr %btree_t_test, ptr %tree_0, i32 0, i32 0"
+  , "  %1 = load ptr, ptr %0"
+  , "  %2 = icmp eq ptr %1, zeroinitializer"
+  , "  br i1 %2, label %null_0, label %not_null_0"
+  , "null_0:"
+  , "  ret i32 0"
+  , "not_null_0:"
+  , "  %3 = call ccc i32 @node_depth(ptr %1)"
+  , "  ret i32 %3"
+  , "}"
+  ]
+
 loadNativeCode :: FilePath -> IO Bindings
 loadNativeCode dir = do
   lib <- dlopen (soFile dir) [RTLD_LAZY]
@@ -544,6 +632,8 @@ loadNativeCode dir = do
   funcMerge <- dlsym lib "eclair_btree_insert_range_test"
   funcEmpty <- dlsym lib "eclair_btree_is_empty_test"
   funcSize <- dlsym lib "eclair_btree_size_test"
+  funcNodeCount <- dlsym lib "eclair_btree_node_count_test"
+  funcDepth <- dlsym lib "eclair_btree_depth_test"
   funcContains <- dlsym lib "eclair_btree_contains_test"
   funcLB <- dlsym lib "eclair_btree_lower_bound_test"
   funcUB <- dlsym lib "eclair_btree_upper_bound_test"
@@ -573,6 +663,8 @@ loadNativeCode dir = do
     , bMerge = mkMerge funcMerge withIter' begin' end'
     , bEmpty = mkIsEmpty funcEmpty
     , bSize = mkSize funcSize
+    , bNodeCount = mkNodeCount funcNodeCount
+    , bDepth = mkDepth funcDepth
     , bContains = mkContains funcContains
     , bIterCurrent = iterCurrent
     , bIterNext = mkIterNext funcIterNext
@@ -600,6 +692,8 @@ loadNativeCode dir = do
       result <- callFFI fn retCUChar [argPtr tree]
       pure $ result == 1
     mkSize fn tree = fromIntegral <$> callFFI fn retCULong [argPtr tree]
+    mkNodeCount fn tree = fromIntegral <$> callFFI fn retCULong [argPtr tree]
+    mkDepth fn tree = fromIntegral <$> callFFI fn retCUInt [argPtr tree]
     mkContains fn tree value = do
       result <- callFFI fn retCUChar [argPtr tree, argPtr value]
       pure $ result == 1

From 2979e5d7e3c04198e26dcd7eecaa9fe741f9a9da Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Wed, 4 Oct 2023 20:07:58 +0200
Subject: [PATCH 07/15] Disallow xit in tests also

---
 tests/check.sh | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/check.sh b/tests/check.sh
index f9b199f..2fed148 100755
--- a/tests/check.sh
+++ b/tests/check.sh
@@ -7,7 +7,7 @@ if [ "$?" == "0" ]; then
   exit 1
 fi
 
-grep -rE "pending" tests/eclair/Test
+grep -rE "(xit|pending)" tests/eclair/Test
 if [ "$?" == "0" ]; then
   echo "Found pending tests, aborting!"
   exit 1

From 6d4c7dc2bd9094d93533d655f06565da528f3f03 Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Wed, 4 Oct 2023 20:09:33 +0200
Subject: [PATCH 08/15] Fix potential uninitialized memory access in btree find

---
 lib/Eclair/LLVM/BTree/Find.hs | 10 +++++-----
 1 file changed, 5 insertions(+), 5 deletions(-)

diff --git a/lib/Eclair/LLVM/BTree/Find.hs b/lib/Eclair/LLVM/BTree/Find.hs
index 8af015e..5e18be0 100644
--- a/lib/Eclair/LLVM/BTree/Find.hs
+++ b/lib/Eclair/LLVM/BTree/Find.hs
@@ -51,11 +51,11 @@ mkBtreeFind isEmptyTree searchLowerBound compareValues iterInit iterInitEnd = do
 
       -- Can the following equality check be done using just pointers?
       foundMatch <- pos `ult` last
-      matchesVal <- (int8 0 `eq`) =<< call compareValues [pos, val]
-      foundValue <- foundMatch `and` matchesVal
-      if' foundValue $ do
-        _ <- call iterInit [result, current, idx]
-        retVoid
+      if' foundMatch $ do
+        matchesVal <- (int8 0 `eq`) =<< call compareValues [pos, val]
+        if' matchesVal $ do
+          _ <- call iterInit [result, current, idx]
+          retVoid
 
       isLeaf <- deref (metaOf ->> nodeTypeOf) current >>= (`eq` leafNodeTypeVal)
       if' isLeaf $ do

From e67cbb25904c1fb40312a50f72df0324691c9d0f Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Wed, 4 Oct 2023 20:11:00 +0200
Subject: [PATCH 09/15] Add small fixes in btree unit tests

---
 tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs | 11 ++++++++---
 1 file changed, 8 insertions(+), 3 deletions(-)

diff --git a/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs b/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
index b38ef7f..bf895cc 100644
--- a/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
+++ b/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
@@ -523,7 +523,7 @@ cgHelperCode table mallocFn freeFn = do
       iterTy = typeIter table
       valueTy = typeValue table
   _ <- function "eclair_btree_new" [] (ptr treeTy) $ \[] ->
-    ret =<< call mallocFn [int32 1]
+    ret =<< call mallocFn [int32 16]
   _ <- function "eclair_btree_delete" [(ptr treeTy, "btree")] void $ \[btree] ->
     call freeFn [btree]
   _ <- function "eclair_iter_new" [] (ptr iterTy) $ \[] ->
@@ -534,11 +534,16 @@ cgHelperCode table mallocFn freeFn = do
     ret =<< call mallocFn [int32 4] -- Hardcoded for 1x i32
   _ <- function "eclair_value_delete" [(ptr valueTy, "value")] void $ \[value] ->
     call freeFn [value]
+  -- Next function is needed because returning i1 is not C ABI compatible
+  _ <- function "eclair_btree_contains_helper_test" [(ptr treeTy, "tree"), (ptr valueTy, "val")] i8 $ \[tree, val] -> do
+    result <- call (fnContains table) [tree, val] >>= (`zext` i8)
+    ret result
   pass
 
 helperCodeAppendix :: Text
 helperCodeAppendix = unlines
-  [ "define external ccc i64 @node_count(ptr %node_0) {"
+  [ ""
+  , "define external ccc i64 @node_count(ptr %node_0) {"
   , "start:"
   , "  %stack.ptr_0 = alloca i64"  -- count
   , "  store i64 1, ptr %stack.ptr_0"
@@ -634,7 +639,7 @@ loadNativeCode dir = do
   funcSize <- dlsym lib "eclair_btree_size_test"
   funcNodeCount <- dlsym lib "eclair_btree_node_count_test"
   funcDepth <- dlsym lib "eclair_btree_depth_test"
-  funcContains <- dlsym lib "eclair_btree_contains_test"
+  funcContains <- dlsym lib "eclair_btree_contains_helper_test"
   funcLB <- dlsym lib "eclair_btree_lower_bound_test"
   funcUB <- dlsym lib "eclair_btree_upper_bound_test"
   funcIterCurrent <- dlsym lib "eclair_btree_iterator_current_test"

From 02441793ea608d0211c9ba1aa5e07c2692dfca58 Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Wed, 4 Oct 2023 20:49:01 +0200
Subject: [PATCH 10/15] Fix another potential memory access issue

---
 lib/Eclair/LLVM/BTree/Insert.hs | 15 ++++++---------
 1 file changed, 6 insertions(+), 9 deletions(-)

diff --git a/lib/Eclair/LLVM/BTree/Insert.hs b/lib/Eclair/LLVM/BTree/Insert.hs
index 1949dd9..3ca1bf5 100644
--- a/lib/Eclair/LLVM/BTree/Insert.hs
+++ b/lib/Eclair/LLVM/BTree/Insert.hs
@@ -85,11 +85,8 @@ mkGrowParent nodeNew insertInner = mdo
 
     assign (metaOf ->> parentOf) n newRoot
     assign (metaOf ->> parentOf) sibling newRoot
-    -- TODO: why missing in souffle code? happens in another function?
-    -- also: why is num elements of n not decremented?
-    -- assign (metaOf ->> posInParentOf) n (int16 0)
 
-    -- update (metaOf ->> numElemsOf) n (`sub` (int16 1))
+    -- assign (metaOf ->> posInParentOf) n (int16 0) -- Not needed, root already has position 0
     assign (metaOf ->> posInParentOf) sibling (int16 1)
     store root 0 newRoot
     retVoid
@@ -310,7 +307,7 @@ mkBtreeInsertValue nodeNew compareValues searchLowerBound searchUpperBound isEmp
       pos <- call searchLowerBound [val, first, last]
       idx <- pointerDiff i16 pos first >>= (`udiv` int32 (toInteger valSize))
       notLast <- pos `ne` last
-      isEqual <- (int8 0 `eq`) =<< call compareValues [pos, val]  -- Can we do a weak compare just by using pointers here?
+      isEqual <- (int8 0 `eq`) =<< call compareValues [pos, val]
       alreadyInserted <- notLast `and` isEqual
       condBr alreadyInserted noInsert continueInsert
 
@@ -332,10 +329,10 @@ mkBtreeInsertValue nodeNew compareValues searchLowerBound searchUpperBound isEmp
       distance <- pointerDiff i16 pos first >>= (`udiv` int32 (toInteger valSize))
       idxPtr <- allocate i16 distance
       notFirst <- pos `ne` first
-      valueAtPrevPos <- gep pos [int32 (-1)]
-      isEqual <- (int8 0 `eq`) =<< call compareValues [valueAtPrevPos, val]  -- Can we do a weak compare just by using pointers here?
-      alreadyInserted <- notFirst `and` isEqual
-      condBr alreadyInserted noInsert continueInsert
+      if' notFirst $ do
+        valueAtPrevPos <- gep pos [int32 (-1)]
+        alreadyInserted <- (int8 0 `eq`) =<< call compareValues [valueAtPrevPos, val]
+        condBr alreadyInserted noInsert continueInsert
 
       continueInsert <- blockNamed "leaf_continue_insert"
       nodeIsFull <- numElems `uge` numberOfKeys

From 6ceaeb8ceef191278a67a57f5972db3a147d7f6e Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Wed, 4 Oct 2023 20:58:23 +0200
Subject: [PATCH 11/15] Fix another potential memory access issue during insert

---
 lib/Eclair/LLVM/BTree/Insert.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/lib/Eclair/LLVM/BTree/Insert.hs b/lib/Eclair/LLVM/BTree/Insert.hs
index 3ca1bf5..b63f3bc 100644
--- a/lib/Eclair/LLVM/BTree/Insert.hs
+++ b/lib/Eclair/LLVM/BTree/Insert.hs
@@ -307,9 +307,9 @@ mkBtreeInsertValue nodeNew compareValues searchLowerBound searchUpperBound isEmp
       pos <- call searchLowerBound [val, first, last]
       idx <- pointerDiff i16 pos first >>= (`udiv` int32 (toInteger valSize))
       notLast <- pos `ne` last
-      isEqual <- (int8 0 `eq`) =<< call compareValues [pos, val]
-      alreadyInserted <- notLast `and` isEqual
-      condBr alreadyInserted noInsert continueInsert
+      if' notLast $ do
+        alreadyInserted <- (int8 0 `eq`) =<< call compareValues [pos, val]
+        condBr alreadyInserted noInsert continueInsert
 
       continueInsert <- blockNamed "inner_continue_insert"
       let iCurrent = ptrcast innerNode current

From bb34ce4fab3b327032146d522b814a73a8bfb77e Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Wed, 4 Oct 2023 21:08:26 +0200
Subject: [PATCH 12/15] Fix another potential memory access issue during bounds
 computation

---
 lib/Eclair/LLVM/BTree/Bounds.hs | 11 +++++------
 1 file changed, 5 insertions(+), 6 deletions(-)

diff --git a/lib/Eclair/LLVM/BTree/Bounds.hs b/lib/Eclair/LLVM/BTree/Bounds.hs
index 9436811..fe92e5b 100644
--- a/lib/Eclair/LLVM/BTree/Bounds.hs
+++ b/lib/Eclair/LLVM/BTree/Bounds.hs
@@ -98,12 +98,11 @@ mkBtreeLowerBound isEmptyTree iterInit iterInitEnd searchLowerBound compareValue
         retVoid
 
       isNotLast <- pos `ne` last
-      -- Can the following be done with just pointer comparisons?
-      matchesVal' <- (int8 0 `eq`) =<< call compareValues [pos, val]
-      matchFound <- isNotLast `and` matchesVal'
-      if' matchFound $ do
-        _ <- call iterInit [result, current, idx]
-        retVoid
+      if' isNotLast $ do
+        matchFound' <- (int8 0 `eq`) =<< call compareValues [pos, val]
+        if' matchFound' $ do
+          _ <- call iterInit [result, current, idx]
+          retVoid
 
       if' isNotLast $ do
         call iterInit [res, current, idx]

From 1596aa480baa554d70bd277ec0c9747bd32371bb Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Thu, 5 Oct 2023 10:07:39 +0200
Subject: [PATCH 13/15] Fix bug due to comparing signed values as unsigned

---
 lib/Eclair/LLVM/BTree/Insert.hs | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/lib/Eclair/LLVM/BTree/Insert.hs b/lib/Eclair/LLVM/BTree/Insert.hs
index b63f3bc..89a1c6b 100644
--- a/lib/Eclair/LLVM/BTree/Insert.hs
+++ b/lib/Eclair/LLVM/BTree/Insert.hs
@@ -140,7 +140,7 @@ mkInsertInner rebalanceOrSplit = mdo
     numElems'' <- deref (metaOf ->> numElemsOf) n
     startIdx <- sub numElems'' (int16 1)
     pos' <- load posPtr 0
-    loopFor startIdx (`uge` pos') (`sub` int16 1) $ \i -> mdo
+    loopFor startIdx (`sge` pos') (`sub` int16 1) $ \i -> mdo
       j <- add i (int16 1)
       k <- add i (int16 2)
       assign (valueAt j) n =<< deref (valueAt i) n
@@ -149,7 +149,6 @@ mkInsertInner rebalanceOrSplit = mdo
       increment int16 (metaOf ->> posInParentOf) childK
 
     -- TODO: assert(i_n->children[pos] == predecessor);
-
     -- Insert new element
     assign (valueAt pos') n =<< load key 0
     pos'' <- add pos' (int16 1)

From 063d3a09736242004d0717de345216822f2028c2 Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Thu, 5 Oct 2023 10:22:06 +0200
Subject: [PATCH 14/15] Clean up btree tests

---
 lib/Eclair/LLVM/BTree/Insert.hs            | 15 ++++++++---
 tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs | 29 ++++++++--------------
 2 files changed, 22 insertions(+), 22 deletions(-)

diff --git a/lib/Eclair/LLVM/BTree/Insert.hs b/lib/Eclair/LLVM/BTree/Insert.hs
index 89a1c6b..c757ebc 100644
--- a/lib/Eclair/LLVM/BTree/Insert.hs
+++ b/lib/Eclair/LLVM/BTree/Insert.hs
@@ -34,6 +34,7 @@ mkSplit nodeNew nodeSplitPoint growParent = mdo
     ty <- deref (metaOf ->> nodeTypeOf) n
     -- Create a new sibling node and move some of the data to sibling
     sibling <- call nodeNew [ty]
+
     jPtr <- allocate i16 (int16 0)
     loopFor splitPoint' (`ult` numberOfKeys) (add (int16 1)) $ \i -> mdo
       j <- load jPtr 0
@@ -220,15 +221,21 @@ mkRebalanceOrSplit splitFn = mdo
           leftNumElems' <- deref (metaOf ->> numElemsOf) left
           leftPos <- add leftNumElems' (int16 1) >>= add i
           assign (childAt leftPos) iLeft =<< deref (childAt i) iN
-          leftChild <- deref (childAt leftPos) iLeft
-          assign (metaOf ->> parentOf) leftChild left
-          assign (metaOf ->> posInParentOf) leftChild leftPos
 
-        -- Shift child pointer to the left + update position
+        -- Update moved children
+        loopFor (int16 0) (`ult` leftSlotsOpen) (add (int16 1)) $ \i -> do
+          leftNumElems' <- deref (metaOf ->> numElemsOf) left
+          leftPos <- add leftNumElems' (int16 1) >>= add i
+          child <- deref (childAt i) iN
+          assign (metaOf ->> parentOf) child left
+          assign (metaOf ->> posInParentOf) child leftPos
+
+        -- Shift child pointer to the left
         endIdx <- sub numElemsN leftSlotsOpen >>= add (int16 1)
         loopFor (int16 0) (`ult` endIdx) (add (int16 1)) $ \i -> do
           j <- add i leftSlotsOpen
           assign (childAt i) iN =<< deref (childAt j) iN
+          -- Update position of children
           child <- deref (childAt i) iN
           assign (metaOf ->> posInParentOf) child i
 
diff --git a/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs b/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
index bf895cc..adf91a2 100644
--- a/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
+++ b/tests/eclair/Test/Eclair/LLVM/BTreeSpec.hs
@@ -215,14 +215,10 @@ spec = describe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
     withTree bindings $ \tree -> do
       bInit bindings tree
       size1 <- bSize bindings tree
-      withValue bindings 1 $ \value -> do
-        _ <- bInsert bindings tree value
-        pass
+      R.void $ withValue bindings 1 $ bInsert bindings tree
       size2 <- bSize bindings tree
       for_ [2..100] $ \i -> do
-        withValue bindings i $ \value -> do
-          _ <- bInsert bindings tree value
-          pass
+        withValue bindings i $ bInsert bindings tree
       size3 <- bSize bindings tree
       bDestroy bindings tree
       size1 `shouldBe` 0
@@ -234,9 +230,7 @@ spec = describe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
       bInit bindings tree
 
       c1 <- withValue bindings 1000 $ bContains bindings tree
-      withValue bindings 1000 $ \value -> do
-        _ <- bInsert bindings tree value
-        pass
+      R.void $ withValue bindings 1000 $ bInsert bindings tree
       c2 <- withValue bindings 1000 $ bContains bindings tree
 
       for_ [1..100] $ \i ->
@@ -258,7 +252,7 @@ spec = describe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
 
   -- Tests below are taken from Souffle's test suite
 
-  fit "should support basic operations on the btree" $ \bindings ->
+  it "should support basic operations on the btree" $ \bindings ->
     withTree bindings $ \tree -> do
       bInit bindings tree
 
@@ -345,22 +339,21 @@ spec = describe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
     withTree bindings $ \tree -> do
       bInit bindings tree
 
-      let n = 1000
+      let n = 100
       for_ [0..n] $ \i -> do
-        R.void $ withValue bindings i (bInsert bindings tree)
+        R.void $ withValue bindings i $ bInsert bindings tree
 
         for_ [0..n] $ \j -> do
-          contains <- withValue bindings j (bContains bindings tree)
+          contains <- withValue bindings j $ bContains bindings tree
           contains `shouldBe` (j <= i)
 
       bDestroy bindings tree
 
-
   it "should contain the value after it is inserted (reverse)" $ \bindings ->
     withTree bindings $ \tree -> do
       bInit bindings tree
 
-      let n = 1000
+      let n = 100
       for_ [n, (n - 1) .. 0] $ \i -> do
         R.void $ withValue bindings i (bInsert bindings tree)
 
@@ -370,7 +363,7 @@ spec = describe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
 
       bDestroy bindings tree
 
-  it "should the contain the value after is inserted (shuffled)" $ \bindings -> do
+  it "should contain the value after is inserted (shuffled)" $ \bindings -> do
     let list = [1..10000]
     shuffled <- shuffle list
 
@@ -388,7 +381,8 @@ spec = describe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
 
   it "should withstand iterator stress test" $ \bindings -> do
     let isSorted xs = sort xs == xs
-        list = [1..1000]
+        list = [1..300]  -- for faster unit tests
+        -- list = [1..1000]  -- for real stress test
     shuffled <- shuffle list
 
     withTree bindings $ \tree -> do
@@ -398,7 +392,6 @@ spec = describe "BTree" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
         values <- treeToList bindings tree
         -- this is the main check if iterators are working correctly:
         isSorted values `shouldBe` True
-
         R.void $ withValue bindings i (bInsert bindings tree)
 
       bDestroy bindings tree

From 45bff9c273006fe3e9cda7768a28c9828305d779 Mon Sep 17 00:00:00 2001
From: Luc Tielen <luc.tielen@gmail.com>
Date: Thu, 5 Oct 2023 10:22:21 +0200
Subject: [PATCH 15/15] Fix CI check for tests marked with "xit"

---
 tests/check.sh | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/check.sh b/tests/check.sh
index 2fed148..cbda6b9 100755
--- a/tests/check.sh
+++ b/tests/check.sh
@@ -7,7 +7,7 @@ if [ "$?" == "0" ]; then
   exit 1
 fi
 
-grep -rE "(xit|pending)" tests/eclair/Test
+grep -rE "(\sxit|pending)" tests/eclair/Test
 if [ "$?" == "0" ]; then
   echo "Found pending tests, aborting!"
   exit 1