diff --git a/eclair-lang.cabal b/eclair-lang.cabal index 48997a8..13d758c 100644 --- a/eclair-lang.cabal +++ b/eclair-lang.cabal @@ -262,6 +262,7 @@ test-suite eclair-test Test.Eclair.LLVM.HashMapSpec Test.Eclair.LLVM.HashSpec Test.Eclair.LLVM.SymbolSpec + Test.Eclair.LLVM.SymbolTableSpec Test.Eclair.LLVM.SymbolUtils Test.Eclair.LLVM.VectorSpec Test.Eclair.LSP.HandlersSpec diff --git a/lib/Eclair/LLVM/Symbol.hs b/lib/Eclair/LLVM/Symbol.hs index 4cb3d69..881f834 100644 --- a/lib/Eclair/LLVM/Symbol.hs +++ b/lib/Eclair/LLVM/Symbol.hs @@ -90,8 +90,8 @@ mkSymbolIsEqual = do data1 <- deref dataOf symbol1 data2 <- deref dataOf symbol2 size1' <- zext size1 i64 - isDataEqual <- (`eq` bit 0) =<< call memcmpFn [data1, data2, size1'] - ret isDataEqual + result <- call memcmpFn [data1, data2, size1'] + ret =<< result `eq` bit 0 data Index = SymbolIdx diff --git a/tests/eclair/Test/Eclair/LLVM/SymbolTableSpec.hs b/tests/eclair/Test/Eclair/LLVM/SymbolTableSpec.hs new file mode 100644 index 0000000..0a97ecb --- /dev/null +++ b/tests/eclair/Test/Eclair/LLVM/SymbolTableSpec.hs @@ -0,0 +1,257 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +module Test.Eclair.LLVM.SymbolTableSpec + ( module Test.Eclair.LLVM.SymbolTableSpec + ) where + +import Prelude hiding (void, Symbol) +import qualified LLVM.C.API as LibLLVM +import qualified Test.Eclair.LLVM.SymbolUtils as S +import Control.Monad.Morph +import Control.Exception +import Eclair.LLVM.SymbolTable +import qualified Eclair.LLVM.Symbol as S +import qualified Eclair.LLVM.Vector as V +import qualified Eclair.LLVM.HashMap as HM +import Eclair.LLVM.Codegen hiding (retVoid, nullPtr) +import Eclair.LLVM.Externals +import System.Posix.DynamicLinker +import System.Directory.Extra +import System.Process.Extra +import System.FilePath +import Foreign hiding (void) +import Foreign.LibFFI +import Test.Hspec + + +type Symbol = S.Symbol +type Value = Word32 + +data Bindings + = Bindings + { dynamicLib :: DL + , symBindings :: S.Bindings + , withSymTab :: (Ptr SymbolTable -> IO ()) -> IO () + , bInit :: Ptr SymbolTable -> IO () + , bDestroy :: Ptr SymbolTable -> IO () + , bFindOrInsert :: Ptr SymbolTable -> Ptr Symbol -> IO Value + -- NOTE: no need to free returned symbol after lookup + , bLookupSymbol :: Ptr SymbolTable -> Value -> IO (Ptr Symbol) + , bContainsSymbol :: Ptr SymbolTable -> Ptr Symbol -> IO Bool + , bLookupIndex :: Ptr SymbolTable -> Ptr Symbol -> IO Value + , bContainsIndex :: Ptr SymbolTable -> Value -> IO Bool + } + +spec :: Spec +spec = describe "Symbol table" $ aroundAll (setupAndTeardown testDir) $ parallel $ do + it "can be initialized and destroyed" $ \bindings -> + withSymTab bindings $ \st -> do + bInit bindings st + bDestroy bindings st + + it "is possible to add symbols to the table" $ \bindings -> do + let sBindings = symBindings bindings + withSymTab bindings $ \st -> do + bInit bindings st + _ <- S.withSymbol sBindings $ \sym -> do + S.bInit sBindings sym "abcd" + idx <- bFindOrInsert bindings st sym + idx `shouldBe` 0 + idx' <- bFindOrInsert bindings st sym + idx' `shouldBe` 0 + -- Owned by symbol table now: + -- S.bDestroy sBindings sym + + _ <- S.withSymbol sBindings $ \sym -> do + S.bInit sBindings sym "123" + idx <- bFindOrInsert bindings st sym + idx `shouldBe` 1 + -- Owned by symbol table now: + -- S.bDestroy sBindings sym + + bDestroy bindings st + + it "is possible to check if the table contains a key" $ \bindings -> do + let sBindings = symBindings bindings + withSymTab bindings $ \st -> do + bInit bindings st + _ <- S.withSymbol sBindings $ \sym -> do + S.bInit sBindings sym "abcd" + result1 <- bContainsSymbol bindings st sym + _ <- bFindOrInsert bindings st sym + result2 <- bContainsSymbol bindings st sym + S.bDestroy sBindings sym + result1 `shouldBe` False + result2 `shouldBe` True + pass + + it "is possible to check if the table contains a value" $ \bindings -> do + let sBindings = symBindings bindings + withSymTab bindings $ \st -> do + bInit bindings st + _ <- S.withSymbol sBindings $ \sym -> do + S.bInit sBindings sym "abcd" + result1 <- bContainsIndex bindings st 0 + _ <- bFindOrInsert bindings st sym + result2 <- bContainsIndex bindings st 0 + S.bDestroy sBindings sym + result1 `shouldBe` False + result2 `shouldBe` True + pass + + it "is possible to lookup a key corresponding to a value" $ \bindings -> do + let sBindings = symBindings bindings + withSymTab bindings $ \st -> do + bInit bindings st + _ <- S.withSymbol sBindings $ \sym -> do + S.bInit sBindings sym "abcd" + -- NOTE: unsafe lookup, don't use it before symbol is inserted + -- sym1 <- bLookupSymbol bindings st 0 + idx <- bFindOrInsert bindings st sym + idx `shouldBe` 0 + print =<< bContainsSymbol bindings st sym + sym' <- bLookupSymbol bindings st idx + -- Owned by symbol table now: + -- S.bDestroy sBindings sym + result <- S.bIsEqual sBindings sym sym' + result `shouldBe` True + pass + pass + + it "is possible to lookup a value corresponding to a key" $ \bindings -> do + let sBindings = symBindings bindings + withSymTab bindings $ \st -> do + bInit bindings st + _ <- S.withSymbol sBindings $ \sym -> do + S.bInit sBindings sym "abcd" + -- NOTE: unsafe lookup, don't use it before symbol is inserted + idx1 <- bLookupIndex bindings st sym + _ <- bFindOrInsert bindings st sym + idx2 <- bLookupIndex bindings st sym + S.bDestroy sBindings sym + idx1 `shouldBe` 0xffffffff + idx2 `shouldBe` 0 + pass + +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 + -> (Symbol -> SymbolTable -> 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 + symbol <- hoist intoIO $ S.codegen exts + let cfg = Config Nothing ctx td + symbolDestructor iterPtr = do + _ <- call (S.symbolDestroy symbol) [iterPtr] + pass + vec <- instantiate "test" (S.tySymbol symbol) $ runConfigT cfg $ V.codegen exts (Just symbolDestructor) + hm <- runConfigT cfg $ HM.codegen symbol exts + symTab <- hoist intoIO $ codegen (S.tySymbol symbol) vec hm + cgHelperCode symbol symTab 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 + 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 -> SymbolTable -> Externals -> ModuleBuilderT IO () +cgTestCode sym symTab exts = do + let mallocFn = extMalloc exts + freeFn = extFree exts + tySym = S.tySymbol sym + symTabTy = tySymbolTable symTab + _ <- function "eclair_symbol_table_new" [] (ptr symTabTy) $ \[] -> + ret =<< call mallocFn [int32 4096] + _ <- function "eclair_symbol_table_delete" [(ptr symTabTy, "hm")] void $ \[h] -> + call freeFn [h] + let args = [(ptr symTabTy, "symbol_table"), (ptr tySym, "symbol")] + _ <- function "eclair_symbol_table_contains_symbol_helper" args i8 $ \[st, s] -> do + result <- call (symbolTableContainsSymbol symTab) [st, s] + ret =<< result `zext` i8 + let args' = [(ptr symTabTy, "symbol_table"), (i32, "value")] + _ <- function "eclair_symbol_table_contains_index_helper" args' i8 $ \[st, v] -> do + result <- call (symbolTableContainsIndex symTab) [st, v] + 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_symbol_table_new" + fnDelete <- dlsym lib "eclair_symbol_table_delete" + fnInit <- dlsym lib "eclair_symbol_table_init" + fnDestroy <- dlsym lib "eclair_symbol_table_destroy" + fnFindOrInsert <- dlsym lib "eclair_symbol_table_find_or_insert" + fnLookupSymbol <- dlsym lib "eclair_symbol_table_lookup_symbol" + fnContainsSymbol <- dlsym lib "eclair_symbol_table_contains_symbol_helper" + fnLookupIndex <- dlsym lib "eclair_symbol_table_lookup_index" + fnContainsIndex <- dlsym lib "eclair_symbol_table_contains_index_helper" + pure $ Bindings + { dynamicLib = lib + , symBindings = sBindings + , withSymTab = mkWithSymTab fnNew fnDelete + , bInit = mkInit fnInit + , bDestroy = mkDestroy fnDestroy + , bFindOrInsert = mkFindOrInsert fnFindOrInsert + , bLookupSymbol = mkLookupSymbol fnLookupSymbol + , bLookupIndex = mkLookupIndex fnLookupIndex + , bContainsSymbol = mkContainsSymbol fnContainsSymbol + , bContainsIndex = mkContainsIndex fnContainsIndex + } + where + mkNew fn = callFFI fn (retPtr retVoid) [] + mkDelete fn st = callFFI fn retVoid [argPtr st] + mkWithSymTab fnNew fnDelete = + bracket (castPtr <$> mkNew fnNew) (mkDelete fnDelete) + mkInit fn st = callFFI fn retVoid [argPtr st] + mkDestroy fn st = callFFI fn retVoid [argPtr st] + mkFindOrInsert fn st sym = + fromIntegral <$> callFFI fn retCUInt [argPtr st, argPtr sym] + mkLookupSymbol fn st value = + castPtr <$> callFFI fn (retPtr retVoid) [argPtr st, argCUInt $ fromIntegral value] + mkLookupIndex fn st sym = + fromIntegral <$> callFFI fn retCUInt [argPtr st, argPtr sym] + mkContainsSymbol fn st sym = do + result <- callFFI fn retCUChar [argPtr st, argPtr sym] + pure $ result == 1 + mkContainsIndex fn st value = do + result <- callFFI fn retCUChar [argPtr st, argCUInt $ fromIntegral value] + pure $ result == 1 + +testDir :: FilePath +testDir = "/tmp/eclair-symbol-table" + +notUsed :: a +notUsed = panic "Not used" + +intoIO :: Identity a -> IO a +intoIO = pure . runIdentity + +llFile, soFile :: FilePath -> FilePath +llFile dir = dir "symbol-table.ll" +soFile dir = dir "symbol-table.so"