From 761bb42e609531373a7b86cabac0d6b93417005d Mon Sep 17 00:00:00 2001 From: Luc Tielen Date: Sat, 7 Oct 2023 11:34:59 +0200 Subject: [PATCH] Add tests for runtime hashmap --- eclair-lang.cabal | 2 + lib/Eclair/LLVM/HashMap.hs | 1 - tests/eclair/Test/Eclair/LLVM/HashMapSpec.hs | 231 +++++++++++++++++++ tests/eclair/Test/Eclair/LLVM/SymbolSpec.hs | 89 +------ tests/eclair/Test/Eclair/LLVM/SymbolUtils.hs | 110 +++++++++ 5 files changed, 344 insertions(+), 89 deletions(-) create mode 100644 tests/eclair/Test/Eclair/LLVM/HashMapSpec.hs create mode 100644 tests/eclair/Test/Eclair/LLVM/SymbolUtils.hs diff --git a/eclair-lang.cabal b/eclair-lang.cabal index 4fd2057..48997a8 100644 --- a/eclair-lang.cabal +++ b/eclair-lang.cabal @@ -259,8 +259,10 @@ test-suite eclair-test Test.Eclair.LLVM.Allocator.MallocSpec Test.Eclair.LLVM.Allocator.Utils Test.Eclair.LLVM.BTreeSpec + Test.Eclair.LLVM.HashMapSpec Test.Eclair.LLVM.HashSpec Test.Eclair.LLVM.SymbolSpec + Test.Eclair.LLVM.SymbolUtils Test.Eclair.LLVM.VectorSpec Test.Eclair.LSP.HandlersSpec Test.Eclair.LSP.JSONSpec diff --git a/lib/Eclair/LLVM/HashMap.hs b/lib/Eclair/LLVM/HashMap.hs index d41c237..04e9651 100644 --- a/lib/Eclair/LLVM/HashMap.hs +++ b/lib/Eclair/LLVM/HashMap.hs @@ -226,4 +226,3 @@ symbolOf = mkPath [int32 0] valueOf :: Path 'EntryIdx 'ValueIdx valueOf = mkPath [int32 1] - diff --git a/tests/eclair/Test/Eclair/LLVM/HashMapSpec.hs b/tests/eclair/Test/Eclair/LLVM/HashMapSpec.hs new file mode 100644 index 0000000..800b1d0 --- /dev/null +++ b/tests/eclair/Test/Eclair/LLVM/HashMapSpec.hs @@ -0,0 +1,231 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module Test.Eclair.LLVM.HashMapSpec + ( module Test.Eclair.LLVM.HashMapSpec + ) where + +import Prelude hiding (void, HashMap, Symbol) +import Control.Exception +import Control.Monad.Morph +import qualified Test.Eclair.LLVM.SymbolUtils as S +import qualified LLVM.C.API as LibLLVM +import Eclair.LLVM.HashMap +import qualified Eclair.LLVM.Symbol as S +import Eclair.LLVM.Codegen hiding (retVoid, nullPtr) +import Eclair.LLVM.Externals +import Foreign.LibFFI +import Foreign hiding (void) +import System.Posix.DynamicLinker +import System.Directory.Extra +import System.Process.Extra +import System.FilePath +import Test.Hspec + +type Value = Word32 + +data Bindings + = Bindings + { dynamicLib :: DL + , symBindings :: S.Bindings + , withHashMap :: (Ptr HashMap -> IO ()) -> IO () + , bInit :: Ptr HashMap -> IO () + , bDestroy :: Ptr HashMap -> IO () + , bGetOrPut :: Ptr HashMap -> Ptr S.Symbol -> Value -> IO Value + , bLookup :: Ptr HashMap -> Ptr S.Symbol -> IO Value + , bContains :: Ptr HashMap -> Ptr S.Symbol -> IO Bool + } + +spec :: Spec +spec = describe "HashMap" $ aroundAll (setupAndTeardown testDir) $ parallel $ do + it "can be initialized and destroyed" $ \bindings -> + withHashMap bindings $ \hm -> do + bInit bindings hm + bDestroy bindings hm + + it "stores a new value if the requested key was not found" $ \bindings -> do + let sBindings = symBindings bindings + withHashMap bindings $ \hm -> do + bInit bindings hm + + withSym sBindings "abcd" $ \sym -> do + value1 <- bGetOrPut bindings hm sym 42 + value1 `shouldBe` 42 + + -- different symbol -> separate entry in the hashmap + withSym sBindings "abcdef" $ \sym' -> do + value3 <- bGetOrPut bindings hm sym' 34 + value3 `shouldBe` 34 + pass + + bDestroy bindings hm + + it "retrieves the old value if the requested key was found" $ \bindings -> do + let sBindings = symBindings bindings + withHashMap bindings $ \hm -> do + bInit bindings hm + + withSym sBindings "abcd" $ \sym -> do + value1 <- bGetOrPut bindings hm sym 42 + value1 `shouldBe` 42 + value2 <- bGetOrPut bindings hm sym 100 + value2 `shouldBe` 42 + + -- same symbol -> same entry in the hashmap + withSym sBindings "abcd" $ \sym' -> do + value4 <- bGetOrPut bindings hm sym' 34 + value4 `shouldBe` 42 + + bDestroy bindings hm + + it "is possible to lookup keys in the hashmap" $ \bindings -> do + let sBindings = symBindings bindings + withHashMap bindings $ \hm -> do + bInit bindings hm + + -- key found + withSym sBindings "abcd" $ \sym -> do + _ <- bGetOrPut bindings hm sym 42 + value <- bLookup bindings hm sym + value `shouldBe` 42 + + -- key not found + withSym sBindings "123" $ \sym -> do + value <- bLookup bindings hm sym + value `shouldBe` 0xffffffff + + bDestroy bindings hm + + it "is possible to check if a hashmap contains a key" $ \bindings -> do + let sBindings = symBindings bindings + withHashMap bindings $ \hm -> do + bInit bindings hm + + -- key found + withSym sBindings "abcd" $ \sym -> do + _ <- bGetOrPut bindings hm sym 42 + value <- bContains bindings hm sym + value `shouldBe` True + + -- key not found + withSym sBindings "123" $ \sym -> do + value <- bContains bindings hm sym + value `shouldBe` False + + bDestroy bindings hm + +-- TODO big hashmap test + test for colissions + +setupAndTeardown :: FilePath -> ActionWith Bindings -> IO () +setupAndTeardown dir = + bracket (setup dir) teardown + +setup :: FilePath -> IO Bindings +setup dir = do + createDirectoryIfMissing False dir + compileCode cgExternals cgTestCode dir + loadNativeCode dir + +teardown :: Bindings -> IO () +teardown = + dlclose . dynamicLib + +compileCode + :: ModuleBuilderT IO Externals + -> (S.Symbol -> HashMap -> Externals -> ModuleBuilderT IO ()) + -> FilePath -> IO () +compileCode cgExts cgHelperCode dir = do + ctx <- LibLLVM.mkContext + llvmMod <- LibLLVM.mkModule ctx "eclair" + td <- LibLLVM.getTargetData llvmMod + llvmIR <- runModuleBuilderT $ do + exts <- cgExts + let cfg = Config Nothing ctx td + sym <- hoist intoIO $ S.codegen exts + hm <- runConfigT cfg $ codegen sym exts + cgHelperCode sym hm 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 + +cgExternals :: ModuleBuilderT IO Externals +cgExternals = do + mallocFn <- extern "malloc" [i32] (ptr i8) + freeFn <- extern "free" [ptr i8] void + memcpyFn <- extern "memcpy" [ptr i8, ptr i8, i64] (ptr i8) + memcmpFn <- extern "memcmp" [ptr i8, ptr i8, i64] i32 + pure $ Externals mallocFn freeFn notUsed memcpyFn memcmpFn notUsed notUsed + +cgTestCode :: S.Symbol -> HashMap -> Externals -> ModuleBuilderT IO () +cgTestCode sym hm exts = do + let hmTypes = hashMapTypes hm + hmTy = tyHashMap hmTypes + tySym = tyKey hmTypes + mallocFn = extMalloc exts + freeFn = extFree exts + + _ <- function "eclair_hashmap_new" [] (ptr hmTy) $ \[] -> + ret =<< call mallocFn [int32 $ 64 * 32] -- 64 vectors long + _ <- function "eclair_hashmap_delete" [(ptr hmTy, "hm")] void $ \[h] -> + call freeFn [h] + let args = [(ptr hmTy, "hashmap"), (ptr tySym, "symbol")] + _ <- function "eclair_hashmap_contains_helper" args i8 $ \[h, s] -> do + result <- call (hashMapContains hm) [h, s] + ret =<< result `zext` i8 + + S.cgTestCode sym exts + +loadNativeCode :: FilePath -> IO Bindings +loadNativeCode dir = do + lib <- dlopen (soFile dir) [RTLD_LAZY] + sBindings <- S.loadNativeCode' lib + fnNew <- dlsym lib "eclair_hashmap_new" + fnDelete <- dlsym lib "eclair_hashmap_delete" + fnInit <- dlsym lib "eclair_hashmap_init" + fnDestroy <- dlsym lib "eclair_hashmap_destroy" + fnGetOrPut <- dlsym lib "eclair_hashmap_get_or_put_value" + fnContains <- dlsym lib "eclair_hashmap_contains_helper" + fnLookup <- dlsym lib "eclair_hashmap_lookup" + pure $ Bindings + { dynamicLib = lib + , symBindings = sBindings + , withHashMap = mkWithHashMap fnNew fnDelete + , bInit = mkInit fnInit + , bDestroy = mkDestroy fnDestroy + , bGetOrPut = mkGetOrPut fnGetOrPut + , bContains = mkContains fnContains + , bLookup = mkLookup fnLookup + } + where + mkNew fn = callFFI fn (retPtr retVoid) [] + mkDelete fn hm = callFFI fn retVoid [argPtr hm] + mkWithHashMap fnNew fnDelete = + bracket (castPtr <$> mkNew fnNew) (mkDelete fnDelete) + mkInit fn hm = callFFI fn retVoid [argPtr hm] + mkDestroy fn hm = callFFI fn retVoid [argPtr hm] + mkGetOrPut fn hm sym value = + fromIntegral <$> callFFI fn retCUInt [argPtr hm, argPtr sym, argCUInt $ fromIntegral value] + mkContains fn hm sym = do + result <- callFFI fn retCUChar [argPtr hm, argPtr sym] + pure $ result == 1 + mkLookup fn hm sym = + fromIntegral <$> callFFI fn retCUInt [argPtr hm, argPtr sym] + +testDir :: FilePath +testDir = "/tmp/eclair-hashmap" + +llFile, soFile :: FilePath -> FilePath +llFile dir = dir "hashmap.ll" +soFile dir = dir "hashmap.so" + +notUsed :: a +notUsed = panic "Not used" + +withSym :: S.Bindings -> String -> (Ptr S.Symbol -> IO a) -> IO a +withSym bindings str f = do + S.withSymbol bindings $ \sym -> do + S.bInit bindings sym str + result <- f sym + S.bDestroy bindings sym + pure result diff --git a/tests/eclair/Test/Eclair/LLVM/SymbolSpec.hs b/tests/eclair/Test/Eclair/LLVM/SymbolSpec.hs index 904c395..32a5b0c 100644 --- a/tests/eclair/Test/Eclair/LLVM/SymbolSpec.hs +++ b/tests/eclair/Test/Eclair/LLVM/SymbolSpec.hs @@ -4,32 +4,17 @@ module Test.Eclair.LLVM.SymbolSpec ) where import Prelude hiding (void, Symbol) +import Test.Eclair.LLVM.SymbolUtils import Control.Monad.Morph import Control.Exception import Eclair.LLVM.Symbol import Eclair.LLVM.Codegen hiding (retVoid, nullPtr) import Eclair.LLVM.Externals -import Foreign.LibFFI -import Foreign hiding (void, bit) import System.Posix.DynamicLinker import System.Directory.Extra import System.Process.Extra -import System.FilePath import Test.Hspec -import Foreign.C -type I8 = CUChar - -data Bindings - = Bindings - { dynamicLib :: DL - , withSymbol :: (Ptr Symbol -> IO ()) -> IO () - , bInit :: Ptr Symbol -> String -> IO () - , bDestroy :: Ptr Symbol -> IO () - , bIsEqual :: Ptr Symbol -> Ptr Symbol -> IO Bool - , bLength :: Ptr Symbol -> IO Word32 - , bData :: Ptr Symbol -> IO String - } spec :: Spec spec = describe "Symbol" $ aroundAll (setupAndTeardown testDir) $ parallel $ do @@ -95,81 +80,9 @@ cgExternals = do memcmpFn <- extern "memcmp" [ptr i8, ptr i8, i64] i32 pure $ Externals mallocFn freeFn notUsed memcpyFn memcmpFn notUsed notUsed -cgTestCode :: Symbol -> Externals -> ModuleBuilderT IO () -cgTestCode sym exts = do - let mallocFn = extMalloc exts - freeFn = extFree exts - memcpyFn = extMemcpy exts - symTy = tySymbol sym - _ <- function "eclair_symbol_new" [] (ptr symTy) $ \[] -> - ret =<< call mallocFn [int32 16] - _ <- function "eclair_symbol_delete" [(ptr symTy, "sym")] void $ \[s] -> - call freeFn [s] - let initArgs = [(ptr symTy, "sym"), (i32, "length"), (ptr i8, "data")] - _ <- function "eclair_symbol_init_helper" initArgs void $ \[s, len, str] -> do - -- Needed because "str" is freed afterwards - memory <- call mallocFn [len] - _ <- call memcpyFn [memory, str, len, bit 0] - _ <- call (symbolInit sym) [s, len, memory] - pass - let isEqArgs = [(ptr symTy, "sym1"), (ptr symTy, "sym2")] - _ <- function "eclair_symbol_is_equal_helper" isEqArgs i8 $ \[sym1, sym2] -> do - isEq <- call (symbolIsEqual sym) [sym1, sym2] - ret =<< isEq `zext` i8 - _ <- function "eclair_symbol_length" [(ptr symTy, "sym")] i32 $ \[s] -> do - lenPtr <- gep s [int32 0, int32 0] - ret =<< load lenPtr 0 - _ <- function "eclair_symbol_data" [(ptr symTy, "sym")] (ptr i8) $ \[s] -> do - lenPtr <- gep s [int32 0, int32 1] - ret =<< load lenPtr 0 - pass - -loadNativeCode :: FilePath -> IO Bindings -loadNativeCode dir = do - lib <- dlopen (soFile dir) [RTLD_LAZY] - fnNew <- dlsym lib "eclair_symbol_new" - fnDelete <- dlsym lib "eclair_symbol_delete" - fnInit <- dlsym lib "eclair_symbol_init_helper" - fnDestroy <- dlsym lib "eclair_symbol_destroy" - fnIsEqual <- dlsym lib "eclair_symbol_is_equal_helper" - fnLength <- dlsym lib "eclair_symbol_length" - fnData <- dlsym lib "eclair_symbol_data" - let getLength = mkLength fnLength - pure $ Bindings - { dynamicLib = lib - , withSymbol = mkWithSymbol fnNew fnDelete - , bInit = mkInit fnInit - , bDestroy = mkDestroy fnDestroy - , bIsEqual = mkIsEqual fnIsEqual - , bLength = getLength - , bData = mkData fnData getLength - } - where - mkNew fn = callFFI fn (retPtr retVoid) [] - mkDelete fn sym = callFFI fn retVoid [argPtr sym] - mkWithSymbol fnNew fnDelete = - bracket (castPtr <$> mkNew fnNew) (mkDelete fnDelete) - mkInit fn sym str = do - let len = fromIntegral $ length str - callFFI fn retVoid [argPtr sym, argCUInt len, argString str] - mkDestroy fn sym = callFFI fn retVoid [argPtr sym] - mkIsEqual fn sym1 sym2 = do - result <- callFFI fn retCUChar [argPtr sym1, argPtr sym2] - pure $ result == 1 - mkLength fn sym = do - fromIntegral <$> callFFI fn retCUInt [argPtr sym] - mkData fn getLength sym = do - len <- fromIntegral <$> getLength sym - strPtr <- callFFI fn (retPtr retCChar) [argPtr sym] - peekCAStringLen (strPtr, len) - testDir :: FilePath testDir = "/tmp/eclair-symbol" -llFile, soFile :: FilePath -> FilePath -llFile dir = dir "symbol.ll" -soFile dir = dir "symbol.so" - notUsed :: a notUsed = panic "Not used" diff --git a/tests/eclair/Test/Eclair/LLVM/SymbolUtils.hs b/tests/eclair/Test/Eclair/LLVM/SymbolUtils.hs new file mode 100644 index 0000000..3d58d67 --- /dev/null +++ b/tests/eclair/Test/Eclair/LLVM/SymbolUtils.hs @@ -0,0 +1,110 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module Test.Eclair.LLVM.SymbolUtils + ( Bindings(..) + , Symbol(..) + , cgTestCode + , loadNativeCode + , loadNativeCode' + , soFile + , llFile + ) where + +import Prelude hiding (void, Symbol) +import Control.Exception +import Eclair.LLVM.Symbol +import Eclair.LLVM.Codegen hiding (retVoid, nullPtr) +import Eclair.LLVM.Externals +import Foreign.LibFFI +import Foreign hiding (void, bit) +import System.Posix.DynamicLinker +import System.FilePath +import Foreign.C + +data Bindings + = Bindings + { dynamicLib :: DL + , withSymbol :: forall a. (Ptr Symbol -> IO a) -> IO a + , bInit :: Ptr Symbol -> String -> IO () + , bDestroy :: Ptr Symbol -> IO () + , bIsEqual :: Ptr Symbol -> Ptr Symbol -> IO Bool + , bLength :: Ptr Symbol -> IO Word32 + , bData :: Ptr Symbol -> IO String + } + +cgTestCode :: Symbol -> Externals -> ModuleBuilderT IO () +cgTestCode sym exts = do + let mallocFn = extMalloc exts + freeFn = extFree exts + memcpyFn = extMemcpy exts + symTy = tySymbol sym + _ <- function "eclair_symbol_new" [] (ptr symTy) $ \[] -> + ret =<< call mallocFn [int32 16] + _ <- function "eclair_symbol_delete" [(ptr symTy, "sym")] void $ \[s] -> + call freeFn [s] + let initArgs = [(ptr symTy, "sym"), (i32, "length"), (ptr i8, "data")] + _ <- function "eclair_symbol_init_helper" initArgs void $ \[s, len, str] -> do + -- Needed because "str" is freed afterwards + memory <- call mallocFn [len] + _ <- call memcpyFn [memory, str, len, bit 0] + _ <- call (symbolInit sym) [s, len, memory] + pass + let isEqArgs = [(ptr symTy, "sym1"), (ptr symTy, "sym2")] + _ <- function "eclair_symbol_is_equal_helper" isEqArgs i8 $ \[sym1, sym2] -> do + isEq <- call (symbolIsEqual sym) [sym1, sym2] + ret =<< isEq `zext` i8 + _ <- function "eclair_symbol_length" [(ptr symTy, "sym")] i32 $ \[s] -> do + lenPtr <- gep s [int32 0, int32 0] + ret =<< load lenPtr 0 + _ <- function "eclair_symbol_data" [(ptr symTy, "sym")] (ptr i8) $ \[s] -> do + lenPtr <- gep s [int32 0, int32 1] + ret =<< load lenPtr 0 + pass + +loadNativeCode :: FilePath -> IO Bindings +loadNativeCode dir = do + lib <- dlopen (soFile dir) [RTLD_LAZY] + loadNativeCode' lib + +loadNativeCode' :: DL -> IO Bindings +loadNativeCode' lib = do + fnNew <- dlsym lib "eclair_symbol_new" + fnDelete <- dlsym lib "eclair_symbol_delete" + fnInit <- dlsym lib "eclair_symbol_init_helper" + fnDestroy <- dlsym lib "eclair_symbol_destroy" + fnIsEqual <- dlsym lib "eclair_symbol_is_equal_helper" + fnLength <- dlsym lib "eclair_symbol_length" + fnData <- dlsym lib "eclair_symbol_data" + let getLength = mkLength fnLength + pure $ Bindings + { dynamicLib = lib + , withSymbol = mkWithSymbol fnNew fnDelete + , bInit = mkInit fnInit + , bDestroy = mkDestroy fnDestroy + , bIsEqual = mkIsEqual fnIsEqual + , bLength = getLength + , bData = mkData fnData getLength + } + where + mkNew fn = callFFI fn (retPtr retVoid) [] + mkDelete fn sym = callFFI fn retVoid [argPtr sym] + mkWithSymbol fnNew fnDelete = + bracket (castPtr <$> mkNew fnNew) (mkDelete fnDelete) + mkInit fn sym str = do + let len = fromIntegral $ length str + callFFI fn retVoid [argPtr sym, argCUInt len, argString str] + mkDestroy fn sym = callFFI fn retVoid [argPtr sym] + mkIsEqual fn sym1 sym2 = do + result <- callFFI fn retCUChar [argPtr sym1, argPtr sym2] + pure $ result == 1 + mkLength fn sym = do + fromIntegral <$> callFFI fn retCUInt [argPtr sym] + mkData fn getLength sym = do + len <- fromIntegral <$> getLength sym + strPtr <- callFFI fn (retPtr retCChar) [argPtr sym] + peekCAStringLen (strPtr, len) + +soFile :: FilePath -> FilePath +soFile dir = dir "symbol.so" + +llFile :: FilePath -> FilePath +llFile dir = dir "symbol.ll"