module Language.Futhark.Interpreter.FFI.ServerM
  ( FS.TypeName,
    ValueRef,
    Server,
    startServer,
    newServer,
    stopServer,
    ServerM,
    runServerM,
    gc,
    release,
    call,
    -- Interrogation
    inputs,
    output,
    kind,
    vtype,
    -- Primitives
    getPrim,
    putPrim,
    putData,
    getData,
    -- Arrays
    rank,
    elemType,
    mkArray,
    shape,
    index,
    -- Records
    fieldOrder,
    mkRecord,
    project,
    unzipArray,
    -- Sums
    variants,
    mkSum,
    destruct,
    -- Error handling convenience
    throwNothing,
  )
where

import Control.Exception (catch)
import Control.Monad (replicateM)
import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Reader (ReaderT, asks, runReaderT)
import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef)
import Data.List (intercalate)
import Data.Map qualified as M
import Data.Set qualified as S
import Data.Text qualified as T
import Data.Unique (hashUnique, newUnique)
import Data.Vector.Storable qualified as V
import Futhark.Data qualified as D
import Futhark.Server qualified as FS
import Futhark.Server.Values qualified as FS
import Futhark.Util (mapAccumLM)
import Language.Futhark.Interpreter.FFI.AtomicList as AL
import Language.Futhark.Syntax

-- | Converts a PrimValue to a Data Value
pToD :: PrimValue -> D.Value
pToD :: PrimValue -> Value
pToD (SignedValue (Int8Value Int8
i)) = Int8 -> Value
forall t. PutValue1 t => t -> Value
D.putValue1 Int8
i
pToD (SignedValue (Int16Value Int16
i)) = Int16 -> Value
forall t. PutValue1 t => t -> Value
D.putValue1 Int16
i
pToD (SignedValue (Int32Value Int32
i)) = Int32 -> Value
forall t. PutValue1 t => t -> Value
D.putValue1 Int32
i
pToD (SignedValue (Int64Value Int64
i)) = Int64 -> Value
forall t. PutValue1 t => t -> Value
D.putValue1 Int64
i
pToD (UnsignedValue (Int8Value Int8
i)) = Word8 -> Value
forall t. PutValue1 t => t -> Value
D.putValue1 (Int8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
i :: Word8)
pToD (UnsignedValue (Int16Value Int16
i)) = Word16 -> Value
forall t. PutValue1 t => t -> Value
D.putValue1 (Int16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
i :: Word16)
pToD (UnsignedValue (Int32Value Int32
i)) = Word32 -> Value
forall t. PutValue1 t => t -> Value
D.putValue1 (Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i :: Word32)
pToD (UnsignedValue (Int64Value Int64
i)) = Word64 -> Value
forall t. PutValue1 t => t -> Value
D.putValue1 (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i :: Word64)
pToD (FloatValue (Float16Value Half
f)) = Half -> Value
forall t. PutValue1 t => t -> Value
D.putValue1 Half
f
pToD (FloatValue (Float32Value Float
f)) = Float -> Value
forall t. PutValue1 t => t -> Value
D.putValue1 Float
f
pToD (FloatValue (Float64Value Double
f)) = Double -> Value
forall t. PutValue1 t => t -> Value
D.putValue1 Double
f
pToD (BoolValue Bool
b) = Bool -> Value
forall t. PutValue1 t => t -> Value
D.putValue1 Bool
b

-- | Converts a Data Value to a PrimValue, assuming that it is a singleton
dToP :: D.Value -> PrimValue
dToP :: Value -> PrimValue
dToP (D.I8Value Vector Int
_ Vector Int8
vs) = IntValue -> PrimValue
SignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int8 -> IntValue
Int8Value (Int8 -> IntValue) -> Int8 -> IntValue
forall a b. (a -> b) -> a -> b
$ Vector Int8
vs Vector Int8 -> Int -> Int8
forall a. Storable a => Vector a -> Int -> a
V.! Int
0
dToP (D.I16Value Vector Int
_ Vector Int16
vs) = IntValue -> PrimValue
SignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int16 -> IntValue
Int16Value (Int16 -> IntValue) -> Int16 -> IntValue
forall a b. (a -> b) -> a -> b
$ Vector Int16
vs Vector Int16 -> Int -> Int16
forall a. Storable a => Vector a -> Int -> a
V.! Int
0
dToP (D.I32Value Vector Int
_ Vector Int32
vs) = IntValue -> PrimValue
SignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int32 -> IntValue
Int32Value (Int32 -> IntValue) -> Int32 -> IntValue
forall a b. (a -> b) -> a -> b
$ Vector Int32
vs Vector Int32 -> Int -> Int32
forall a. Storable a => Vector a -> Int -> a
V.! Int
0
dToP (D.I64Value Vector Int
_ Vector Int64
vs) = IntValue -> PrimValue
SignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int64 -> IntValue
Int64Value (Int64 -> IntValue) -> Int64 -> IntValue
forall a b. (a -> b) -> a -> b
$ Vector Int64
vs Vector Int64 -> Int -> Int64
forall a. Storable a => Vector a -> Int -> a
V.! Int
0
dToP (D.U8Value Vector Int
_ Vector Word8
vs) = IntValue -> PrimValue
UnsignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int8 -> IntValue
Int8Value (Int8 -> IntValue) -> Int8 -> IntValue
forall a b. (a -> b) -> a -> b
$ Word8 -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int8) -> Word8 -> Int8
forall a b. (a -> b) -> a -> b
$ Vector Word8
vs Vector Word8 -> Int -> Word8
forall a. Storable a => Vector a -> Int -> a
V.! Int
0
dToP (D.U16Value Vector Int
_ Vector Word16
vs) = IntValue -> PrimValue
UnsignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int16 -> IntValue
Int16Value (Int16 -> IntValue) -> Int16 -> IntValue
forall a b. (a -> b) -> a -> b
$ Word16 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Int16) -> Word16 -> Int16
forall a b. (a -> b) -> a -> b
$ Vector Word16
vs Vector Word16 -> Int -> Word16
forall a. Storable a => Vector a -> Int -> a
V.! Int
0
dToP (D.U32Value Vector Int
_ Vector Word32
vs) = IntValue -> PrimValue
UnsignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int32 -> IntValue
Int32Value (Int32 -> IntValue) -> Int32 -> IntValue
forall a b. (a -> b) -> a -> b
$ Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int32) -> Word32 -> Int32
forall a b. (a -> b) -> a -> b
$ Vector Word32
vs Vector Word32 -> Int -> Word32
forall a. Storable a => Vector a -> Int -> a
V.! Int
0
dToP (D.U64Value Vector Int
_ Vector Word64
vs) = IntValue -> PrimValue
UnsignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Int64 -> IntValue
Int64Value (Int64 -> IntValue) -> Int64 -> IntValue
forall a b. (a -> b) -> a -> b
$ Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int64) -> Word64 -> Int64
forall a b. (a -> b) -> a -> b
$ Vector Word64
vs Vector Word64 -> Int -> Word64
forall a. Storable a => Vector a -> Int -> a
V.! Int
0
dToP (D.F16Value Vector Int
_ Vector Half
vs) = FloatValue -> PrimValue
FloatValue (FloatValue -> PrimValue) -> FloatValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Half -> FloatValue
Float16Value (Half -> FloatValue) -> Half -> FloatValue
forall a b. (a -> b) -> a -> b
$ Vector Half
vs Vector Half -> Int -> Half
forall a. Storable a => Vector a -> Int -> a
V.! Int
0
dToP (D.F32Value Vector Int
_ Vector Float
vs) = FloatValue -> PrimValue
FloatValue (FloatValue -> PrimValue) -> FloatValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Float -> FloatValue
Float32Value (Float -> FloatValue) -> Float -> FloatValue
forall a b. (a -> b) -> a -> b
$ Vector Float
vs Vector Float -> Int -> Float
forall a. Storable a => Vector a -> Int -> a
V.! Int
0
dToP (D.F64Value Vector Int
_ Vector Double
vs) = FloatValue -> PrimValue
FloatValue (FloatValue -> PrimValue) -> FloatValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ Double -> FloatValue
Float64Value (Double -> FloatValue) -> Double -> FloatValue
forall a b. (a -> b) -> a -> b
$ Vector Double
vs Vector Double -> Int -> Double
forall a. Storable a => Vector a -> Int -> a
V.! Int
0
dToP (D.BoolValue Vector Int
_ Vector Bool
vs) = Bool -> PrimValue
BoolValue (Bool -> PrimValue) -> Bool -> PrimValue
forall a b. (a -> b) -> a -> b
$ Vector Bool
vs Vector Bool -> Int -> Bool
forall a. Storable a => Vector a -> Int -> a
V.! Int
0

newtype ValueRef = ValueRef (IORef FS.VarName)

data Server = Server
  { Server -> Server
server :: FS.Server,
    -- | Variables whose 'ValueRef' has been garbage collected.
    Server -> AtomicList Text
queue :: AL.AtomicList FS.VarName,
    -- | Variables created by us that have not yet been freed.
    Server -> IORef (Set Text)
live :: IORef (S.Set FS.VarName)
  }

newtype ServerM a = ServerM (ReaderT Server (ExceptT String IO) a)
  deriving
    ( (forall a b. (a -> b) -> ServerM a -> ServerM b)
-> (forall a b. a -> ServerM b -> ServerM a) -> Functor ServerM
forall a b. a -> ServerM b -> ServerM a
forall a b. (a -> b) -> ServerM a -> ServerM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> ServerM a -> ServerM b
fmap :: forall a b. (a -> b) -> ServerM a -> ServerM b
$c<$ :: forall a b. a -> ServerM b -> ServerM a
<$ :: forall a b. a -> ServerM b -> ServerM a
Functor,
      Functor ServerM
Functor ServerM =>
(forall a. a -> ServerM a)
-> (forall a b. ServerM (a -> b) -> ServerM a -> ServerM b)
-> (forall a b c.
    (a -> b -> c) -> ServerM a -> ServerM b -> ServerM c)
-> (forall a b. ServerM a -> ServerM b -> ServerM b)
-> (forall a b. ServerM a -> ServerM b -> ServerM a)
-> Applicative ServerM
forall a. a -> ServerM a
forall a b. ServerM a -> ServerM b -> ServerM a
forall a b. ServerM a -> ServerM b -> ServerM b
forall a b. ServerM (a -> b) -> ServerM a -> ServerM b
forall a b c. (a -> b -> c) -> ServerM a -> ServerM b -> ServerM c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> ServerM a
pure :: forall a. a -> ServerM a
$c<*> :: forall a b. ServerM (a -> b) -> ServerM a -> ServerM b
<*> :: forall a b. ServerM (a -> b) -> ServerM a -> ServerM b
$cliftA2 :: forall a b c. (a -> b -> c) -> ServerM a -> ServerM b -> ServerM c
liftA2 :: forall a b c. (a -> b -> c) -> ServerM a -> ServerM b -> ServerM c
$c*> :: forall a b. ServerM a -> ServerM b -> ServerM b
*> :: forall a b. ServerM a -> ServerM b -> ServerM b
$c<* :: forall a b. ServerM a -> ServerM b -> ServerM a
<* :: forall a b. ServerM a -> ServerM b -> ServerM a
Applicative,
      Applicative ServerM
Applicative ServerM =>
(forall a b. ServerM a -> (a -> ServerM b) -> ServerM b)
-> (forall a b. ServerM a -> ServerM b -> ServerM b)
-> (forall a. a -> ServerM a)
-> Monad ServerM
forall a. a -> ServerM a
forall a b. ServerM a -> ServerM b -> ServerM b
forall a b. ServerM a -> (a -> ServerM b) -> ServerM b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. ServerM a -> (a -> ServerM b) -> ServerM b
>>= :: forall a b. ServerM a -> (a -> ServerM b) -> ServerM b
$c>> :: forall a b. ServerM a -> ServerM b -> ServerM b
>> :: forall a b. ServerM a -> ServerM b -> ServerM b
$creturn :: forall a. a -> ServerM a
return :: forall a. a -> ServerM a
Monad,
      MonadError String,
      Monad ServerM
Monad ServerM => (forall a. IO a -> ServerM a) -> MonadIO ServerM
forall a. IO a -> ServerM a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> ServerM a
liftIO :: forall a. IO a -> ServerM a
MonadIO
    )

askServer :: ServerM FS.Server
askServer :: ServerM Server
askServer = ReaderT Server (ExceptT [Char] IO) Server -> ServerM Server
forall a. ReaderT Server (ExceptT [Char] IO) a -> ServerM a
ServerM (ReaderT Server (ExceptT [Char] IO) Server -> ServerM Server)
-> ReaderT Server (ExceptT [Char] IO) Server -> ServerM Server
forall a b. (a -> b) -> a -> b
$ (Server -> Server) -> ReaderT Server (ExceptT [Char] IO) Server
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Server -> Server
server

askQueue :: ServerM (AL.AtomicList FS.VarName)
askQueue :: ServerM (AtomicList Text)
askQueue = ReaderT Server (ExceptT [Char] IO) (AtomicList Text)
-> ServerM (AtomicList Text)
forall a. ReaderT Server (ExceptT [Char] IO) a -> ServerM a
ServerM (ReaderT Server (ExceptT [Char] IO) (AtomicList Text)
 -> ServerM (AtomicList Text))
-> ReaderT Server (ExceptT [Char] IO) (AtomicList Text)
-> ServerM (AtomicList Text)
forall a b. (a -> b) -> a -> b
$ (Server -> AtomicList Text)
-> ReaderT Server (ExceptT [Char] IO) (AtomicList Text)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Server -> AtomicList Text
queue

modifyLive :: (S.Set FS.VarName -> S.Set FS.VarName) -> ServerM ()
modifyLive :: (Set Text -> Set Text) -> ServerM ()
modifyLive Set Text -> Set Text
f = do
  r <- ReaderT Server (ExceptT [Char] IO) (IORef (Set Text))
-> ServerM (IORef (Set Text))
forall a. ReaderT Server (ExceptT [Char] IO) a -> ServerM a
ServerM (ReaderT Server (ExceptT [Char] IO) (IORef (Set Text))
 -> ServerM (IORef (Set Text)))
-> ReaderT Server (ExceptT [Char] IO) (IORef (Set Text))
-> ServerM (IORef (Set Text))
forall a b. (a -> b) -> a -> b
$ (Server -> IORef (Set Text))
-> ReaderT Server (ExceptT [Char] IO) (IORef (Set Text))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Server -> IORef (Set Text)
live
  liftIO $ atomicModifyIORef' r $ (,()) . f

startServer :: FS.ServerCfg -> IO Server
startServer :: ServerCfg -> IO Server
startServer ServerCfg
cfg = Server -> IO Server
newServer (Server -> IO Server) -> IO Server -> IO Server
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ServerCfg -> IO Server
FS.startServer ServerCfg
cfg

-- | Use an already-running server. Shutting it down remains the
-- responsibility of whoever started it.
newServer :: FS.Server -> IO Server
newServer :: Server -> IO Server
newServer Server
s = Server -> AtomicList Text -> IORef (Set Text) -> Server
Server Server
s (AtomicList Text -> IORef (Set Text) -> Server)
-> IO (AtomicList Text) -> IO (IORef (Set Text) -> Server)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (AtomicList Text)
forall v. IO (AtomicList v)
AL.new IO (IORef (Set Text) -> Server)
-> IO (IORef (Set Text)) -> IO Server
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Set Text -> IO (IORef (Set Text))
forall a. a -> IO (IORef a)
newIORef Set Text
forall a. Monoid a => a
mempty

-- | Shut down the server. Returns a message on termination failure.
stopServer :: Server -> IO (Maybe T.Text)
stopServer :: Server -> IO (Maybe Text)
stopServer Server
s =
  (Maybe Text
forall a. Maybe a
Nothing Maybe Text -> IO () -> IO (Maybe Text)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Server -> IO ()
FS.stopServer (Server -> Server
server Server
s))
    IO (Maybe Text)
-> (ServerException -> IO (Maybe Text)) -> IO (Maybe Text)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(FS.ServerException Text
e) -> Maybe Text -> IO (Maybe Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO (Maybe Text)) -> Maybe Text -> IO (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
e

runServerM :: Server -> ServerM a -> IO (Either String a)
runServerM :: forall a. Server -> ServerM a -> IO (Either [Char] a)
runServerM Server
s (ServerM ReaderT Server (ExceptT [Char] IO) a
m) = ExceptT [Char] IO a -> IO (Either [Char] a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT [Char] IO a -> IO (Either [Char] a))
-> ExceptT [Char] IO a -> IO (Either [Char] a)
forall a b. (a -> b) -> a -> b
$ ReaderT Server (ExceptT [Char] IO) a
-> Server -> ExceptT [Char] IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Server (ExceptT [Char] IO) a
m Server
s

varName :: ValueRef -> ServerM FS.VarName
varName :: ValueRef -> ServerM Text
varName (ValueRef IORef Text
r) = IO Text -> ServerM Text
forall a. IO a -> ServerM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ServerM Text) -> IO Text -> ServerM Text
forall a b. (a -> b) -> a -> b
$ IORef Text -> IO Text
forall a. IORef a -> IO a
readIORef IORef Text
r

uniqueName :: ServerM FS.VarName
uniqueName :: ServerM Text
uniqueName = (Text
"v" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Unique -> Text) -> Unique -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text
forall a. Show a => a -> Text
T.show (Int -> Text) -> (Unique -> Int) -> Unique -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Unique -> Int
hashUnique (Unique -> Text) -> ServerM Unique -> ServerM Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Unique -> ServerM Unique
forall a. IO a -> ServerM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Unique
newUnique

mkValueRef :: FS.VarName -> ServerM ValueRef
mkValueRef :: Text -> ServerM ValueRef
mkValueRef Text
n = do
  (Set Text -> Set Text) -> ServerM ()
modifyLive ((Set Text -> Set Text) -> ServerM ())
-> (Set Text -> Set Text) -> ServerM ()
forall a b. (a -> b) -> a -> b
$ Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
S.insert Text
n
  r <- IO (IORef Text) -> ServerM (IORef Text)
forall a. IO a -> ServerM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Text) -> ServerM (IORef Text))
-> IO (IORef Text) -> ServerM (IORef Text)
forall a b. (a -> b) -> a -> b
$ Text -> IO (IORef Text)
forall a. a -> IO (IORef a)
newIORef Text
n
  q <- askQueue
  _ <- liftIO $ mkWeakIORef r $ AL.prepend n q
  pure $ ValueRef r

gc :: ServerM ()
gc :: ServerM ()
gc = [Text] -> ServerM ()
freeVars ([Text] -> ServerM ()) -> ServerM [Text] -> ServerM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [Text] -> ServerM [Text]
forall a. IO a -> ServerM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Text] -> ServerM [Text])
-> (AtomicList Text -> IO [Text])
-> AtomicList Text
-> ServerM [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AtomicList Text -> IO [Text]
forall v. AtomicList v -> IO [v]
AL.flush (AtomicList Text -> ServerM [Text])
-> ServerM (AtomicList Text) -> ServerM [Text]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ServerM (AtomicList Text)
askQueue

freeVars :: [FS.VarName] -> ServerM ()
freeVars :: [Text] -> ServerM ()
freeVars [Text]
vns = do
  s <- ServerM Server
askServer
  liftIO (FS.cmdFree s vns)
    >>= throwServerJust ("cmdFree failed on variables " ++ csList (map T.unpack vns) ++ ".")
  modifyLive (`S.difference` S.fromList vns)

-- | End the use of this 'Server'. The variables of the given values are
-- adopted by the caller under the given names, and every other variable we
-- have created is freed, whether or not its 'ValueRef' is still reachable.
-- Neither the 'Server' nor any 'ValueRef' may be used afterwards. A variable
-- may occur more than once, in which case it is adopted under the first of its
-- names. Returns the name of the variable of each value.
release :: [(ValueRef, FS.VarName)] -> ServerM [FS.VarName]
release :: [(ValueRef, Text)] -> ServerM [Text]
release [(ValueRef, Text)]
adopted = do
  s <- ServerM Server
askServer
  -- Everything in the queue is also live, so it is freed below.
  _ <- askQueue >>= liftIO . AL.flush
  srcs <- mapM (varName . fst) adopted
  let adopt Map Text Text
renamed (Text
src, Text
dst)
        | Just Text
dst' <- Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
src Map Text Text
renamed = (Map Text Text, Text) -> f (Map Text Text, Text)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map Text Text
renamed, Text
dst')
        | Bool
otherwise = do
            IO (Maybe CmdFailure) -> f (Maybe CmdFailure)
forall a. IO a -> f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Server -> Text -> Text -> IO (Maybe CmdFailure)
FS.cmdRename Server
s Text
src Text
dst)
              f (Maybe CmdFailure) -> (Maybe CmdFailure -> f ()) -> f ()
forall a b. f a -> (a -> f b) -> f b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Maybe CmdFailure -> f ()
forall (m :: * -> *).
MonadError [Char] m =>
[Char] -> Maybe CmdFailure -> m ()
throwServerJust ([Char]
"cmdRename failed on variable " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
src [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".")
            (Map Text Text, Text) -> f (Map Text Text, Text)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text -> Map Text Text -> Map Text Text
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
src Text
dst Map Text Text
renamed, Text
dst)
  (renamed, dsts) <- mapAccumLM adopt mempty $ zip srcs $ map snd adopted
  modifyLive (`S.difference` M.keysSet renamed)
  freeVars . S.toList =<< liftIO . readIORef =<< ServerM (asks live)
  pure dsts

call :: Name -> [ValueRef] -> ServerM ValueRef
call :: Name -> [ValueRef] -> ServerM ValueRef
call Name
fn [ValueRef]
ps = do
  s <- ServerM Server
askServer
  nps <- mapM varName ps
  ndst <- uniqueName
  -- A failing call is usually the program itself failing (e.g. OOB), so report
  -- just what the server said.
  _ <-
    liftIO (FS.cmdCall s (nameToText fn) ndst nps)
      >>= either (throwError . T.unpack . T.unlines . FS.failureMsg) pure
  mkValueRef ndst

-- Interrogation
inputs :: Name -> ServerM [FS.TypeName]
inputs :: Name -> ServerM [Text]
inputs Name
fn = do
  s <- ServerM Server
askServer
  map FS.inputType <$> (liftIO (FS.cmdInputs s $ nameToText fn) >>= throwServerLeft ("cmdInputs failed on function " ++ nameToString fn ++ "."))

output :: Name -> ServerM FS.TypeName
output :: Name -> ServerM Text
output Name
fn = do
  s <- ServerM Server
askServer
  FS.outputType <$> (liftIO (FS.cmdOutput s $ nameToText fn) >>= throwServerLeft ("cmdOutput failed on function " ++ nameToString fn ++ "."))

kind :: FS.TypeName -> ServerM FS.Kind
kind :: Text -> ServerM Kind
kind Text
tn = do
  s <- ServerM Server
askServer
  liftIO (FS.cmdKind s tn) >>= throwServerLeft ("cmdKind failed on type " ++ T.unpack tn ++ ".")

vtype :: ValueRef -> ServerM FS.TypeName
vtype :: ValueRef -> ServerM Text
vtype ValueRef
vr = do
  s <- ServerM Server
askServer
  vn <- varName vr
  liftIO (FS.cmdType s vn) >>= throwServerLeft ("cmdType failed on variable " ++ T.unpack vn ++ ".")

-- Primitives
getPrim :: ValueRef -> ServerM PrimValue
getPrim :: ValueRef -> ServerM PrimValue
getPrim ValueRef
vr = do
  s <- ServerM Server
askServer
  nsrc <- varName vr
  v <- liftIO (FS.getValue s nsrc) >>= throwLeft ("Failed to get primitive variable " ++ T.unpack nsrc ++ ".")
  pure $ dToP v

putPrim :: PrimValue -> ServerM ValueRef
putPrim :: PrimValue -> ServerM ValueRef
putPrim = Value -> ServerM ValueRef
putData (Value -> ServerM ValueRef)
-> (PrimValue -> Value) -> PrimValue -> ServerM ValueRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimValue -> Value
pToD

-- | Put an entire value on the server at once. This is only possible for
-- values that can be represented in the Futhark data format (primitives and
-- arrays of primitive).
putData :: D.Value -> ServerM ValueRef
putData :: Value -> ServerM ValueRef
putData Value
v = do
  s <- ServerM Server
askServer
  ndst <- uniqueName
  liftIO (FS.putValue s ndst v)
    >>= throwServerJust ("Failed to put value of type " ++ T.unpack (D.valueTypeText (D.valueType v)) ++ ".")
  mkValueRef ndst

-- Arrays
rank :: FS.TypeName -> ServerM Int
rank :: Text -> ServerM Int
rank Text
tn = do
  s <- ServerM Server
askServer
  liftIO (FS.cmdRank s tn) >>= throwServerLeft ("cmdRank failed on type " ++ T.unpack tn ++ ".")

elemType :: FS.TypeName -> ServerM FS.TypeName
elemType :: Text -> ServerM Text
elemType Text
tn = do
  s <- ServerM Server
askServer
  liftIO (FS.cmdElemtype s tn) >>= throwServerLeft ("cmdElemtype failed on type " ++ T.unpack tn ++ ".")

mkArray :: FS.TypeName -> [Int64] -> [ValueRef] -> ServerM ValueRef
mkArray :: Text -> [Int64] -> [ValueRef] -> ServerM ValueRef
mkArray Text
tn [Int64]
dims [ValueRef]
vs = do
  s <- ServerM Server
askServer
  vns <- mapM varName vs
  dst <- uniqueName
  liftIO (FS.cmdNewArray s dst tn (map fromIntegral dims) vns) >>= throwServerJust ("cmdNewArray failed on type " ++ T.unpack tn ++ " with variables " ++ csList (map T.unpack vns) ++ ".")
  mkValueRef dst

shape :: ValueRef -> ServerM [Int64]
shape :: ValueRef -> ServerM [Int64]
shape ValueRef
vr = do
  s <- ServerM Server
askServer
  vn <- varName vr
  map fromIntegral <$> (liftIO (FS.cmdShape s vn) >>= throwServerLeft ("cmdShape failed on variable " ++ T.unpack vn ++ "."))

-- | Retrieve an entire value from the server at once. This is only possible for
-- values that can be represented in the Futhark data format (primitives and
-- arrays of primitive).
getData :: ValueRef -> ServerM (Maybe D.Value)
getData :: ValueRef -> ServerM (Maybe Value)
getData ValueRef
vr = do
  s <- ServerM Server
askServer
  n <- varName vr
  either (const Nothing) Just <$> liftIO (FS.getValue s n)

index :: [Int64] -> ValueRef -> ServerM ValueRef
index :: [Int64] -> ValueRef -> ServerM ValueRef
index [Int64]
is ValueRef
src = do
  s <- ServerM Server
askServer
  nsrc <- varName src
  ndst <- uniqueName
  liftIO (FS.cmdIndex s ndst nsrc $ map fromIntegral is) >>= throwServerJust ("cmdIndex failed on source " ++ T.unpack nsrc ++ ", destination " ++ T.unpack ndst ++ ", and index " ++ show is ++ ".")
  mkValueRef ndst

-- Records

-- | The fields of a record type, in the order the server uses.
fieldOrder :: FS.TypeName -> ServerM [(Name, FS.TypeName)]
fieldOrder :: Text -> ServerM [(Name, Text)]
fieldOrder Text
tn = do
  s <- ServerM Server
askServer
  fs <- liftIO (FS.cmdFields s tn) >>= throwServerLeft ("cmdFields failed on type " ++ T.unpack tn ++ ".")
  pure $ map (\Field
f -> (Text -> Name
nameFromText (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ Field -> Text
FS.fieldName Field
f, Field -> Text
FS.fieldType Field
f)) fs

-- | Split an array of records into one array per field, in 'fieldOrder'. The
-- fields of an array cannot be projected one element at a time, and doing so
-- would anyway be impossible for an empty array.
unzipArray :: ValueRef -> Int -> ServerM [ValueRef]
unzipArray :: ValueRef -> Int -> ServerM [ValueRef]
unzipArray ValueRef
src Int
n = do
  s <- ServerM Server
askServer
  nsrc <- varName src
  ndsts <- replicateM n uniqueName
  liftIO (FS.cmdUnzip s nsrc ndsts)
    >>= throwServerJust ("cmdUnzip failed on variable " ++ T.unpack nsrc ++ ".")
  mapM mkValueRef ndsts

mkRecord :: FS.TypeName -> M.Map Name ValueRef -> ServerM ValueRef
mkRecord :: Text -> Map Name ValueRef -> ServerM ValueRef
mkRecord Text
tn Map Name ValueRef
vrm = do
  s <- ServerM Server
askServer
  fns <- map (nameFromText . FS.fieldName) <$> (liftIO (FS.cmdFields s tn) >>= throwServerLeft ("cmdFields failed on type " ++ T.unpack tn ++ "."))
  vns <-
    mapM
      ( \Name
fn ->
          [Char] -> Maybe ValueRef -> ServerM ValueRef
forall (m :: * -> *) a.
MonadError [Char] m =>
[Char] -> Maybe a -> m a
throwNothing ([Char]
"Missing field " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
nameToString Name
fn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" when constructing record of type " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
tn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".") (Name -> Map Name ValueRef -> Maybe ValueRef
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
fn Map Name ValueRef
vrm)
            ServerM ValueRef -> (ValueRef -> ServerM Text) -> ServerM Text
forall a b. ServerM a -> (a -> ServerM b) -> ServerM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ValueRef -> ServerM Text
varName
      )
      fns
  dst <- uniqueName
  liftIO (FS.cmdNew s dst tn vns) >>= throwServerJust ("cmdNew failed on type " ++ T.unpack tn ++ " with variables " ++ csList (map T.unpack vns) ++ ".")
  mkValueRef dst

project :: ValueRef -> Name -> ServerM ValueRef
project :: ValueRef -> Name -> ServerM ValueRef
project ValueRef
src Name
fn = do
  s <- ServerM Server
askServer
  nsrc <- varName src
  ndst <- uniqueName
  liftIO (FS.cmdProject s ndst nsrc $ nameToText fn)
    >>= throwServerJust ("cmdProject failed on source " ++ T.unpack nsrc ++ ", destination " ++ T.unpack ndst ++ ", and field " ++ nameToString fn ++ ".")
  mkValueRef ndst

-- Sums
variants :: FS.TypeName -> ServerM (M.Map Name [FS.TypeName])
variants :: Text -> ServerM (Map Name [Text])
variants Text
tn = do
  s <- ServerM Server
askServer
  vs <- liftIO (FS.cmdVariants s tn) >>= throwServerLeft ("cmdVariants failed on type " ++ T.unpack tn ++ ".")
  pure $ M.fromList $ map (\Variant
v -> (Text -> Name
nameFromText (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ Variant -> Text
FS.variantName Variant
v, Variant -> [Text]
FS.variantTypes Variant
v)) vs

mkSum :: FS.TypeName -> Name -> [ValueRef] -> ServerM ValueRef
mkSum :: Text -> Name -> [ValueRef] -> ServerM ValueRef
mkSum Text
tn Name
vn [ValueRef]
vrs = do
  s <- ServerM Server
askServer
  vns <- mapM varName vrs
  dst <- uniqueName
  liftIO (FS.cmdConstruct s dst tn (nameToText vn) vns)
    >>= throwServerJust ("cmdConstruct failed on type " ++ T.unpack tn ++ ", variant " ++ nameToString vn ++ " with variables " ++ csList (map T.unpack vns) ++ ".")
  mkValueRef dst

-- | The variant of a sum, and its payload.
destruct :: ValueRef -> ServerM (Name, [ValueRef])
destruct :: ValueRef -> ServerM (Name, [ValueRef])
destruct ValueRef
src = do
  vn <- ValueRef -> ServerM Name
variant ValueRef
src
  tn <- vtype src
  vts <- variants tn >>= throwNothing ("Variant " ++ nameToString vn ++ " is not part of its own sum type, " ++ T.unpack tn ++ ". This should be impossible.") . M.lookup vn
  do
    s <- askServer
    nsrc <- varName src
    ndsts <- mapM (const uniqueName) vts
    liftIO (FS.cmdDestruct s nsrc ndsts)
      >>= throwServerJust ("cmdVariants failed on source " ++ T.unpack nsrc ++ ", destinations " ++ csList (map T.unpack ndsts) ++ ".")
    (vn,) <$> mapM mkValueRef ndsts

variant :: ValueRef -> ServerM Name
variant :: ValueRef -> ServerM Name
variant ValueRef
src = do
  s <- ServerM Server
askServer
  nsrc <- varName src
  vn <-
    liftIO (FS.cmdVariant s nsrc)
      >>= throwServerLeft ("cmdIndex failed on variable " ++ T.unpack nsrc ++ ".")
  pure $ nameFromText vn

-- Error handling convenience
formatServerError :: String -> FS.CmdFailure -> String
formatServerError :: [Char] -> CmdFailure -> [Char]
formatServerError [Char]
e CmdFailure
f | [Char]
e [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
forall a. Monoid a => a
mempty = [Char] -> CmdFailure -> [Char]
formatServerError [Char]
"Server error." CmdFailure
f
formatServerError [Char]
e CmdFailure
f = Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
e Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Text
"Failure message:" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: CmdFailure -> [Text]
FS.failureMsg CmdFailure
f

throwServerLeft :: (MonadError String m) => String -> Either FS.CmdFailure a -> m a
throwServerLeft :: forall (m :: * -> *) a.
MonadError [Char] m =>
[Char] -> Either CmdFailure a -> m a
throwServerLeft [Char]
e (Left CmdFailure
c) = [Char] -> m a
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m a) -> [Char] -> m a
forall a b. (a -> b) -> a -> b
$ [Char] -> CmdFailure -> [Char]
formatServerError [Char]
e CmdFailure
c
throwServerLeft [Char]
_ (Right a
v) = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v

throwServerJust :: (MonadError String m) => String -> Maybe FS.CmdFailure -> m ()
throwServerJust :: forall (m :: * -> *).
MonadError [Char] m =>
[Char] -> Maybe CmdFailure -> m ()
throwServerJust [Char]
e Maybe CmdFailure
c = Maybe [Char] -> m ()
forall (m :: * -> *). MonadError [Char] m => Maybe [Char] -> m ()
throwJust (Maybe [Char] -> m ()) -> Maybe [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> CmdFailure -> [Char]
formatServerError [Char]
e (CmdFailure -> [Char]) -> Maybe CmdFailure -> Maybe [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CmdFailure
c

throwLeft :: (MonadError String m) => String -> Either T.Text a -> m a
throwLeft :: forall (m :: * -> *) a.
MonadError [Char] m =>
[Char] -> Either Text a -> m a
throwLeft [Char]
t (Left Text
e) = [Char] -> m a
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> m a) -> [Char] -> m a
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines [[Char] -> Text
T.pack [Char]
t, Text
e]
throwLeft [Char]
_ (Right a
v) = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v

throwJust :: (MonadError String m) => Maybe String -> m ()
throwJust :: forall (m :: * -> *). MonadError [Char] m => Maybe [Char] -> m ()
throwJust (Just [Char]
e) = [Char] -> m ()
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Char]
e
throwJust Maybe [Char]
Nothing = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

throwNothing :: (MonadError String m) => String -> Maybe a -> m a
throwNothing :: forall (m :: * -> *) a.
MonadError [Char] m =>
[Char] -> Maybe a -> m a
throwNothing [Char]
_ (Just a
v) = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v
throwNothing [Char]
e Maybe a
Nothing = [Char] -> m a
forall a. [Char] -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError [Char]
e

csList :: [String] -> String
csList :: [[Char]] -> [Char]
csList = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
","