{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
module Cryptol.Eval.FFI
( findForeignDecls
, evalForeignDecls
) where
import Cryptol.Backend.FFI
import Cryptol.Backend.FFI.Error
import Cryptol.Eval
import Cryptol.TypeCheck.AST
import Cryptol.TypeCheck.FFI.FFIType
#ifdef FFI_ENABLED
import Control.Exception(bracket_)
import Data.Either
import Data.Foldable
import Data.IORef
import Data.Proxy
import Data.Ratio
import Data.Traversable
import Data.Word
import Foreign
import Foreign.C.Types
import GHC.Float
import LibBF (bfFromDouble, bfToDouble,
pattern NearEven)
import Numeric.GMP.Raw.Unsafe
import Numeric.GMP.Utils
import Cryptol.Backend
import Cryptol.Backend.Concrete
import Cryptol.Backend.FloatHelpers
import Cryptol.Backend.Monad
import Cryptol.Backend.SeqMap
import Cryptol.Eval.Env
import Cryptol.Eval.Prims
import Cryptol.Eval.Type
import Cryptol.Eval.Value
import Cryptol.ModuleSystem.Name
import Cryptol.Utils.Ident
import Cryptol.Utils.RecordMap
#endif
#ifdef FFI_ENABLED
evalForeignDecls :: ForeignSrc -> [(Name, FFIFunType)] -> EvalEnv ->
Eval (Either [FFILoadError] EvalEnv)
evalForeignDecls :: ForeignSrc
-> [(Name, FFIFunType)]
-> EvalEnv
-> Eval (Either [FFILoadError] EvalEnv)
evalForeignDecls ForeignSrc
fsrc [(Name, FFIFunType)]
decls EvalEnv
env = forall a. IO a -> Eval a
io do
[Either FFILoadError (Name, Prim Concrete)]
ePrims <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Name, FFIFunType)]
decls \(Name
name, FFIFunType
ffiFunType) ->
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Name
name,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> FFIFunType -> ForeignImpl -> Prim Concrete
foreignPrimPoly Name
name FFIFunType
ffiFunType) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
ForeignSrc -> String -> IO (Either FFILoadError ForeignImpl)
loadForeignImpl ForeignSrc
fsrc (Ident -> String
unpackIdent forall a b. (a -> b) -> a -> b
$ Name -> Ident
nameIdent Name
name)
forall (f :: * -> *) a. Applicative f => a -> f a
pure case forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either FFILoadError (Name, Prim Concrete)]
ePrims of
([], [(Name, Prim Concrete)]
prims) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall sym.
Backend sym =>
Name -> Prim sym -> GenEvalEnv sym -> GenEvalEnv sym
bindVarDirect) EvalEnv
env [(Name, Prim Concrete)]
prims
([FFILoadError]
errs, [(Name, Prim Concrete)]
_) -> forall a b. a -> Either a b
Left [FFILoadError]
errs
foreignPrimPoly :: Name -> FFIFunType -> ForeignImpl -> Prim Concrete
foreignPrimPoly :: Name -> FFIFunType -> ForeignImpl -> Prim Concrete
foreignPrimPoly Name
name FFIFunType
fft ForeignImpl
impl = [TParam] -> TypeEnv -> Prim Concrete
buildNumPoly (FFIFunType -> [TParam]
ffiTParams FFIFunType
fft) forall a. Monoid a => a
mempty
where
buildNumPoly :: [TParam] -> TypeEnv -> Prim Concrete
buildNumPoly (TParam
tp:[TParam]
tps) TypeEnv
tenv = forall sym. (Nat' -> Prim sym) -> Prim sym
PNumPoly \Nat'
n ->
[TParam] -> TypeEnv -> Prim Concrete
buildNumPoly [TParam]
tps forall a b. (a -> b) -> a -> b
$ TVar -> Either Nat' TValue -> TypeEnv -> TypeEnv
bindTypeVar (TParam -> TVar
TVBound TParam
tp) (forall a b. a -> Either a b
Left Nat'
n) TypeEnv
tenv
buildNumPoly [] TypeEnv
tenv = Name -> FFIFunType -> ForeignImpl -> TypeEnv -> Prim Concrete
foreignPrim Name
name FFIFunType
fft ForeignImpl
impl TypeEnv
tenv
data GetRet = GetRet
{ GetRet -> forall a. FFIRet a => IO a
getRetAsValue :: forall a. FFIRet a => IO a
, GetRet -> [SomeFFIArg] -> IO ()
getRetAsOutArgs :: [SomeFFIArg] -> IO () }
data BasicRefRet a = BasicRefRet
{
forall a. BasicRefRet a -> Ptr a -> IO ()
initBasicRefRet :: Ptr a -> IO ()
, forall a. BasicRefRet a -> Ptr a -> IO ()
clearBasicRefRet :: Ptr a -> IO ()
, forall a. BasicRefRet a -> a -> Eval (GenValue Concrete)
marshalBasicRefRet :: a -> Eval (GenValue Concrete) }
foreignPrim :: Name -> FFIFunType -> ForeignImpl -> TypeEnv -> Prim Concrete
foreignPrim :: Name -> FFIFunType -> ForeignImpl -> TypeEnv -> Prim Concrete
foreignPrim Name
name FFIFunType {[TParam]
[FFIType]
FFIType
ffiRetType :: FFIFunType -> FFIType
ffiArgTypes :: FFIFunType -> [FFIType]
ffiRetType :: FFIType
ffiArgTypes :: [FFIType]
ffiTParams :: [TParam]
ffiTParams :: FFIFunType -> [TParam]
..} ForeignImpl
impl TypeEnv
tenv = [FFIType] -> [(FFIType, GenValue Concrete)] -> Prim Concrete
buildFun [FFIType]
ffiArgTypes []
where
buildFun :: [FFIType] -> [(FFIType, GenValue Concrete)] -> Prim Concrete
buildFun :: [FFIType] -> [(FFIType, GenValue Concrete)] -> Prim Concrete
buildFun (FFIType
argType:[FFIType]
argTypes) [(FFIType, GenValue Concrete)]
typesAndVals = forall sym. (GenValue sym -> Prim sym) -> Prim sym
PStrict \GenValue Concrete
val ->
[FFIType] -> [(FFIType, GenValue Concrete)] -> Prim Concrete
buildFun [FFIType]
argTypes forall a b. (a -> b) -> a -> b
$ [(FFIType, GenValue Concrete)]
typesAndVals forall a. [a] -> [a] -> [a]
++ [(FFIType
argType, GenValue Concrete
val)]
buildFun [] [(FFIType, GenValue Concrete)]
typesAndVals = forall sym. SEval sym (GenValue sym) -> Prim sym
PPrim forall a b. (a -> b) -> a -> b
$
forall a.
[(FFIType, GenValue Concrete)]
-> ([SomeFFIArg] -> Eval a) -> Eval a
marshalArgs [(FFIType, GenValue Concrete)]
typesAndVals \[SomeFFIArg]
inArgs -> do
[SomeFFIArg]
tyArgs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse TParam -> Eval SomeFFIArg
marshalTyArg [TParam]
ffiTParams
let tyInArgs :: [SomeFFIArg]
tyInArgs = [SomeFFIArg]
tyArgs forall a. [a] -> [a] -> [a]
++ [SomeFFIArg]
inArgs
FFIType -> GetRet -> Eval (GenValue Concrete)
marshalRet FFIType
ffiRetType GetRet
{ getRetAsValue :: forall a. FFIRet a => IO a
getRetAsValue = forall a. FFIRet a => ForeignImpl -> [SomeFFIArg] -> IO a
callForeignImpl ForeignImpl
impl [SomeFFIArg]
tyInArgs
, getRetAsOutArgs :: [SomeFFIArg] -> IO ()
getRetAsOutArgs = forall a. FFIRet a => ForeignImpl -> [SomeFFIArg] -> IO a
callForeignImpl ForeignImpl
impl forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([SomeFFIArg]
tyInArgs forall a. [a] -> [a] -> [a]
++) }
marshalTyArg :: TParam -> Eval SomeFFIArg
marshalTyArg :: TParam -> Eval SomeFFIArg
marshalTyArg TParam
tp
| Integer
n forall a. Ord a => a -> a -> Bool
<= forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: CSize) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. FFIArg a => a -> SomeFFIArg
SomeFFIArg @CSize forall a b. (a -> b) -> a -> b
$ forall a. Num a => Integer -> a
fromInteger Integer
n
| Bool
otherwise = forall sym a. Backend sym => sym -> EvalError -> SEval sym a
raiseError Concrete
Concrete forall a b. (a -> b) -> a -> b
$ Name -> TParam -> Integer -> EvalError
FFITypeNumTooBig Name
name TParam
tp Integer
n
where n :: Integer
n = Type -> Integer
evalFinType forall a b. (a -> b) -> a -> b
$ TVar -> Type
TVar forall a b. (a -> b) -> a -> b
$ TParam -> TVar
TVBound TParam
tp
marshalArg ::
FFIType ->
GenValue Concrete ->
([SomeFFIArg] -> Eval a) ->
Eval a
marshalArg :: forall a.
FFIType -> GenValue Concrete -> ([SomeFFIArg] -> Eval a) -> Eval a
marshalArg FFIType
FFIBool GenValue Concrete
val [SomeFFIArg] -> Eval a
f = [SomeFFIArg] -> Eval a
f [forall a. FFIArg a => a -> SomeFFIArg
SomeFFIArg @Word8 (forall a. Num a => Bool -> a
fromBool (forall sym. GenValue sym -> SBit sym
fromVBit GenValue Concrete
val))]
marshalArg (FFIBasic (FFIBasicVal FFIBasicValType
t)) GenValue Concrete
val [SomeFFIArg] -> Eval a
f =
forall result.
FFIBasicValType
-> (forall rep.
FFIArg rep =>
(GenValue Concrete -> Eval rep) -> result)
-> result
getMarshalBasicValArg FFIBasicValType
t \GenValue Concrete -> Eval rep
doExport ->
do rep
arg <- GenValue Concrete -> Eval rep
doExport GenValue Concrete
val
[SomeFFIArg] -> Eval a
f [forall a. FFIArg a => a -> SomeFFIArg
SomeFFIArg rep
arg]
marshalArg (FFIBasic (FFIBasicRef FFIBasicRefType
t)) GenValue Concrete
val [SomeFFIArg] -> Eval a
f =
forall val result.
FFIBasicRefType
-> (forall rep.
Storable rep =>
(GenValue Concrete -> (rep -> IO val) -> IO val) -> result)
-> result
getMarshalBasicRefArg FFIBasicRefType
t \GenValue Concrete -> (rep -> IO a) -> IO a
doExport ->
forall a. (CallStack -> IO a) -> Eval a
Eval \CallStack
stk ->
GenValue Concrete -> (rep -> IO a) -> IO a
doExport GenValue Concrete
val \rep
arg ->
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with rep
arg \Ptr rep
ptr ->
forall a. CallStack -> Eval a -> IO a
runEval CallStack
stk ([SomeFFIArg] -> Eval a
f [forall a. FFIArg a => a -> SomeFFIArg
SomeFFIArg Ptr rep
ptr])
marshalArg (FFIArray (forall a b. (a -> b) -> [a] -> [b]
map Type -> Integer
evalFinType -> [Integer]
sizes) FFIBasicType
bt) GenValue Concrete
val [SomeFFIArg] -> Eval a
f =
case FFIBasicType
bt of
FFIBasicVal FFIBasicValType
t ->
forall result.
FFIBasicValType
-> (forall rep.
FFIArg rep =>
(GenValue Concrete -> Eval rep) -> result)
-> result
getMarshalBasicValArg FFIBasicValType
t \GenValue Concrete -> Eval rep
doExport ->
forall a. (CallStack -> IO a) -> Eval a
Eval \CallStack
stk ->
forall {a}.
Storable a =>
CallStack -> (GenValue Concrete -> (a -> IO ()) -> IO ()) -> IO a
marshalArrayArg CallStack
stk \GenValue Concrete
v rep -> IO ()
k ->
rep -> IO ()
k forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. CallStack -> Eval a -> IO a
runEval CallStack
stk (GenValue Concrete -> Eval rep
doExport GenValue Concrete
v)
FFIBasicRef FFIBasicRefType
t -> forall a. (CallStack -> IO a) -> Eval a
Eval \CallStack
stk ->
forall val result.
FFIBasicRefType
-> (forall rep.
Storable rep =>
(GenValue Concrete -> (rep -> IO val) -> IO val) -> result)
-> result
getMarshalBasicRefArg FFIBasicRefType
t \GenValue Concrete -> (rep -> IO ()) -> IO ()
doExport ->
forall {a}.
Storable a =>
CallStack -> (GenValue Concrete -> (a -> IO ()) -> IO ()) -> IO a
marshalArrayArg CallStack
stk GenValue Concrete -> (rep -> IO ()) -> IO ()
doExport
where marshalArrayArg :: CallStack -> (GenValue Concrete -> (a -> IO ()) -> IO ()) -> IO a
marshalArrayArg CallStack
stk GenValue Concrete -> (a -> IO ()) -> IO ()
doExport =
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray (forall a. Num a => Integer -> a
fromInteger (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [Integer]
sizes)) \Ptr a
ptr -> do
let
write :: [a]
-> [GenValue Concrete]
-> [(a, [GenValue Concrete])]
-> Int
-> IO ()
write (a
n:[a]
ns) (GenValue Concrete
v:[GenValue Concrete]
vs) [(a, [GenValue Concrete])]
nvss !Int
i =
do [GenValue Concrete]
vs' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a. CallStack -> Eval a -> IO a
runEval CallStack
stk)
(forall sym n a.
(Backend sym, Integral n) =>
n -> SeqMap sym a -> [SEval sym a]
enumerateSeqMap a
n (forall sym. GenValue sym -> SeqMap sym (GenValue sym)
fromVSeq GenValue Concrete
v))
[a]
-> [GenValue Concrete]
-> [(a, [GenValue Concrete])]
-> Int
-> IO ()
write [a]
ns [GenValue Concrete]
vs' ((a
n, [GenValue Concrete]
vs)forall a. a -> [a] -> [a]
:[(a, [GenValue Concrete])]
nvss) Int
i
write [] (GenValue Concrete
v:[GenValue Concrete]
vs) [(a, [GenValue Concrete])]
nvss !Int
i =
GenValue Concrete -> (a -> IO ()) -> IO ()
doExport GenValue Concrete
v \a
rep ->
do forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
ptr Int
i a
rep
[a]
-> [GenValue Concrete]
-> [(a, [GenValue Concrete])]
-> Int
-> IO ()
write [] [GenValue Concrete]
vs [(a, [GenValue Concrete])]
nvss (Int
i forall a. Num a => a -> a -> a
+ Int
1)
write [a]
ns [] ((a
n, [GenValue Concrete]
vs):[(a, [GenValue Concrete])]
nvss) !Int
i = [a]
-> [GenValue Concrete]
-> [(a, [GenValue Concrete])]
-> Int
-> IO ()
write (a
nforall a. a -> [a] -> [a]
:[a]
ns) [GenValue Concrete]
vs [(a, [GenValue Concrete])]
nvss Int
i
write [a]
_ [GenValue Concrete]
_ [] Int
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
forall {a}.
Integral a =>
[a]
-> [GenValue Concrete]
-> [(a, [GenValue Concrete])]
-> Int
-> IO ()
write [Integer]
sizes [GenValue Concrete
val] [] Int
0
forall a. CallStack -> Eval a -> IO a
runEval CallStack
stk forall a b. (a -> b) -> a -> b
$ [SomeFFIArg] -> Eval a
f [forall a. FFIArg a => a -> SomeFFIArg
SomeFFIArg Ptr a
ptr]
marshalArg (FFITuple [FFIType]
types) GenValue Concrete
val [SomeFFIArg] -> Eval a
f =
do [GenValue Concrete]
vals <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall sym. GenValue sym -> [SEval sym (GenValue sym)]
fromVTuple GenValue Concrete
val)
forall a.
[(FFIType, GenValue Concrete)]
-> ([SomeFFIArg] -> Eval a) -> Eval a
marshalArgs ([FFIType]
types forall a b. [a] -> [b] -> [(a, b)]
`zip` [GenValue Concrete]
vals) [SomeFFIArg] -> Eval a
f
marshalArg (FFIRecord RecordMap Ident FFIType
typeMap) GenValue Concrete
val [SomeFFIArg] -> Eval a
f =
do [GenValue Concrete]
vals <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall sym. Ident -> GenValue sym -> SEval sym (GenValue sym)
`lookupRecord` GenValue Concrete
val) (forall a b. RecordMap a b -> [a]
displayOrder RecordMap Ident FFIType
typeMap)
forall a.
[(FFIType, GenValue Concrete)]
-> ([SomeFFIArg] -> Eval a) -> Eval a
marshalArgs (forall a b. (Show a, Ord a) => RecordMap a b -> [b]
displayElements RecordMap Ident FFIType
typeMap forall a b. [a] -> [b] -> [(a, b)]
`zip` [GenValue Concrete]
vals) [SomeFFIArg] -> Eval a
f
marshalArgs ::
[(FFIType, GenValue Concrete)] ->
([SomeFFIArg] -> Eval a) ->
Eval a
marshalArgs :: forall a.
[(FFIType, GenValue Concrete)]
-> ([SomeFFIArg] -> Eval a) -> Eval a
marshalArgs [(FFIType, GenValue Concrete)]
typesAndVals [SomeFFIArg] -> Eval a
f = [(FFIType, GenValue Concrete)] -> [[SomeFFIArg]] -> Eval a
go [(FFIType, GenValue Concrete)]
typesAndVals []
where
go :: [(FFIType, GenValue Concrete)] -> [[SomeFFIArg]] -> Eval a
go [] [[SomeFFIArg]]
args = [SomeFFIArg] -> Eval a
f (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. [a] -> [a]
reverse [[SomeFFIArg]]
args))
go ((FFIType
t, GenValue Concrete
v):[(FFIType, GenValue Concrete)]
tvs) [[SomeFFIArg]]
prevArgs =
forall a.
FFIType -> GenValue Concrete -> ([SomeFFIArg] -> Eval a) -> Eval a
marshalArg FFIType
t GenValue Concrete
v \[SomeFFIArg]
currArgs ->
[(FFIType, GenValue Concrete)] -> [[SomeFFIArg]] -> Eval a
go [(FFIType, GenValue Concrete)]
tvs ([SomeFFIArg]
currArgs forall a. a -> [a] -> [a]
: [[SomeFFIArg]]
prevArgs)
marshalRet :: FFIType -> GetRet -> Eval (GenValue Concrete)
marshalRet :: FFIType -> GetRet -> Eval (GenValue Concrete)
marshalRet FFIType
FFIBool GetRet
gr =
do Word8
rep <- forall a. IO a -> Eval a
io (GetRet -> forall a. FFIRet a => IO a
getRetAsValue GetRet
gr @Word8)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall sym. SBit sym -> GenValue sym
VBit (forall a. (Eq a, Num a) => a -> Bool
toBool Word8
rep))
marshalRet (FFIBasic (FFIBasicVal FFIBasicValType
t)) GetRet
gr =
forall b.
FFIBasicValType
-> (forall a. FFIRet a => (a -> Eval (GenValue Concrete)) -> b)
-> b
getMarshalBasicValRet FFIBasicValType
t \a -> Eval (GenValue Concrete)
doImport ->
do a
rep <- forall a. IO a -> Eval a
io (GetRet -> forall a. FFIRet a => IO a
getRetAsValue GetRet
gr)
a -> Eval (GenValue Concrete)
doImport a
rep
marshalRet (FFIBasic (FFIBasicRef FFIBasicRefType
t)) GetRet
gr =
forall b.
FFIBasicRefType
-> (forall a. Storable a => BasicRefRet a -> b) -> b
getBasicRefRet FFIBasicRefType
t \BasicRefRet a
how ->
forall a. (CallStack -> IO a) -> Eval a
Eval \CallStack
stk ->
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr a
ptr ->
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (forall a. BasicRefRet a -> Ptr a -> IO ()
initBasicRefRet BasicRefRet a
how Ptr a
ptr) (forall a. BasicRefRet a -> Ptr a -> IO ()
clearBasicRefRet BasicRefRet a
how Ptr a
ptr)
do GetRet -> [SomeFFIArg] -> IO ()
getRetAsOutArgs GetRet
gr [forall a. FFIArg a => a -> SomeFFIArg
SomeFFIArg Ptr a
ptr]
a
rep <- forall a. Storable a => Ptr a -> IO a
peek Ptr a
ptr
forall a. CallStack -> Eval a -> IO a
runEval CallStack
stk (forall a. BasicRefRet a -> a -> Eval (GenValue Concrete)
marshalBasicRefRet BasicRefRet a
how a
rep)
marshalRet (FFIArray (forall a b. (a -> b) -> [a] -> [b]
map Type -> Integer
evalFinType -> [Integer]
sizes) FFIBasicType
bt) GetRet
gr =
forall a. (CallStack -> IO a) -> Eval a
Eval \CallStack
stk -> do
let totalSize :: Int
totalSize = forall a. Num a => Integer -> a
fromInteger (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [Integer]
sizes)
getResult :: (a -> Eval (GenValue Concrete)) -> Ptr a -> IO (GenValue Concrete)
getResult a -> Eval (GenValue Concrete)
marshal Ptr a
ptr = do
GetRet -> [SomeFFIArg] -> IO ()
getRetAsOutArgs GetRet
gr [forall a. FFIArg a => a -> SomeFFIArg
SomeFFIArg Ptr a
ptr]
let build :: [Integer] -> Int -> IO (GenValue Concrete)
build (Integer
n:[Integer]
ns) !Int
i = do
[GenValue Concrete]
vs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Int
0 .. forall a. Num a => Integer -> a
fromInteger Integer
n forall a. Num a => a -> a -> a
- Int
1] \Int
j ->
[Integer] -> Int -> IO (GenValue Concrete)
build [Integer]
ns (Int
i forall a. Num a => a -> a -> a
* forall a. Num a => Integer -> a
fromInteger Integer
n forall a. Num a => a -> a -> a
+ Int
j)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall sym. Integer -> SeqMap sym (GenValue sym) -> GenValue sym
VSeq Integer
n (forall sym a. Backend sym => sym -> [SEval sym a] -> SeqMap sym a
finiteSeqMap Concrete
Concrete (forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [GenValue Concrete]
vs)))
build [] !Int
i = forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
ptr Int
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. CallStack -> Eval a -> IO a
runEval CallStack
stk forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Eval (GenValue Concrete)
marshal
[Integer] -> Int -> IO (GenValue Concrete)
build [Integer]
sizes Int
0
case FFIBasicType
bt of
FFIBasicVal FFIBasicValType
t ->
forall b.
FFIBasicValType
-> (forall a. FFIRet a => (a -> Eval (GenValue Concrete)) -> b)
-> b
getMarshalBasicValRet FFIBasicValType
t \a -> Eval (GenValue Concrete)
doImport ->
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
totalSize (forall {a}.
Storable a =>
(a -> Eval (GenValue Concrete)) -> Ptr a -> IO (GenValue Concrete)
getResult a -> Eval (GenValue Concrete)
doImport)
FFIBasicRef FFIBasicRefType
t ->
forall b.
FFIBasicRefType
-> (forall a. Storable a => BasicRefRet a -> b) -> b
getBasicRefRet FFIBasicRefType
t \BasicRefRet a
how ->
forall a b. Storable a => Int -> (Ptr a -> IO b) -> IO b
allocaArray Int
totalSize \Ptr a
ptr ->
do let forEach :: (Ptr a -> f b) -> f ()
forEach Ptr a -> f b
f = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Int
0 .. Int
totalSize forall a. Num a => a -> a -> a
- Int
1] (Ptr a -> f b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr a
ptr)
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (forall {f :: * -> *} {b}. Applicative f => (Ptr a -> f b) -> f ()
forEach (forall a. BasicRefRet a -> Ptr a -> IO ()
initBasicRefRet BasicRefRet a
how))
(forall {f :: * -> *} {b}. Applicative f => (Ptr a -> f b) -> f ()
forEach (forall a. BasicRefRet a -> Ptr a -> IO ()
clearBasicRefRet BasicRefRet a
how))
(forall {a}.
Storable a =>
(a -> Eval (GenValue Concrete)) -> Ptr a -> IO (GenValue Concrete)
getResult (forall a. BasicRefRet a -> a -> Eval (GenValue Concrete)
marshalBasicRefRet BasicRefRet a
how) Ptr a
ptr)
marshalRet (FFITuple [FFIType]
types) GetRet
gr = forall sym. [SEval sym (GenValue sym)] -> GenValue sym
VTuple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FFIType] -> GetRet -> Eval [Eval (GenValue Concrete)]
marshalMultiRet [FFIType]
types GetRet
gr
marshalRet (FFIRecord RecordMap Ident FFIType
typeMap) GetRet
gr =
forall sym.
RecordMap Ident (SEval sym (GenValue sym)) -> GenValue sym
VRecord forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Show a, Ord a) => [(a, b)] -> RecordMap a b
recordFromFields forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. RecordMap a b -> [a]
displayOrder RecordMap Ident FFIType
typeMap) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
[FFIType] -> GetRet -> Eval [Eval (GenValue Concrete)]
marshalMultiRet (forall a b. (Show a, Ord a) => RecordMap a b -> [b]
displayElements RecordMap Ident FFIType
typeMap) GetRet
gr
marshalMultiRet :: [FFIType] -> GetRet -> Eval [Eval (GenValue Concrete)]
marshalMultiRet :: [FFIType] -> GetRet -> Eval [Eval (GenValue Concrete)]
marshalMultiRet [FFIType]
types GetRet
gr = forall a. (CallStack -> IO a) -> Eval a
Eval \CallStack
stk -> do
IORef [GenValue Concrete]
vals <- forall a. a -> IO (IORef a)
newIORef []
let go :: [FFIType] -> [SomeFFIArg] -> IO ()
go [] [SomeFFIArg]
args = GetRet -> [SomeFFIArg] -> IO ()
getRetAsOutArgs GetRet
gr [SomeFFIArg]
args
go (FFIType
t:[FFIType]
ts) [SomeFFIArg]
prevArgs = do
GenValue Concrete
val <- forall a. CallStack -> Eval a -> IO a
runEval CallStack
stk forall a b. (a -> b) -> a -> b
$ FFIType -> GetRet -> Eval (GenValue Concrete)
marshalRet FFIType
t forall a b. (a -> b) -> a -> b
$ ([SomeFFIArg] -> IO ()) -> GetRet
getRetFromAsOutArgs \[SomeFFIArg]
currArgs ->
[FFIType] -> [SomeFFIArg] -> IO ()
go [FFIType]
ts ([SomeFFIArg]
prevArgs forall a. [a] -> [a] -> [a]
++ [SomeFFIArg]
currArgs)
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [GenValue Concrete]
vals (GenValue Concrete
val forall a. a -> [a] -> [a]
:)
[FFIType] -> [SomeFFIArg] -> IO ()
go [FFIType]
types []
forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef [GenValue Concrete]
vals
getBasicRefRet :: FFIBasicRefType ->
(forall a. Storable a => BasicRefRet a -> b) -> b
getBasicRefRet :: forall b.
FFIBasicRefType
-> (forall a. Storable a => BasicRefRet a -> b) -> b
getBasicRefRet (FFIInteger Maybe Type
mbMod) forall a. Storable a => BasicRefRet a -> b
f = forall a. Storable a => BasicRefRet a -> b
f BasicRefRet
{ initBasicRefRet :: Ptr MPZ -> IO ()
initBasicRefRet = Ptr MPZ -> IO ()
mpz_init
, clearBasicRefRet :: Ptr MPZ -> IO ()
clearBasicRefRet = Ptr MPZ -> IO ()
mpz_clear
, marshalBasicRefRet :: MPZ -> Eval (GenValue Concrete)
marshalBasicRefRet = \MPZ
mpz -> do
Integer
n <- forall a. IO a -> Eval a
io forall a b. (a -> b) -> a -> b
$ MPZ -> IO Integer
peekInteger' MPZ
mpz
forall sym. SInteger sym -> GenValue sym
VInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
case Maybe Type
mbMod of
Maybe Type
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
n
Just Type
m -> forall sym.
Backend sym =>
sym -> Integer -> SInteger sym -> SEval sym (SInteger sym)
intToZn Concrete
Concrete (Type -> Integer
evalFinType Type
m) Integer
n }
getBasicRefRet FFIBasicRefType
FFIRational forall a. Storable a => BasicRefRet a -> b
f = forall a. Storable a => BasicRefRet a -> b
f BasicRefRet
{ initBasicRefRet :: Ptr MPQ -> IO ()
initBasicRefRet = Ptr MPQ -> IO ()
mpq_init
, clearBasicRefRet :: Ptr MPQ -> IO ()
clearBasicRefRet = Ptr MPQ -> IO ()
mpq_clear
, marshalBasicRefRet :: MPQ -> Eval (GenValue Concrete)
marshalBasicRefRet = \MPQ
mpq -> do
Rational
r <- forall a. IO a -> Eval a
io forall a b. (a -> b) -> a -> b
$ MPQ -> IO Rational
peekRational' MPQ
mpq
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall sym. SRational sym -> GenValue sym
VRational forall a b. (a -> b) -> a -> b
$ forall sym. SInteger sym -> SInteger sym -> SRational sym
SRational (forall a. Ratio a -> a
numerator Rational
r) (forall a. Ratio a -> a
denominator Rational
r) }
evalFinType :: Type -> Integer
evalFinType :: Type -> Integer
evalFinType = Nat' -> Integer
finNat' forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeEnv -> Type -> Nat'
evalNumType TypeEnv
tenv
getRetFromAsOutArgs :: ([SomeFFIArg] -> IO ()) -> GetRet
getRetFromAsOutArgs :: ([SomeFFIArg] -> IO ()) -> GetRet
getRetFromAsOutArgs [SomeFFIArg] -> IO ()
f = GetRet
{ getRetAsValue :: forall a. FFIRet a => IO a
getRetAsValue = forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca \Ptr a
ptr -> do
[SomeFFIArg] -> IO ()
f [forall a. FFIArg a => a -> SomeFFIArg
SomeFFIArg Ptr a
ptr]
forall a. Storable a => Ptr a -> IO a
peek Ptr a
ptr
, getRetAsOutArgs :: [SomeFFIArg] -> IO ()
getRetAsOutArgs = [SomeFFIArg] -> IO ()
f }
getMarshalBasicValArg ::
FFIBasicValType ->
(forall rep.
FFIArg rep =>
(GenValue Concrete -> Eval rep) ->
result) ->
result
getMarshalBasicValArg :: forall result.
FFIBasicValType
-> (forall rep.
FFIArg rep =>
(GenValue Concrete -> Eval rep) -> result)
-> result
getMarshalBasicValArg (FFIWord Integer
_ FFIWordSize
s) forall rep. FFIArg rep => (GenValue Concrete -> Eval rep) -> result
f = forall b.
FFIWordSize
-> (forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b)
-> b
withWordType FFIWordSize
s \(Proxy a
_ :: p t) ->
forall rep. FFIArg rep => (GenValue Concrete -> Eval rep) -> result
f @t forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => Integer -> a
fromInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. BV -> Integer
bvVal) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall sym.
Backend sym =>
sym -> String -> GenValue sym -> SEval sym (SWord sym)
fromVWord Concrete
Concrete String
"getMarshalBasicValArg"
getMarshalBasicValArg (FFIFloat Integer
_ Integer
_ FFIFloatSize
s) forall rep. FFIArg rep => (GenValue Concrete -> Eval rep) -> result
f =
case FFIFloatSize
s of
FFIFloatSize
FFIFloat32 -> forall rep. FFIArg rep => (GenValue Concrete -> Eval rep) -> result
f forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> CFloat
CFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Float
double2Float forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenValue Concrete -> Double
toDouble
FFIFloatSize
FFIFloat64 -> forall rep. FFIArg rep => (GenValue Concrete -> Eval rep) -> result
f forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> CDouble
CDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenValue Concrete -> Double
toDouble
where
toDouble :: GenValue Concrete -> Double
toDouble = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. RoundMode -> BigFloat -> (Double, Status)
bfToDouble RoundMode
NearEven forall b c a. (b -> c) -> (a -> b) -> a -> c
. BF -> BigFloat
bfValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall sym. GenValue sym -> SFloat sym
fromVFloat
getMarshalBasicValRet :: FFIBasicValType ->
(forall a. FFIRet a => (a -> Eval (GenValue Concrete)) -> b) -> b
getMarshalBasicValRet :: forall b.
FFIBasicValType
-> (forall a. FFIRet a => (a -> Eval (GenValue Concrete)) -> b)
-> b
getMarshalBasicValRet (FFIWord Integer
n FFIWordSize
s) forall a. FFIRet a => (a -> Eval (GenValue Concrete)) -> b
f = forall b.
FFIWordSize
-> (forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b)
-> b
withWordType FFIWordSize
s \(Proxy a
_ :: p t) ->
forall a. FFIRet a => (a -> Eval (GenValue Concrete)) -> b
f @t forall a b. (a -> b) -> a -> b
$ forall sym.
Backend sym =>
sym -> Integer -> Integer -> SEval sym (GenValue sym)
word Concrete
Concrete Integer
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Integer
toInteger
getMarshalBasicValRet (FFIFloat Integer
e Integer
p FFIFloatSize
s) forall a. FFIRet a => (a -> Eval (GenValue Concrete)) -> b
f =
case FFIFloatSize
s of
FFIFloatSize
FFIFloat32 -> forall a. FFIRet a => (a -> Eval (GenValue Concrete)) -> b
f forall a b. (a -> b) -> a -> b
$ Double -> Eval (GenValue Concrete)
toValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case CFloat Float
x -> Float -> Double
float2Double Float
x
FFIFloatSize
FFIFloat64 -> forall a. FFIRet a => (a -> Eval (GenValue Concrete)) -> b
f forall a b. (a -> b) -> a -> b
$ Double -> Eval (GenValue Concrete)
toValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case CDouble Double
x -> Double
x
where toValue :: Double -> Eval (GenValue Concrete)
toValue = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall sym. SFloat sym -> GenValue sym
VFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Integer -> BigFloat -> BF
BF Integer
e Integer
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> BigFloat
bfFromDouble
withWordType :: FFIWordSize ->
(forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b) -> b
withWordType :: forall b.
FFIWordSize
-> (forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b)
-> b
withWordType FFIWordSize
FFIWord8 forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b
f = forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b
f forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @Word8
withWordType FFIWordSize
FFIWord16 forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b
f = forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b
f forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @Word16
withWordType FFIWordSize
FFIWord32 forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b
f = forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b
f forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @Word32
withWordType FFIWordSize
FFIWord64 forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b
f = forall a. (FFIArg a, FFIRet a, Integral a) => Proxy a -> b
f forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @Word64
getMarshalBasicRefArg :: FFIBasicRefType ->
(forall rep.
Storable rep =>
(GenValue Concrete -> (rep -> IO val) -> IO val) ->
result) ->
result
getMarshalBasicRefArg :: forall val result.
FFIBasicRefType
-> (forall rep.
Storable rep =>
(GenValue Concrete -> (rep -> IO val) -> IO val) -> result)
-> result
getMarshalBasicRefArg (FFIInteger Maybe Type
_) forall rep.
Storable rep =>
(GenValue Concrete -> (rep -> IO val) -> IO val) -> result
f = forall rep.
Storable rep =>
(GenValue Concrete -> (rep -> IO val) -> IO val) -> result
f \GenValue Concrete
val MPZ -> IO val
g ->
forall r. Integer -> (MPZ -> IO r) -> IO r
withInInteger' (forall sym. GenValue sym -> SInteger sym
fromVInteger GenValue Concrete
val) MPZ -> IO val
g
getMarshalBasicRefArg FFIBasicRefType
FFIRational forall rep.
Storable rep =>
(GenValue Concrete -> (rep -> IO val) -> IO val) -> result
f = forall rep.
Storable rep =>
(GenValue Concrete -> (rep -> IO val) -> IO val) -> result
f \GenValue Concrete
val MPQ -> IO val
g -> do
let SRational {SInteger Concrete
sDenom :: forall sym. SRational sym -> SInteger sym
sNum :: forall sym. SRational sym -> SInteger sym
sDenom :: SInteger Concrete
sNum :: SInteger Concrete
..} = forall sym. GenValue sym -> SRational sym
fromVRational GenValue Concrete
val
forall r. Rational -> (MPQ -> IO r) -> IO r
withInRational' (Integer
sNum forall a. Integral a => a -> a -> Ratio a
% Integer
sDenom) MPQ -> IO val
g
#else
evalForeignDecls :: ForeignSrc -> [(Name, FFIFunType)] -> EvalEnv ->
Eval (Either [FFILoadError] EvalEnv)
evalForeignDecls _ _ env = pure $ Right env
#endif