Foreign Function Interface

.github/workflows/ci.yml

@@ -16,7 +16,7 @@ env:
   # older .so files are cached, which can have various effects
   # (e.g. cabal complains it can't find a valid version of the "happy"
   # tool).
-  CACHE_VERSION: 1
+  CACHE_VERSION: 2
 
 jobs:
   config:
@@ -299,7 +299,9 @@ jobs:
         name: test-lib ${{ matrix.target }}
         run: |
           export PATH=$PWD/bin:$PWD/dist/bin:$PATH
-          ./bin/test-runner --ext=.icry -F -b --exe=dist/bin/cryptol ./tests/${{ matrix.target }}
+          if ${{ matrix.target != 'ffi' }} || dist/bin/cryptol -v | grep -q 'FFI enabled'; then
+            ./bin/test-runner --ext=.icry -F -b --exe=dist/bin/cryptol ./tests/${{ matrix.target }}
+          fi
 
       - if: matrix.suite == 'rpc'
         shell: bash

.gitmodules

@@ -4,3 +4,7 @@
 [submodule "deps/argo"]
 	path = deps/argo
 	url = https://github.com/galoisinc/argo
+[submodule "deps/libffi"]
+	path = deps/libffi
+	url = https://github.com/RyanGlScott/libffi
+	branch = static-linking-alt

cabal.project

@@ -3,3 +3,4 @@ packages:
     cryptol-remote-api
     tests
     deps/argo/argo
+    deps/libffi

cry

@@ -79,11 +79,21 @@ case $COMMAND in
   test)
     echo Running tests
     setup_external_tools
-    if [ "$#" == "0" ]; then TESTS=tests; else TESTS=$*; fi
+    if [ "$#" == "0" ]; then
+      if cabal v2-exec cryptol -- -v | grep -q 'FFI enabled'; then
+        TESTS=(tests/*)
+      else
+        GLOBIGNORE="tests/ffi"
+        TESTS=(tests/*)
+        unset GLOBIGNORE
+      fi
+    else
+      TESTS=("$*")
+    fi
     $BIN/test-runner --ext=.icry \
       --exe=cabal \
       -F v2-run -F -v0 -F exe:cryptol -F -- -F -b \
-      $TESTS
+      "${TESTS[@]}"
     ;;
 
   rpc-test)

cryptol-remote-api/src/CryptolServer/Exceptions.hs

@@ -107,6 +107,10 @@ cryptolError modErr warns =
       NotAParameterizedModule x ->
         (20650, [ ("module", jsonPretty x)
                 ])
+      FFILoadErrors x errs ->
+        (20660, [ ("module", jsonPretty x)
+                , ("errors", jsonList (map jsonPretty errs))
+                ])
       OtherFailure x ->
         (29999, [ ("error", jsonString x)
                 ])

cryptol.cabal

@@ -37,6 +37,10 @@ flag relocatable
   default: True
   description: Don't use the Cabal-provided data directory for looking up Cryptol libraries. This is useful when the data directory can't be known ahead of time, like for a relocatable distribution.
 
+flag ffi
+  default: True
+  description: Enable the foreign function interface
+
 library
   Default-language:
     Haskell2010
@@ -81,6 +85,11 @@ library
   else
     build-depends:     integer-gmp       >= 1.0 && < 1.1
 
+  if flag(ffi)
+    build-depends:     libffi,
+                       unix
+    cpp-options:       -DFFI_ENABLED
+
   Build-tool-depends:  alex:alex, happy:happy
   hs-source-dirs:      src
 
@@ -147,6 +156,9 @@ library
                        Cryptol.TypeCheck.TypeMap,
                        Cryptol.TypeCheck.TypeOf,
                        Cryptol.TypeCheck.Sanity,
+                       Cryptol.TypeCheck.FFI,
+                       Cryptol.TypeCheck.FFI.Error,
+                       Cryptol.TypeCheck.FFI.FFIType,
 
                        Cryptol.TypeCheck.Solver.Types,
                        Cryptol.TypeCheck.Solver.SMT,
@@ -169,6 +181,8 @@ library
                        Cryptol.Backend,
                        Cryptol.Backend.Arch,
                        Cryptol.Backend.Concrete,
+                       Cryptol.Backend.FFI,
+                       Cryptol.Backend.FFI.Error,
                        Cryptol.Backend.FloatHelpers,
                        Cryptol.Backend.Monad,
                        Cryptol.Backend.SeqMap,
@@ -179,6 +193,7 @@ library
                        Cryptol.Eval,
                        Cryptol.Eval.Concrete,
                        Cryptol.Eval.Env,
+                       Cryptol.Eval.FFI,
                        Cryptol.Eval.Generic,
                        Cryptol.Eval.Prims,
                        Cryptol.Eval.Reference,

cryptol/CheckExercises.hs

@@ -291,7 +291,7 @@ main = do
 
     if Seq.null (rdReplout rd)
       then do let cryCmd = (P.shell (exe ++ " --interactive-batch " ++ inFile ++ " -e"))
-              (cryEC, cryOut, _) <- P.readCreateProcessWithExitCode cryCmd ""
+              (cryEC, cryOut, cryErr) <- P.readCreateProcessWithExitCode cryCmd ""
 
 
               Line lnReplinStart _ Seq.:<| _ <- return $ rdReplin rd
@@ -301,6 +301,7 @@ main = do
                   putStrLn $ "REPL error (replin lines " ++
                     show lnReplinStart ++ "-" ++ show lnReplinEnd ++ ")."
                   putStr cryOut
+                  putStr cryErr
                   exitFailure
                 ExitSuccess -> do
                   -- remove temporary input file

src/Cryptol/Backend/FFI.hs

@@ -0,0 +1,166 @@
+{-# LANGUAGE BlockArguments            #-}
+{-# LANGUAGE CPP                       #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE RecordWildCards           #-}
+{-# LANGUAGE ScopedTypeVariables       #-}
+{-# LANGUAGE TypeApplications          #-}
+
+-- | The implementation of loading and calling external functions from shared
+-- libraries. Currently works on Unix only.
+module Cryptol.Backend.FFI
+#ifdef FFI_ENABLED
+  ( ForeignSrc
+  , loadForeignSrc
+  , ForeignImpl
+  , loadForeignImpl
+  , FFIArg
+  , FFIRet
+  , SomeFFIArg (..)
+  , callForeignImpl
+  )
+#endif
+  where
+
+#ifdef FFI_ENABLED
+
+import           Control.Exception
+import           Control.Monad
+import           Data.Bifunctor
+import           Data.Word
+import           Foreign                    hiding (newForeignPtr)
+import           Foreign.C.Types
+import           Foreign.Concurrent
+import           Foreign.LibFFI
+import           System.FilePath            ((-<.>))
+import           System.IO.Error
+import           System.Posix.DynamicLinker
+
+import           Cryptol.Backend.FFI.Error
+
+-- | A source from which we can retrieve implementations of foreign functions.
+--
+-- This is implemented as a 'ForeignPtr' wrapper around the pointer returned by
+-- 'dlopen', where the destructor 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 when the Cryptol module is unloaded, the
+-- shared library will be closed too.
+newtype ForeignSrc = ForeignSrc (ForeignPtr ())
+
+-- | 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 ->
+  ForeignSrc <$> newForeignPtr ptr (unloadForeignLib ptr)
+
+loadForeignLib :: FilePath -> IO (Either FFILoadError (Ptr ()))
+#ifdef darwin_HOST_OS
+-- On Darwin, try loading .dylib first, and if that fails try .so
+loadForeignLib path =
+  (Right <$> open "dylib") `catchIOError` \e1 ->
+    (Right <$> open "so") `catchIOError` \e2 ->
+      pure $ Left $ CantLoadFFISrc path $
+        displayException e1 ++ "\n" ++ displayException e2
+#else
+-- On other platforms, use .so
+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]
+
+unloadForeignLib :: Ptr () -> IO ()
+unloadForeignLib = dlclose . DLHandle
+
+-- | An implementation of a foreign function.
+data ForeignImpl = ForeignImpl
+  { foreignImplFun :: FunPtr ()
+    -- | We don't need this to call the function but we want to keep the library
+    -- around as long as we still have a function from it so that the destructor
+    -- isn't called too early.
+  , foreignImplLib :: ForeignPtr ()
+  }
+
+-- | Load a 'ForeignImpl' with the given name from the given 'ForeignSrc'.
+loadForeignImpl :: ForeignSrc -> String -> IO (Either FFILoadError ForeignImpl)
+loadForeignImpl (ForeignSrc foreignImplLib) name =
+  withForeignPtr foreignImplLib \lib ->
+    tryLoad (CantLoadFFIImpl name) do
+      foreignImplFun <- loadForeignFunPtr lib name
+      pure ForeignImpl {..}
+
+loadForeignFunPtr :: Ptr () -> String -> IO (FunPtr ())
+loadForeignFunPtr = dlsym . DLHandle
+
+tryLoad :: (String -> FFILoadError) -> IO a -> IO (Either FFILoadError a)
+tryLoad err = fmap (first $ err . displayException) . tryIOError
+
+-- | Types which can be converted into libffi arguments.
+--
+-- The Storable constraint is so that we can put them in arrays.
+class Storable a => FFIArg a where
+  ffiArg :: a -> Arg
+
+instance FFIArg Word8 where
+  ffiArg = argWord8
+
+instance FFIArg Word16 where
+  ffiArg = argWord16
+
+instance FFIArg Word32 where
+  ffiArg = argWord32
+
+instance FFIArg Word64 where
+  ffiArg = argWord64
+
+instance FFIArg CFloat where
+  ffiArg = argCFloat
+
+instance FFIArg CDouble where
+  ffiArg = argCDouble
+
+instance FFIArg (Ptr a) where
+  ffiArg = argPtr
+
+instance FFIArg CSize where
+  ffiArg = argCSize
+
+-- | Types which can be returned from libffi.
+--
+-- The Storable constraint is so that we can put them in arrays.
+class Storable a => FFIRet a where
+  ffiRet :: RetType a
+
+instance FFIRet Word8 where
+  ffiRet = retWord8
+
+instance FFIRet Word16 where
+  ffiRet = retWord16
+
+instance FFIRet Word32 where
+  ffiRet = retWord32
+
+instance FFIRet Word64 where
+  ffiRet = retWord64
+
+instance FFIRet CFloat where
+  ffiRet = retCFloat
+
+instance FFIRet CDouble where
+  ffiRet = retCDouble
+
+instance FFIRet () where
+  ffiRet = retVoid
+
+-- | Existential wrapper around a 'FFIArg'.
+data SomeFFIArg = forall a. FFIArg a => SomeFFIArg a
+
+-- | Call a 'ForeignImpl' with the given arguments. The type parameter decides
+-- how the return value should be converted into a Haskell value.
+callForeignImpl :: forall a. FFIRet a => ForeignImpl -> [SomeFFIArg] -> IO a
+callForeignImpl ForeignImpl {..} xs = withForeignPtr foreignImplLib \_ ->
+  callFFI foreignImplFun (ffiRet @a) $ map toArg xs
+  where toArg (SomeFFIArg x) = ffiArg x
+
+#endif

src/Cryptol/Backend/FFI/Error.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric  #-}
+
+-- | Errors from dynamic loading of shared libraries for FFI.
+module Cryptol.Backend.FFI.Error where
+
+import           Control.DeepSeq
+import           GHC.Generics
+
+import           Cryptol.Utils.PP
+
+data FFILoadError
+  = CantLoadFFISrc
+    FilePath -- ^ Path to cryptol module
+    String   -- ^ Error message
+  | CantLoadFFIImpl
+    String   -- ^ Function name
+    String   -- ^ Error message
+  deriving (Show, Generic, NFData)
+
+instance PP FFILoadError where
+  ppPrec _ e = case e of
+    CantLoadFFISrc path msg ->
+      hang (text "Could not load foreign source for module located at"
+            <+> text path <.> colon)
+         4 (text msg)
+    CantLoadFFIImpl name msg ->
+      hang (text "Could not load foreign implementation for binding"
+            <+> text name <.> colon)
+         4 (text msg)

src/Cryptol/Backend/Monad.hs

@@ -54,7 +54,7 @@ import qualified Control.Exception as X
 import Cryptol.Parser.Position
 import Cryptol.Utils.Panic
 import Cryptol.Utils.PP
-import Cryptol.TypeCheck.AST(Name)
+import Cryptol.TypeCheck.AST(Name, TParam)
 
 -- | A computation that returns an already-evaluated value.
 ready :: a -> Eval a
@@ -412,15 +412,18 @@ evalPanic cxt = panic ("[Eval] " ++ cxt)
 
 -- | Data type describing errors that can occur during evaluation.
 data EvalError
-  = InvalidIndex (Maybe Integer)  -- ^ Out-of-bounds index
-  | DivideByZero                  -- ^ Division or modulus by 0
-  | NegativeExponent              -- ^ Exponentiation by negative integer
-  | LogNegative                   -- ^ Logarithm of a negative integer
-  | UserError String              -- ^ Call to the Cryptol @error@ primitive
-  | LoopError String              -- ^ Detectable nontermination
-  | NoPrim Name                   -- ^ Primitive with no implementation
-  | BadRoundingMode Integer       -- ^ Invalid rounding mode
-  | BadValue String               -- ^ Value outside the domain of a partial function.
+  = InvalidIndex (Maybe Integer)         -- ^ Out-of-bounds index
+  | DivideByZero                         -- ^ Division or modulus by 0
+  | NegativeExponent                     -- ^ Exponentiation by negative integer
+  | LogNegative                          -- ^ Logarithm of a negative integer
+  | UserError String                     -- ^ Call to the Cryptol @error@ primitive
+  | LoopError String                     -- ^ Detectable nontermination
+  | NoPrim Name                          -- ^ Primitive with no implementation
+  | BadRoundingMode Integer              -- ^ Invalid rounding mode
+  | BadValue String                      -- ^ Value outside the domain of a partial function.
+  | FFINotSupported Name                 -- ^ Foreign function cannot be called
+  | FFITypeNumTooBig Name TParam Integer -- ^ Number passed to foreign function
+                                         --   as a type argument is too large
     deriving Typeable
 
 instance PP EvalError where
@@ -440,6 +443,17 @@ instance PP EvalError where
     BadRoundingMode r -> "invalid rounding mode" <+> integer r
     BadValue x -> "invalid input for" <+> backticks (text x)
     NoPrim x -> text "unimplemented primitive:" <+> pp x
+    FFINotSupported x -> vcat
+      [ text "cannot call foreign function" <+> pp x
+      , text "FFI calls are not supported in this context"
+      , text "If you are trying to evaluate an expression, try rebuilding"
+      , text "  Cryptol with FFI support enabled."
+      ]
+    FFITypeNumTooBig f p n -> vcat
+      [ text "numeric type argument to foreign function is too large:"
+        <+> integer n
+      , text "in type parameter" <+> pp p <+> "of function" <+> pp f
+      , text "type arguments must fit in a C `size_t`" ]
 
 instance Show EvalError where
   show = show . pp