diff --git a/eclair-lang.cabal b/eclair-lang.cabal index d8c23b2..4fd2057 100644 --- a/eclair-lang.cabal +++ b/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 diff --git a/tests/eclair/Test/Eclair/LLVM/VectorSpec.hs b/tests/eclair/Test/Eclair/LLVM/VectorSpec.hs new file mode 100644 index 0000000..09e7cf8 --- /dev/null +++ b/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"