diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index c99f63cfa..4a5f1dcea 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -147,6 +147,8 @@ jobs: cmd="cat \$1.stdout" if ${{ runner.os == 'Windows' }}; then cmd="cat \$1.stdout.mingw32 2>/dev/null || $cmd" + elif ${{ runner.os == 'macOS' }}; then + cmd="cat \$1.stdout.darwin 2>/dev/null || $cmd" fi ./bin/test-runner --ext=.icry -r ./output --exe=$(which bash) -F -c -F "$cmd" -F -- ./tests TARGETS_JSON=$(echo -n "$(ls -1 ./output/tests)" | jq -Rsc 'split("\n")') diff --git a/src/Cryptol/Backend/FFI.hs b/src/Cryptol/Backend/FFI.hs index 7b13d16be..686c02385 100644 --- a/src/Cryptol/Backend/FFI.hs +++ b/src/Cryptol/Backend/FFI.hs @@ -12,6 +12,7 @@ -- libraries. Currently works on Unix only. module Cryptol.Backend.FFI ( ForeignSrc + , getForeignSrcPath , loadForeignSrc , unloadForeignSrc #ifdef FFI_ENABLED @@ -56,12 +57,14 @@ import GHC.Generics -- | A source from which we can retrieve implementations of foreign functions. data ForeignSrc = ForeignSrc - { -- | The 'ForeignPtr' wraps the pointer returned by 'dlopen', where the + { -- | The file path of the 'ForeignSrc'. + foreignSrcPath :: FilePath + -- | The 'ForeignPtr' wraps the pointer returned by 'dlopen', where the -- finalizer calls 'dlclose' when the library is no longer needed. We keep -- references to the 'ForeignPtr' in each foreign function that is in the -- evaluation environment, so that the shared library will stay open as long -- as there are references to it. - foreignSrcFPtr :: ForeignPtr () + , foreignSrcFPtr :: ForeignPtr () -- | We support explicit unloading of the shared library so we keep track of -- if it has already been unloaded, and if so the finalizer does nothing. -- This is updated atomically when the library is unloaded. @@ -73,16 +76,20 @@ instance Show ForeignSrc where instance NFData ForeignSrc where rnf ForeignSrc {..} = foreignSrcFPtr `seq` foreignSrcLoaded `deepseq` () +-- | Get the file path of the 'ForeignSrc'. +getForeignSrcPath :: ForeignSrc -> Maybe FilePath +getForeignSrcPath = Just . foreignSrcPath + -- | Load a 'ForeignSrc' for the given __Cryptol__ file path. The file path of -- the shared library that we try to load is the same as the Cryptol file path -- except with a platform specific extension. loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc) -loadForeignSrc = loadForeignLib >=> traverse \ptr -> do +loadForeignSrc = loadForeignLib >=> traverse \(foreignSrcPath, ptr) -> do foreignSrcLoaded <- newMVar True foreignSrcFPtr <- newForeignPtr ptr (unloadForeignSrc' foreignSrcLoaded ptr) pure ForeignSrc {..} -loadForeignLib :: FilePath -> IO (Either FFILoadError (Ptr ())) +loadForeignLib :: FilePath -> IO (Either FFILoadError (FilePath, Ptr ())) #ifdef darwin_HOST_OS -- On Darwin, try loading .dylib first, and if that fails try .so loadForeignLib path = @@ -95,9 +102,12 @@ loadForeignLib path = loadForeignLib path = tryLoad (CantLoadFFISrc path) $ open "so" #endif - where -- RTLD_NOW so we can make sure that the symbols actually exist at - -- module loading time - open ext = undl <$> dlopen (path -<.> ext) [RTLD_NOW] + where open ext = do + let libPath = path -<.> ext + -- RTLD_NOW so we can make sure that the symbols actually exist at + -- module loading time + ptr <- undl <$> dlopen libPath [RTLD_NOW] + pure (libPath, ptr) -- | Explicitly unload a 'ForeignSrc' immediately instead of waiting for the -- garbage collector to do it. This can be useful if you want to immediately @@ -218,6 +228,9 @@ callForeignImpl ForeignImpl {..} xs = withForeignSrc foreignImplSrc \_ -> data ForeignSrc = ForeignSrc deriving (Show, Generic, NFData) +getForeignSrcPath :: ForeignSrc -> Maybe FilePath +getForeignSrcPath _ = Nothing + loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc) loadForeignSrc _ = pure $ Right ForeignSrc diff --git a/src/Cryptol/Eval/FFI.hs b/src/Cryptol/Eval/FFI.hs index 51b06e247..dab50b4e7 100644 --- a/src/Cryptol/Eval/FFI.hs +++ b/src/Cryptol/Eval/FFI.hs @@ -12,29 +12,30 @@ -- | Evaluation of foreign functions. module Cryptol.Eval.FFI - ( evalForeignDecls + ( findForeignDecls + , evalForeignDecls ) where +import Data.Maybe + import Cryptol.Backend.FFI import Cryptol.Backend.FFI.Error import Cryptol.Eval -import Cryptol.ModuleSystem.Env import Cryptol.TypeCheck.AST +import Cryptol.TypeCheck.FFI.FFIType #ifdef FFI_ENABLED import Data.Either import Data.IORef -import Data.Maybe import Data.Proxy import Data.Traversable import Data.Word import Foreign import Foreign.C.Types import GHC.Float -import LibBF (bfFromDouble, bfToDouble, - pattern NearEven) -import System.Directory +import LibBF (bfFromDouble, bfToDouble, + pattern NearEven) import Cryptol.Backend.Concrete import Cryptol.Backend.FloatHelpers @@ -45,42 +46,36 @@ import Cryptol.Eval.Prims import Cryptol.Eval.Type import Cryptol.Eval.Value import Cryptol.ModuleSystem.Name -import Cryptol.TypeCheck.FFI.FFIType import Cryptol.Utils.Ident import Cryptol.Utils.RecordMap --- | Find all the foreign declarations in the module and add them to the --- environment. This is a separate pass from the main evaluation functions in --- "Cryptol.Eval" since it only works for the Concrete backend. --- --- Note: 'Right' is only returned if we successfully loaded some foreign --- functions and the environment was modified. If there were no foreign --- declarations at all then @Left []@ is returned, so 'Left' does not --- necessarily indicate an error. -evalForeignDecls :: ModulePath -> Module -> EvalEnv -> - Eval (Either [FFILoadError] (ForeignSrc, EvalEnv)) -evalForeignDecls path m env = io - case mapMaybe getForeign $ mDecls m of - [] -> pure $ Left [] - foreigns -> - case path of - InFile p -> canonicalizePath p >>= loadForeignSrc >>= - \case - Right fsrc -> collect <$> for foreigns \(name, ffiType) -> - fmap ((name,) . foreignPrimPoly name ffiType) <$> - loadForeignImpl fsrc (unpackIdent $ nameIdent name) - where collect (partitionEithers -> (errs, primMap)) - | null errs = Right - (fsrc, foldr (uncurry bindVarDirect) env primMap) - | otherwise = Left errs - Left err -> pure $ Left [err] - -- We don't handle in-memory modules for now - InMem _ _ -> evalPanic "evalForeignDecls" - ["Can't find foreign source of in-memory module"] +#endif + +-- | Find all the foreign declarations in the module and return their names and +-- FFIFunTypes. +findForeignDecls :: Module -> [(Name, FFIFunType)] +findForeignDecls = mapMaybe getForeign . mDecls where getForeign (NonRecursive Decl { dName, dDefinition = DForeign ffiType }) = Just (dName, ffiType) + -- Recursive DeclGroups can't have foreign decls getForeign _ = Nothing +#ifdef FFI_ENABLED + +-- | Add the given foreign declarations to the environment, loading their +-- implementations from the given 'ForeignSrc'. This is a separate pass from the +-- main evaluation functions in "Cryptol.Eval" since it only works for the +-- Concrete backend. +evalForeignDecls :: ForeignSrc -> [(Name, FFIFunType)] -> EvalEnv -> + Eval (Either [FFILoadError] EvalEnv) +evalForeignDecls fsrc decls env = io do + ePrims <- for decls \(name, ffiType) -> + fmap ((name,) . foreignPrimPoly name ffiType) <$> + loadForeignImpl fsrc (unpackIdent $ nameIdent name) + pure case partitionEithers ePrims of + ([], prims) -> Right $ foldr (uncurry bindVarDirect) env prims + (errs, _) -> Left errs + -- | Generate a 'Prim' value representing the given foreign function, containing -- all the code necessary to marshal arguments and return values and do the -- actual FFI call. @@ -274,8 +269,8 @@ withWordType FFIWord64 f = f $ Proxy @Word64 -- | Dummy implementation for when FFI is disabled. Does not add anything to -- the environment. -evalForeignDecls :: ModulePath -> Module -> EvalEnv -> - Eval (Either [FFILoadError] (ForeignSrc, EvalEnv)) -evalForeignDecls _ _ _ = pure $ Left [] +evalForeignDecls :: ForeignSrc -> [(Name, FFIFunType)] -> EvalEnv -> + Eval (Either [FFILoadError] EvalEnv) +evalForeignDecls _ _ env = pure $ Right env #endif diff --git a/src/Cryptol/ModuleSystem/Base.hs b/src/Cryptol/ModuleSystem/Base.hs index e17384e75..7113a488c 100644 --- a/src/Cryptol/ModuleSystem/Base.hs +++ b/src/Cryptol/ModuleSystem/Base.hs @@ -19,7 +19,6 @@ module Cryptol.ModuleSystem.Base where import qualified Control.Exception as X import Control.Monad (unless,when) -import Data.Functor.Compose import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import Data.Text.Encoding (decodeUtf8') @@ -51,6 +50,7 @@ import Cryptol.ModuleSystem.Env (lookupModule , meCoreLint, CoreLint(..) , ModContext(..) , ModulePath(..), modulePathLabel) +import Cryptol.Backend.FFI import qualified Cryptol.Eval as E import qualified Cryptol.Eval.Concrete as Concrete import Cryptol.Eval.Concrete (Concrete(..)) @@ -240,16 +240,11 @@ doLoadModule quiet isrc path fp pm0 = let ?evalPrim = \i -> Right <$> Map.lookup i tbl callStacks <- getCallStacks let ?callStacks = callStacks - foreignSrc <- - if T.isParametrizedModule tcm - then pure Nothing - else (getCompose - <$> modifyEvalEnvM (fmap Compose . evalForeignDecls path tcm) - >>= \case - Left [] -> pure Nothing - Left errs -> ffiLoadErrors (T.mName tcm) errs - Right (foreignSrc, ()) -> pure (Just foreignSrc)) - <* modifyEvalEnv (E.moduleEnv Concrete tcm) + foreignSrc <- if T.isParametrizedModule tcm + then pure Nothing + else evalForeign tcm + unless (T.isParametrizedModule tcm) $ + modifyEvalEnv (E.moduleEnv Concrete tcm) loadedModule path fp nameEnv foreignSrc tcm return tcm @@ -263,7 +258,25 @@ doLoadModule quiet isrc path fp pm0 = else notAParameterizedModule (T.mName tcm) | otherwise = return tcm - + evalForeign tcm + | null foreigns = pure Nothing + | otherwise = case path of + InFile p -> io (canonicalizePath p >>= loadForeignSrc) >>= + \case + Right fsrc -> do + unless quiet $ + case getForeignSrcPath fsrc of + Just fpath -> withLogger logPutStrLn $ + "Loading dynamic library " ++ takeFileName fpath + Nothing -> pure () + modifyEvalEnvM (evalForeignDecls fsrc foreigns) >>= + \case + Right () -> pure $ Just fsrc + Left errs -> ffiLoadErrors (T.mName tcm) errs + Left err -> ffiLoadErrors (T.mName tcm) [err] + InMem m _ -> panic "doLoadModule" + ["Can't find foreign source of in-memory module", m] + where foreigns = findForeignDecls tcm diff --git a/tests/ffi/ffi-reload.icry.stdout b/tests/ffi/ffi-reload.icry.stdout index 441a89a75..ed065cd07 100644 --- a/tests/ffi/ffi-reload.icry.stdout +++ b/tests/ffi/ffi-reload.icry.stdout @@ -1,7 +1,9 @@ Loading module Cryptol Loading module Cryptol Loading module Main +Loading dynamic library ffi-reload.so False Loading module Cryptol Loading module Main +Loading dynamic library ffi-reload.so True diff --git a/tests/ffi/ffi-reload.icry.stdout.darwin b/tests/ffi/ffi-reload.icry.stdout.darwin new file mode 100644 index 000000000..28ace0847 --- /dev/null +++ b/tests/ffi/ffi-reload.icry.stdout.darwin @@ -0,0 +1,9 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main +Loading dynamic library ffi-reload.dylib +False +Loading module Cryptol +Loading module Main +Loading dynamic library ffi-reload.dylib +True diff --git a/tests/ffi/ffi-runtime-errors.icry.stdout b/tests/ffi/ffi-runtime-errors.icry.stdout index 1bf3c9006..19f17e108 100644 --- a/tests/ffi/ffi-runtime-errors.icry.stdout +++ b/tests/ffi/ffi-runtime-errors.icry.stdout @@ -1,6 +1,7 @@ Loading module Cryptol Loading module Cryptol Loading module Main +Loading dynamic library ffi-runtime-errors.so numeric type argument to foreign function is too large: 18446744073709551616 in type parameter n`899 of function Main::f diff --git a/tests/ffi/ffi-runtime-errors.icry.stdout.darwin b/tests/ffi/ffi-runtime-errors.icry.stdout.darwin new file mode 100644 index 000000000..105b5ba54 --- /dev/null +++ b/tests/ffi/ffi-runtime-errors.icry.stdout.darwin @@ -0,0 +1,29 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Main +Loading dynamic library ffi-runtime-errors.dylib + +numeric type argument to foreign function is too large: 18446744073709551616 +in type parameter n`899 of function Main::f +type arguments must fit in a C `size_t` +-- Backtrace -- +Main::f called at ffi-runtime-errors.icry:4:1--4:2 + +cannot call foreign function Main::g +FFI calls are not supported in this context +If you are trying to evaluate an expression, try rebuilding + Cryptol with FFI support enabled. + +cannot call foreign function Main::g +FFI calls are not supported in this context +If you are trying to evaluate an expression, try rebuilding + Cryptol with FFI support enabled. + +cannot call foreign function Main::g +FFI calls are not supported in this context +If you are trying to evaluate an expression, try rebuilding + Cryptol with FFI support enabled. +cannot call foreign function Main::g +FFI calls are not supported in this context +If you are trying to evaluate an expression, try rebuilding + Cryptol with FFI support enabled. diff --git a/tests/ffi/test-ffi.icry.stdout b/tests/ffi/test-ffi.icry.stdout index 72db4b2e8..4cbf0cdd5 100644 --- a/tests/ffi/test-ffi.icry.stdout +++ b/tests/ffi/test-ffi.icry.stdout @@ -2,6 +2,7 @@ Loading module Cryptol Loading module Cryptol Loading module Float Loading module Main +Loading dynamic library test-ffi.so 0x03 0x15b4 0x3a0f1880 diff --git a/tests/ffi/test-ffi.icry.stdout.darwin b/tests/ffi/test-ffi.icry.stdout.darwin new file mode 100644 index 000000000..9c0f7ea0a --- /dev/null +++ b/tests/ffi/test-ffi.icry.stdout.darwin @@ -0,0 +1,34 @@ +Loading module Cryptol +Loading module Cryptol +Loading module Float +Loading module Main +Loading dynamic library test-ffi.dylib +0x03 +0x15b4 +0x3a0f1880 +0x00000002e90edc8f +0x07 +0x7 +0x0 +False +0x45.1eb8 +-0x1e61.c71de69ad5 +fpPosInf +fpNegInf +fpNaN +-0.0 +True +0x00000037 +[0xb.cd, -0x9.0a, 0x6.78, -0x3.45, 0x1.23] +{a = (0x1234, 0x5678), + b = {c = [0x0000a, 0x00014, 0x0001e, 0x00028, 0x00032, 0x0003c, + 0x00046, 0x00050], + d = 0x09, + e = 0x0c}} +0x12345678deadbeef +0x00000000 +0x00000037 +0x02fb0408 +[0x01, 0x01, 0x02, 0x01, 0x02, 0x03, 0x01, 0x02, 0x03, 0x04, 0x01, + 0x02, 0x03, 0x04, 0x05] +[0x12.0, 0x38.0, 0x78.0]