Merge branch 'main' into test-runtime-symbol

eclair-lang.cabal

@@ -261,6 +261,7 @@ test-suite eclair-test
     Test.Eclair.LLVM.BTreeSpec
     Test.Eclair.LLVM.HashSpec
     Test.Eclair.LLVM.SymbolSpec
+    Test.Eclair.LLVM.VectorSpec
     Test.Eclair.LSP.HandlersSpec
     Test.Eclair.LSP.JSONSpec
     Test.Eclair.RA.IndexSelectionSpec

tests/eclair/Test/Eclair/LLVM/VectorSpec.hs

@@ -0,0 +1,222 @@
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+module Test.Eclair.LLVM.VectorSpec
+  ( module Test.Eclair.LLVM.VectorSpec
+  ) where
+
+import Prelude hiding (void)
+import qualified LLVM.C.API as LibLLVM
+import Eclair.LLVM.Vector
+import Eclair.LLVM.Codegen hiding (retVoid, nullPtr)
+import Eclair.LLVM.Externals
+import Foreign.LibFFI
+import Foreign hiding (void)
+import System.Posix.DynamicLinker
+import Control.Exception
+import System.Directory.Extra
+import System.Process.Extra
+import System.FilePath
+import Test.Hspec
+
+type Value = Int
+
+data Bindings
+  = Bindings
+  { dynamicLib :: DL
+  , withVec :: (Ptr Vector -> IO ()) -> IO ()
+  , bInit :: Ptr Vector -> IO ()
+  , bDestroy :: Ptr Vector -> IO ()
+  , bPush :: Ptr Vector -> Value -> IO Word32
+  , bSize :: Ptr Vector -> IO Word64
+  , bCapacity :: Ptr Vector -> IO Word64
+  , bGetValue :: Ptr Vector -> Int -> IO Value
+  }
+
+spec :: Spec
+spec = describe "Vector" $ aroundAll (setupAndTeardown testDir) $ parallel $ do
+  it "can be initialized and destroyed" $ \bindings ->
+    withVec bindings $ \v -> do
+      bInit bindings v
+      bDestroy bindings v
+
+  it "can store multiple elements" $ \bindings -> do
+    withVec bindings $ \v -> do
+      bInit bindings v
+      idx1 <- bPush bindings v 42
+      idx2 <- bPush bindings v 123
+      value2 <- bGetValue bindings v 1
+      value1 <- bGetValue bindings v 0
+      bDestroy bindings v
+      idx1 `shouldBe` 0
+      idx2 `shouldBe` 1
+      value1 `shouldBe` 42
+      value2 `shouldBe` 123
+
+  it "can store duplicate values" $ \bindings -> do
+    withVec bindings $ \v -> do
+      bInit bindings v
+      idx1 <- bPush bindings v 42
+      idx2 <- bPush bindings v 42
+      value1 <- bGetValue bindings v 0
+      value2 <- bGetValue bindings v 1
+      bDestroy bindings v
+      idx1 `shouldBe` 0
+      idx2 `shouldBe` 1
+      value1 `shouldBe` 42
+      value2 `shouldBe` 42
+
+  it "keeps track of the number of elements inside" $ \bindings ->
+    withVec bindings $ \v -> do
+      bInit bindings v
+
+      bSize bindings v >>= (`shouldBe` 0)
+      -- This vector allocates on initialization
+      bCapacity bindings v >>= (`shouldBe` 16)
+
+      _ <- bPush bindings v 1
+      bSize bindings v >>= (`shouldBe` 1)
+      bCapacity bindings v >>= (`shouldBe` 16)
+      _ <- bPush bindings v 2
+      bSize bindings v >>= (`shouldBe` 2)
+      bCapacity bindings v >>= (`shouldBe` 16)
+
+      for_ [0..13] $ bPush bindings v
+      bSize bindings v >>= (`shouldBe` 16)
+      bCapacity bindings v >>= (`shouldBe` 16)
+
+      _ <- bPush bindings v 42
+      bSize bindings v >>= (`shouldBe` 17)
+      bCapacity bindings v >>= (`shouldBe` 32)
+
+      for_ [0..15] $ bPush bindings v
+      bSize bindings v >>= (`shouldBe` 33)
+      bCapacity bindings v >>= (`shouldBe` 64)
+
+      bDestroy bindings v
+
+  it "always keeps order of elements, even after resizing" $ \bindings ->
+    withVec bindings $ \v -> do
+      bInit bindings v
+
+      -- This does several reallocations
+      for_ [0..99] $ bPush bindings v
+      bSize bindings v >>= (`shouldBe` 100)
+      bCapacity bindings v >>= (`shouldBe` 128)
+
+      for_ [0..99] $ \i -> do
+        bGetValue bindings v i >>= (`shouldBe` i)
+
+      bDestroy bindings v
+
+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
+  -> (Vector -> Operand -> Operand -> 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
+    vec <- instantiate "test" i32 $ runConfigT cfg $
+      codegen exts Nothing -- TODO destructor
+    cgHelperCode vec (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
+  memcpyFn <- extern "llvm.memcpy.p0i8.p0i8.i64" [ptr i8, ptr i8, i64, i1] void
+  pure $ Externals mallocFn freeFn notUsed memcpyFn notUsed notUsed notUsed
+
+cgTestCode :: Vector -> Operand -> Operand -> ModuleBuilderT IO ()
+cgTestCode vec mallocFn freeFn = do
+  let vecTypes = vectorTypes vec
+      vecTy = tyVector vecTypes
+      valueTy = tyElement vecTypes
+  _ <- function "eclair_vector_new_test" [] (ptr vecTy) $ \[] ->
+    ret =<< call mallocFn [int32 24]
+  _ <- function "eclair_vector_delete_test" [(ptr vecTy, "vec")] void $ \[v] ->
+    call freeFn [v]
+  _ <- function "eclair_vector_capacity_test" [(ptr vecTy, "vec")] i32 $ \[v] -> do
+    capPtr <- gep v [int32 0, int32 2]
+    ret =<< load capPtr 0
+  _ <- function "eclair_value_new_test" [(i32, "value")] (ptr valueTy) $ \[v] -> do
+    vPtr <- call mallocFn [int32 4]
+    store vPtr 0 v
+    ret vPtr
+  _ <- function "eclair_value_delete_test" [(ptr valueTy, "value")] void $ \[v] ->
+    call freeFn [v]
+  pass
+
+loadNativeCode :: FilePath -> IO Bindings
+loadNativeCode dir = do
+  lib <- dlopen (soFile dir) [RTLD_LAZY]
+  fnNew <- dlsym lib "eclair_vector_new_test"
+  fnDelete <- dlsym lib "eclair_vector_delete_test"
+  fnValueNew <- dlsym lib "eclair_value_new_test"
+  fnValueDelete <- dlsym lib "eclair_value_delete_test"
+  fnInit <- dlsym lib "eclair_vector_init_test"
+  fnDestroy <- dlsym lib "eclair_vector_destroy_test"
+  fnPush <- dlsym lib "eclair_vector_push_test"
+  fnSize <- dlsym lib "eclair_vector_size_test"
+  fnCapacity <- dlsym lib "eclair_vector_capacity_test"
+  fnGetValue <- dlsym lib "eclair_vector_get_value_test"
+  pure $ Bindings
+    { dynamicLib = lib
+    , withVec = mkWithVec fnNew fnDelete
+    , bInit = mkInit fnInit
+    , bDestroy = mkDestroy fnDestroy
+    , bPush = mkPush fnValueNew fnValueDelete fnPush
+    , bSize = mkSize fnSize
+    , bCapacity = mkCapacity fnCapacity
+    , bGetValue = mkGetValue fnGetValue
+    }
+  where
+    mkNew fn = callFFI fn (retPtr retVoid) []
+    mkDelete fn vec = callFFI fn retVoid [argPtr vec]
+    mkWithVec fnNew fnDelete =
+      bracket (castPtr <$> mkNew fnNew) (mkDelete fnDelete)
+    mkInit fn vec = callFFI fn retVoid [argPtr vec]
+    mkDestroy fn vec = callFFI fn retVoid [argPtr vec]
+    mkPush fnValueNew fnValueDelete fn vec value =
+      withValue fnValueNew fnValueDelete value $ \valuePtr ->
+        fromIntegral <$> callFFI fn retCUInt [argPtr vec, argPtr valuePtr]
+    mkSize fn vec =
+      fromIntegral <$> callFFI fn retCULong [argPtr vec]
+    mkCapacity fn vec =
+      fromIntegral <$> callFFI fn retCULong [argPtr vec]
+    mkGetValue fn vec idx = do
+      resultPtr <- callFFI fn (retPtr retCUInt) [argPtr vec, argCUInt $ fromIntegral idx]
+      fromIntegral <$> peek resultPtr
+    withValue fnNew fnDelete value =
+      bracket
+        (castPtr <$> callFFI fnNew (retPtr retCUChar) [argCUInt $ fromIntegral value])
+        (\valuePtr -> callFFI fnDelete retVoid [argPtr valuePtr])
+
+testDir :: FilePath
+testDir = "/tmp/eclair-vector"
+
+llFile, soFile :: FilePath -> FilePath
+llFile dir = dir </> "vector.ll"
+soFile dir = dir </> "vector.so"
+
+notUsed :: a
+notUsed = panic "Not used"