{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Cryptol.Backend.FFI
( ForeignSrc
, getForeignSrcPath
, loadForeignSrc
, unloadForeignSrc
, foreignLibPath
#ifdef FFI_ENABLED
, ForeignImpl
, loadForeignImpl
, FFIArg
, FFIRet
, SomeFFIArg (..)
, callForeignImpl
#endif
)
where
import Control.DeepSeq
import Cryptol.Backend.FFI.Error
#ifdef FFI_ENABLED
import Control.Concurrent.MVar
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.Directory(doesFileExist)
import System.IO.Error
import System.Info(os)
#if defined(mingw32_HOST_OS)
import System.Win32.DLL
#else
import System.Posix.DynamicLinker
#endif
import Cryptol.Utils.Panic
#else
import GHC.Generics
#endif
#ifdef FFI_ENABLED
data ForeignSrc = ForeignSrc
{
ForeignSrc -> FilePath
foreignSrcPath :: FilePath
, ForeignSrc -> ForeignPtr ()
foreignSrcFPtr :: ForeignPtr ()
, ForeignSrc -> MVar Bool
foreignSrcLoaded :: MVar Bool }
instance Show ForeignSrc where
show :: ForeignSrc -> FilePath
show = forall a. Show a => a -> FilePath
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignSrc -> ForeignPtr ()
foreignSrcFPtr
instance NFData ForeignSrc where
rnf :: ForeignSrc -> ()
rnf ForeignSrc {FilePath
ForeignPtr ()
MVar Bool
foreignSrcLoaded :: MVar Bool
foreignSrcFPtr :: ForeignPtr ()
foreignSrcPath :: FilePath
foreignSrcLoaded :: ForeignSrc -> MVar Bool
foreignSrcFPtr :: ForeignSrc -> ForeignPtr ()
foreignSrcPath :: ForeignSrc -> FilePath
..} = ForeignPtr ()
foreignSrcFPtr seq :: forall a b. a -> b -> b
`seq` MVar Bool
foreignSrcLoaded forall a b. NFData a => a -> b -> b
`deepseq` ()
getForeignSrcPath :: ForeignSrc -> Maybe FilePath
getForeignSrcPath :: ForeignSrc -> Maybe FilePath
getForeignSrcPath = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignSrc -> FilePath
foreignSrcPath
loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc)
loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc)
loadForeignSrc = FilePath -> IO (Either FFILoadError (FilePath, Ptr ()))
loadForeignLib forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse \(FilePath
foreignSrcPath, Ptr ()
ptr) -> do
MVar Bool
foreignSrcLoaded <- forall a. a -> IO (MVar a)
newMVar Bool
True
ForeignPtr ()
foreignSrcFPtr <- forall a. Ptr a -> IO () -> IO (ForeignPtr a)
newForeignPtr Ptr ()
ptr (MVar Bool -> Ptr () -> IO ()
unloadForeignSrc' MVar Bool
foreignSrcLoaded Ptr ()
ptr)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForeignSrc {FilePath
ForeignPtr ()
MVar Bool
foreignSrcFPtr :: ForeignPtr ()
foreignSrcLoaded :: MVar Bool
foreignSrcPath :: FilePath
foreignSrcLoaded :: MVar Bool
foreignSrcFPtr :: ForeignPtr ()
foreignSrcPath :: FilePath
..}
foreignLibPath :: FilePath -> IO (Maybe FilePath)
foreignLibPath :: FilePath -> IO (Maybe FilePath)
foreignLibPath FilePath
path =
[FilePath] -> IO (Maybe FilePath)
search
case FilePath
os of
FilePath
"mingw32" -> [FilePath
"dll"]
FilePath
"darwin" -> [FilePath
"dylib",FilePath
"so"]
FilePath
_ -> [FilePath
"so"]
where
search :: [FilePath] -> IO (Maybe FilePath)
search [FilePath]
es =
case [FilePath]
es of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
FilePath
e : [FilePath]
more ->
do let p :: FilePath
p = FilePath
path FilePath -> ShowS
-<.> FilePath
e
Bool
yes <- FilePath -> IO Bool
doesFileExist FilePath
p
if Bool
yes then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just FilePath
p) else [FilePath] -> IO (Maybe FilePath)
search [FilePath]
more
loadForeignLib :: FilePath -> IO (Either FFILoadError (FilePath, Ptr ()))
loadForeignLib :: FilePath -> IO (Either FFILoadError (FilePath, Ptr ()))
loadForeignLib FilePath
path =
do Maybe FilePath
mb <- FilePath -> IO (Maybe FilePath)
foreignLibPath FilePath
path
case Maybe FilePath
mb of
Maybe FilePath
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left (FilePath -> FilePath -> FFILoadError
CantLoadFFISrc FilePath
path FilePath
"File not found"))
Just FilePath
libPath -> forall a.
(FilePath -> FFILoadError) -> IO a -> IO (Either FFILoadError a)
tryLoad (FilePath -> FilePath -> FFILoadError
CantLoadFFISrc FilePath
path) (FilePath -> IO (FilePath, Ptr ())
open FilePath
libPath)
where open :: FilePath -> IO (FilePath, Ptr ())
open FilePath
libPath = do
#if defined(mingw32_HOST_OS)
ptr <- loadLibrary libPath
#else
Ptr ()
ptr <- DL -> Ptr ()
undl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [RTLDFlags] -> IO DL
dlopen FilePath
libPath [RTLDFlags
RTLD_NOW]
#endif
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
libPath, Ptr ()
ptr)
unloadForeignSrc :: ForeignSrc -> IO ()
unloadForeignSrc :: ForeignSrc -> IO ()
unloadForeignSrc ForeignSrc {FilePath
ForeignPtr ()
MVar Bool
foreignSrcLoaded :: MVar Bool
foreignSrcFPtr :: ForeignPtr ()
foreignSrcPath :: FilePath
foreignSrcLoaded :: ForeignSrc -> MVar Bool
foreignSrcFPtr :: ForeignSrc -> ForeignPtr ()
foreignSrcPath :: ForeignSrc -> FilePath
..} = forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ()
foreignSrcFPtr forall a b. (a -> b) -> a -> b
$
MVar Bool -> Ptr () -> IO ()
unloadForeignSrc' MVar Bool
foreignSrcLoaded
unloadForeignSrc' :: MVar Bool -> Ptr () -> IO ()
unloadForeignSrc' :: MVar Bool -> Ptr () -> IO ()
unloadForeignSrc' MVar Bool
loaded Ptr ()
lib = forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Bool
loaded \Bool
l -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
l forall a b. (a -> b) -> a -> b
$ Ptr () -> IO ()
unloadForeignLib Ptr ()
lib
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
unloadForeignLib :: Ptr () -> IO ()
#if defined(mingw32_HOST_OS)
unloadForeignLib = freeLibrary
#else
unloadForeignLib :: Ptr () -> IO ()
unloadForeignLib = DL -> IO ()
dlclose forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr () -> DL
DLHandle
#endif
withForeignSrc :: ForeignSrc -> (Ptr () -> IO a) -> IO a
withForeignSrc :: forall a. ForeignSrc -> (Ptr () -> IO a) -> IO a
withForeignSrc ForeignSrc {FilePath
ForeignPtr ()
MVar Bool
foreignSrcLoaded :: MVar Bool
foreignSrcFPtr :: ForeignPtr ()
foreignSrcPath :: FilePath
foreignSrcLoaded :: ForeignSrc -> MVar Bool
foreignSrcFPtr :: ForeignSrc -> ForeignPtr ()
foreignSrcPath :: ForeignSrc -> FilePath
..} Ptr () -> IO a
f = forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar Bool
foreignSrcLoaded
\case
Bool
True -> forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr ()
foreignSrcFPtr Ptr () -> IO a
f
Bool
False ->
forall a. HasCallStack => FilePath -> [FilePath] -> a
panic FilePath
"[FFI] withForeignSrc" [FilePath
"Use of foreign library after unload"]
data ForeignImpl = ForeignImpl
{ ForeignImpl -> FunPtr ()
foreignImplFun :: FunPtr ()
, ForeignImpl -> ForeignSrc
foreignImplSrc :: ForeignSrc
}
loadForeignImpl :: ForeignSrc -> String -> IO (Either FFILoadError ForeignImpl)
loadForeignImpl :: ForeignSrc -> FilePath -> IO (Either FFILoadError ForeignImpl)
loadForeignImpl ForeignSrc
foreignImplSrc FilePath
name =
forall a. ForeignSrc -> (Ptr () -> IO a) -> IO a
withForeignSrc ForeignSrc
foreignImplSrc \Ptr ()
lib ->
forall a.
(FilePath -> FFILoadError) -> IO a -> IO (Either FFILoadError a)
tryLoad (FilePath -> FilePath -> FFILoadError
CantLoadFFIImpl FilePath
name) do
FunPtr ()
foreignImplFun <- Ptr () -> FilePath -> IO (FunPtr ())
loadForeignFunPtr Ptr ()
lib FilePath
name
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForeignImpl {FunPtr ()
ForeignSrc
foreignImplFun :: FunPtr ()
foreignImplSrc :: ForeignSrc
foreignImplSrc :: ForeignSrc
foreignImplFun :: FunPtr ()
..}
loadForeignFunPtr :: Ptr () -> String -> IO (FunPtr ())
#if defined(mingw32_HOST_OS)
loadForeignFunPtr source symbol = do
addr <- getProcAddress source symbol
pure $ castPtrToFunPtr addr
#else
loadForeignFunPtr :: Ptr () -> FilePath -> IO (FunPtr ())
loadForeignFunPtr = forall a. DL -> FilePath -> IO (FunPtr a)
dlsym forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr () -> DL
DLHandle
#endif
tryLoad :: (String -> FFILoadError) -> IO a -> IO (Either FFILoadError a)
tryLoad :: forall a.
(FilePath -> FFILoadError) -> IO a -> IO (Either FFILoadError a)
tryLoad FilePath -> FFILoadError
err = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a -> b) -> a -> b
$ FilePath -> FFILoadError
err forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> FilePath
displayException) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IO a -> IO (Either IOError a)
tryIOError
class Storable a => FFIArg a where
ffiArg :: a -> Arg
instance FFIArg Word8 where
ffiArg :: Word8 -> Arg
ffiArg = Word8 -> Arg
argWord8
instance FFIArg Word16 where
ffiArg :: Word16 -> Arg
ffiArg = Word16 -> Arg
argWord16
instance FFIArg Word32 where
ffiArg :: Word32 -> Arg
ffiArg = Word32 -> Arg
argWord32
instance FFIArg Word64 where
ffiArg :: Word64 -> Arg
ffiArg = Word64 -> Arg
argWord64
instance FFIArg CFloat where
ffiArg :: CFloat -> Arg
ffiArg = CFloat -> Arg
argCFloat
instance FFIArg CDouble where
ffiArg :: CDouble -> Arg
ffiArg = CDouble -> Arg
argCDouble
instance FFIArg (Ptr a) where
ffiArg :: Ptr a -> Arg
ffiArg = forall a. Ptr a -> Arg
argPtr
instance FFIArg CSize where
ffiArg :: CSize -> Arg
ffiArg = CSize -> Arg
argCSize
class Storable a => FFIRet a where
ffiRet :: RetType a
instance FFIRet Word8 where
ffiRet :: RetType Word8
ffiRet = RetType Word8
retWord8
instance FFIRet Word16 where
ffiRet :: RetType Word16
ffiRet = RetType Word16
retWord16
instance FFIRet Word32 where
ffiRet :: RetType Word32
ffiRet = RetType Word32
retWord32
instance FFIRet Word64 where
ffiRet :: RetType Word64
ffiRet = RetType Word64
retWord64
instance FFIRet CFloat where
ffiRet :: RetType CFloat
ffiRet = RetType CFloat
retCFloat
instance FFIRet CDouble where
ffiRet :: RetType CDouble
ffiRet = RetType CDouble
retCDouble
instance FFIRet () where
ffiRet :: RetType ()
ffiRet = RetType ()
retVoid
data SomeFFIArg = forall a. FFIArg a => SomeFFIArg a
callForeignImpl :: forall a. FFIRet a => ForeignImpl -> [SomeFFIArg] -> IO a
callForeignImpl :: forall a. FFIRet a => ForeignImpl -> [SomeFFIArg] -> IO a
callForeignImpl ForeignImpl {FunPtr ()
ForeignSrc
foreignImplSrc :: ForeignSrc
foreignImplFun :: FunPtr ()
foreignImplSrc :: ForeignImpl -> ForeignSrc
foreignImplFun :: ForeignImpl -> FunPtr ()
..} [SomeFFIArg]
xs = forall a. ForeignSrc -> (Ptr () -> IO a) -> IO a
withForeignSrc ForeignSrc
foreignImplSrc \Ptr ()
_ ->
forall a b. FunPtr a -> RetType b -> [Arg] -> IO b
callFFI FunPtr ()
foreignImplFun (forall a. FFIRet a => RetType a
ffiRet @a) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map SomeFFIArg -> Arg
toArg [SomeFFIArg]
xs
where toArg :: SomeFFIArg -> Arg
toArg (SomeFFIArg a
x) = forall a. FFIArg a => a -> Arg
ffiArg a
x
#else
data ForeignSrc = ForeignSrc deriving (Show, Generic, NFData)
getForeignSrcPath :: ForeignSrc -> Maybe FilePath
getForeignSrcPath _ = Nothing
loadForeignSrc :: FilePath -> IO (Either FFILoadError ForeignSrc)
loadForeignSrc _ = pure $ Right ForeignSrc
unloadForeignSrc :: ForeignSrc -> IO ()
unloadForeignSrc _ = pure ()
#endif