Print message in REPL when loading dynamic library for FFI

.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")')

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
 

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

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
 
 
 

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

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

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

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.

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

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]