Add symbol table tests

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

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

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"