Merge branch 'main' into bootstrap-eclair

.github/workflows/build.yml

@@ -22,7 +22,7 @@ jobs:
 
       - name: Upload logs
         if: ${{ always() }}
-        uses: actions/upload-artifact@v2
+        uses: actions/upload-artifact@v3
         with:
           name: eclair-lang-${{matrix.os}}.log
           path: eclair-lang-${{matrix.os}}.log

Dockerfile

@@ -29,9 +29,9 @@ RUN echo 'tzdata tzdata/Areas select Europe' | debconf-set-selections \
     && ln -s wasm-ld-$LLVM_VERSION wasm-ld \
     && cd - \
     && pip install lit==14.0.6 \
-    # install ghcup, ghc-9.4.4 and cabal-3.8.1.0
+    # install ghcup, ghc-9.6.3 and cabal-3.10.1.0
     && curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | \
-    BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_GHC_VERSION=9.4.4 BOOTSTRAP_HASKELL_CABAL_VERSION=3.8.1.0 \
+    BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_GHC_VERSION=9.6.3 BOOTSTRAP_HASKELL_CABAL_VERSION=3.10.1.0 \
     BOOTSTRAP_HASKELL_INSTALL_STACK=1 BOOTSTRAP_HASKELL_INSTALL_HLS=1 BOOTSTRAP_HASKELL_ADJUST_BASHRC=P sh \
     && source /root/.ghcup/env \
     && cabal install cabal-fmt \

cabal.project

@@ -3,7 +3,7 @@ packages: .
 source-repository-package
     type: git
     location: https://github.com/luc-tielen/llvm-codegen.git
-    tag: 497c7c0ffad5f3e4b6f4e74550a477e75b0beb23
+    tag: 83b04cb576208ea74ddd62016e4fa03f0df138ac
 
 source-repository-package
     type: git
@@ -13,7 +13,7 @@ source-repository-package
 source-repository-package
     type: git
     location: https://github.com/luc-tielen/souffle-haskell.git
-    tag: bcd7e3c058c9036d8495cf114520663917b7ac81
+    tag: e441c84f1d64890e31c92fbb278c074ae8bcaff5
 
 source-repository-package
     type: git

eclair-lang.cabal

@@ -273,9 +273,15 @@ test-suite eclair-test
     Test.Eclair.ArgParserSpec
     Test.Eclair.JSONSpec
     Test.Eclair.LLVM.Allocator.MallocSpec
+    Test.Eclair.LLVM.Allocator.PageSpec
     Test.Eclair.LLVM.Allocator.Utils
     Test.Eclair.LLVM.BTreeSpec
+    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
     Test.Eclair.LSP.JSONSpec
     Test.Eclair.RA.IndexSelectionSpec

lib/Eclair/LLVM/Allocator/Page.hs

@@ -1,6 +1,7 @@
 module Eclair.LLVM.Allocator.Page
   ( Page
   , allocator
+  , roundToNearestPageSize  -- for testing only
   ) where
 
 import Eclair.LLVM.Allocator.Common

lib/Eclair/LLVM/HashMap.hs

@@ -226,4 +226,3 @@ symbolOf = mkPath [int32 0]
 
 valueOf :: Path 'EntryIdx 'ValueIdx
 valueOf = mkPath [int32 1]
-

lib/Eclair/LLVM/Symbol.hs

@@ -35,6 +35,7 @@ codegen exts = do
 generateTypes :: ModuleBuilder Type
 generateTypes =
   -- For now, only up to 4GB of strings are supported.
+  -- TODO consider strings with i8 and i16 as size also
   typedef "symbol_t" On [i32, ptr i8]
 
 generateFunctions :: ModuleCodegen Symbol
@@ -89,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

lib/Eclair/Parser.hs

@@ -352,9 +352,9 @@ betweenParens =
 --   In case of error, keeps parsing up to and including 'endChar'
 withRecovery :: Char -> Parser a -> Parser (Maybe a)
 withRecovery endChar p =
-  P.withRecovery handleError $ map Just p
+  P.withRecovery handleErr $ map Just p
   where
-    handleError err = do
+    handleErr err = do
       P.registerParseError err
       _ <- P.takeWhileP Nothing (/= endChar)
       _ <- P.char endChar

lib/Prelude.hs

@@ -4,6 +4,7 @@ module Prelude
   , module Control.Monad.Writer.Strict
   , module Control.Monad.RWS.Strict
   , module Control.Monad.Except
+  , module Control.Monad.Fix
   , module Control.Category
   , module Control.Comonad
   , module Data.Functor.Foldable
@@ -30,6 +31,7 @@ import Control.Concurrent.MVar (modifyMVar_)
 import Control.Monad.Writer.Strict hiding (pass)
 import Control.Monad.RWS.Strict hiding (pass)
 import Control.Monad.Except
+import Control.Monad.Fix
 import Data.Functor.Foldable hiding (fold, unfold, refold, hoist)
 import Data.Functor.Foldable.TH
 import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)

tests/eclair/Test/Eclair/LLVM/Allocator/MallocSpec.hs

@@ -59,8 +59,10 @@ cgExternals = do
   pure $ Externals mallocFn freeFn notUsed notUsed notUsed notUsed notUsed
 
 -- Helper test code for initializing and freeing a struct from native code:
-cgTestCode :: Type -> Operand -> Operand -> ModuleBuilderT IO ()
-cgTestCode ty mallocFn freeFn = do
+cgTestCode :: Type -> Externals -> ModuleBuilderT IO ()
+cgTestCode ty exts = do
+  let mallocFn = extMalloc exts
+      freeFn = extFree exts
   _ <- function "mallocator_new" [] (ptr ty) $ \[] ->
     ret =<< call mallocFn [int32 1]
   _ <- function "mallocator_delete" [(ptr ty, "allocator")] void $ \[alloc] ->

tests/eclair/Test/Eclair/LLVM/Allocator/PageSpec.hs

@@ -0,0 +1,120 @@
+{-# OPTIONS_GHC -Wno-deprecations -Wno-incomplete-uni-patterns #-}
+module Test.Eclair.LLVM.Allocator.PageSpec
+  ( module Test.Eclair.LLVM.Allocator.PageSpec
+  ) where
+
+import Prelude hiding (void)
+import Control.Monad.Morph
+import Eclair.LLVM.Allocator.Page
+import Eclair.LLVM.Allocator.Common
+import Test.Eclair.LLVM.Allocator.Utils
+import Eclair.LLVM.Codegen hiding (retVoid)
+import System.Directory.Extra
+import System.Posix.DynamicLinker
+import Test.Hspec
+import Control.Exception (bracket)
+import Foreign hiding (void)
+import Foreign.LibFFI
+
+data PageAllocator
+
+spec :: Spec
+spec = describe "PageAllocator" $
+  aroundAll (setupAndTeardown testDir) $ parallel $ do
+    it "can be initialized and destroyed" $ \bindings ->
+      withAlloc bindings $ \obj -> do
+        fnInit bindings obj
+        fnDestroy bindings obj
+
+    it "can allocate and free memory" $ \bindings -> do
+      let numBytes = 1
+          value = 42
+      withAlloc bindings $ \obj -> do
+        fnInit bindings obj
+        memory <- fnAlloc bindings obj numBytes
+        let memoryEnd = memory `plusPtr` 4095
+        poke memory value
+        poke memoryEnd value
+        value' <- peek memory
+        valueEnd <- peek memoryEnd
+        fnFree bindings obj memory numBytes
+        fnDestroy bindings obj
+        value' `shouldBe` value
+        valueEnd `shouldBe` value
+
+    it "rounds up to the nearest page size" $ \_ -> do
+      withNearestPageSize $ \roundFn -> do
+        result1 <- roundFn 1
+        result2 <- roundFn 4096
+        result3 <- roundFn 4097
+        result4 <- roundFn 0
+        result5 <- roundFn 12345678
+        result1 `shouldBe` 4096
+        result2 `shouldBe` 4096
+        result3 `shouldBe` (4096 * 2)
+        result4 `shouldBe` 0
+        result5 `shouldBe` 12349440
+
+setupAndTeardown :: FilePath -> ActionWith (Bindings PageAllocator) -> IO ()
+setupAndTeardown dir =
+  bracket (setup dir) teardown
+
+setup :: FilePath -> IO (Bindings PageAllocator)
+setup dir = do
+  createDirectoryIfMissing False dir
+  compileAllocatorCode allocator prefix cgExternals cgTestCode dir
+  loadNativeCode prefix dir
+
+teardown :: Bindings PageAllocator -> IO ()
+teardown =
+  dlclose . dynamicLib
+
+cgExternals :: ModuleBuilderT IO Externals
+cgExternals = do
+  -- Need malloc and free to allocate the allocator itself
+  mallocFn <- extern "malloc" [i32] (ptr i8)
+  freeFn <- extern "free" [ptr i8] void
+  -- mmap [hint, numBytes', prot, flags, noFd, offset]
+  mmapFn <- extern "mmap" [ptr void, i64, i32, i32, i32, i32] (ptr void)
+  -- munmap [memory, len']
+  munmapFn <- extern "munmap" [ptr void, i64] i32
+  pure $ Externals mallocFn freeFn notUsed notUsed notUsed mmapFn munmapFn
+
+-- Helper test code for allocating and freeing a struct from native code:
+cgTestCode :: Type -> Externals -> ModuleBuilderT IO ()
+cgTestCode ty exts = do
+  let mallocFn = extMalloc exts
+      freeFn = extFree exts
+  _ <- function "pageallocator_new" [] (ptr ty) $ \[] ->
+    ret =<< call mallocFn [int32 1]
+  _ <- function "pageallocator_delete" [(ptr ty, "allocator")] void $ \[alloc] ->
+    call freeFn [alloc]
+  let roundToNearestInstructions numBytes =
+        hoist (hoist intoIO) $ hoist (`evalStateT` exts) $ roundToNearestPageSize numBytes
+  _ <- function "nearest_page_size" [(i32, "num_bytes")] i32 $ \[num] ->
+    ret =<< roundToNearestInstructions num
+  pass
+
+withNearestPageSize :: ((Word32 -> IO Word32) -> IO ()) -> IO ()
+withNearestPageSize f =
+  bracket open close (\(_, roundFn) -> f roundFn)
+  where
+    open = do
+      dl <- dlopen (soFile testDir) [RTLD_LAZY]
+      roundingFn <- dlsym dl "nearest_page_size"
+      let roundFn numBytes =
+            fromIntegral <$> callFFI roundingFn retCUInt [argCUInt $ fromIntegral numBytes]
+      pure (dl, roundFn)
+    close = dlclose . fst
+
+prefix :: Text
+prefix = "pageallocator"
+
+testDir :: FilePath
+testDir = "/tmp/eclair-pageallocator"
+
+notUsed :: a
+notUsed = panic "Not used"
+
+intoIO :: Identity a -> IO a
+intoIO = pure . runIdentity

tests/eclair/Test/Eclair/LLVM/Allocator/Utils.hs

@@ -1,7 +1,9 @@
+{-# OPTIONS_GHC -Wno-deprecations #-}
 module Test.Eclair.LLVM.Allocator.Utils
   ( Bindings(..)
   , compileAllocatorCode
   , loadNativeCode
+  , soFile
   ) where
 
 import System.Process.Extra
@@ -31,14 +33,14 @@ compileAllocatorCode
   :: Allocator a
   -> Text
   -> ModuleBuilderT IO Externals
-  -> (Type -> Operand -> Operand -> ModuleBuilderT IO ())
+  -> (Type -> Externals -> ModuleBuilderT IO ())
   -> FilePath -> IO ()
 compileAllocatorCode allocator prefix cgExts cgHelperCode dir = do
   llvmIR <- runModuleBuilderT $ do
     exts <- cgExts
     let cgBlueprint = flip evalStateT exts $ cgAlloc prefix allocator
     blueprint <- hoist intoIO cgBlueprint
-    cgHelperCode (bpType blueprint) (extMalloc exts) (extFree exts)
+    cgHelperCode (bpType blueprint) exts
   let llvmIRText = ppllvm llvmIR
   writeFileText (llFile dir) llvmIRText
   callProcess "clang" ["-fPIC", "-shared", "-O0", "-o", soFile dir, llFile dir]