diff --git a/cpphs-cpp b/cpphs-cpp new file mode 100644 --- /dev/null +++ b/cpphs-cpp @@ -0,0 +1,4 @@ +#!/bin/sh +# Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/17185 +cpphs --cpp $@ +exit $? diff --git a/jni.cabal b/jni.cabal --- a/jni.cabal +++ b/jni.cabal @@ -1,5 +1,5 @@ name: jni -version: 0.6.1 +version: 0.8.0 synopsis: Complete JNI raw bindings. description: Please see README.md. homepage: https://github.com/tweag/inline-java/tree/master/jni#readme @@ -11,43 +11,81 @@ category: FFI, JVM, Java build-type: Simple cabal-version: >=1.10 -extra-source-files: README.md +extra-source-files: README.md cpphs-cpp source-repository head type: git location: https://github.com/tweag/inline-java subdir: jni +flag linear-types + description: Build the linear types interface. + default: False + library - hs-source-dirs: src - if impl(ghc < 8.2.1) - c-sources: src/Foreign/JNI.c + hs-source-dirs: src/common cc-options: -std=c11 - -- XXX pgmP directive should be redundant. But necessary to workaround - -- https://github.com/haskell/cabal/issues/4278. - -- Needed for Foreign.JNI. - ghc-options: -pgmPcpphs -optP--cpp + if os(darwin) + -- XXX pgmP directive should be redundant. But necessary to workaround + -- https://github.com/haskell/cabal/issues/4278. + -- Needed for Foreign.JNI. + -- XXX we use an auxiliary script here that passes --cpp to cpphs. + -- Otherwise we hit https://gitlab.haskell.org/ghc/ghc/-/issues/17185 + ghc-options: -pgmP./cpphs-cpp extra-libraries: jvm exposed-modules: Foreign.JNI Foreign.JNI.Types Foreign.JNI.String Foreign.JNI.Internal + Foreign.JNI.Internal.BackgroundWorker + Foreign.JNI.Internal.RWLock + Foreign.JNI.Unsafe + Foreign.JNI.Unsafe.Internal + Foreign.JNI.Unsafe.Internal.Introspection other-modules: Foreign.JNI.NativeMethod build-depends: - base >=4.7 && <5, + async >=2.2.2, + base >=4.14 && <5, bytestring >=0.10, choice >=0.2.0, containers >=0.5, constraints >=0.8, deepseq >=1.4.2, - singletons >=2.0 - if impl(ghc < 8.2.1) + inline-c >=0.6, + stm >= 2.3, + text >= 1.2.3 + if flag(linear-types) + hs-source-dirs: src/linear-types build-depends: - inline-c >=0.5.6.1 && <0.6 + linear-base ==0.1.0.0 + exposed-modules: + Data.Singletons + Foreign.JNI.Safe + Foreign.JNI.Types.Safe else build-depends: - inline-c >=0.6 + singletons >=2.6 build-tools: cpphs default-language: Haskell2010 + +test-suite spec + type: + exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + other-modules: + Foreign.JNISpec + Spec + build-depends: + base, + hspec, + jni + if !flag(linear-types) + build-depends: + singletons + default-language: Haskell2010 + extra-libraries: pthread + ghc-options: -threaded + cpp-options: -DHSPEC_DISCOVER=hspec-discover diff --git a/src/Foreign/JNI.c b/src/Foreign/JNI.c deleted file mode 100644 --- a/src/Foreign/JNI.c +++ /dev/null diff --git a/src/Foreign/JNI.hs b/src/Foreign/JNI.hs deleted file mode 100644 --- a/src/Foreign/JNI.hs +++ /dev/null @@ -1,985 +0,0 @@ --- | Low-level bindings to the Java Native Interface (JNI). --- --- Read the --- --- for authoritative documentation as to what each of the functions in --- this module does. The names of the bindings in this module were chosen to --- match the names of the functions in the JNI spec. --- --- All bindings in this module access the JNI via a thread-local variable of --- type @JNIEnv *@. If the current OS thread has not yet been "attached" to the --- JVM, it is attached implicitly upon the first call to one of these bindings --- in the current thread. --- --- The 'String' type in this module is the type of JNI strings. See --- "Foreign.JNI.String". - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - --- XXX This file uses cpphs for preprocessing instead of the system's native --- CPP, because the OS X has subtly different whitespace behaviour in the --- presence of concatenation. - -module Foreign.JNI - ( -- * JNI functions - -- ** VM management - withJVM - , newJVM - , destroyJVM - -- ** Class loading - , defineClass - , JNINativeMethod(..) - , registerNatives - -- ** String wrappers - , ReferenceTypeName - , MethodSignature - , Signature - -- ** Exceptions - , JVMException(..) - , throw - , throwNew - -- ** Query functions - , findClass - , getFieldID - , getStaticFieldID - , getMethodID - , getStaticMethodID - , getObjectClass - -- ** Reference manipulation - , newGlobalRef - , deleteGlobalRef - , newGlobalRefNonFinalized - , deleteGlobalRefNonFinalized - , newLocalRef - , deleteLocalRef - , pushLocalFrame - , popLocalFrame - -- ** Field accessor functions - -- *** Get fields - , getObjectField - , getBooleanField - , getIntField - , getLongField - , getCharField - , getShortField - , getByteField - , getDoubleField - , getFloatField - -- *** Get static fields - , getStaticObjectField - , getStaticBooleanField - , getStaticIntField - , getStaticLongField - , getStaticCharField - , getStaticShortField - , getStaticByteField - , getStaticDoubleField - , getStaticFloatField - -- *** Set fields - , setObjectField - , setBooleanField - , setIntField - , setLongField - , setCharField - , setShortField - , setByteField - , setDoubleField - , setFloatField - -- *** Set static fields - , setStaticObjectField - , setStaticBooleanField - , setStaticIntField - , setStaticLongField - , setStaticCharField - , setStaticShortField - , setStaticByteField - , setStaticDoubleField - , setStaticFloatField - -- ** Method invocation - , callObjectMethod - , callBooleanMethod - , callIntMethod - , callLongMethod - , callCharMethod - , callShortMethod - , callByteMethod - , callDoubleMethod - , callFloatMethod - , callVoidMethod - , callStaticObjectMethod - , callStaticVoidMethod - , callStaticBooleanMethod - , callStaticIntMethod - , callStaticLongMethod - , callStaticCharMethod - , callStaticShortMethod - , callStaticByteMethod - , callStaticDoubleMethod - , callStaticFloatMethod - -- ** Object construction - , newObject - , newString - , newObjectArray - , newBooleanArray - , newByteArray - , newCharArray - , newShortArray - , newIntArray - , newLongArray - , newFloatArray - , newDoubleArray - -- ** Array manipulation - , getArrayLength - , getStringLength - , ArrayCopyFailed(..) - , NullPointerException(..) - , getBooleanArrayElements - , getByteArrayElements - , getCharArrayElements - , getShortArrayElements - , getIntArrayElements - , getLongArrayElements - , getFloatArrayElements - , getDoubleArrayElements - , getStringChars - , setBooleanArrayRegion - , setByteArrayRegion - , setCharArrayRegion - , setShortArrayRegion - , setIntArrayRegion - , setLongArrayRegion - , setFloatArrayRegion - , setDoubleArrayRegion - , releaseBooleanArrayElements - , releaseByteArrayElements - , releaseCharArrayElements - , releaseShortArrayElements - , releaseIntArrayElements - , releaseLongArrayElements - , releaseFloatArrayElements - , releaseDoubleArrayElements - , releaseStringChars - , getObjectArrayElement - , setObjectArrayElement - -- * Thread management - , attachCurrentThreadAsDaemon - , detachCurrentThread - , runInAttachedThread - ) where - -import Control.Concurrent (isCurrentThreadBound, rtsSupportsBoundThreads) -import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) -import Control.Exception (Exception, bracket, bracket_, catch, finally, throwIO) -import Control.Monad (join, unless, void, when) -import Data.Choice -import Data.Coerce -import Data.Int -import Data.IORef (IORef, newIORef, atomicModifyIORef) -import Data.Word -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import Data.Monoid ((<>)) -import Data.Typeable (Typeable) -import Foreign.C (CChar) -import Foreign.ForeignPtr - ( finalizeForeignPtr - , newForeignPtr_ - , withForeignPtr - ) -import Foreign.JNI.Internal -import Foreign.JNI.NativeMethod -import Foreign.JNI.Types -import qualified Foreign.JNI.String as JNI -import Foreign.Marshal.Alloc (alloca) -import Foreign.Marshal.Array -import Foreign.Ptr (Ptr, nullPtr) -import Foreign.Storable (peek) -import GHC.ForeignPtr (newConcForeignPtr) -import GHC.Stack (HasCallStack, callStack, getCallStack, prettySrcLoc) -import qualified Language.C.Inline as C -import qualified Language.C.Inline.Unsafe as CU -import System.IO (fixIO) -import System.IO.Unsafe (unsafePerformIO) -import Prelude hiding (String) -import qualified Prelude - -C.context (C.baseCtx <> C.bsCtx <> jniCtx) - -C.include "" -C.include "" -C.include "" -C.include "" - --- A thread-local variable to cache the JNI environment. Accessing this variable --- is faster than calling @jvm->GetEnv()@. -$(C.verbatim "static __thread JNIEnv* jniEnv; ") - --- | A JNI call may cause a (Java) exception to be raised. This module raises it --- as a Haskell exception wrapping the Java exception. -newtype JVMException = JVMException JThrowable - deriving (Show, Typeable) - -instance Exception JVMException - --- | Thrown when @GetArrayElements@ returns a null pointer, --- because it wanted to copy the array contents but couldn't. In this case the --- JVM doesn't throw OutOfMemory according to the JNI spec. -data ArrayCopyFailed = ArrayCopyFailed - deriving (Exception, Show, Typeable) - --- | A null reference is found where a non-null reference was expected. -data NullPointerException = NullPointerException - deriving (Exception, Show, Typeable) - --- | A JNI call is made from a thread not attached to the JVM. -data ThreadNotAttached = ThreadNotAttached - deriving (Exception, Show, Typeable) - --- | A JNI call is made from an unbound thread. -data ThreadNotBound = ThreadNotBound - deriving (Exception, Show, Typeable) - --- | Thrown when an JNI call is made from an unbound thread. -data JNIError = JNIError Prelude.String Int32 - deriving (Show, Typeable) - -instance Exception JNIError - --- | Map Java exceptions to Haskell exceptions. -throwIfException :: Ptr JNIEnv -> IO a -> IO a -throwIfException env m = m `finally` do - excptr <- [CU.exp| jthrowable { (*$(JNIEnv *env))->ExceptionOccurred($(JNIEnv *env)) } |] - unless (excptr == nullPtr) $ do - [CU.exp| void { (*$(JNIEnv *env))->ExceptionDescribe($(JNIEnv *env)) } |] - [CU.exp| void { (*$(JNIEnv *env))->ExceptionClear($(JNIEnv *env)) } |] - throwIO . JVMException =<< newGlobalRef =<< objectFromPtr excptr - --- | Check whether a pointer is null. -throwIfNull :: IO (Ptr a) -> IO (Ptr a) -throwIfNull m = do - ptr <- m - if ptr == nullPtr - then throwIO ArrayCopyFailed - else return ptr - --- | Throws an error if the given reference is null, otherwise performs --- the given io action. -throwIfJNull :: J ty -> IO a -> IO a -throwIfJNull j io = - if j == jnull - then throwIO NullPointerException - else io - --- | A read-write lock --- --- Concurrent readers are allowed, but only one writer is supported. -newtype RWLock = - RWLock (IORef (Int, RWWantedState)) - -- ^ A count of the held read locks and the wanted state - --- | The wanted state of the RW -data RWWantedState - = Reading -- ^ There are no writers - | Writing (MVar ()) - -- ^ A writer wants to write, grant no more read locks. The MVar is used - -- to notify the writer when the currently held read locks are released. - --- | Creates a new read-write lock. -newRWLock :: IO RWLock -newRWLock = RWLock <$> newIORef (0, Reading) - --- | Tries to acquire a read lock. If this call returns `Do #read`, no writer --- will be granted a lock before the read lock is released. -tryAcquireReadLock :: RWLock -> IO (Choice "read") -tryAcquireReadLock (RWLock ref) = do - atomicModifyIORef ref $ \case - (!readers, Reading) -> ((readers + 1, Reading), Do #read) - st -> ( st, Don't #read) - --- | Releases a read lock. -releaseReadLock :: RWLock -> IO () -releaseReadLock (RWLock ref) = do - st <- atomicModifyIORef ref $ - \st@(readers, aim) -> ((readers - 1, aim), st) - case st of - -- Notify the writer if I'm the last reader. - (1, Writing mv) -> putMVar mv () - _ -> return () - --- | Waits until the current read locks are released and grants a write lock. -acquireWriteLock :: RWLock -> IO () -acquireWriteLock (RWLock ref) = do - mv <- newEmptyMVar - join $ atomicModifyIORef ref $ \(readers, _) -> - ((readers, Writing mv), when (readers > 0) (takeMVar mv)) - --- | This lock is used to avoid the JVM from dying before any finalizers --- deleting global references are finished. --- --- Finalizers try to acquire read locks. --- --- The JVM acquires a write lock before shutdown. Thence, finalizers fail to --- acquire read locks and behave as noops. -globalJVMLock :: RWLock -globalJVMLock = unsafePerformIO newRWLock -{-# NOINLINE globalJVMLock #-} - -throwIfNotOK_ :: HasCallStack => IO Int32 -> IO () -throwIfNotOK_ m = m >>= \case - rc - | rc == [CU.pure| jint { JNI_OK } |] -> return () - | rc == [CU.pure| jint { JNI_EDETACHED } |] -> throwIO ThreadNotAttached - | otherwise -> throwIO $ JNIError (prettySrcLoc loc) rc - where - (_, loc):_ = getCallStack callStack - -attachCurrentThreadAsDaemon :: IO () -attachCurrentThreadAsDaemon = do - throwIfNotOK_ - [CU.exp| jint { - (*$(JavaVM* jvm))->AttachCurrentThreadAsDaemon($(JavaVM* jvm), (void**)&jniEnv, NULL) - } |] - -detachCurrentThread :: IO () -detachCurrentThread = - throwIfNotOK_ - [CU.block| jint { - int rc = (*$(JavaVM* jvm))->DetachCurrentThread($(JavaVM* jvm)); - if (rc == JNI_OK) - jniEnv = NULL; - return rc; - } |] - --- | Attaches the calling thread to the JVM, runs the given IO action and --- then detaches the thread. --- --- If the thread is already attached no attaching and detaching is performed. -runInAttachedThread :: IO a -> IO a -runInAttachedThread io = do - attached <- - catch (getJNIEnv >> return True) (\ThreadNotBound -> return False) - if attached - then io - else bracket_ - attachCurrentThreadAsDaemon - detachCurrentThread - io - --- | The current JVM --- --- Assumes there's at most one JVM. The current JNI spec (2016) says only --- one JVM per process is supported anyways. -{-# NOINLINE jvm #-} -jvm :: Ptr JVM -jvm = unsafePerformIO $ alloca $ \pjvm -> alloca $ \pnum_jvms -> do - throwIfNotOK_ - [CU.exp| jint { - JNI_GetCreatedJavaVMs($(JavaVM** pjvm), 1, $(jsize* pnum_jvms)) - }|] - num_jvms <- peek pnum_jvms - when (num_jvms == 0) $ - fail "JNI_GetCreatedJavaVMs: No JVM has been initialized yet." - when (num_jvms > 1) $ - fail "JNI_GetCreatedJavaVMs: There are multiple JVMs but only one is supported." - peek pjvm - --- | Yields the JNIEnv of the calling thread. --- --- Yields @Nothing@ if the calling thread is not attached to the JVM. -getJNIEnv :: IO (Ptr JNIEnv) -getJNIEnv = [CU.exp| JNIEnv* { jniEnv } |] >>= \case - env | env == nullPtr -> do - throwIfNotOK_ - [CU.exp| jint { - (*$(JavaVM* jvm))->GetEnv($(JavaVM* jvm), (void**)&jniEnv, JNI_VERSION_1_6) - }|] - [CU.exp| JNIEnv* { jniEnv } |] - env -> return env - --- | Run an action against the appropriate 'JNIEnv'. --- --- Each OS thread has its own 'JNIEnv', which this function gives access to. -withJNIEnv :: (Ptr JNIEnv -> IO a) -> IO a -withJNIEnv f = getJNIEnv >>= f - -useAsCStrings :: [ByteString] -> ([Ptr CChar] -> IO a) -> IO a -useAsCStrings strs m = - foldr (\str k cstrs -> BS.useAsCString str $ \cstr -> k (cstr:cstrs)) m strs [] - --- | Create a new JVM, with the given arguments. /Can only be called once/. Best --- practice: use 'withJVM' instead. Only useful for GHCi. -newJVM :: [ByteString] -> IO JVM -newJVM options = JVM_ <$> do - useAsCStrings options $ \cstrs -> do - withArray cstrs $ \(coptions :: Ptr (Ptr CChar)) -> do - let n = fromIntegral (length cstrs) :: C.CInt - checkBoundness - [C.block| JavaVM * { - JavaVM *jvm; - JavaVMInitArgs vm_args; - JavaVMOption *options = malloc(sizeof(JavaVMOption) * $(int n)); - for(int i = 0; i < $(int n); i++) - options[i].optionString = $(char **coptions)[i]; - vm_args.version = JNI_VERSION_1_6; - vm_args.nOptions = $(int n); - vm_args.options = options; - vm_args.ignoreUnrecognized = 0; - JNI_CreateJavaVM(&jvm, (void**)&jniEnv, &vm_args); - free(options); - return jvm; } |] - - where - checkBoundness :: IO () - checkBoundness = when rtsSupportsBoundThreads $ do - bound <- isCurrentThreadBound - unless bound (throwIO ThreadNotBound) - --- | Deallocate a 'JVM' created using 'newJVM'. -destroyJVM :: JVM -> IO () -destroyJVM (JVM_ jvm) = do - acquireWriteLock globalJVMLock - [C.block| void { - (*$(JavaVM *jvm))->DestroyJavaVM($(JavaVM *jvm)); - jniEnv = NULL; - } |] - --- | Create a new JVM, with the given arguments. Destroy it once the given --- action completes. /Can only be called once/. Best practice: use it to wrap --- your @main@ function. -withJVM :: [ByteString] -> IO a -> IO a -withJVM options action = bracket (newJVM options) destroyJVM (const action) - -defineClass - :: Coercible o (J ('Class "java.lang.ClassLoader")) - => ReferenceTypeName -- ^ Class name - -> o -- ^ Loader - -> ByteString -- ^ Bytecode buffer - -> IO JClass -defineClass (coerce -> name) (coerce -> upcast -> loader) buf = withJNIEnv $ \env -> - throwIfException env $ - JNI.withString name $ \namep -> - objectFromPtr =<< - [CU.exp| jclass { - (*$(JNIEnv *env))->DefineClass($(JNIEnv *env), - $(char *namep), - $fptr-ptr:(jobject loader), - $bs-ptr:buf, - $bs-len:buf) } |] -registerNatives - :: JClass - -> [JNINativeMethod] - -> IO () -registerNatives cls methods = withJNIEnv $ \env -> - throwIfException env $ - withArray methods $ \cmethods -> do - let numMethods = fromIntegral $ length methods - _ <- [CU.exp| jint { - (*$(JNIEnv *env))->RegisterNatives($(JNIEnv *env), - $fptr-ptr:(jclass cls), - $(JNINativeMethod *cmethods), - $(int numMethods)) } |] - return () - -throw :: Coercible o (J a) => o -> IO () -throw (coerce -> upcast -> obj) = withJNIEnv $ \env -> void $ do - [CU.exp| jint { - (*$(JNIEnv *env))->Throw($(JNIEnv *env), - $fptr-ptr:(jobject obj)) } |] - -throwNew :: JClass -> JNI.String -> IO () -throwNew cls msg = throwIfJNull cls $ withJNIEnv $ \env -> - JNI.withString msg $ \msgp -> void $ do - [CU.exp| jint { - (*$(JNIEnv *env))->ThrowNew($(JNIEnv *env), - $fptr-ptr:(jclass cls), - $(char *msgp)) } |] - -findClass - :: ReferenceTypeName -- ^ Class name - -> IO JClass -findClass (coerce -> name) = withJNIEnv $ \env -> - throwIfException env $ - JNI.withString name $ \namep -> - objectFromPtr =<< - [CU.exp| jclass { (*$(JNIEnv *env))->FindClass($(JNIEnv *env), $(char *namep)) } |] - -newObject :: JClass -> MethodSignature -> [JValue] -> IO JObject -newObject cls (coerce -> sig) args = throwIfJNull cls $ withJNIEnv $ \env -> - throwIfException env $ - withJValues args $ \cargs -> do - constr <- getMethodID cls "" sig - objectFromPtr =<< [CU.exp| jobject { - (*$(JNIEnv *env))->NewObjectA($(JNIEnv *env), - $fptr-ptr:(jclass cls), - $(jmethodID constr), - $(jvalue *cargs)) } |] - -getFieldID - :: JClass -- ^ A class object as returned by 'findClass' - -> JNI.String -- ^ Field name - -> Signature -- ^ JNI signature - -> IO JFieldID -getFieldID cls fieldname (coerce -> sig) = throwIfJNull cls $ - withJNIEnv $ \env -> - throwIfException env $ - JNI.withString fieldname $ \fieldnamep -> - JNI.withString sig $ \sigp -> - [CU.exp| jfieldID { - (*$(JNIEnv *env))->GetFieldID($(JNIEnv *env), - $fptr-ptr:(jclass cls), - $(char *fieldnamep), - $(char *sigp)) } |] - -getStaticFieldID - :: JClass -- ^ A class object as returned by 'findClass' - -> JNI.String -- ^ Field name - -> Signature -- ^ JNI signature - -> IO JFieldID -getStaticFieldID cls fieldname (coerce -> sig) = throwIfJNull cls $ - withJNIEnv $ \env -> - throwIfException env $ - JNI.withString fieldname $ \fieldnamep -> - JNI.withString sig $ \sigp -> - [CU.exp| jfieldID { - (*$(JNIEnv *env))->GetStaticFieldID($(JNIEnv *env), - $fptr-ptr:(jclass cls), - $(char *fieldnamep), - $(char *sigp)) } |] - -#define GET_FIELD(name, hs_rettype, c_rettype) \ -get/**/name/**/Field :: Coercible o (J a) => o -> JFieldID -> IO hs_rettype; \ -get/**/name/**/Field (coerce -> upcast -> obj) field = withJNIEnv $ \env -> \ - throwIfException env $ \ - [CU.exp| c_rettype { \ - (*$(JNIEnv *env))->Get/**/name/**/Field($(JNIEnv *env), \ - $fptr-ptr:(jobject obj), \ - $(jfieldID field)) } |] - -getObjectField :: Coercible o (J a) => o -> JFieldID -> IO JObject -getObjectField x y = - let GET_FIELD(Object, (Ptr JObject), jobject) - in objectFromPtr =<< getObjectField x y -GET_FIELD(Boolean, Word8, jboolean) -GET_FIELD(Byte, CChar, jbyte) -GET_FIELD(Char, Word16, jchar) -GET_FIELD(Short, Int16, jshort) -GET_FIELD(Int, Int32, jint) -GET_FIELD(Long, Int64, jlong) -GET_FIELD(Float, Float, jfloat) -GET_FIELD(Double, Double, jdouble) - -#define GET_STATIC_FIELD(name, hs_rettype, c_rettype) \ -getStatic/**/name/**/Field :: JClass -> JFieldID -> IO hs_rettype; \ -getStatic/**/name/**/Field klass field = throwIfJNull klass $ \ - withJNIEnv $ \env -> \ - throwIfException env $ \ - [CU.exp| c_rettype { \ - (*$(JNIEnv *env))->GetStatic/**/name/**/Field($(JNIEnv *env), \ - $fptr-ptr:(jclass klass), \ - $(jfieldID field)) } |] - -getStaticObjectField :: JClass -> JFieldID -> IO JObject -getStaticObjectField x y = - let GET_STATIC_FIELD(Object, (Ptr JObject), jobject) - in objectFromPtr =<< getStaticObjectField x y -GET_STATIC_FIELD(Boolean, Word8, jboolean) -GET_STATIC_FIELD(Byte, CChar, jbyte) -GET_STATIC_FIELD(Char, Word16, jchar) -GET_STATIC_FIELD(Short, Int16, jshort) -GET_STATIC_FIELD(Int, Int32, jint) -GET_STATIC_FIELD(Long, Int64, jlong) -GET_STATIC_FIELD(Float, Float, jfloat) -GET_STATIC_FIELD(Double, Double, jdouble) - -#define SET_FIELD(name, hs_fieldtype, c_fieldtype) \ -set/**/name/**/Field :: Coercible o (J a) => o -> JFieldID -> hs_fieldtype -> IO (); \ -set/**/name/**/Field (coerce -> upcast -> obj) field x = \ - withJNIEnv $ \env -> \ - throwIfException env $ \ - [CU.block| void { \ - (*$(JNIEnv *env))->Set/**/name/**/Field($(JNIEnv *env), \ - $fptr-ptr:(jobject obj), \ - $(jfieldID field), \ - $(c_fieldtype x)); } |] - -setObjectField :: Coercible o (J a) => o -> JFieldID -> JObject -> IO () -setObjectField x y z = - let SET_FIELD(Object, (Ptr JObject), jobject) - in withForeignPtr (coerce z) (setObjectField x y) -SET_FIELD(Boolean, Word8, jboolean) -SET_FIELD(Byte, CChar, jbyte) -SET_FIELD(Char, Word16, jchar) -SET_FIELD(Short, Int16, jshort) -SET_FIELD(Int, Int32, jint) -SET_FIELD(Long, Int64, jlong) -SET_FIELD(Float, Float, jfloat) -SET_FIELD(Double, Double, jdouble) - -#define SET_STATIC_FIELD(name, hs_fieldtype, c_fieldtype) \ -setStatic/**/name/**/Field :: JClass -> JFieldID -> hs_fieldtype -> IO (); \ -setStatic/**/name/**/Field klass field x = throwIfJNull klass $ \ - withJNIEnv $ \env -> \ - throwIfException env $ \ - [CU.block| void { \ - (*$(JNIEnv *env))->SetStatic/**/name/**/Field($(JNIEnv *env), \ - $fptr-ptr:(jclass klass), \ - $(jfieldID field), \ - $(c_fieldtype x)); } |] - -setStaticObjectField :: JClass -> JFieldID -> JObject -> IO () -setStaticObjectField x y z = - let SET_STATIC_FIELD(Object, (Ptr JObject), jobject) - in withForeignPtr (coerce z) (setStaticObjectField x y) -SET_STATIC_FIELD(Boolean, Word8, jboolean) -SET_STATIC_FIELD(Byte, CChar, jbyte) -SET_STATIC_FIELD(Char, Word16, jchar) -SET_STATIC_FIELD(Short, Int16, jshort) -SET_STATIC_FIELD(Int, Int32, jint) -SET_STATIC_FIELD(Long, Int64, jlong) -SET_STATIC_FIELD(Float, Float, jfloat) -SET_STATIC_FIELD(Double, Double, jdouble) - -getMethodID - :: JClass -- ^ A class object as returned by 'findClass' - -> JNI.String -- ^ Field name - -> MethodSignature -- ^ JNI signature - -> IO JMethodID -getMethodID cls methodname (coerce -> sig) = throwIfJNull cls $ - withJNIEnv $ \env -> - throwIfException env $ - JNI.withString methodname $ \methodnamep -> - JNI.withString sig $ \sigp -> - [CU.exp| jmethodID { - (*$(JNIEnv *env))->GetMethodID($(JNIEnv *env), - $fptr-ptr:(jclass cls), - $(char *methodnamep), - $(char *sigp)) } |] - -getStaticMethodID - :: JClass -- ^ A class object as returned by 'findClass' - -> JNI.String -- ^ Field name - -> MethodSignature -- ^ JNI signature - -> IO JMethodID -getStaticMethodID cls methodname (coerce -> sig) = throwIfJNull cls $ - withJNIEnv $ \env -> - throwIfException env $ - JNI.withString methodname $ \methodnamep -> - JNI.withString sig $ \sigp -> - [CU.exp| jmethodID { - (*$(JNIEnv *env))->GetStaticMethodID($(JNIEnv *env), - $fptr-ptr:(jclass cls), - $(char *methodnamep), - $(char *sigp)) } |] - -getObjectClass :: Coercible o (J ty) => o -> IO JClass -getObjectClass (coerce -> upcast -> obj) = throwIfJNull obj $ - withJNIEnv $ \env -> - objectFromPtr =<< - [CU.exp| jclass { - (*$(JNIEnv *env))->GetObjectClass($(JNIEnv *env), - $fptr-ptr:(jobject obj)) } |] - --- | Creates a global reference to the object referred to by --- the given reference. --- --- Arranges for a finalizer to call 'deleteGlobalRef' when the --- global reference is no longer reachable on the Haskell side. -newGlobalRef :: Coercible o (J ty) => o -> IO o -newGlobalRef (coerce -> upcast -> obj) = withJNIEnv $ \env -> do - gobj <- - [CU.exp| jobject { - (*$(JNIEnv *env))->NewGlobalRef($(JNIEnv *env), - $fptr-ptr:(jobject obj)) } |] - fixIO $ \j -> - coerce <$> J <$> newConcForeignPtr gobj (deleteGlobalRefNonFinalized j) - -deleteGlobalRef :: Coercible o (J ty) => o -> IO () -deleteGlobalRef (coerce -> J p) = finalizeForeignPtr p - --- | Like 'newGlobalRef' but it doesn't attach a finalizer to destroy --- the reference when it is not longer reachable. Use --- 'deleteGlobalRefNonFinalized' to destroy this reference. -newGlobalRefNonFinalized :: Coercible o (J ty) => o -> IO o -newGlobalRefNonFinalized (coerce -> upcast -> obj) = withJNIEnv $ \env -> do - gobj <- - [CU.exp| jobject { - (*$(JNIEnv *env))->NewGlobalRef($(JNIEnv *env), - $fptr-ptr:(jobject obj)) } |] - coerce <$> J <$> newForeignPtr_ gobj - --- | Like 'deleteGlobalRef' but it can be used only on references created with --- 'newGlobalRefNonFinalized'. -deleteGlobalRefNonFinalized :: Coercible o (J ty) => o -> IO () -deleteGlobalRefNonFinalized (coerce -> upcast -> obj) = do - bracket (tryAcquireReadLock globalJVMLock) - (\doRead -> when (toBool doRead) $ releaseReadLock globalJVMLock) - $ \doRead -> - when (toBool doRead) $ withJNIEnv $ \env -> do - [CU.block| void { (*$(JNIEnv *env))->DeleteGlobalRef($(JNIEnv *env) - ,$fptr-ptr:(jobject obj)); - } |] - --- NB: Cannot add a finalizer to local references because it may --- run in a thread where the reference is not valid. -newLocalRef :: Coercible o (J ty) => o -> IO o -newLocalRef (coerce -> upcast -> obj) = withJNIEnv $ \env -> - coerce <$> (objectFromPtr =<<) - [CU.exp| jobject { - (*$(JNIEnv *env))->NewLocalRef($(JNIEnv *env), - $fptr-ptr:(jobject obj)) } |] - -deleteLocalRef :: Coercible o (J ty) => o -> IO () -deleteLocalRef (coerce -> upcast -> obj) = withJNIEnv $ \env -> - [CU.exp| void { - (*$(JNIEnv *env))->DeleteLocalRef($(JNIEnv *env), - $fptr-ptr:(jobject obj)) } |] - -pushLocalFrame :: Int32 -> IO () -pushLocalFrame (coerce -> capacity) = withJNIEnv $ \env -> - -- We ignore the output as it is always 0 on success and throws an - -- exception otherwise. - throwIfException env $ void $ - [CU.block| jint { - (*$(JNIEnv *env))->PushLocalFrame($(JNIEnv *env), - $(jint capacity)); } |] - -popLocalFrame :: Coercible o (J ty) => o -> IO o -popLocalFrame (coerce -> upcast -> obj) = withJNIEnv $ \env -> - coerce <$> (objectFromPtr =<<) - [CU.exp| jobject { - (*$(JNIEnv *env))->PopLocalFrame($(JNIEnv *env), - $fptr-ptr:(jobject obj)) } |] - --- Modern CPP does have ## for concatenating strings, but we use the hacky /**/ --- comment syntax for string concatenation. This is because GHC passes --- the -traditional flag to the preprocessor by default, which turns off several --- modern CPP features. - -#define CALL_METHOD(name, hs_rettype, c_rettype) \ -call/**/name/**/Method :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO hs_rettype; \ -call/**/name/**/Method (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> \ - throwIfException env $ \ - withJValues args $ \cargs -> \ - [C.exp| c_rettype { \ - (*$(JNIEnv *env))->Call/**/name/**/MethodA($(JNIEnv *env), \ - $fptr-ptr:(jobject obj), \ - $(jmethodID method), \ - $(jvalue *cargs)) } |] - -CALL_METHOD(Void, (), void) -callObjectMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO JObject -callObjectMethod x y z = - let CALL_METHOD(Object, (Ptr JObject), jobject) - in objectFromPtr =<< callObjectMethod x y z -callBooleanMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO Bool -callBooleanMethod x y z = - let CALL_METHOD(Boolean, Word8, jboolean) - in toEnum . fromIntegral <$> callBooleanMethod x y z -CALL_METHOD(Byte, CChar, jbyte) -CALL_METHOD(Char, Word16, jchar) -CALL_METHOD(Short, Int16, jshort) -CALL_METHOD(Int, Int32, jint) -CALL_METHOD(Long, Int64, jlong) -CALL_METHOD(Float, Float, jfloat) -CALL_METHOD(Double, Double, jdouble) - -#define CALL_STATIC_METHOD(name, hs_rettype, c_rettype) \ -callStatic/**/name/**/Method :: JClass -> JMethodID -> [JValue] -> IO hs_rettype; \ -callStatic/**/name/**/Method cls method args = throwIfJNull cls $ \ - withJNIEnv $ \env -> \ - throwIfException env $ \ - withJValues args $ \cargs -> \ - [C.exp| c_rettype { \ - (*$(JNIEnv *env))->CallStatic/**/name/**/MethodA($(JNIEnv *env), \ - $fptr-ptr:(jclass cls), \ - $(jmethodID method), \ - $(jvalue *cargs)) } |] - -CALL_STATIC_METHOD(Void, (), void) -callStaticObjectMethod :: JClass -> JMethodID -> [JValue] -> IO JObject -callStaticObjectMethod x y z = - let CALL_STATIC_METHOD(Object, (Ptr JObject), jobject) - in objectFromPtr =<< callStaticObjectMethod x y z -callStaticBooleanMethod :: JClass -> JMethodID -> [JValue] -> IO Bool -callStaticBooleanMethod x y z = - let CALL_STATIC_METHOD(Boolean, Word8, jboolean) - in toEnum . fromIntegral <$> callStaticBooleanMethod x y z -CALL_STATIC_METHOD(Byte, CChar, jbyte) -CALL_STATIC_METHOD(Char, Word16, jchar) -CALL_STATIC_METHOD(Short, Int16, jshort) -CALL_STATIC_METHOD(Int, Int32, jint) -CALL_STATIC_METHOD(Long, Int64, jlong) -CALL_STATIC_METHOD(Float, Float, jfloat) -CALL_STATIC_METHOD(Double, Double, jdouble) - -newObjectArray :: Int32 -> JClass -> IO JObjectArray -newObjectArray sz cls = throwIfJNull cls $ withJNIEnv $ \env -> - throwIfException env $ - objectFromPtr =<< - [CU.exp| jobjectArray { - (*$(JNIEnv *env))->NewObjectArray($(JNIEnv *env), - $(jsize sz), - $fptr-ptr:(jclass cls), - NULL) } |] - -#define NEW_ARRAY(name, c_rettype) \ -new/**/name/**/Array :: Int32 -> IO J/**/name/**/Array; \ -new/**/name/**/Array sz = withJNIEnv $ \env -> \ - throwIfException env $ \ - objectFromPtr =<< \ - [CU.exp| c_rettype/**/Array { \ - (*$(JNIEnv *env))->New/**/name/**/Array($(JNIEnv *env), \ - $(jsize sz)) } |] - -NEW_ARRAY(Boolean, jboolean) -NEW_ARRAY(Byte, jbyte) -NEW_ARRAY(Char, jchar) -NEW_ARRAY(Short, jshort) -NEW_ARRAY(Int, jint) -NEW_ARRAY(Long, jlong) -NEW_ARRAY(Float, jfloat) -NEW_ARRAY(Double, jdouble) - -newString :: Ptr Word16 -> Int32 -> IO JString -newString ptr len = withJNIEnv $ \env -> - throwIfException env $ - objectFromPtr =<< - [CU.exp| jstring { - (*$(JNIEnv *env))->NewString($(JNIEnv *env), - $(jchar *ptr), - $(jsize len)) } |] - -getArrayLength :: Coercible o (JArray a) => o -> IO Int32 -getArrayLength (coerce -> upcast -> array) = throwIfJNull array $ - withJNIEnv $ \env -> - [C.exp| jsize { - (*$(JNIEnv *env))->GetArrayLength($(JNIEnv *env), - $fptr-ptr:(jarray array)) } |] - -getStringLength :: JString -> IO Int32 -getStringLength jstr = throwIfJNull jstr $ withJNIEnv $ \env -> - [CU.exp| jsize { - (*$(JNIEnv *env))->GetStringLength($(JNIEnv *env), - $fptr-ptr:(jstring jstr)) } |] - -#define GET_ARRAY_ELEMENTS(name, hs_rettype, c_rettype) \ -get/**/name/**/ArrayElements :: J/**/name/**/Array -> IO (Ptr hs_rettype); \ -get/**/name/**/ArrayElements (upcast -> array) = throwIfJNull array $ \ - withJNIEnv $ \env -> \ - throwIfNull $ \ - [CU.exp| c_rettype* { \ - (*$(JNIEnv *env))->Get/**/name/**/ArrayElements($(JNIEnv *env), \ - $fptr-ptr:(jobject array), \ - NULL) } |] - -GET_ARRAY_ELEMENTS(Boolean, Word8, jboolean) -GET_ARRAY_ELEMENTS(Byte, CChar, jbyte) -GET_ARRAY_ELEMENTS(Char, Word16, jchar) -GET_ARRAY_ELEMENTS(Short, Int16, jshort) -GET_ARRAY_ELEMENTS(Int, Int32, jint) -GET_ARRAY_ELEMENTS(Long, Int64, jlong) -GET_ARRAY_ELEMENTS(Float, Float, jfloat) -GET_ARRAY_ELEMENTS(Double, Double, jdouble) - -getStringChars :: JString -> IO (Ptr Word16) -getStringChars jstr = throwIfJNull jstr $ withJNIEnv $ \env -> - throwIfNull $ - [CU.exp| const jchar* { - (*$(JNIEnv *env))->GetStringChars($(JNIEnv *env), - $fptr-ptr:(jstring jstr), - NULL) } |] - -#define SET_ARRAY_REGION(name, hs_argtype, c_argtype) \ -set/**/name/**/ArrayRegion :: J/**/name/**/Array -> Int32 -> Int32 -> Ptr hs_argtype -> IO (); \ -set/**/name/**/ArrayRegion array start len buf = throwIfJNull array $ \ - withJNIEnv $ \env -> \ - throwIfException env $ \ - [CU.exp| void { \ - (*$(JNIEnv *env))->Set/**/name/**/ArrayRegion($(JNIEnv *env), \ - $fptr-ptr:(c_argtype/**/Array array), \ - $(jsize start), \ - $(jsize len), \ - $(c_argtype *buf)) } |] - -SET_ARRAY_REGION(Boolean, Word8, jboolean) -SET_ARRAY_REGION(Byte, CChar, jbyte) -SET_ARRAY_REGION(Char, Word16, jchar) -SET_ARRAY_REGION(Short, Int16, jshort) -SET_ARRAY_REGION(Int, Int32, jint) -SET_ARRAY_REGION(Long, Int64, jlong) -SET_ARRAY_REGION(Float, Float, jfloat) -SET_ARRAY_REGION(Double, Double, jdouble) - -#define RELEASE_ARRAY_ELEMENTS(name, hs_argtype, c_argtype) \ -release/**/name/**/ArrayElements :: J/**/name/**/Array -> Ptr hs_argtype -> IO (); \ -release/**/name/**/ArrayElements (upcast -> array) xs = throwIfJNull array $ \ - withJNIEnv $ \env -> \ - [CU.exp| void { \ - (*$(JNIEnv *env))->Release/**/name/**/ArrayElements($(JNIEnv *env), \ - $fptr-ptr:(jobject array), \ - $(c_argtype *xs), \ - JNI_ABORT) } |] - -RELEASE_ARRAY_ELEMENTS(Boolean, Word8, jboolean) -RELEASE_ARRAY_ELEMENTS(Byte, CChar, jbyte) -RELEASE_ARRAY_ELEMENTS(Char, Word16, jchar) -RELEASE_ARRAY_ELEMENTS(Short, Int16, jshort) -RELEASE_ARRAY_ELEMENTS(Int, Int32, jint) -RELEASE_ARRAY_ELEMENTS(Long, Int64, jlong) -RELEASE_ARRAY_ELEMENTS(Float, Float, jfloat) -RELEASE_ARRAY_ELEMENTS(Double, Double, jdouble) - -releaseStringChars :: JString -> Ptr Word16 -> IO () -releaseStringChars jstr chars = throwIfJNull jstr $ withJNIEnv $ \env -> - [CU.exp| void { - (*$(JNIEnv *env))->ReleaseStringChars($(JNIEnv *env), - $fptr-ptr:(jstring jstr), - $(jchar *chars)) } |] - -getObjectArrayElement - :: forall a o. - (IsReferenceType a, Coercible o (J a)) - => JArray a - -> Int32 - -> IO o -getObjectArrayElement (arrayUpcast -> array) i = throwIfJNull array $ - withJNIEnv $ \env -> - ( (coerce :: J a -> o) - . (unsafeCast :: JObject -> J a) - ) <$> (objectFromPtr =<<) - [C.exp| jobject { - (*$(JNIEnv *env))->GetObjectArrayElement($(JNIEnv *env), - $fptr-ptr:(jarray array), - $(jsize i)) } |] - -setObjectArrayElement - :: forall a o. - (IsReferenceType a, Coercible o (J a)) - => JArray a - -> Int32 - -> o - -> IO () -setObjectArrayElement (arrayUpcast -> array) - i - ((coerce :: o -> J a) -> upcast -> x) = - throwIfJNull array $ - withJNIEnv $ \env -> - [C.exp| void { - (*$(JNIEnv *env))->SetObjectArrayElement($(JNIEnv *env), - $fptr-ptr:(jobjectArray array), - $(jsize i), - $fptr-ptr:(jobject x)); } |] diff --git a/src/Foreign/JNI/Internal.hs b/src/Foreign/JNI/Internal.hs deleted file mode 100644 --- a/src/Foreign/JNI/Internal.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Foreign.JNI.Internal where - -import qualified Foreign.JNI.String as JNI - --- | A reference type name is not just any 'JNI.String', but a fully qualified --- identifier well-formed by construction. -newtype ReferenceTypeName = ReferenceTypeName JNI.String - deriving (Eq, Ord) - -instance Show ReferenceTypeName where - show (ReferenceTypeName str) = show str - --- | A string representing a signature, well-formed by construction. -newtype Signature = Signature JNI.String - deriving (Eq, Ord) - -instance Show Signature where - show (Signature str) = show str - --- | A string representing a method signature, well-formed by construction. -newtype MethodSignature = MethodSignature JNI.String - deriving (Eq, Ord) - -instance Show MethodSignature where - show (MethodSignature str) = show str diff --git a/src/Foreign/JNI/NativeMethod.hsc b/src/Foreign/JNI/NativeMethod.hsc deleted file mode 100644 --- a/src/Foreign/JNI/NativeMethod.hsc +++ /dev/null @@ -1,42 +0,0 @@ --- | Bindings to the JNINativeMethod struct. - -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RecordWildCards #-} - -module Foreign.JNI.NativeMethod where - -import qualified Data.ByteString.Unsafe as BS -import Data.Coerce (coerce) -import Foreign.JNI.Internal -import qualified Foreign.JNI.String as JNI -import Foreign.Ptr (FunPtr) -import Foreign.Storable (Storable(..)) - -#include - -#if __GLASGOW_HASKELL__ < 800 -#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) -#endif - -data JNINativeMethod = forall a. JNINativeMethod - { jniNativeMethodName :: JNI.String - , jniNativeMethodSignature :: MethodSignature - , jniNativeMethodFunPtr :: FunPtr a - } - -instance Storable JNINativeMethod where - sizeOf _ = #{size JNINativeMethod} - alignment _ = #{alignment JNINativeMethod} - peek ptr = do - name <- BS.unsafePackCString =<< #{peek JNINativeMethod, name} ptr - sig <- BS.unsafePackCString =<< #{peek JNINativeMethod, signature} ptr - fptr <- #{peek JNINativeMethod, fnPtr} ptr - return $ - JNINativeMethod - (JNI.unsafeFromByteString name) - (coerce (JNI.unsafeFromByteString sig)) - fptr - poke ptr JNINativeMethod{..} = do - JNI.withString jniNativeMethodName $ #{poke JNINativeMethod, name} ptr - JNI.withString (coerce jniNativeMethodSignature) $ #{poke JNINativeMethod, signature} ptr - #{poke JNINativeMethod, fnPtr} ptr jniNativeMethodFunPtr diff --git a/src/Foreign/JNI/String.hs b/src/Foreign/JNI/String.hs deleted file mode 100644 --- a/src/Foreign/JNI/String.hs +++ /dev/null @@ -1,75 +0,0 @@ --- | JNI strings. Like C strings and unlike 'Data.ByteString.ByteString', these --- are null-terminated. Unlike C strings, each character is (multi-byte) encoded --- as UTF-8. Unlike UTF-8, embedded NULL characters are encoded as two bytes and --- the four-byte UTF-8 format for characters is not recognized. A custom --- encoding is used instead. See --- --- for more details. --- --- /NOTE:/ the current implementation does not support embedded NULL's and --- four-byte characters. - -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MagicHash #-} - -module Foreign.JNI.String - ( String - , toChars - , fromChars - , fromByteString - , unsafeFromByteString - , toByteString - , withString - ) where - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Unsafe as BS -import Data.ByteString (ByteString) -import Data.String (IsString(..)) -import Foreign.C.String (CString) -import qualified GHC.Foreign as GHC -import qualified GHC.IO.Encoding as GHC -import System.IO.Unsafe (unsafeDupablePerformIO) -import qualified Prelude -import Prelude hiding (String) - --- A JNI string is represented as a NUL terminated bytestring in UTF-8 encoding. -newtype String = String ByteString - deriving (Eq, Ord) - -instance Show String where - show str = show (toChars str) - -instance IsString String where - fromString str = fromChars str - -fromChars :: Prelude.String -> String -{-# INLINE [0] fromChars #-} -fromChars str = unsafeDupablePerformIO $ - GHC.withCString GHC.utf8 str $ \cstr -> do - -- we need to copy the trailing NUL - len <- BS.c_strlen cstr - String <$> BS.packCStringLen (cstr, fromIntegral len + 1) - -toChars :: String -> Prelude.String -toChars (String bs) = unsafeDupablePerformIO $ BS.unsafeUseAsCString bs $ GHC.peekCString GHC.utf8 - -withString :: String -> (CString -> IO a) -> IO a -withString (String bs) f = BS.unsafeUseAsCString bs f - --- Discards the trailing NUL. -toByteString :: String -> ByteString -toByteString (String bs) = BS.init bs - --- | O(1) if the input is null-terminated. Otherwise the input is copied into --- a null-terminated buffer first. -fromByteString :: ByteString -> String -fromByteString bs - | BS.last bs == 0 = String bs - | otherwise = String (bs `BS.snoc` 0) - --- | Same as 'fromByteString', but doesn't check whether the input is --- null-terminated or not. -unsafeFromByteString :: ByteString -> String -unsafeFromByteString = String diff --git a/src/Foreign/JNI/Types.hs b/src/Foreign/JNI/Types.hs deleted file mode 100644 --- a/src/Foreign/JNI/Types.hs +++ /dev/null @@ -1,464 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} - -#if __GLASGOW_HASKELL__ >= 800 -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -#endif - -module Foreign.JNI.Types - ( JType(..) - , IsPrimitiveType - , IsReferenceType - , Sing(..) - , type (<>) - -- * JNI types - , J(..) - , jnull - , upcast - , arrayUpcast - , unsafeCast - , generic - , unsafeUngeneric - , jtypeOf - , ReferenceTypeName - , singToIsReferenceType - , referenceTypeName - , Signature - , signature - , MethodSignature - , methodSignature - , JVM(..) - , JNIEnv(..) - , JMethodID(..) - , JFieldID(..) - , JValue(..) - , withJValues - -- * Conversions - , objectFromPtr - , unsafeObjectToPtr - -- * JNI defined object types - , JObject - , JClass - , JString - , JArray - , JObjectArray - , JBooleanArray - , JByteArray - , JCharArray - , JShortArray - , JIntArray - , JLongArray - , JFloatArray - , JDoubleArray - , JThrowable - -- * inline-c contexts - , jniCtx - ) where - -import Control.DeepSeq (NFData) -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Builder as Builder -import qualified Data.ByteString.Builder.Prim as Prim -import Data.ByteString.Builder (Builder) -import Data.Char (chr, ord) -import Data.Constraint (Dict(..)) -import Data.Int -import qualified Data.Map as Map -import Data.Monoid ((<>)) -import Data.Singletons - ( Sing - , SingI(..) - , SomeSing(..) -#if !MIN_VERSION_singletons(2,2,0) - , KProxy(..) -#endif - ) -import Data.Singletons.Prelude (Sing(..)) -#if MIN_VERSION_singletons(2,4,0) -import Data.Singletons.ShowSing (ShowSing(..)) -#endif -import Data.Singletons.TypeLits (KnownSymbol, symbolVal) -import Data.Word -import Foreign.C (CChar) -import Foreign.ForeignPtr - ( ForeignPtr - , castForeignPtr - , newForeignPtr_ - , withForeignPtr - ) -import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) -import Foreign.JNI.Internal -import Foreign.JNI.NativeMethod -import qualified Foreign.JNI.String as JNI -import Foreign.Marshal.Alloc (allocaBytesAligned) -import Foreign.Ptr -import Foreign.Storable (Storable(..)) -import GHC.TypeLits (Symbol) -import Language.C.Types (TypeSpecifier(TypeName)) -import Language.C.Inline.Context (Context(..), fptrCtx) -import System.IO.Unsafe (unsafePerformIO) - --- | A JVM instance. -newtype JVM = JVM_ (Ptr JVM) - deriving (Eq, Show, Storable, NFData) - --- | The thread-local JNI context. Do not share this object between threads. -newtype JNIEnv = JNIEnv_ (Ptr JNIEnv) - deriving (Eq, Show, Storable, NFData) - --- | A thread-local reference to a field of an object. -newtype JFieldID = JFieldID_ (Ptr JFieldID) - deriving (Eq, Show, Storable, NFData) - --- | A thread-local reference to a method of an object. -newtype JMethodID = JMethodID_ (Ptr JMethodID) - deriving (Eq, Show, Storable, NFData) - --- | Not part of the JNI. The kind of 'J' type indices. Useful to reflect the --- object's class at the type-level. -data JType - = Class Symbol -- ^ Class name - | Iface Symbol -- ^ Interface name - | Prim Symbol -- ^ Primitive type - | Array JType -- ^ Array type - | Generic JType [JType] -- ^ Parameterized (generic) type - | Void -- ^ Void special type - --- | The class of Java types that are "unboxed". -class SingI ty => IsPrimitiveType (ty :: JType) -instance KnownSymbol sym => IsPrimitiveType ('Prim sym) - -class IsReferenceType (ty :: JType) -instance IsReferenceType ('Class sym) -instance IsReferenceType ('Iface sym) -instance IsReferenceType ('Array ty) -instance IsReferenceType ty => IsReferenceType ('Generic ty tys) - --- | Produces evidence for IsReferenceType from a `Sing ty`. -singToIsReferenceType :: Sing (ty :: JType) -> Maybe (Dict (IsReferenceType ty)) -singToIsReferenceType tysing = case tysing of - SClass _ -> Just Dict - SPrim _ -> Nothing - SIface _ -> Just Dict - SArray _ -> Just Dict - SGeneric tysing' _ -> (\Dict -> Dict) <$> singToIsReferenceType tysing' - SVoid -> Nothing - -data instance Sing (a :: JType) where - -- Using String instead of JNI.String for the singleton data constructors - -- is an optimization. Otherwise, the comparisons in Language.Java.call - -- and callStatic would involve allocations and cannot be cached. - -- - -- See commit 3da51a4 and https://github.com/tweag/inline-java/issues/11 - SClass :: String -> Sing ('Class sym) - SIface :: String -> Sing ('Iface sym) - SPrim :: String -> Sing ('Prim sym) - SArray :: Sing ty -> Sing ('Array ty) - SGeneric :: Sing ty -> Sing tys -> Sing ('Generic ty tys) - SVoid :: Sing 'Void - -realShowsPrec :: Show a => Int -> a -> ShowS -realShowsPrec = showsPrec - -#if MIN_VERSION_singletons(2,4,0) - -instance Show (Sing (a :: JType)) where - showsPrec = showsSingPrec - --- The instance of Show and ShowSing for JType singletons --- is reused by adjusting the method name with a macro --- definition. -#define showsPrec showsSingPrec -instance ShowSing JType where -#else - -instance Show (Sing (a :: [JType])) where - showsPrec _ SNil = showString "SNil" - showsPrec d (SCons ty tys) = showParen (d > 10) $ - showString "SCons " . showsPrec 11 ty . showChar ' ' . showsPrec 11 tys - -instance Show (Sing (a :: JType)) where -#endif - showsPrec d (SClass s) = showParen (d > 10) $ - showString "SClass " . realShowsPrec 11 s - showsPrec d (SIface s) = showParen (d > 10) $ - showString "SIface " . realShowsPrec 11 s - showsPrec d (SPrim s) = showParen (d > 10) $ - showString "SPrim " . realShowsPrec 11 s - showsPrec d (SArray s) = showParen (d > 10) $ - showString "SArray " . showsPrec 11 s - showsPrec d (SGeneric s sargs) = showParen (d > 10) $ - showString "SGeneric " . showsPrec 11 s . showsPrec 11 sargs - showsPrec _ SVoid = showString "SVoid" - -#undef showsPrec - --- XXX SingI constraint temporary hack because GHC 7.10 has trouble inferring --- this constraint in 'signature'. -instance (KnownSymbol sym, SingI sym) => SingI ('Class (sym :: Symbol)) where - sing = SClass $ symbolVal (undefined :: proxy sym) -instance (KnownSymbol sym, SingI sym) => SingI ('Iface (sym :: Symbol)) where - sing = SIface $ symbolVal (undefined :: proxy sym) -instance (KnownSymbol sym, SingI sym) => SingI ('Prim (sym :: Symbol)) where - sing = SPrim $ symbolVal (undefined :: proxy sym) -instance SingI ty => SingI ('Array ty) where - sing = SArray sing -instance (SingI ty, SingI tys) => SingI ('Generic ty tys) where - sing = SGeneric sing sing -instance SingI 'Void where - sing = SVoid - --- | Shorthand for parametized Java types. -type a <> g = 'Generic a g - --- | Type indexed Java Objects. -newtype J (a :: JType) = J (ForeignPtr (J a)) - deriving (Eq, Show) - -type role J representational - --- | The null reference. -jnull :: J a -jnull = J $ unsafePerformIO $ newForeignPtr_ nullPtr - --- | Any object can be cast to @Object@. -upcast :: J a -> JObject -upcast = unsafeCast - --- | Any array of a reference type can be casted to an array of @Object@s. -arrayUpcast :: IsReferenceType ty => J ('Array ty) -> JObjectArray -arrayUpcast = unsafeCast - --- | Unsafe type cast. Should only be used to downcast. -unsafeCast :: J a -> J b -unsafeCast (J x) = J (castForeignPtr x) - --- | Parameterize the type of an object, making its type a /generic type/. -generic :: J a -> J (a <> g) -generic = unsafeCast - --- | Get the base type of a generic type. -unsafeUngeneric :: J (a <> g) -> J a -unsafeUngeneric = unsafeCast - --- | A union type for uniformly passing arguments to methods. -data JValue - = JBoolean Word8 - | JByte CChar - | JChar Word16 - | JShort Int16 - | JInt Int32 - | JLong Int64 - | JFloat Float - | JDouble Double - | forall a. SingI a => JObject {-# UNPACK #-} !(J a) - -instance Show JValue where - show (JBoolean x) = "JBoolean " ++ show x - show (JByte x) = "JByte " ++ show x - show (JChar x) = "JChar " ++ show x - show (JShort x) = "JShort " ++ show x - show (JInt x) = "JInt " ++ show x - show (JLong x) = "JLong " ++ show x - show (JFloat x) = "JFloat " ++ show x - show (JDouble x) = "JDouble " ++ show x - show (JObject x) = "JObject " ++ show x - -instance Eq JValue where - (JBoolean x) == (JBoolean y) = x == y - (JByte x) == (JByte y) = x == y - (JChar x) == (JChar y) = x == y - (JShort x) == (JShort y) = x == y - (JInt x) == (JInt y) = x == y - (JLong x) == (JLong y) = x == y - (JFloat x) == (JFloat y) = x == y - (JDouble x) == (JDouble y) = x == y - (JObject (J x)) == (JObject (J y)) = castForeignPtr x == castForeignPtr y - _ == _ = False - -sizeOfJValue, alignmentJValue :: Int -sizeOfJValue = 8 -alignmentJValue = 8 - --- | @withJValue jvalues f@ provides a pointer to an array containing the given --- @jvalues@. --- --- The array is valid only while evaluating @f@. -withJValues :: [JValue] -> (Ptr JValue -> IO a) -> IO a -withJValues args f = - allocaBytesAligned (sizeOfJValue * length args) alignmentJValue $ \p -> - foldr (.) id (zipWith (withJValueOff p) [0..] args) (f p) - --- @withJValueOff p n jvalue io@ writes the given @jvalue@ to @p `plusPtr` n@ --- and runs @io@. --- --- The jvalue is guaranteed to stay valid while @io@ evaluates. -withJValueOff :: Ptr JValue -> Int -> JValue -> IO a -> IO a -withJValueOff p n jvalue io = case jvalue of - JBoolean x -> pokeByteOff (castPtr p) offset x >> io - JByte x -> pokeByteOff (castPtr p) offset x >> io - JChar x -> pokeByteOff (castPtr p) offset x >> io - JShort x -> pokeByteOff (castPtr p) offset x >> io - JInt x -> pokeByteOff (castPtr p) offset x >> io - JLong x -> pokeByteOff (castPtr p) offset x >> io - JFloat x -> pokeByteOff (castPtr p) offset x >> io - JDouble x -> pokeByteOff (castPtr p) offset x >> io - - JObject (J x) -> withForeignPtr x $ \xp -> - pokeByteOff (castPtr p) offset xp >> io - where - offset = n * sizeOfJValue - --- | Get the Java type of a value. -#if MIN_VERSION_singletons(2,2,0) -jtypeOf :: JValue -> SomeSing JType -#else -jtypeOf :: JValue -> SomeSing ('KProxy :: KProxy JType) -#endif -jtypeOf (JBoolean _) = SomeSing (sing :: Sing ('Prim "boolean")) -jtypeOf (JByte _) = SomeSing (sing :: Sing ('Prim "byte")) -jtypeOf (JChar _) = SomeSing (sing :: Sing ('Prim "char")) -jtypeOf (JShort _) = SomeSing (sing :: Sing ('Prim "short")) -jtypeOf (JInt _) = SomeSing (sing :: Sing ('Prim "int")) -jtypeOf (JLong _) = SomeSing (sing :: Sing ('Prim "long")) -jtypeOf (JFloat _) = SomeSing (sing :: Sing ('Prim "float")) -jtypeOf (JDouble _) = SomeSing (sing :: Sing ('Prim "double")) -jtypeOf (JObject (_ :: J ty)) = SomeSing (sing :: Sing ty) - --- | Create a null-terminated string. -build :: Builder -> JNI.String -build = - JNI.unsafeFromByteString . - BSL.toStrict . - Builder.toLazyByteString . - (<> Builder.char7 '\NUL') - --- | The name of a type, suitable for passing to 'Foreign.JNI.findClass'. -referenceTypeName :: IsReferenceType ty => Sing (ty :: JType) -> ReferenceTypeName -referenceTypeName (SClass sym) = ReferenceTypeName $ build $ classSymbolBuilder sym -referenceTypeName (SIface sym) = ReferenceTypeName $ build $ classSymbolBuilder sym -referenceTypeName ty@(SArray _) = ReferenceTypeName $ build $ signatureBuilder ty -referenceTypeName (SGeneric ty@(SClass _) _) = referenceTypeName ty -referenceTypeName (SGeneric ty@(SIface _) _) = referenceTypeName ty -referenceTypeName _ = error "referenceTypeName: Impossible." - -classSymbolBuilder :: String -> Builder -classSymbolBuilder sym = - Prim.primMapByteStringFixed (subst Prim.>$< Prim.word8) - (JNI.toByteString $ JNI.fromChars sym) - where - subst (chr . fromIntegral -> '.') = fromIntegral (ord '/') - subst x = x - -signatureBuilder :: Sing (ty :: JType) -> Builder -signatureBuilder (SClass sym) = Builder.char7 'L' <> classSymbolBuilder sym <> Builder.char7 ';' -signatureBuilder (SIface sym) = Builder.char7 'L' <> classSymbolBuilder sym <> Builder.char7 ';' -signatureBuilder (SPrim "boolean") = Builder.char7 'Z' -signatureBuilder (SPrim "byte") = Builder.char7 'B' -signatureBuilder (SPrim "char") = Builder.char7 'C' -signatureBuilder (SPrim "short") = Builder.char7 'S' -signatureBuilder (SPrim "int") = Builder.char7 'I' -signatureBuilder (SPrim "long") = Builder.char7 'J' -signatureBuilder (SPrim "float") = Builder.char7 'F' -signatureBuilder (SPrim "double") = Builder.char7 'D' -signatureBuilder (SPrim sym) = error $ "Unknown primitive: " ++ sym -signatureBuilder (SArray ty) = Builder.char7 '[' <> signatureBuilder ty -signatureBuilder (SGeneric ty _) = signatureBuilder ty -signatureBuilder SVoid = Builder.char7 'V' - --- | Construct a JNI type signature from a Java type. -signature :: Sing (ty :: JType) -> Signature -signature = Signature . build . signatureBuilder - --- | Construct a method's JNI type signature, given the type of the arguments --- and the return type. -methodSignature -#if MIN_VERSION_singletons(2,2,0) - :: [SomeSing JType] -#else - :: [SomeSing ('KProxy :: KProxy JType)] -#endif - -> Sing (ty :: JType) - -> MethodSignature -methodSignature args ret = - MethodSignature $ - build $ - Builder.char7 '(' <> - mconcat (map (\(SomeSing s) -> signatureBuilder s) args) <> - Builder.char7 ')' <> - signatureBuilder ret - --- | Turn the raw pointer into an object. -objectFromPtr :: Ptr (J a) -> IO (J a) -objectFromPtr ptr = J <$> newForeignPtr_ ptr - --- | Get a raw pointer to an object. This is unsafe because if the argument is --- the last usage occurrence of the given foreign pointer, then its finalizer(s) --- will be run, which potentially invalidates the plain pointer just obtained. -unsafeObjectToPtr :: J a -> Ptr (J a) -unsafeObjectToPtr (J fptr) = unsafeForeignPtrToPtr fptr - -type JObject = J ('Class "java.lang.Object") -type JClass = J ('Class "java.lang.Class") -type JString = J ('Class "java.lang.String") -type JThrowable = J ('Class "java.lang.Throwable") -type JArray a = J ('Array a) -type JObjectArray = JArray ('Class "java.lang.Object") -type JBooleanArray = JArray ('Prim "boolean") -type JByteArray = JArray ('Prim "byte") -type JCharArray = JArray ('Prim "char") -type JShortArray = JArray ('Prim "short") -type JIntArray = JArray ('Prim "int") -type JLongArray = JArray ('Prim "long") -type JFloatArray = JArray ('Prim "float") -type JDoubleArray = JArray ('Prim "double") - -jniCtx :: Context -jniCtx = mempty { ctxTypesTable = Map.fromList tytab } <> fptrCtx - where - tytab = - [ -- Primitive types - (TypeName "jboolean", [t| Word8 |]) - , (TypeName "jbyte", [t| CChar |]) - , (TypeName "jchar", [t| Word16 |]) - , (TypeName "jshort", [t| Int16 |]) - , (TypeName "jint", [t| Int32 |]) - , (TypeName "jlong", [t| Int64 |]) - , (TypeName "jfloat", [t| Float |]) - , (TypeName "jdouble", [t| Double |]) - -- Reference types - , (TypeName "jobject", [t| Ptr JObject |]) - , (TypeName "jclass", [t| Ptr JClass |]) - , (TypeName "jstring", [t| Ptr JString |]) - , (TypeName "jarray", [t| Ptr JObject |]) - , (TypeName "jobjectArray", [t| Ptr JObjectArray |]) - , (TypeName "jbooleanArray", [t| Ptr JBooleanArray |]) - , (TypeName "jbyteArray", [t| Ptr JByteArray |]) - , (TypeName "jcharArray", [t| Ptr JCharArray |]) - , (TypeName "jshortArray", [t| Ptr JShortArray |]) - , (TypeName "jintArray", [t| Ptr JIntArray |]) - , (TypeName "jlongArray", [t| Ptr JLongArray |]) - , (TypeName "jfloatArray", [t| Ptr JFloatArray |]) - , (TypeName "jdoubleArray", [t| Ptr JDoubleArray |]) - , (TypeName "jthrowable", [t| Ptr JThrowable |]) - -- Internal types - , (TypeName "JavaVM", [t| JVM |]) - , (TypeName "JNIEnv", [t| JNIEnv |]) - , (TypeName "JNINativeMethod", [t| JNINativeMethod |]) - , (TypeName "jfieldID", [t| JFieldID |]) - , (TypeName "jmethodID", [t| JMethodID |]) - , (TypeName "jsize", [t| Int32 |]) - , (TypeName "jvalue", [t| JValue |]) - ] diff --git a/src/common/Foreign/JNI.hs b/src/common/Foreign/JNI.hs new file mode 100644 --- /dev/null +++ b/src/common/Foreign/JNI.hs @@ -0,0 +1,4 @@ +-- | Reexports definitions from "Foreign.JNI.Unsafe". +module Foreign.JNI (module Foreign.JNI.Unsafe) where + +import Foreign.JNI.Unsafe diff --git a/src/common/Foreign/JNI/Internal.hs b/src/common/Foreign/JNI/Internal.hs new file mode 100644 --- /dev/null +++ b/src/common/Foreign/JNI/Internal.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Foreign.JNI.Internal where + +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Foreign.JNI.String as JNI + +-- | A reference type name is not just any 'JNI.String', but a fully qualified +-- identifier well-formed by construction. +newtype ReferenceTypeName = ReferenceTypeName JNI.String + deriving (Eq, Ord) + +instance Show ReferenceTypeName where + show (ReferenceTypeName str) = show str + +-- | A string representing a signature, well-formed by construction. +newtype Signature = Signature JNI.String + deriving (Eq, Ord) + +instance Show Signature where + show (Signature str) = show str + +-- | A string representing a method signature, well-formed by construction. +newtype MethodSignature = MethodSignature JNI.String + deriving (Eq, Ord) + +instance Show MethodSignature where + show (MethodSignature str) = show str + +jniMethodToJavaSignature :: Text -> Either String ([Text], Text) +jniMethodToJavaSignature sig = do + (argTypes, rest1) <- dropChar '(' sig >>= many toJavaType + (returnType, rest2) <- dropChar ')' rest1 >>= toJavaType + if Text.null rest2 then return (argTypes, returnType) + else Left $ "Unexpected suffix " ++ show rest2 + where + dropChar c t = case Text.uncons t of + Just (c', t') | c == c' -> Right t' + _ -> Left $ unwords + [ "Expected ", show c, "but found", show t] + many p = go id + where + go acc t = case p t of + Left _ -> Right (acc [], t) + Right (x, t') -> go (acc . (x:)) t' + toJavaType t = case Text.uncons t of + Just (c, t') -> + case c of + 'L' -> case Text.breakOn ";" t' of + (jtype, rest) -> Right (Text.map substSlash jtype, Text.drop 1 rest) + '[' -> + fmap (\(jtype, rest) -> (jtype <> "[]", rest)) (toJavaType t') + 'Z' -> Right ("boolean", t') + 'B' -> Right ("byte", t') + 'C' -> Right ("char", t') + 'S' -> Right ("short", t') + 'I' -> Right ("int", t') + 'J' -> Right ("long", t') + 'F' -> Right ("float", t') + 'D' -> Right ("double", t') + 'V' -> Right ("void", t') + _ -> Left $ "Unexpected char " ++ show c ++ " at " ++ show t' + Nothing -> + Left "Unexpected empty text" + substSlash = \case + '/' -> '.' + c -> c diff --git a/src/common/Foreign/JNI/Internal/BackgroundWorker.hs b/src/common/Foreign/JNI/Internal/BackgroundWorker.hs new file mode 100644 --- /dev/null +++ b/src/common/Foreign/JNI/Internal/BackgroundWorker.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +module Foreign.JNI.Internal.BackgroundWorker + ( BackgroundWorker + , create + , setQueueSize + , stop + , submitTask + ) where + +import Control.Concurrent.Async (Async, async, waitCatch) +import Control.Concurrent.STM + (TVar, atomically, modifyTVar', newTVarIO, readTVar, retry, writeTVar) +import Control.Exception (Exception, handle, throwIO, uninterruptibleMask_) +import Control.Monad (forever, join, void) + + +-- | A background thread that can run tasks asynchronously +data BackgroundWorker = BackgroundWorker + { nextBatchRef :: TVar Batch + , queueSizeRef :: TVar Int + , workerAsync :: Async () + } + +-- | Creates a background worker that starts running immediately. +-- +-- Takes a function that can initialize the thread before entering +-- the main loop. +-- +create :: (IO () -> IO ()) -> IO BackgroundWorker +create runInInitializedThread = do + queueSizeRef <- newTVarIO defaultQueueSize + nextBatchRef <- newTVarIO emptyBatch + workerAsync <- async $ runInInitializedThread $ handleTermination $ + forever (runNextBatch nextBatchRef) + return BackgroundWorker + { nextBatchRef + , queueSizeRef + , workerAsync + } + where + handleTermination = handle $ \StopWorkerException -> return () + runNextBatch nextBatchRef = + join $ atomically $ do + nextBatch <- readTVar nextBatchRef + case getTasks nextBatch of + Just tasks -> tasks <$ writeTVar nextBatchRef emptyBatch + Nothing -> retry + +defaultQueueSize :: Int +defaultQueueSize = 1024 * 1024 + +-- | Set the maximum number of pending tasks +setQueueSize :: BackgroundWorker -> Int -> IO () +setQueueSize (BackgroundWorker {queueSizeRef}) n = + if n > 0 + then atomically $ writeTVar queueSizeRef n + else error ("The queue size must be a positive number. Tried " ++ show n) + +data StopWorkerException = StopWorkerException + deriving Show + +instance Exception StopWorkerException + +-- | Stops the background worker and waits until it terminates. +stop :: BackgroundWorker -> IO () +stop (BackgroundWorker {nextBatchRef, workerAsync}) = + uninterruptibleMask_ $ do + submitStopAtEndOfBatch + void $ waitCatch workerAsync + where + submitStopAtEndOfBatch = do + let task = throwIO StopWorkerException + atomically $ modifyTVar' nextBatchRef (snocTask task) + +-- | Submits a task to the background worker. +-- +-- Any exception thrown in the given task will stop the +-- background thread. +-- +-- If the job queue is currently full, block until it isn't. +-- +submitTask :: BackgroundWorker -> IO () -> IO () +submitTask (BackgroundWorker {nextBatchRef, queueSizeRef}) task = do + atomically $ do + queueSize <- readTVar queueSizeRef + nextBatch <- readTVar nextBatchRef + if getBatchSize nextBatch < queueSize then + writeTVar nextBatchRef (consTask task nextBatch) + else + retry + +-- | A batch of tasks +-- +-- Contains the task count and the computation that performs +-- all the tasks. +newtype Batch = Batch (Int, IO ()) + +emptyBatch :: Batch +emptyBatch = Batch (0, return ()) + +consTask :: IO () -> Batch -> Batch +consTask task (Batch (n, tasks)) = Batch (n + 1, task >> tasks) + +snocTask :: IO () -> Batch -> Batch +snocTask task (Batch (n, tasks)) = Batch (n + 1, tasks >> task) + +-- | Yields Nothing on an empty batch. +getTasks :: Batch -> Maybe (IO ()) +getTasks (Batch (0, _)) = Nothing +getTasks (Batch (_, tasks)) = Just tasks + +getBatchSize :: Batch -> Int +getBatchSize (Batch (n, _)) = n diff --git a/src/common/Foreign/JNI/Internal/RWLock.hs b/src/common/Foreign/JNI/Internal/RWLock.hs new file mode 100644 --- /dev/null +++ b/src/common/Foreign/JNI/Internal/RWLock.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +module Foreign.JNI.Internal.RWLock + ( RWLock + , new + , tryAcquireReadLock + , releaseReadLock + , acquireWriteLock + ) where + +import Control.Concurrent.STM + (TVar, atomically, check, newTVarIO, readTVar, stateTVar, writeTVar) +import Control.Monad (when) +import Data.Choice + + +-- | A read-write lock +-- +-- Concurrent readers are allowed, but only one writer is supported. +-- +-- Moreover, a writer trying to acquire a write lock has priority over +-- new readers trying to acquire a read lock. +newtype RWLock = + RWLock (TVar (Int, RWWantedState)) + -- ^ A count of the held read locks and the wanted state + +-- | The wanted state of the RW +data RWWantedState + = Reading -- ^ There are no writers + | Writing (TVar Bool) -- ^ A writer wants to write, grant no more read locks. + -- The TVar is to be written when the last read lock + -- is released. + +-- | Creates a new read-write lock. +new :: IO RWLock +new = RWLock <$> newTVarIO (0, Reading) + +-- | Tries to acquire a read lock. If this call returns `Do #read`, no writer +-- will be granted a lock before the read lock is released. The lock can be +-- denied if a writer is writing or waiting to write. +tryAcquireReadLock :: RWLock -> IO (Choice "read") +tryAcquireReadLock (RWLock ref) = atomically $ + readTVar ref >>= \case + (!readers, Reading) -> do + writeTVar ref (readers + 1, Reading) + return $ Do #read + _ -> return $ Don't #read + +-- | Releases a read lock. +releaseReadLock :: RWLock -> IO () +releaseReadLock (RWLock ref) = + atomically $ do + (readers, aim) <- readTVar ref + writeTVar ref (readers - 1, aim) + case (readers, aim) of + (1, Writing noReadersRef) -> writeTVar noReadersRef True + _ -> return () + +-- | Waits until the current read locks are released and grants a write lock. +-- No new reader locks are granted while the writer is waiting for the lock +-- and while it holds the write lock. +acquireWriteLock :: RWLock -> IO () +acquireWriteLock (RWLock ref) = do + noReadersRef <- newTVarIO False + readers <- atomically $ stateTVar ref $ \(readers, _) -> + (readers, (readers, Writing noReadersRef)) + when (readers > 0) $ atomically $ + readTVar noReadersRef >>= check diff --git a/src/common/Foreign/JNI/NativeMethod.hsc b/src/common/Foreign/JNI/NativeMethod.hsc new file mode 100644 --- /dev/null +++ b/src/common/Foreign/JNI/NativeMethod.hsc @@ -0,0 +1,42 @@ +-- | Bindings to the JNINativeMethod struct. + +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RecordWildCards #-} + +module Foreign.JNI.NativeMethod where + +import qualified Data.ByteString.Unsafe as BS +import Data.Coerce (coerce) +import Foreign.JNI.Internal +import qualified Foreign.JNI.String as JNI +import Foreign.Ptr (FunPtr) +import Foreign.Storable (Storable(..)) + +#include + +#if __GLASGOW_HASKELL__ < 800 +#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +#endif + +data JNINativeMethod = forall a. JNINativeMethod + { jniNativeMethodName :: JNI.String + , jniNativeMethodSignature :: MethodSignature + , jniNativeMethodFunPtr :: FunPtr a + } + +instance Storable JNINativeMethod where + sizeOf _ = #{size JNINativeMethod} + alignment _ = #{alignment JNINativeMethod} + peek ptr = do + name <- BS.unsafePackCString =<< #{peek JNINativeMethod, name} ptr + sig <- BS.unsafePackCString =<< #{peek JNINativeMethod, signature} ptr + fptr <- #{peek JNINativeMethod, fnPtr} ptr + return $ + JNINativeMethod + (JNI.unsafeFromByteString name) + (coerce (JNI.unsafeFromByteString sig)) + fptr + poke ptr JNINativeMethod{..} = do + JNI.withString jniNativeMethodName $ #{poke JNINativeMethod, name} ptr + JNI.withString (coerce jniNativeMethodSignature) $ #{poke JNINativeMethod, signature} ptr + #{poke JNINativeMethod, fnPtr} ptr jniNativeMethodFunPtr diff --git a/src/common/Foreign/JNI/String.hs b/src/common/Foreign/JNI/String.hs new file mode 100644 --- /dev/null +++ b/src/common/Foreign/JNI/String.hs @@ -0,0 +1,75 @@ +-- | JNI strings. Like C strings and unlike 'Data.ByteString.ByteString', these +-- are null-terminated. Unlike C strings, each character is (multi-byte) encoded +-- as UTF-8. Unlike UTF-8, embedded NULL characters are encoded as two bytes and +-- the four-byte UTF-8 format for characters is not recognized. A custom +-- encoding is used instead. See +-- +-- for more details. +-- +-- /NOTE:/ the current implementation does not support embedded NULL's and +-- four-byte characters. + +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MagicHash #-} + +module Foreign.JNI.String + ( String + , toChars + , fromChars + , fromByteString + , unsafeFromByteString + , toByteString + , withString + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Unsafe as BS +import Data.ByteString (ByteString) +import Data.String (IsString(..)) +import Foreign.C.String (CString) +import qualified GHC.Foreign as GHC +import qualified GHC.IO.Encoding as GHC +import System.IO.Unsafe (unsafeDupablePerformIO) +import qualified Prelude +import Prelude hiding (String) + +-- A JNI string is represented as a NUL terminated bytestring in UTF-8 encoding. +newtype String = String ByteString + deriving (Eq, Ord) + +instance Show String where + show str = show (toChars str) + +instance IsString String where + fromString str = fromChars str + +fromChars :: Prelude.String -> String +{-# INLINE [0] fromChars #-} +fromChars str = unsafeDupablePerformIO $ + GHC.withCString GHC.utf8 str $ \cstr -> do + -- we need to copy the trailing NUL + len <- BS.c_strlen cstr + String <$> BS.packCStringLen (cstr, fromIntegral len + 1) + +toChars :: String -> Prelude.String +toChars (String bs) = unsafeDupablePerformIO $ BS.unsafeUseAsCString bs $ GHC.peekCString GHC.utf8 + +withString :: String -> (CString -> IO a) -> IO a +withString (String bs) f = BS.unsafeUseAsCString bs f + +-- Discards the trailing NUL. +toByteString :: String -> ByteString +toByteString (String bs) = BS.init bs + +-- | O(1) if the input is null-terminated. Otherwise the input is copied into +-- a null-terminated buffer first. +fromByteString :: ByteString -> String +fromByteString bs + | BS.length bs > 0 && BS.last bs == 0 = String bs + | otherwise = String (bs `BS.snoc` 0) + +-- | Same as 'fromByteString', but doesn't check whether the input is +-- null-terminated or not. +unsafeFromByteString :: ByteString -> String +unsafeFromByteString = String diff --git a/src/common/Foreign/JNI/Types.hs b/src/common/Foreign/JNI/Types.hs new file mode 100644 --- /dev/null +++ b/src/common/Foreign/JNI/Types.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module Foreign.JNI.Types + ( JType(..) + , IsPrimitiveType + , IsReferenceType + , Sing + , SJType(..) + , type (<>) + -- * JNI types + , J(..) + , jnull + , upcast + , arrayUpcast + , unsafeCast + , generic + , unsafeUngeneric + , jtypeOf + , ReferenceTypeName + , singToIsReferenceType + , referenceTypeName + , Signature + , signature + , MethodSignature + , methodSignature + , JVM(..) + , JNIEnv(..) + , JMethodID(..) + , JFieldID(..) + , JValue(..) + , withJValues + -- * Conversions + , objectFromPtr + , unsafeObjectToPtr + -- * JNI defined object types + , JObject + , JClass + , JString + , JArray + , JObjectArray + , JBooleanArray + , JByteArray + , JCharArray + , JShortArray + , JIntArray + , JLongArray + , JFloatArray + , JDoubleArray + , JThrowable + , JByteBuffer + -- * inline-c contexts + , jniCtx + ) where + +import Control.DeepSeq (NFData) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Builder.Prim as Prim +import Data.ByteString.Builder (Builder) +import Data.Char (chr, ord) +import Data.Constraint (Dict(..)) +import Data.Int +import qualified Data.Map as Map +import Data.Singletons +import Data.Word +import Foreign.C (CChar) +import Foreign.ForeignPtr + ( ForeignPtr + , castForeignPtr + , newForeignPtr_ + , withForeignPtr + ) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import Foreign.JNI.Internal +import Foreign.JNI.NativeMethod +import qualified Foreign.JNI.String as JNI +import Foreign.Marshal.Alloc (allocaBytesAligned) +import Foreign.Ptr +import Foreign.Storable (Storable(..)) +import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) +import Language.C.Types (TypeSpecifier(TypeName)) +import Language.C.Inline.Context (Context(..), fptrCtx) +import System.IO.Unsafe (unsafePerformIO) + +-- | A JVM instance. +newtype JVM = JVM_ (Ptr JVM) + deriving (Eq, Show, Storable, NFData) + +-- | The thread-local JNI context. Do not share this object between threads. +newtype JNIEnv = JNIEnv_ (Ptr JNIEnv) + deriving (Eq, Show, Storable, NFData) + +-- | A thread-local reference to a field of an object. +newtype JFieldID = JFieldID_ (Ptr JFieldID) + deriving (Eq, Show, Storable, NFData) + +-- | A thread-local reference to a method of an object. +newtype JMethodID = JMethodID_ (Ptr JMethodID) + deriving (Eq, Show, Storable, NFData) + +-- | Not part of the JNI. The kind of 'J' type indices. Useful to reflect the +-- object's class at the type-level. +data JType + = Class Symbol -- ^ Class name + | Iface Symbol -- ^ Interface name + | Prim Symbol -- ^ Primitive type + | Array JType -- ^ Array type + | Generic JType [JType] -- ^ Parameterized (generic) type + | Void -- ^ Void special type + +-- | The class of Java types that are "unboxed". +class SingI ty => IsPrimitiveType (ty :: JType) +instance KnownSymbol sym => IsPrimitiveType ('Prim sym) + +class IsReferenceType (ty :: JType) +instance IsReferenceType ('Class sym) +instance IsReferenceType ('Iface sym) +instance IsReferenceType ('Array ty) +instance IsReferenceType ty => IsReferenceType ('Generic ty tys) + +-- | Produces evidence for IsReferenceType from a `Sing ty`. +singToIsReferenceType :: Sing (ty :: JType) -> Maybe (Dict (IsReferenceType ty)) +singToIsReferenceType tysing = case tysing of + SClass _ -> Just Dict + SPrim _ -> Nothing + SIface _ -> Just Dict + SArray _ -> Just Dict + SGeneric tysing' _ -> (\Dict -> Dict) <$> singToIsReferenceType tysing' + SVoid -> Nothing + +type instance Sing = SJType +data SJType (a :: JType) where + -- Using String instead of JNI.String for the singleton data constructors + -- is an optimization. Otherwise, the comparisons in Language.Java.call + -- and callStatic would involve allocations and cannot be cached. + -- + -- See commit 3da51a4 and https://github.com/tweag/inline-java/issues/11 + SClass :: String -> SJType ('Class sym) + SIface :: String -> SJType ('Iface sym) + SPrim :: String -> SJType ('Prim sym) + SArray :: SJType ty -> SJType ('Array ty) + SGeneric :: SJType ty -> Sing tys -> SJType ('Generic ty tys) + SVoid :: SJType 'Void + +realShowsPrec :: Show a => Int -> a -> ShowS +realShowsPrec = showsPrec + +instance Show (SJType a) where + showsPrec d (SClass s) = showParen (d > 10) $ + showString "SClass " . realShowsPrec 11 s + showsPrec d (SIface s) = showParen (d > 10) $ + showString "SIface " . realShowsPrec 11 s + showsPrec d (SPrim s) = showParen (d > 10) $ + showString "SPrim " . realShowsPrec 11 s + showsPrec d (SArray s) = showParen (d > 10) $ + showString "SArray " . showsPrec 11 s + showsPrec d (SGeneric s sargs) = showParen (d > 10) $ + showString "SGeneric " . showsPrec 11 s . showsPrec 11 sargs + showsPrec _ SVoid = showString "SVoid" + +-- XXX SingI constraint temporary hack because GHC 7.10 has trouble inferring +-- this constraint in 'signature'. +instance (KnownSymbol sym, SingI sym) => SingI ('Class (sym :: Symbol)) where + sing = SClass $ symbolVal (undefined :: proxy sym) +instance (KnownSymbol sym, SingI sym) => SingI ('Iface (sym :: Symbol)) where + sing = SIface $ symbolVal (undefined :: proxy sym) +instance (KnownSymbol sym, SingI sym) => SingI ('Prim (sym :: Symbol)) where + sing = SPrim $ symbolVal (undefined :: proxy sym) +instance SingI ty => SingI ('Array ty) where + sing = SArray (sing @ty) +instance (SingI ty, SingI tys) => SingI ('Generic ty tys) where + sing = SGeneric (sing @ty) (sing @tys) +instance SingI 'Void where + sing = SVoid + +-- | Shorthand for parametized Java types. +type a <> g = 'Generic a g + +-- | Type indexed Java Objects. +newtype J (a :: JType) = J (ForeignPtr (J a)) + deriving (Eq, Show) + +type role J representational + +-- | The null reference. +jnull :: J a +jnull = J $ unsafePerformIO $ newForeignPtr_ nullPtr + +-- | Any object can be cast to @Object@. +upcast :: J a -> JObject +upcast = unsafeCast + +-- | Any array of a reference type can be casted to an array of @Object@s. +arrayUpcast :: IsReferenceType ty => J ('Array ty) -> JObjectArray +arrayUpcast = unsafeCast + +-- | Unsafe type cast. Should only be used to downcast. +unsafeCast :: J a -> J b +unsafeCast (J x) = J (castForeignPtr x) + +-- | Parameterize the type of an object, making its type a /generic type/. +generic :: J a -> J (a <> g) +generic = unsafeCast + +-- | Get the base type of a generic type. +unsafeUngeneric :: J (a <> g) -> J a +unsafeUngeneric = unsafeCast + +-- | A union type for uniformly passing arguments to methods. +data JValue + = JBoolean Word8 + | JByte CChar + | JChar Word16 + | JShort Int16 + | JInt Int32 + | JLong Int64 + | JFloat Float + | JDouble Double + | forall a. SingI a => JObject {-# UNPACK #-} !(J a) + +instance Show JValue where + show (JBoolean x) = "JBoolean " ++ show x + show (JByte x) = "JByte " ++ show x + show (JChar x) = "JChar " ++ show x + show (JShort x) = "JShort " ++ show x + show (JInt x) = "JInt " ++ show x + show (JLong x) = "JLong " ++ show x + show (JFloat x) = "JFloat " ++ show x + show (JDouble x) = "JDouble " ++ show x + show (JObject x) = "JObject " ++ show x + +instance Eq JValue where + (JBoolean x) == (JBoolean y) = x == y + (JByte x) == (JByte y) = x == y + (JChar x) == (JChar y) = x == y + (JShort x) == (JShort y) = x == y + (JInt x) == (JInt y) = x == y + (JLong x) == (JLong y) = x == y + (JFloat x) == (JFloat y) = x == y + (JDouble x) == (JDouble y) = x == y + (JObject (J x)) == (JObject (J y)) = castForeignPtr x == castForeignPtr y + _ == _ = False + +sizeOfJValue, alignmentJValue :: Int +sizeOfJValue = 8 +alignmentJValue = 8 + +-- | @withJValue jvalues f@ provides a pointer to an array containing the given +-- @jvalues@. +-- +-- The array is valid only while evaluating @f@. +withJValues :: [JValue] -> (Ptr JValue -> IO a) -> IO a +withJValues args f = + allocaBytesAligned (sizeOfJValue * length args) alignmentJValue $ \p -> + foldr (.) id (zipWith (withJValueOff p) [0..] args) (f p) + +-- @withJValueOff p n jvalue io@ writes the given @jvalue@ to @p `plusPtr` n@ +-- and runs @io@. +-- +-- The jvalue is guaranteed to stay valid while @io@ evaluates. +withJValueOff :: Ptr JValue -> Int -> JValue -> IO a -> IO a +withJValueOff p n jvalue io = case jvalue of + JBoolean x -> pokeByteOff (castPtr p) offset x >> io + JByte x -> pokeByteOff (castPtr p) offset x >> io + JChar x -> pokeByteOff (castPtr p) offset x >> io + JShort x -> pokeByteOff (castPtr p) offset x >> io + JInt x -> pokeByteOff (castPtr p) offset x >> io + JLong x -> pokeByteOff (castPtr p) offset x >> io + JFloat x -> pokeByteOff (castPtr p) offset x >> io + JDouble x -> pokeByteOff (castPtr p) offset x >> io + + JObject (J x) -> withForeignPtr x $ \xp -> + pokeByteOff (castPtr p) offset xp >> io + where + offset = n * sizeOfJValue + +-- | Get the Java type of a value. +jtypeOf :: JValue -> SomeSing JType +jtypeOf (JBoolean _) = SomeSing (sing :: Sing ('Prim "boolean")) +jtypeOf (JByte _) = SomeSing (sing :: Sing ('Prim "byte")) +jtypeOf (JChar _) = SomeSing (sing :: Sing ('Prim "char")) +jtypeOf (JShort _) = SomeSing (sing :: Sing ('Prim "short")) +jtypeOf (JInt _) = SomeSing (sing :: Sing ('Prim "int")) +jtypeOf (JLong _) = SomeSing (sing :: Sing ('Prim "long")) +jtypeOf (JFloat _) = SomeSing (sing :: Sing ('Prim "float")) +jtypeOf (JDouble _) = SomeSing (sing :: Sing ('Prim "double")) +jtypeOf (JObject (_ :: J ty)) = SomeSing (sing :: Sing ty) + +-- | Create a null-terminated string. +build :: Builder -> JNI.String +build = + JNI.unsafeFromByteString . + BSL.toStrict . + Builder.toLazyByteString . + (<> Builder.char7 '\NUL') + +-- | The name of a type, suitable for passing to 'Foreign.JNI.findClass'. +referenceTypeName :: IsReferenceType ty => Sing (ty :: JType) -> ReferenceTypeName +referenceTypeName (SClass sym) = ReferenceTypeName $ build $ classSymbolBuilder sym +referenceTypeName (SIface sym) = ReferenceTypeName $ build $ classSymbolBuilder sym +referenceTypeName ty@(SArray _) = ReferenceTypeName $ build $ signatureBuilder ty +referenceTypeName (SGeneric ty@(SClass _) _) = referenceTypeName ty +referenceTypeName (SGeneric ty@(SIface _) _) = referenceTypeName ty +referenceTypeName _ = error "referenceTypeName: Impossible." + +classSymbolBuilder :: String -> Builder +classSymbolBuilder sym = + Prim.primMapByteStringFixed (subst Prim.>$< Prim.word8) + (JNI.toByteString $ JNI.fromChars sym) + where + subst (chr . fromIntegral -> '.') = fromIntegral (ord '/') + subst x = x + +signatureBuilder :: Sing (ty :: JType) -> Builder +signatureBuilder (SClass sym) = Builder.char7 'L' <> classSymbolBuilder sym <> Builder.char7 ';' +signatureBuilder (SIface sym) = Builder.char7 'L' <> classSymbolBuilder sym <> Builder.char7 ';' +signatureBuilder (SPrim "boolean") = Builder.char7 'Z' +signatureBuilder (SPrim "byte") = Builder.char7 'B' +signatureBuilder (SPrim "char") = Builder.char7 'C' +signatureBuilder (SPrim "short") = Builder.char7 'S' +signatureBuilder (SPrim "int") = Builder.char7 'I' +signatureBuilder (SPrim "long") = Builder.char7 'J' +signatureBuilder (SPrim "float") = Builder.char7 'F' +signatureBuilder (SPrim "double") = Builder.char7 'D' +signatureBuilder (SPrim sym) = error $ "Unknown primitive: " ++ sym +signatureBuilder (SArray ty) = Builder.char7 '[' <> signatureBuilder ty +signatureBuilder (SGeneric ty _) = signatureBuilder ty +signatureBuilder SVoid = Builder.char7 'V' + +-- | Construct a JNI type signature from a Java type. +signature :: Sing (ty :: JType) -> Signature +signature = Signature . build . signatureBuilder + +-- | Construct a method's JNI type signature, given the type of the arguments +-- and the return type. +methodSignature + :: [SomeSing JType] + -> Sing (ty :: JType) + -> MethodSignature +methodSignature args ret = + MethodSignature $ + build $ + Builder.char7 '(' <> + mconcat (map (\(SomeSing s) -> signatureBuilder s) args) <> + Builder.char7 ')' <> + signatureBuilder ret + +-- | Turn the raw pointer into an object. +objectFromPtr :: Ptr (J a) -> IO (J a) +objectFromPtr ptr = J <$> newForeignPtr_ ptr + +-- | Get a raw pointer to an object. This is unsafe because if the argument is +-- the last usage occurrence of the given foreign pointer, then its finalizer(s) +-- will be run, which potentially invalidates the plain pointer just obtained. +unsafeObjectToPtr :: J a -> Ptr (J a) +unsafeObjectToPtr (J fptr) = unsafeForeignPtrToPtr fptr + +type JObject = J ('Class "java.lang.Object") +type JClass = J ('Class "java.lang.Class") +type JString = J ('Class "java.lang.String") +type JThrowable = J ('Class "java.lang.Throwable") +type JArray a = J ('Array a) +type JObjectArray = JArray ('Class "java.lang.Object") +type JBooleanArray = JArray ('Prim "boolean") +type JByteArray = JArray ('Prim "byte") +type JCharArray = JArray ('Prim "char") +type JShortArray = JArray ('Prim "short") +type JIntArray = JArray ('Prim "int") +type JLongArray = JArray ('Prim "long") +type JFloatArray = JArray ('Prim "float") +type JDoubleArray = JArray ('Prim "double") +type JByteBuffer = J ('Class "java.nio.ByteBuffer") + +jniCtx :: Context +jniCtx = mempty { ctxTypesTable = Map.fromList tytab } <> fptrCtx + where + tytab = + [ -- Primitive types + (TypeName "jboolean", [t| Word8 |]) + , (TypeName "jbyte", [t| CChar |]) + , (TypeName "jchar", [t| Word16 |]) + , (TypeName "jshort", [t| Int16 |]) + , (TypeName "jint", [t| Int32 |]) + , (TypeName "jlong", [t| Int64 |]) + , (TypeName "jfloat", [t| Float |]) + , (TypeName "jdouble", [t| Double |]) + -- Reference types + , (TypeName "jobject", [t| Ptr JObject |]) + , (TypeName "jclass", [t| Ptr JClass |]) + , (TypeName "jstring", [t| Ptr JString |]) + , (TypeName "jarray", [t| Ptr JObject |]) + , (TypeName "jobjectArray", [t| Ptr JObjectArray |]) + , (TypeName "jbooleanArray", [t| Ptr JBooleanArray |]) + , (TypeName "jbyteArray", [t| Ptr JByteArray |]) + , (TypeName "jcharArray", [t| Ptr JCharArray |]) + , (TypeName "jshortArray", [t| Ptr JShortArray |]) + , (TypeName "jintArray", [t| Ptr JIntArray |]) + , (TypeName "jlongArray", [t| Ptr JLongArray |]) + , (TypeName "jfloatArray", [t| Ptr JFloatArray |]) + , (TypeName "jdoubleArray", [t| Ptr JDoubleArray |]) + , (TypeName "jthrowable", [t| Ptr JThrowable |]) + -- Internal types + , (TypeName "JavaVM", [t| JVM |]) + , (TypeName "JNIEnv", [t| JNIEnv |]) + , (TypeName "JNINativeMethod", [t| JNINativeMethod |]) + , (TypeName "jfieldID", [t| JFieldID |]) + , (TypeName "jmethodID", [t| JMethodID |]) + , (TypeName "jsize", [t| Int32 |]) + , (TypeName "jvalue", [t| JValue |]) + ] diff --git a/src/common/Foreign/JNI/Unsafe.hs b/src/common/Foreign/JNI/Unsafe.hs new file mode 100644 --- /dev/null +++ b/src/common/Foreign/JNI/Unsafe.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Low-level bindings to the Java Native Interface (JNI). +-- +-- Read the +-- +-- for authoritative documentation as to what each of the functions in +-- this module does. The names of the bindings in this module were chosen to +-- match the names of the functions in the JNI spec. +-- +-- All bindings in this module access the JNI via a thread-local variable of +-- type @JNIEnv *@. If the current OS thread has not yet been "attached" to the +-- JVM, it needs to be attached. See 'JNI.runInAttachedThread'. +-- +-- The 'String' type in this module is the type of JNI strings. See +-- "Foreign.JNI.String". +-- +-- The functions in this module are considered unsafe in opposition +-- to those in "Foreign.JNI.Safe", which ensure that local references are not +-- leaked. + +-- Reexports definitions from "Foreign.JNI.Unsafe.Internal". +module Foreign.JNI.Unsafe + ( module Foreign.JNI.Unsafe.Internal + , NoSuchMethod(..) + , getMethodID + , getStaticMethodID + ) where + +import Control.Exception (Exception, bracket, catch, throwIO) +import Data.List (intersperse) +import Data.Singletons (sing) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Foreign.JNI.Types +import Foreign.JNI.Internal (MethodSignature(..), jniMethodToJavaSignature) +import qualified Foreign.JNI.String as JNI +import qualified Foreign.JNI.Unsafe.Internal as Internal +import Foreign.JNI.Unsafe.Internal hiding (getMethodID, getStaticMethodID) +import Foreign.JNI.Unsafe.Internal.Introspection +import System.IO.Unsafe (unsafePerformIO) + +-- | Throws when a method can't be found +data NoSuchMethod = NoSuchMethod + { noSuchMethodClassName :: Text + , noSuchMethodName :: Text + , noSuchMethodSignature :: Text + , noSuchMethodOverloadings :: [Text] + } deriving Exception + +instance Show NoSuchMethod where + show exn = Text.unpack $ Text.concat $ + case noSuchMethodOverloadings exn of + [] -> + [ "No method named ", noSuchMethodName exn + , " was found in class ", noSuchMethodClassName exn + , "\nWas there a mispelling?" + ] + sigs -> + [ "Couldn't find method\n " + , showMethod (noSuchMethodName exn) (noSuchMethodSignature exn) + , "\nin class ", noSuchMethodClassName exn + , ".\nThe available method overloadings are:\n" + , Text.unlines $ map (" "<>) sigs + ] + where + showMethod methodName sig = + case jniMethodToJavaSignature sig of + -- A Left value is a bug, but we provide the JNI signature + -- which is still useful. + Left _ -> methodName <> ": " <> sig + Right (args, ret) -> Text.concat $ + ret : " " : methodName : "(" : intersperse "," args ++ [")"] + +getMethodID + :: JClass -- ^ A class object as returned by 'findClass' + -> JNI.String -- ^ Field name + -> MethodSignature -- ^ JNI signature + -> IO JMethodID +getMethodID cls method sig = catch + (Internal.getMethodID cls method sig) + (handleJVMException cls method sig) + +getStaticMethodID + :: JClass -- ^ A class object as returned by 'findClass' + -> JNI.String -- ^ Field name + -> MethodSignature -- ^ JNI signature + -> IO JMethodID +getStaticMethodID cls method sig = catch + (Internal.getStaticMethodID cls method sig) + (handleJVMException cls method sig) + +-- | The "NoSuchMethodError" class. +kexception :: JClass +{-# NOINLINE kexception #-} +kexception = unsafePerformIO $ bracket + (findClass $ referenceTypeName $ sing @('Class "java.lang.NoSuchMethodError")) + deleteLocalRef + newGlobalRef + +-- | When the exception is an instance of java.lang.NoSuchMethodError, +-- throw a verbose exception suggesting possible corrections. +-- If it isn't, throw it as is. +handleJVMException + :: JClass + -> JNI.String + -> MethodSignature + -> JVMException + -> IO a +handleJVMException cls method (MethodSignature sig) (JVMException e) = + isInstanceOf (upcast e) kexception >>= \case + True -> do + noSuchMethodOverloadings <- getSignatures cls method + noSuchMethodClassName <- getClassName cls + throwIO $ NoSuchMethod + { noSuchMethodClassName + , noSuchMethodName = Text.decodeUtf8 (JNI.toByteString method) + , noSuchMethodSignature = Text.decodeUtf8 (JNI.toByteString sig) + , noSuchMethodOverloadings + } + False -> throwIO $ JVMException e diff --git a/src/common/Foreign/JNI/Unsafe/Internal.hs b/src/common/Foreign/JNI/Unsafe/Internal.hs new file mode 100644 --- /dev/null +++ b/src/common/Foreign/JNI/Unsafe/Internal.hs @@ -0,0 +1,1062 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + +-- XXX This file uses cpphs for preprocessing instead of the system's native +-- CPP, because the OS X has subtly different whitespace behaviour in the +-- presence of concatenation. + +module Foreign.JNI.Unsafe.Internal + ( -- * JNI functions + -- ** VM management + withJVM + , newJVM + , destroyJVM + -- ** Class loading + , defineClass + , JNINativeMethod(..) + , registerNatives + -- ** String wrappers + , ReferenceTypeName + , MethodSignature + , Signature + -- ** Exceptions + , JVMException(..) + , throw + , throwNew + -- ** Query functions + , findClass + , getFieldID + , getStaticFieldID + , getMethodID + , getStaticMethodID + , getObjectClass + , isInstanceOf + -- ** Reference manipulation + , newGlobalRef + , deleteGlobalRef + , newGlobalRefNonFinalized + , deleteGlobalRefNonFinalized + , newLocalRef + , deleteLocalRef + , pushLocalFrame + , popLocalFrame + , submitToFinalizerThread + -- ** Field accessor functions + -- *** Get fields + , getObjectField + , getBooleanField + , getIntField + , getLongField + , getCharField + , getShortField + , getByteField + , getDoubleField + , getFloatField + -- *** Get static fields + , getStaticObjectField + , getStaticBooleanField + , getStaticIntField + , getStaticLongField + , getStaticCharField + , getStaticShortField + , getStaticByteField + , getStaticDoubleField + , getStaticFloatField + -- *** Set fields + , setObjectField + , setBooleanField + , setIntField + , setLongField + , setCharField + , setShortField + , setByteField + , setDoubleField + , setFloatField + -- *** Set static fields + , setStaticObjectField + , setStaticBooleanField + , setStaticIntField + , setStaticLongField + , setStaticCharField + , setStaticShortField + , setStaticByteField + , setStaticDoubleField + , setStaticFloatField + -- ** Method invocation + , callObjectMethod + , callBooleanMethod + , callIntMethod + , callLongMethod + , callCharMethod + , callShortMethod + , callByteMethod + , callDoubleMethod + , callFloatMethod + , callVoidMethod + , callStaticObjectMethod + , callStaticVoidMethod + , callStaticBooleanMethod + , callStaticIntMethod + , callStaticLongMethod + , callStaticCharMethod + , callStaticShortMethod + , callStaticByteMethod + , callStaticDoubleMethod + , callStaticFloatMethod + -- ** Object construction + , newObject + , newString + , newObjectArray + , newBooleanArray + , newByteArray + , newCharArray + , newShortArray + , newIntArray + , newLongArray + , newFloatArray + , newDoubleArray + -- ** Array manipulation + , getArrayLength + , getStringLength + , ArrayCopyFailed(..) + , NullPointerException(..) + , getBooleanArrayElements + , getByteArrayElements + , getCharArrayElements + , getShortArrayElements + , getIntArrayElements + , getLongArrayElements + , getFloatArrayElements + , getDoubleArrayElements + , getStringChars + , getBooleanArrayRegion + , getByteArrayRegion + , getCharArrayRegion + , getShortArrayRegion + , getIntArrayRegion + , getLongArrayRegion + , getFloatArrayRegion + , getDoubleArrayRegion + , setBooleanArrayRegion + , setByteArrayRegion + , setCharArrayRegion + , setShortArrayRegion + , setIntArrayRegion + , setLongArrayRegion + , setFloatArrayRegion + , setDoubleArrayRegion + , releaseBooleanArrayElements + , releaseByteArrayElements + , releaseCharArrayElements + , releaseShortArrayElements + , releaseIntArrayElements + , releaseLongArrayElements + , releaseFloatArrayElements + , releaseDoubleArrayElements + , releaseStringChars + , getObjectArrayElement + , setObjectArrayElement + -- * Thread management + , attachCurrentThreadAsDaemon + , detachCurrentThread + , isCurrentThreadAttached + , runInAttachedThread + , ThreadNotAttached(..) + -- * NIO support + , DirectBufferFailed(..) + , newDirectByteBuffer + , getDirectBufferAddress + , getDirectBufferCapacity + ) where + +import Control.Concurrent + (isCurrentThreadBound, rtsSupportsBoundThreads, runInBoundThread) +import Control.Exception + (Exception, SomeException, bracket, bracket_, catch, finally, handle, throwIO) +import Control.Monad (unless, void, when) +import Data.Choice +import Data.Coerce +import Data.Int +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Word +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Foreign.C (CChar) +import Foreign.ForeignPtr + ( finalizeForeignPtr + , newForeignPtr_ + , withForeignPtr + ) +import Foreign.JNI.Internal +import Foreign.JNI.Internal.RWLock (RWLock) +import qualified Foreign.JNI.Internal.RWLock as RWLock +import Foreign.JNI.Internal.BackgroundWorker (BackgroundWorker) +import qualified Foreign.JNI.Internal.BackgroundWorker as BackgroundWorker +import Foreign.JNI.NativeMethod +import Foreign.JNI.Types +import qualified Foreign.JNI.String as JNI +import Foreign.Marshal.Alloc (alloca) +import Foreign.Marshal.Array +import Foreign.Ptr (Ptr, castPtr, nullPtr) +import Foreign.Storable (peek) +import GHC.ForeignPtr (newConcForeignPtr) +import GHC.Stack (HasCallStack, callStack, getCallStack, prettySrcLoc) +import qualified Language.C.Inline as C +import qualified Language.C.Inline.Unsafe as CU +import qualified System.Exit +import System.IO (fixIO) +import System.IO.Unsafe (unsafePerformIO) +import Prelude hiding (String) +import qualified Prelude + +C.context (C.baseCtx <> C.bsCtx <> jniCtx) + +C.include "" +C.include "" +C.include "" +C.include "" + +-- A thread-local variable to cache the JNI environment. Accessing this variable +-- is faster than calling @jvm->GetEnv()@. +$(C.verbatim "static __thread JNIEnv* jniEnv; ") + +-- | A JNI call may cause a (Java) exception to be raised. This module raises it +-- as a Haskell exception wrapping the Java exception. +newtype JVMException = JVMException JThrowable + +instance Exception JVMException + +instance Show JVMException where + show (JVMException e) = show e ++ ": Call (Foreign.JNI.showException e) to see details." + +-- | Thrown when @GetArrayElements@ returns a null pointer, +-- because it wanted to copy the array contents but couldn't. In this case the +-- JVM doesn't throw OutOfMemory according to the JNI spec. +data ArrayCopyFailed = ArrayCopyFailed + deriving (Exception, Show) + +-- Thrown when @NewDirectByteBuffer@ or @GetDirectBufferAddress@ returns NULL, +-- and when @GetDirectBufferCapacity@ return @-1@. +data DirectBufferFailed = DirectBufferFailed + deriving (Exception, Show) + +-- | A null reference is found where a non-null reference was expected. +data NullPointerException = NullPointerException + deriving (Exception, Show) + +-- | A JNI call is made from a thread not attached to the JVM. +data ThreadNotAttached = ThreadNotAttached + deriving (Exception, Show) + +-- | A JNI call is made from an unbound thread. +data ThreadNotBound = ThreadNotBound + deriving (Exception, Show) + +-- | Thrown when an JNI call is made from an unbound thread. +data JNIError = JNIError Prelude.String Int32 + deriving Show + +instance Exception JNIError + +-- | Map Java exceptions to Haskell exceptions. +throwIfException :: Ptr JNIEnv -> IO a -> IO a +throwIfException env m = m `finally` do + excptr <- [CU.exp| jthrowable { (*$(JNIEnv *env))->ExceptionOccurred($(JNIEnv *env)) } |] + unless (excptr == nullPtr) $ do + [CU.exp| void { (*$(JNIEnv *env))->ExceptionClear($(JNIEnv *env)) } |] + throwIO . JVMException =<< newGlobalRef =<< objectFromPtr excptr + +-- | Check whether a pointer is null. +throwIfNull :: Exception e => e -> IO (Ptr a) -> IO (Ptr a) +throwIfNull e m = do + ptr <- m + if ptr == nullPtr + then throwIO e + else return ptr + +-- | Throws an error if the given reference is null, otherwise performs +-- the given io action. +throwIfJNull :: J ty -> IO a -> IO a +throwIfJNull j io = + if j == jnull + then throwIO NullPointerException + else io + +-- | This lock is used to avoid the JVM from dying before any finalizers +-- deleting global references are finished. +-- +-- Finalizers try to acquire read locks. +-- +-- The JVM acquires a write lock before shutdown. Thence, finalizers fail to +-- acquire read locks and behave as noops. +globalJVMLock :: RWLock +globalJVMLock = unsafePerformIO RWLock.new +{-# NOINLINE globalJVMLock #-} + +throwIfNotOK_ :: HasCallStack => IO Int32 -> IO () +throwIfNotOK_ m = m >>= \case + rc + | rc == [CU.pure| jint { JNI_OK } |] -> return () + | rc == [CU.pure| jint { JNI_EDETACHED } |] -> throwIO ThreadNotAttached + | otherwise -> throwIO $ JNIError (prettySrcLoc loc) rc + where + (_, loc):_ = getCallStack callStack + +attachCurrentThreadAsDaemon :: IO () +attachCurrentThreadAsDaemon = do + checkBoundness + throwIfNotOK_ + [CU.exp| jint { + (*$(JavaVM* jvm))->AttachCurrentThreadAsDaemon($(JavaVM* jvm), (void**)&jniEnv, NULL) + } |] + +detachCurrentThread :: IO () +detachCurrentThread = + throwIfNotOK_ + [CU.block| jint { + int rc = (*$(JavaVM* jvm))->DetachCurrentThread($(JavaVM* jvm)); + if (rc == JNI_OK) + jniEnv = NULL; + return rc; + } |] + +-- | Tells whether the calling thread is attached to the JVM. +isCurrentThreadAttached :: IO Bool +isCurrentThreadAttached = + catch (getJNIEnv >> return True) (\ThreadNotAttached -> return False) + +-- | Attaches the calling thread to the JVM, runs the given IO action and +-- then detaches the thread. +-- +-- If the thread is already attached no attaching and detaching is performed. +runInAttachedThread :: IO a -> IO a +runInAttachedThread io = do + attached <- isCurrentThreadAttached + if attached + then io + else bracket_ + attachCurrentThreadAsDaemon + detachCurrentThread + io + +-- | The current JVM +-- +-- Assumes there's at most one JVM. The current JNI spec (2016) says only +-- one JVM per process is supported anyways. +{-# NOINLINE jvm #-} +jvm :: Ptr JVM +jvm = unsafePerformIO $ alloca $ \pjvm -> alloca $ \pnum_jvms -> do + throwIfNotOK_ + [CU.exp| jint { + JNI_GetCreatedJavaVMs($(JavaVM** pjvm), 1, $(jsize* pnum_jvms)) + }|] + num_jvms <- peek pnum_jvms + when (num_jvms == 0) $ + fail "JNI_GetCreatedJavaVMs: No JVM has been initialized yet." + when (num_jvms > 1) $ + fail "JNI_GetCreatedJavaVMs: There are multiple JVMs but only one is supported." + peek pjvm + +-- | Yields the JNIEnv of the calling thread. +-- +-- Yields @Nothing@ if the calling thread is not attached to the JVM. +getJNIEnv :: IO (Ptr JNIEnv) +getJNIEnv = [CU.exp| JNIEnv* { jniEnv } |] >>= \case + env | env == nullPtr -> do + throwIfNotOK_ + [CU.exp| jint { + (*$(JavaVM* jvm))->GetEnv($(JavaVM* jvm), (void**)&jniEnv, JNI_VERSION_1_6) + }|] + [CU.exp| JNIEnv* { jniEnv } |] + env -> return env + +-- | Run an action against the appropriate 'JNIEnv'. +-- +-- Each OS thread has its own 'JNIEnv', which this function gives access to. +withJNIEnv :: (Ptr JNIEnv -> IO a) -> IO a +withJNIEnv f = getJNIEnv >>= f + +useAsCStrings :: [ByteString] -> ([Ptr CChar] -> IO a) -> IO a +useAsCStrings strs m = + foldr (\str k cstrs -> BS.useAsCString str $ \cstr -> k (cstr:cstrs)) m strs [] + +-- | Create a new JVM, with the given arguments. /Can only be called once/. Best +-- practice: use 'withJVM' instead. Only useful for GHCi. +newJVM :: [ByteString] -> IO JVM +newJVM options = JVM_ <$> do + checkBoundness + startJVM options <* startFinalizerThread + where + startFinalizerThread = + BackgroundWorker.create + (exitOnError . runInBoundThread . runInAttachedThread) + >>= writeIORef finalizerThread + + exitOnError = handle $ \(e :: SomeException) -> do + System.Exit.die $ "Haskell jni package: error in finalizer thread: " ++ show e + + startJVM options = + useAsCStrings options $ \cstrs -> do + withArray cstrs $ \(coptions :: Ptr (Ptr CChar)) -> do + let n = fromIntegral (length cstrs) :: C.CInt + + [C.block| JavaVM * { + JavaVM *jvm; + JavaVMInitArgs vm_args; + JavaVMOption *options = malloc(sizeof(JavaVMOption) * $(int n)); + for(int i = 0; i < $(int n); i++) + options[i].optionString = $(char **coptions)[i]; + vm_args.version = JNI_VERSION_1_6; + vm_args.nOptions = $(int n); + vm_args.options = options; + vm_args.ignoreUnrecognized = 0; + JNI_CreateJavaVM(&jvm, (void**)&jniEnv, &vm_args); + free(options); + return jvm; } |] + +checkBoundness :: IO () +checkBoundness = + if rtsSupportsBoundThreads then do + bound <- isCurrentThreadBound + unless bound (throwIO ThreadNotBound) + else + error $ unlines + [ "jni won't work with a non-threaded runtime." + , "Perhaps link your program with -threaded." + ] + +-- | Deallocate a 'JVM' created using 'newJVM'. +destroyJVM :: JVM -> IO () +destroyJVM (JVM_ jvm) = do + readIORef finalizerThread >>= BackgroundWorker.stop + writeIORef finalizerThread uninitializedFinalizerThread + RWLock.acquireWriteLock globalJVMLock + [C.block| void { + (*$(JavaVM *jvm))->DestroyJavaVM($(JavaVM *jvm)); + jniEnv = NULL; + } |] + +-- | Create a new JVM, with the given arguments. Destroy it once the given +-- action completes. /Can only be called once/. Best practice: use it to wrap +-- your @main@ function. +withJVM :: [ByteString] -> IO a -> IO a +withJVM options action = bracket (newJVM options) destroyJVM (const action) + +defineClass + :: Coercible o (J ('Class "java.lang.ClassLoader")) + => ReferenceTypeName -- ^ Class name + -> o -- ^ Loader + -> ByteString -- ^ Bytecode buffer + -> IO JClass +defineClass (coerce -> name) (coerce -> upcast -> loader) buf = withJNIEnv $ \env -> + throwIfException env $ + JNI.withString name $ \namep -> + objectFromPtr =<< + [CU.exp| jclass { + (*$(JNIEnv *env))->DefineClass($(JNIEnv *env), + $(char *namep), + $fptr-ptr:(jobject loader), + $bs-ptr:buf, + $bs-len:buf) } |] +registerNatives + :: JClass + -> [JNINativeMethod] + -> IO () +registerNatives cls methods = withJNIEnv $ \env -> + throwIfException env $ + withArray methods $ \cmethods -> do + let numMethods = fromIntegral $ length methods + _ <- [CU.exp| jint { + (*$(JNIEnv *env))->RegisterNatives($(JNIEnv *env), + $fptr-ptr:(jclass cls), + $(JNINativeMethod *cmethods), + $(int numMethods)) } |] + return () + +throw :: Coercible o (J a) => o -> IO () +throw (coerce -> upcast -> obj) = withJNIEnv $ \env -> void $ do + [CU.exp| jint { + (*$(JNIEnv *env))->Throw($(JNIEnv *env), + $fptr-ptr:(jobject obj)) } |] + +throwNew :: JClass -> JNI.String -> IO () +throwNew cls msg = throwIfJNull cls $ withJNIEnv $ \env -> + JNI.withString msg $ \msgp -> void $ do + [CU.exp| jint { + (*$(JNIEnv *env))->ThrowNew($(JNIEnv *env), + $fptr-ptr:(jclass cls), + $(char *msgp)) } |] + +findClass + :: ReferenceTypeName -- ^ Class name + -> IO JClass +findClass (coerce -> name) = withJNIEnv $ \env -> + throwIfException env $ + JNI.withString name $ \namep -> + objectFromPtr =<< + [CU.exp| jclass { (*$(JNIEnv *env))->FindClass($(JNIEnv *env), $(char *namep)) } |] + +newObject :: JClass -> MethodSignature -> [JValue] -> IO JObject +newObject cls (coerce -> sig) args = throwIfJNull cls $ withJNIEnv $ \env -> + throwIfException env $ + withJValues args $ \cargs -> do + constr <- getMethodID cls "" sig + objectFromPtr =<< [CU.exp| jobject { + (*$(JNIEnv *env))->NewObjectA($(JNIEnv *env), + $fptr-ptr:(jclass cls), + $(jmethodID constr), + $(jvalue *cargs)) } |] + +getFieldID + :: JClass -- ^ A class object as returned by 'findClass' + -> JNI.String -- ^ Field name + -> Signature -- ^ JNI signature + -> IO JFieldID +getFieldID cls fieldname (coerce -> sig) = throwIfJNull cls $ + withJNIEnv $ \env -> + throwIfException env $ + JNI.withString fieldname $ \fieldnamep -> + JNI.withString sig $ \sigp -> + [CU.exp| jfieldID { + (*$(JNIEnv *env))->GetFieldID($(JNIEnv *env), + $fptr-ptr:(jclass cls), + $(char *fieldnamep), + $(char *sigp)) } |] + +getStaticFieldID + :: JClass -- ^ A class object as returned by 'findClass' + -> JNI.String -- ^ Field name + -> Signature -- ^ JNI signature + -> IO JFieldID +getStaticFieldID cls fieldname (coerce -> sig) = throwIfJNull cls $ + withJNIEnv $ \env -> + throwIfException env $ + JNI.withString fieldname $ \fieldnamep -> + JNI.withString sig $ \sigp -> + [CU.exp| jfieldID { + (*$(JNIEnv *env))->GetStaticFieldID($(JNIEnv *env), + $fptr-ptr:(jclass cls), + $(char *fieldnamep), + $(char *sigp)) } |] + +#define GET_FIELD(name, hs_rettype, c_rettype) \ +get/**/name/**/Field :: Coercible o (J a) => o -> JFieldID -> IO hs_rettype; \ +get/**/name/**/Field (coerce -> upcast -> obj) field = withJNIEnv $ \env -> \ + throwIfException env $ \ + [CU.exp| c_rettype { \ + (*$(JNIEnv *env))->Get/**/name/**/Field($(JNIEnv *env), \ + $fptr-ptr:(jobject obj), \ + $(jfieldID field)) } |] + +getObjectField :: Coercible o (J a) => o -> JFieldID -> IO JObject +getObjectField x y = + let GET_FIELD(Object, (Ptr JObject), jobject) + in objectFromPtr =<< getObjectField x y +GET_FIELD(Boolean, Word8, jboolean) +GET_FIELD(Byte, CChar, jbyte) +GET_FIELD(Char, Word16, jchar) +GET_FIELD(Short, Int16, jshort) +GET_FIELD(Int, Int32, jint) +GET_FIELD(Long, Int64, jlong) +GET_FIELD(Float, Float, jfloat) +GET_FIELD(Double, Double, jdouble) + +#define GET_STATIC_FIELD(name, hs_rettype, c_rettype) \ +getStatic/**/name/**/Field :: JClass -> JFieldID -> IO hs_rettype; \ +getStatic/**/name/**/Field klass field = throwIfJNull klass $ \ + withJNIEnv $ \env -> \ + throwIfException env $ \ + [CU.exp| c_rettype { \ + (*$(JNIEnv *env))->GetStatic/**/name/**/Field($(JNIEnv *env), \ + $fptr-ptr:(jclass klass), \ + $(jfieldID field)) } |] + +getStaticObjectField :: JClass -> JFieldID -> IO JObject +getStaticObjectField x y = + let GET_STATIC_FIELD(Object, (Ptr JObject), jobject) + in objectFromPtr =<< getStaticObjectField x y +GET_STATIC_FIELD(Boolean, Word8, jboolean) +GET_STATIC_FIELD(Byte, CChar, jbyte) +GET_STATIC_FIELD(Char, Word16, jchar) +GET_STATIC_FIELD(Short, Int16, jshort) +GET_STATIC_FIELD(Int, Int32, jint) +GET_STATIC_FIELD(Long, Int64, jlong) +GET_STATIC_FIELD(Float, Float, jfloat) +GET_STATIC_FIELD(Double, Double, jdouble) + +#define SET_FIELD(name, hs_fieldtype, c_fieldtype) \ +set/**/name/**/Field :: Coercible o (J a) => o -> JFieldID -> hs_fieldtype -> IO (); \ +set/**/name/**/Field (coerce -> upcast -> obj) field x = \ + withJNIEnv $ \env -> \ + throwIfException env $ \ + [CU.block| void { \ + (*$(JNIEnv *env))->Set/**/name/**/Field($(JNIEnv *env), \ + $fptr-ptr:(jobject obj), \ + $(jfieldID field), \ + $(c_fieldtype x)); } |] + +setObjectField :: Coercible o (J a) => o -> JFieldID -> JObject -> IO () +setObjectField x y z = + let SET_FIELD(Object, (Ptr JObject), jobject) + in withForeignPtr (coerce z) (setObjectField x y) +SET_FIELD(Boolean, Word8, jboolean) +SET_FIELD(Byte, CChar, jbyte) +SET_FIELD(Char, Word16, jchar) +SET_FIELD(Short, Int16, jshort) +SET_FIELD(Int, Int32, jint) +SET_FIELD(Long, Int64, jlong) +SET_FIELD(Float, Float, jfloat) +SET_FIELD(Double, Double, jdouble) + +#define SET_STATIC_FIELD(name, hs_fieldtype, c_fieldtype) \ +setStatic/**/name/**/Field :: JClass -> JFieldID -> hs_fieldtype -> IO (); \ +setStatic/**/name/**/Field klass field x = throwIfJNull klass $ \ + withJNIEnv $ \env -> \ + throwIfException env $ \ + [CU.block| void { \ + (*$(JNIEnv *env))->SetStatic/**/name/**/Field($(JNIEnv *env), \ + $fptr-ptr:(jclass klass), \ + $(jfieldID field), \ + $(c_fieldtype x)); } |] + +setStaticObjectField :: JClass -> JFieldID -> JObject -> IO () +setStaticObjectField x y z = + let SET_STATIC_FIELD(Object, (Ptr JObject), jobject) + in withForeignPtr (coerce z) (setStaticObjectField x y) +SET_STATIC_FIELD(Boolean, Word8, jboolean) +SET_STATIC_FIELD(Byte, CChar, jbyte) +SET_STATIC_FIELD(Char, Word16, jchar) +SET_STATIC_FIELD(Short, Int16, jshort) +SET_STATIC_FIELD(Int, Int32, jint) +SET_STATIC_FIELD(Long, Int64, jlong) +SET_STATIC_FIELD(Float, Float, jfloat) +SET_STATIC_FIELD(Double, Double, jdouble) + +getMethodID + :: JClass -- ^ A class object as returned by 'findClass' + -> JNI.String -- ^ Field name + -> MethodSignature -- ^ JNI signature + -> IO JMethodID +getMethodID cls methodname (coerce -> sig) = throwIfJNull cls $ + withJNIEnv $ \env -> + throwIfException env $ + JNI.withString methodname $ \methodnamep -> + JNI.withString sig $ \sigp -> + [CU.exp| jmethodID { + (*$(JNIEnv *env))->GetMethodID($(JNIEnv *env), + $fptr-ptr:(jclass cls), + $(char *methodnamep), + $(char *sigp)) } |] + +getStaticMethodID + :: JClass -- ^ A class object as returned by 'findClass' + -> JNI.String -- ^ Field name + -> MethodSignature -- ^ JNI signature + -> IO JMethodID +getStaticMethodID cls methodname (coerce -> sig) = throwIfJNull cls $ + withJNIEnv $ \env -> + throwIfException env $ + JNI.withString methodname $ \methodnamep -> + JNI.withString sig $ \sigp -> + [CU.exp| jmethodID { + (*$(JNIEnv *env))->GetStaticMethodID($(JNIEnv *env), + $fptr-ptr:(jclass cls), + $(char *methodnamep), + $(char *sigp)) } |] + +getObjectClass :: Coercible o (J ty) => o -> IO JClass +getObjectClass (coerce -> upcast -> obj) = throwIfJNull obj $ + withJNIEnv $ \env -> + objectFromPtr =<< + [CU.exp| jclass { + (*$(JNIEnv *env))->GetObjectClass($(JNIEnv *env), + $fptr-ptr:(jobject obj)) } |] + +-- | Creates a global reference to the object referred to by +-- the given reference. +-- +-- Arranges for a finalizer to call 'deleteGlobalRef' when the +-- global reference is no longer reachable on the Haskell side. +newGlobalRef :: Coercible o (J ty) => o -> IO o +newGlobalRef (coerce -> upcast -> obj) = withJNIEnv $ \env -> do + gobj <- + [CU.exp| jobject { + (*$(JNIEnv *env))->NewGlobalRef($(JNIEnv *env), + $fptr-ptr:(jobject obj)) } |] + fixIO $ \j -> + coerce <$> J <$> + newConcForeignPtr gobj + (submitToFinalizerThread $ deleteGlobalRefNonFinalized j) + +deleteGlobalRef :: Coercible o (J ty) => o -> IO () +deleteGlobalRef (coerce -> J p) = finalizeForeignPtr p + +-- | Like 'newGlobalRef' but it doesn't attach a finalizer to destroy +-- the reference when it is not longer reachable. Use +-- 'deleteGlobalRefNonFinalized' to destroy this reference. +newGlobalRefNonFinalized :: Coercible o (J ty) => o -> IO o +newGlobalRefNonFinalized (coerce -> upcast -> obj) = withJNIEnv $ \env -> do + gobj <- + [CU.exp| jobject { + (*$(JNIEnv *env))->NewGlobalRef($(JNIEnv *env), + $fptr-ptr:(jobject obj)) } |] + coerce <$> J <$> newForeignPtr_ gobj + +-- | Like 'deleteGlobalRef' but it can be used only on references created with +-- 'newGlobalRefNonFinalized'. +deleteGlobalRefNonFinalized :: Coercible o (J ty) => o -> IO () +deleteGlobalRefNonFinalized (coerce -> upcast -> obj) = do + bracket (RWLock.tryAcquireReadLock globalJVMLock) + (\doRead -> when (toBool doRead) $ RWLock.releaseReadLock globalJVMLock) + $ \doRead -> + when (toBool doRead) $ withJNIEnv $ \env -> do + [CU.block| void { (*$(JNIEnv *env))->DeleteGlobalRef($(JNIEnv *env) + ,$fptr-ptr:(jobject obj)); + } |] + +-- NB: Cannot add a finalizer to local references because it may +-- run in a thread where the reference is not valid. +newLocalRef :: Coercible o (J ty) => o -> IO o +newLocalRef (coerce -> upcast -> obj) = withJNIEnv $ \env -> + coerce <$> (objectFromPtr =<<) + [CU.exp| jobject { + (*$(JNIEnv *env))->NewLocalRef($(JNIEnv *env), + $fptr-ptr:(jobject obj)) } |] + +deleteLocalRef :: Coercible o (J ty) => o -> IO () +deleteLocalRef (coerce -> upcast -> obj) = withJNIEnv $ \env -> + [CU.exp| void { + (*$(JNIEnv *env))->DeleteLocalRef($(JNIEnv *env), + $fptr-ptr:(jobject obj)) } |] + +pushLocalFrame :: Int32 -> IO () +pushLocalFrame (coerce -> capacity) = withJNIEnv $ \env -> + -- We ignore the output as it is always 0 on success and throws an + -- exception otherwise. + throwIfException env $ void $ + [CU.block| jint { + (*$(JNIEnv *env))->PushLocalFrame($(JNIEnv *env), + $(jint capacity)); } |] + +popLocalFrame :: Coercible o (J ty) => o -> IO o +popLocalFrame (coerce -> upcast -> obj) = withJNIEnv $ \env -> + coerce <$> (objectFromPtr =<<) + [CU.exp| jobject { + (*$(JNIEnv *env))->PopLocalFrame($(JNIEnv *env), + $fptr-ptr:(jobject obj)) } |] + +-- Modern CPP does have ## for concatenating strings, but we use the hacky /**/ +-- comment syntax for string concatenation. This is because GHC passes +-- the -traditional flag to the preprocessor by default, which turns off several +-- modern CPP features. + +#define CALL_METHOD(name, hs_rettype, c_rettype) \ +call/**/name/**/Method :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO hs_rettype; \ +call/**/name/**/Method (coerce -> upcast -> obj) method args = withJNIEnv $ \env -> \ + throwIfException env $ \ + withJValues args $ \cargs -> \ + [C.exp| c_rettype { \ + (*$(JNIEnv *env))->Call/**/name/**/MethodA($(JNIEnv *env), \ + $fptr-ptr:(jobject obj), \ + $(jmethodID method), \ + $(jvalue *cargs)) } |] + +CALL_METHOD(Void, (), void) +callObjectMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO JObject +callObjectMethod x y z = + let CALL_METHOD(Object, (Ptr JObject), jobject) + in objectFromPtr =<< callObjectMethod x y z +callBooleanMethod :: Coercible o (J a) => o -> JMethodID -> [JValue] -> IO Bool +callBooleanMethod x y z = + let CALL_METHOD(Boolean, Word8, jboolean) + in toEnum . fromIntegral <$> callBooleanMethod x y z +CALL_METHOD(Byte, CChar, jbyte) +CALL_METHOD(Char, Word16, jchar) +CALL_METHOD(Short, Int16, jshort) +CALL_METHOD(Int, Int32, jint) +CALL_METHOD(Long, Int64, jlong) +CALL_METHOD(Float, Float, jfloat) +CALL_METHOD(Double, Double, jdouble) + +#define CALL_STATIC_METHOD(name, hs_rettype, c_rettype) \ +callStatic/**/name/**/Method :: JClass -> JMethodID -> [JValue] -> IO hs_rettype; \ +callStatic/**/name/**/Method cls method args = throwIfJNull cls $ \ + withJNIEnv $ \env -> \ + throwIfException env $ \ + withJValues args $ \cargs -> \ + [C.exp| c_rettype { \ + (*$(JNIEnv *env))->CallStatic/**/name/**/MethodA($(JNIEnv *env), \ + $fptr-ptr:(jclass cls), \ + $(jmethodID method), \ + $(jvalue *cargs)) } |] + +CALL_STATIC_METHOD(Void, (), void) +callStaticObjectMethod :: JClass -> JMethodID -> [JValue] -> IO JObject +callStaticObjectMethod x y z = + let CALL_STATIC_METHOD(Object, (Ptr JObject), jobject) + in objectFromPtr =<< callStaticObjectMethod x y z +callStaticBooleanMethod :: JClass -> JMethodID -> [JValue] -> IO Bool +callStaticBooleanMethod x y z = + let CALL_STATIC_METHOD(Boolean, Word8, jboolean) + in toEnum . fromIntegral <$> callStaticBooleanMethod x y z +CALL_STATIC_METHOD(Byte, CChar, jbyte) +CALL_STATIC_METHOD(Char, Word16, jchar) +CALL_STATIC_METHOD(Short, Int16, jshort) +CALL_STATIC_METHOD(Int, Int32, jint) +CALL_STATIC_METHOD(Long, Int64, jlong) +CALL_STATIC_METHOD(Float, Float, jfloat) +CALL_STATIC_METHOD(Double, Double, jdouble) + +newObjectArray :: Int32 -> JClass -> IO JObjectArray +newObjectArray sz cls = throwIfJNull cls $ withJNIEnv $ \env -> + throwIfException env $ + objectFromPtr =<< + [CU.exp| jobjectArray { + (*$(JNIEnv *env))->NewObjectArray($(JNIEnv *env), + $(jsize sz), + $fptr-ptr:(jclass cls), + NULL) } |] + +#define NEW_ARRAY(name, c_rettype) \ +new/**/name/**/Array :: Int32 -> IO J/**/name/**/Array; \ +new/**/name/**/Array sz = withJNIEnv $ \env -> \ + throwIfException env $ \ + objectFromPtr =<< \ + [CU.exp| c_rettype/**/Array { \ + (*$(JNIEnv *env))->New/**/name/**/Array($(JNIEnv *env), \ + $(jsize sz)) } |] + +NEW_ARRAY(Boolean, jboolean) +NEW_ARRAY(Byte, jbyte) +NEW_ARRAY(Char, jchar) +NEW_ARRAY(Short, jshort) +NEW_ARRAY(Int, jint) +NEW_ARRAY(Long, jlong) +NEW_ARRAY(Float, jfloat) +NEW_ARRAY(Double, jdouble) + +newString :: Ptr Word16 -> Int32 -> IO JString +newString ptr len = withJNIEnv $ \env -> + throwIfException env $ + objectFromPtr =<< + [CU.exp| jstring { + (*$(JNIEnv *env))->NewString($(JNIEnv *env), + $(jchar *ptr), + $(jsize len)) } |] + +getArrayLength :: Coercible o (JArray a) => o -> IO Int32 +getArrayLength (coerce -> upcast -> array) = throwIfJNull array $ + withJNIEnv $ \env -> + [C.exp| jsize { + (*$(JNIEnv *env))->GetArrayLength($(JNIEnv *env), + $fptr-ptr:(jarray array)) } |] + +getStringLength :: JString -> IO Int32 +getStringLength jstr = throwIfJNull jstr $ withJNIEnv $ \env -> + [CU.exp| jsize { + (*$(JNIEnv *env))->GetStringLength($(JNIEnv *env), + $fptr-ptr:(jstring jstr)) } |] + +#define GET_ARRAY_ELEMENTS(name, hs_rettype, c_rettype) \ +get/**/name/**/ArrayElements :: J/**/name/**/Array -> IO (Ptr hs_rettype); \ +get/**/name/**/ArrayElements (upcast -> array) = throwIfJNull array $ \ + withJNIEnv $ \env -> \ + throwIfNull ArrayCopyFailed $ \ + [CU.exp| c_rettype* { \ + (*$(JNIEnv *env))->Get/**/name/**/ArrayElements($(JNIEnv *env), \ + $fptr-ptr:(jobject array), \ + NULL) } |] + +GET_ARRAY_ELEMENTS(Boolean, Word8, jboolean) +GET_ARRAY_ELEMENTS(Byte, CChar, jbyte) +GET_ARRAY_ELEMENTS(Char, Word16, jchar) +GET_ARRAY_ELEMENTS(Short, Int16, jshort) +GET_ARRAY_ELEMENTS(Int, Int32, jint) +GET_ARRAY_ELEMENTS(Long, Int64, jlong) +GET_ARRAY_ELEMENTS(Float, Float, jfloat) +GET_ARRAY_ELEMENTS(Double, Double, jdouble) + +getStringChars :: JString -> IO (Ptr Word16) +getStringChars jstr = throwIfJNull jstr $ withJNIEnv $ \env -> + throwIfNull ArrayCopyFailed $ + [CU.exp| const jchar* { + (*$(JNIEnv *env))->GetStringChars($(JNIEnv *env), + $fptr-ptr:(jstring jstr), + NULL) } |] + +#define GET_ARRAY_REGION(name, hs_argtype, c_argtype) \ +get/**/name/**/ArrayRegion :: J/**/name/**/Array -> Int32 -> Int32 -> Ptr hs_argtype -> IO (); \ +get/**/name/**/ArrayRegion array start len buf = throwIfJNull array $ \ + withJNIEnv $ \env -> \ + throwIfException env $ \ + [CU.exp| void { \ + (*$(JNIEnv *env))->Get/**/name/**/ArrayRegion($(JNIEnv *env), \ + $fptr-ptr:(c_argtype/**/Array array), \ + $(jsize start), \ + $(jsize len), \ + $(c_argtype *buf)) } |] + +GET_ARRAY_REGION(Boolean, Word8, jboolean) +GET_ARRAY_REGION(Byte, CChar, jbyte) +GET_ARRAY_REGION(Char, Word16, jchar) +GET_ARRAY_REGION(Short, Int16, jshort) +GET_ARRAY_REGION(Int, Int32, jint) +GET_ARRAY_REGION(Long, Int64, jlong) +GET_ARRAY_REGION(Float, Float, jfloat) +GET_ARRAY_REGION(Double, Double, jdouble) + +#define SET_ARRAY_REGION(name, hs_argtype, c_argtype) \ +set/**/name/**/ArrayRegion :: J/**/name/**/Array -> Int32 -> Int32 -> Ptr hs_argtype -> IO (); \ +set/**/name/**/ArrayRegion array start len buf = throwIfJNull array $ \ + withJNIEnv $ \env -> \ + throwIfException env $ \ + [CU.exp| void { \ + (*$(JNIEnv *env))->Set/**/name/**/ArrayRegion($(JNIEnv *env), \ + $fptr-ptr:(c_argtype/**/Array array), \ + $(jsize start), \ + $(jsize len), \ + $(c_argtype *buf)) } |] + +SET_ARRAY_REGION(Boolean, Word8, jboolean) +SET_ARRAY_REGION(Byte, CChar, jbyte) +SET_ARRAY_REGION(Char, Word16, jchar) +SET_ARRAY_REGION(Short, Int16, jshort) +SET_ARRAY_REGION(Int, Int32, jint) +SET_ARRAY_REGION(Long, Int64, jlong) +SET_ARRAY_REGION(Float, Float, jfloat) +SET_ARRAY_REGION(Double, Double, jdouble) + +#define RELEASE_ARRAY_ELEMENTS(name, hs_argtype, c_argtype) \ +release/**/name/**/ArrayElements :: J/**/name/**/Array -> Ptr hs_argtype -> IO (); \ +release/**/name/**/ArrayElements (upcast -> array) xs = throwIfJNull array $ \ + withJNIEnv $ \env -> \ + [CU.exp| void { \ + (*$(JNIEnv *env))->Release/**/name/**/ArrayElements($(JNIEnv *env), \ + $fptr-ptr:(jobject array), \ + $(c_argtype *xs), \ + JNI_ABORT) } |] + +RELEASE_ARRAY_ELEMENTS(Boolean, Word8, jboolean) +RELEASE_ARRAY_ELEMENTS(Byte, CChar, jbyte) +RELEASE_ARRAY_ELEMENTS(Char, Word16, jchar) +RELEASE_ARRAY_ELEMENTS(Short, Int16, jshort) +RELEASE_ARRAY_ELEMENTS(Int, Int32, jint) +RELEASE_ARRAY_ELEMENTS(Long, Int64, jlong) +RELEASE_ARRAY_ELEMENTS(Float, Float, jfloat) +RELEASE_ARRAY_ELEMENTS(Double, Double, jdouble) + +releaseStringChars :: JString -> Ptr Word16 -> IO () +releaseStringChars jstr chars = throwIfJNull jstr $ withJNIEnv $ \env -> + [CU.exp| void { + (*$(JNIEnv *env))->ReleaseStringChars($(JNIEnv *env), + $fptr-ptr:(jstring jstr), + $(jchar *chars)) } |] + +getObjectArrayElement + :: forall a o. + (IsReferenceType a, Coercible o (J a)) + => JArray a + -> Int32 + -> IO o +getObjectArrayElement (arrayUpcast -> array) i = throwIfJNull array $ + withJNIEnv $ \env -> + ( (coerce :: J a -> o) + . (unsafeCast :: JObject -> J a) + ) <$> (objectFromPtr =<<) + [C.exp| jobject { + (*$(JNIEnv *env))->GetObjectArrayElement($(JNIEnv *env), + $fptr-ptr:(jarray array), + $(jsize i)) } |] + +setObjectArrayElement + :: forall a o. + (IsReferenceType a, Coercible o (J a)) + => JArray a + -> Int32 + -> o + -> IO () +setObjectArrayElement (arrayUpcast -> array) + i + ((coerce :: o -> J a) -> upcast -> x) = + throwIfJNull array $ + withJNIEnv $ \env -> + [C.exp| void { + (*$(JNIEnv *env))->SetObjectArrayElement($(JNIEnv *env), + $fptr-ptr:(jobjectArray array), + $(jsize i), + $fptr-ptr:(jobject x)); } |] + +newDirectByteBuffer :: Ptr CChar -> Int64 -> IO JByteBuffer +newDirectByteBuffer (castPtr -> address) capacity = + (throwIfNull NullPointerException (return address) >>) $ + withJNIEnv $ \env -> + fmap (unsafeCast :: JObject -> JByteBuffer) $ + (objectFromPtr =<<) $ + throwIfNull DirectBufferFailed $ + [C.exp| jobject { + (*$(JNIEnv *env))->NewDirectByteBuffer($(JNIEnv *env), + $(void *address), + $(jlong capacity)) } |] + +getDirectBufferAddress :: JByteBuffer -> IO (Ptr CChar) +getDirectBufferAddress (upcast -> jbuffer) = + throwIfJNull jbuffer $ + withJNIEnv $ \env -> + fmap castPtr $ + throwIfNull DirectBufferFailed $ + [C.exp| void* { + (*$(JNIEnv *env))->GetDirectBufferAddress($(JNIEnv *env), + $fptr-ptr:(jobject jbuffer)) } |] + +getDirectBufferCapacity :: JByteBuffer -> IO Int64 +getDirectBufferCapacity (upcast -> jbuffer) = do + capacity <- throwIfJNull jbuffer $ + withJNIEnv $ \env -> + [C.exp| jlong { + (*$(JNIEnv *env))->GetDirectBufferCapacity($(JNIEnv *env), + $fptr-ptr:(jobject jbuffer)) } |] + if capacity >= 0 then + return capacity + else + throwIO DirectBufferFailed + +isInstanceOf :: Coercible o (J ty) => o -> JClass -> IO Bool +isInstanceOf (coerce -> upcast -> obj) cls = do + w <- throwIfJNull obj $ throwIfJNull cls $ + withJNIEnv $ \env -> + [C.exp| jboolean { + (*$(JNIEnv *env))->IsInstanceOf($(JNIEnv *env), + $fptr-ptr:(jobject obj), + $fptr-ptr:(jclass cls)) } |] + return $ toEnum $ fromIntegral w + +-- | A background thread for cleaning global references +finalizerThread :: IORef BackgroundWorker +{-# NOINLINE finalizerThread #-} +finalizerThread = unsafePerformIO $ newIORef uninitializedFinalizerThread + +uninitializedFinalizerThread :: BackgroundWorker +uninitializedFinalizerThread = error "The finalizer thread is not initialized" + +-- | Runs a task in a long-living background thread attached to the +-- JVM. The thread is dedicated to release unused references to java +-- objects. +-- +-- Useful to be called from GC finalizers, where attaching to the JVM would +-- be too expensive. +-- +submitToFinalizerThread :: IO () -> IO () +submitToFinalizerThread action = do + worker <- readIORef finalizerThread + BackgroundWorker.submitTask worker action diff --git a/src/common/Foreign/JNI/Unsafe/Internal/Introspection.hs b/src/common/Foreign/JNI/Unsafe/Internal/Introspection.hs new file mode 100644 --- /dev/null +++ b/src/common/Foreign/JNI/Unsafe/Internal/Introspection.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Foreign.JNI.Unsafe.Internal.Introspection + ( getClassName + , getSignatures + , toText + , classGetNameMethod + , showException + ) where + +import Control.Exception (bracket) +import Control.Monad (forM) +import Data.Coerce +import Data.Maybe (catMaybes) +import Data.Singletons +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Foreign as Text +import Foreign.JNI.Unsafe.Internal +import Foreign.JNI.Types +import qualified Foreign.JNI.String as JNI +import Prelude hiding (String) +import System.IO.Unsafe (unsafePerformIO) +import GHC.ForeignPtr (ForeignPtr) + +-- | The "Class" class. +kclass :: JClass +{-# NOINLINE kclass #-} +kclass = unsafePerformIO $ bracket + (findClass $ referenceTypeName $ sing @('Class "java.lang.Class")) + deleteLocalRef + newGlobalRef + +-- | The "Method" class +kmethod :: JClass +{-# NOINLINE kmethod #-} +kmethod = unsafePerformIO $ bracket + (findClass $ referenceTypeName $ sing @('Class "java.lang.reflect.Method")) + deleteLocalRef + newGlobalRef + +-- | Class.getMethods +classGetMethodsMethod :: JMethodID +{-# NOINLINE classGetMethodsMethod #-} +classGetMethodsMethod = unsafePerformIO $ + getMethodID kclass (JNI.fromChars "getMethods") $ + methodSignature [] (SArray $ sing @('Class "java.lang.reflect.Method")) + +-- | Method.toString +methodToStringMethod :: JMethodID +{-# NOINLINE methodToStringMethod #-} +methodToStringMethod = unsafePerformIO $ + getMethodID kmethod (JNI.fromChars "toString") $ + methodSignature [] (sing @('Class "java.lang.String")) + +-- | Method.getName +methodGetNameMethod :: JMethodID +{-# NOINLINE methodGetNameMethod #-} +methodGetNameMethod = unsafePerformIO $ + getMethodID kmethod (JNI.fromChars "getName") $ + methodSignature [] (sing @('Class "java.lang.String")) + +-- | Class.getName +classGetNameMethod :: JMethodID +{-# NOINLINE classGetNameMethod #-} +classGetNameMethod = unsafePerformIO $ + getMethodID kclass (JNI.fromChars "getName") $ + methodSignature [] (sing @('Class "java.lang.String")) + +withDeleteLocalRef :: Coercible o (ForeignPtr (J ty)) => IO o -> (o -> IO c) -> IO c +withDeleteLocalRef grab action = bracket grab deleteLocalRef action + +-- | @getSignatures c methodName@ yields the Java signatures of overloadings of +-- methods called @methodName@ in class @c@. +getSignatures :: JClass -> JNI.String -> IO [Text.Text] +getSignatures c methodName = withDeleteLocalRef + (unsafeCast <$> callObjectMethod c classGetMethodsMethod []) $ + \(array :: JObjectArray) -> do + l <- getArrayLength array + let methodNameTxt = Text.decodeUtf8 $ JNI.toByteString methodName + names <- forM [0 .. l - 1] $ \i -> withDeleteLocalRef + (getObjectArrayElement array i) $ + \(ithObj :: JObject) -> withDeleteLocalRef + (unsafeCast <$> callObjectMethod ithObj methodGetNameMethod []) $ + \(jName :: JString) -> do + name <- toText jName + if name == methodNameTxt + then withDeleteLocalRef + (unsafeCast <$> callObjectMethod ithObj methodToStringMethod []) $ + \(jMethodName :: JString) -> Just <$> toText jMethodName + else return Nothing + return $ catMaybes names + +-- | Turns a JString into Text. +toText :: JString -> IO Text.Text +toText obj = bracket + (getStringChars obj) + (releaseStringChars obj) $ + \cs -> do + sz <- fromIntegral <$> getStringLength obj + txt <- Text.fromPtr cs sz + return txt + +-- | @getClassName c@ yields the name of class @c@ +getClassName :: JClass -> IO Text.Text +getClassName c = withDeleteLocalRef + (unsafeCast <$> callObjectMethod c classGetNameMethod []) $ + \(jName :: JString) -> toText jName + +-- | The "Throwable" interface. +iThrowable :: JClass +{-# NOINLINE iThrowable #-} +iThrowable = unsafePerformIO $ withDeleteLocalRef + (findClass $ referenceTypeName $ sing @('Class "java.lang.Throwable")) + newGlobalRef + +-- | Throwable.printStackTrace(PrintWriter s) +throwablePrintStackTraceMethod :: JMethodID +{-# NOINLINE throwablePrintStackTraceMethod #-} +throwablePrintStackTraceMethod = unsafePerformIO $ + getMethodID iThrowable (JNI.fromChars "printStackTrace") $ + methodSignature [SomeSing (sing :: Sing ('Class "java.io.PrintWriter"))] (sing :: Sing 'Void) + +-- | The "StringWriter" class. +kStringWriter :: JClass +{-# NOINLINE kStringWriter #-} +kStringWriter = unsafePerformIO $ withDeleteLocalRef + (findClass $ referenceTypeName $ sing @('Class "java.io.StringWriter")) + newGlobalRef + +-- | The "PrintWriter" class. +kPrintWriter :: JClass +{-# NOINLINE kPrintWriter #-} +kPrintWriter = unsafePerformIO $ withDeleteLocalRef + (findClass $ referenceTypeName $ sing @('Class "java.io.PrintWriter")) + newGlobalRef + +-- | StringWriter.toString +stringWriterToStringMethod :: JMethodID +{-# NOINLINE stringWriterToStringMethod #-} +stringWriterToStringMethod = unsafePerformIO $ + getMethodID kStringWriter (JNI.fromChars "toString") $ + methodSignature [] (sing @('Class "java.lang.String")) + +-- | Equivalent Java code: +-- StringWriter stringWriter = new StringWriter(); +-- PrintWriter printWriter = new PrintWriter(stringWriter); +-- e.printStackTrace(printWriter); +-- return stringWriter.toString(); +showException :: JVMException -> IO Text.Text +showException (JVMException e) = withDeleteLocalRef + (newObject + kStringWriter + (methodSignature [] (sing :: Sing 'Void)) + []) + $ \stringWriter -> withDeleteLocalRef + (newObject + kPrintWriter + (methodSignature + [SomeSing (sing :: Sing ('Class "java.io.Writer"))] + (sing :: Sing 'Void)) + [JObject stringWriter]) + $ \printWriter -> do + _ <- callVoidMethod + e + throwablePrintStackTraceMethod + [JObject printWriter] + withDeleteLocalRef + (unsafeCast <$> callObjectMethod + stringWriter + stringWriterToStringMethod + []) + toText diff --git a/src/linear-types/Data/Singletons.hs b/src/linear-types/Data/Singletons.hs new file mode 100644 --- /dev/null +++ b/src/linear-types/Data/Singletons.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Data.Singletons where + +import Data.Kind (Type) +import GHC.TypeLits (KnownSymbol) + +type family Sing :: k -> Data.Kind.Type + +class SingI ty where + sing :: Sing ty + +instance SingI ('[] :: [k]) where + sing = SNil +instance (SingI x, SingI xs) => SingI (x ': xs) where + sing = SCons (sing @x) (sing @xs) + +type instance Sing = SSymbol + +data SSymbol n = KnownSymbol n => SSym + +instance KnownSymbol n => SingI n where + sing = SSym + +type instance Sing = SList + +data SList (xs :: [k]) where + SNil :: SList '[] + SCons :: Sing x -> SList xs -> SList (x ': xs) + +data SomeSing k where + SomeSing :: Sing (a :: k) -> SomeSing k + +instance ShowSing k => Show (SList(a :: [k])) where + showsPrec _ SNil = showString "SNil" + showsPrec d sxs@(SCons ty tys) = + case sxs of + (_ :: SList (x : ys)) -> showParen (d > 10) $ + showString "SCons " . showsPrec 11 ty . showChar ' ' . showsPrec 11 tys + :: (ShowSing' x, ShowSing' ys) => ShowS + +class (forall (z :: k). ShowSing' z) => ShowSing k +instance (forall (z :: k). ShowSing' z) => ShowSing k + +class Show (Sing z) => ShowSing' (z :: k) +instance Show (Sing z) => ShowSing' z diff --git a/src/linear-types/Foreign/JNI/Safe.hs b/src/linear-types/Foreign/JNI/Safe.hs new file mode 100644 --- /dev/null +++ b/src/linear-types/Foreign/JNI/Safe.hs @@ -0,0 +1,505 @@ +-- | Low-level bindings to the Java Native Interface (JNI). +-- +-- This module provides a safer interface with linear types to the functions +-- of JNI. The compiler will check that all local references to java +-- objects are eventually deleted. Unlike garbage collection +-- and finalizers, the references are guaranteed to be removed when +-- execution reaches explicit API calls for that sake. See +-- +-- for the motivation. +-- +-- Class references returned by 'findClass' and 'getObjectClass' are not +-- given linear multiplicity. The lifetime of classes is not so efemeral +-- and we expect them to be less prone to leak. For a similar reason, +-- global references aren't given linear multiplity either. +-- +-- Read the +-- +-- for authoritative documentation as to what each of the functions in +-- this module does. The names of the bindings in this module were chosen to +-- match the names of the functions in the JNI spec. +-- +-- All bindings in this module access the JNI via a thread-local variable of +-- type @JNIEnv *@. If the current OS thread has not yet been "attached" to the +-- JVM, it needs to be attached. See 'JNI.runInAttachedThread'. +-- +-- The 'String' type in this module is the type of JNI strings. See +-- "Foreign.JNI.String". +-- +-- == Notes on linearity +-- +-- Most functions taking references with linear multiplicty return the same +-- references so they can be used again. One notable exception is the +-- 'deleteLocalRef' function, which deletes a reference without returning it. +-- +-- Another exception are the /call/ functions which take a list of 'JValue' +-- (`[JValue]`). /call/ functions delete all references with linear multiplicity +-- in the list of JValues. The references are not returned, so if the +-- caller wants to use them again, they need to be duplicated with +-- 'newLocalRef' before the call. Returning the `[JValue]`s would make it +-- rather clumsy to extract an object reference from it to use it again. +-- +-- Because /call/ functions delete their reference arguments, they have +-- to discriminate references with linear multiplicity from the rest. +-- We introduce a new type 'Foreign.JNI.Types.Safe.J' of references with +-- linear multiplicity, and a type 'Foreign.JNI.Types.Safe.JValue' that +-- is a sum of primitive types, unrestricted references and references with +-- linear multiplicity. +-- +-- Some functions like 'setObjectArrayElement' or 'setObjectField' offer +-- variants 'setObjectArrayElement_' and 'setObjectField_' which delete +-- one of the objects that the former functions would otherwise return. +-- +-- Because we use linear multiplicities with local references only, we can +-- depend on local JNI frames to cleanup references when an exception occurs. +-- For this reason, functions or code blocks which use the JNI interface must +-- be wrapped with either 'withLocalFrame' or 'withLocalFrame_'. +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- XXX This file uses cpphs for preprocessing instead of the system's native +-- CPP, because the OS X has subtly different whitespace behaviour in the +-- presence of concatenation. + +module Foreign.JNI.Safe + ( module Foreign.JNI.Safe + , JNI.withJVM + ) where + +import Control.Exception hiding (throw) +import Control.Monad +import Control.Monad.IO.Class.Linear (MonadIO(liftIO)) +import qualified Control.Monad.Linear as Linear +import Data.Functor +import Data.Int +import Data.Word +import Foreign.C.Types +import qualified Foreign.JNI as JNI +import qualified Foreign.JNI.String as JNI +import qualified Foreign.JNI.Types as JNI +import Foreign.JNI.Types.Safe +import Foreign.Ptr (Ptr) +import qualified System.IO.Linear as Linear +import qualified Unsafe.Linear as Unsafe +import Prelude ((.)) +import qualified Prelude +import Prelude.Linear hiding ((<*), (.)) + + +liftPreludeIO :: MonadIO m => Prelude.IO a -> m a +liftPreludeIO io = liftIO (Linear.fromSystemIO io) + +liftPreludeIOU :: MonadIO m => Prelude.IO a -> m (Unrestricted a) +liftPreludeIOU io = liftIO (Linear.fromSystemIOU io) + +throw :: MonadIO m => J a #-> m (J a) +throw = Unsafe.toLinear $ \x -> liftPreludeIO (x Prelude.<$ JNI.throw x) + +throw_ :: MonadIO m => J a #-> m () +throw_ x = throw x Linear.>>= deleteLocalRef + +throwNew :: MonadIO m => JNI.JClass -> JNI.String #-> m () +throwNew jclass = Unsafe.toLinear $ \msg -> + liftPreludeIO (JNI.throwNew jclass msg) + +findClass + :: MonadIO m + => ReferenceTypeName + -> m (UnsafeUnrestrictedReference JNI.JClass) +findClass name = liftPreludeIO (UnsafeUnrestrictedReference <$> JNI.findClass name) + +newObject + :: MonadIO m + => JNI.JClass + -> MethodSignature + #-> [JValue] + #-> m JObject +newObject jclass = Unsafe.toLinear2 $ \m args -> + liftPreludeIO (J <$> JNI.newObject jclass m (toJNIJValues args)) + +getFieldID + :: MonadIO m + => JNI.JClass -- ^ A class object as returned by 'findClass' + -> JNI.String -- ^ Field name + #-> Signature -- ^ JNI signature + #-> m (Unrestricted JFieldID) +getFieldID jclass = Unsafe.toLinear2 $ \fieldname sig -> + liftPreludeIO (Unrestricted <$> JNI.getFieldID jclass fieldname sig) + +getStaticFieldID + :: MonadIO m + => JNI.JClass -- ^ A class object as returned by 'findClass' + -> JNI.String -- ^ Field name + #-> Signature -- ^ JNI signature + #-> m (Unrestricted JFieldID) +getStaticFieldID jclass = Unsafe.toLinear2 $ \fieldname sig -> + liftPreludeIO (Unrestricted <$> JNI.getStaticFieldID jclass fieldname sig) + +#define GET_FIELD(name, hs_rettype) \ +get/**/name/**/Field :: MonadIO m => J a #-> JFieldID #-> m (J a, Unrestricted hs_rettype); \ +get/**/name/**/Field = Unsafe.toLinear2 $ \obj field -> \ + liftPreludeIO \ + ((,) obj . Unrestricted <$> JNI.get/**/name/**/Field (unJ obj) field) + +getObjectField :: MonadIO m => J a #-> JFieldID #-> m (J a, JObject) +getObjectField = Unsafe.toLinear2 $ \obj field -> + liftPreludeIO ((,) obj . J <$> JNI.getObjectField (unJ obj) field) + +GET_FIELD(Boolean, Word8) +GET_FIELD(Byte, CChar) +GET_FIELD(Char, Word16) +GET_FIELD(Short, Int16) +GET_FIELD(Int, Int32) +GET_FIELD(Long, Int64) +GET_FIELD(Float, Float) +GET_FIELD(Double, Double) + +#define GET_STATIC_FIELD(name, hs_rettype) \ +getStatic/**/name/**/Field :: MonadIO m => JNI.JClass -> JFieldID #-> m (Unrestricted hs_rettype); \ +getStatic/**/name/**/Field jclass = Unsafe.toLinear $ \field -> \ + liftPreludeIOU (JNI.getStatic/**/name/**/Field jclass field) + +getStaticObjectField :: MonadIO m => JNI.JClass -> JFieldID #-> m JObject +getStaticObjectField jclass = Unsafe.toLinear $ \field -> + liftPreludeIO (J <$> JNI.getStaticObjectField jclass field) + +GET_STATIC_FIELD(Boolean, Word8) +GET_STATIC_FIELD(Byte, CChar) +GET_STATIC_FIELD(Char, Word16) +GET_STATIC_FIELD(Short, Int16) +GET_STATIC_FIELD(Int, Int32) +GET_STATIC_FIELD(Long, Int64) +GET_STATIC_FIELD(Float, Float) +GET_STATIC_FIELD(Double, Double) + +#define SET_FIELD(name, hs_fieldtype) \ +set/**/name/**/Field :: MonadIO m => J a #-> JFieldID #-> hs_fieldtype #-> m (J a); \ +set/**/name/**/Field = Unsafe.toLinear2 $ \obj field -> Unsafe.toLinear $ \v -> \ + liftPreludeIO \ + (obj <$ JNI.set/**/name/**/Field (unJ obj) field v) + +setObjectField + :: MonadIO m + => J a + #-> JFieldID + #-> JObject + #-> m (J a, JObject) +setObjectField = Unsafe.toLinear3 $ \obj field v -> + liftPreludeIO ((obj, v) <$ JNI.setObjectField (unJ obj) field (unJ v)) + +setObjectField_ + :: MonadIO m + => J a + #-> JFieldID + #-> JObject + #-> m (J a) +setObjectField_ _o f _v = + setObjectField _o f _v Linear.>>= \(_o, _v) -> + _o Linear.<$ deleteLocalRef _v + +SET_FIELD(Boolean, Word8) +SET_FIELD(Byte, CChar) +SET_FIELD(Char, Word16) +SET_FIELD(Short, Int16) +SET_FIELD(Int, Int32) +SET_FIELD(Long, Int64) +SET_FIELD(Float, Float) +SET_FIELD(Double, Double) + +#define SET_STATIC_FIELD(name, hs_fieldtype) \ +setStatic/**/name/**/Field :: MonadIO m => JNI.JClass -> JFieldID #-> hs_fieldtype #-> m (); \ +setStatic/**/name/**/Field jclass = Unsafe.toLinear2 $ \field v -> \ + liftPreludeIO (JNI.setStatic/**/name/**/Field jclass field v) + +setStaticObjectField + :: MonadIO m + => JNI.JClass + -> JFieldID + #-> JObject + #-> m JObject +setStaticObjectField jclass = + Unsafe.toLinear2 $ \field v -> + liftPreludeIO (v <$ JNI.setStaticObjectField jclass field (unJ v)) + +setStaticObjectField_ + :: MonadIO m + => JNI.JClass + -> JFieldID + #-> JObject + #-> m () +setStaticObjectField_ c f _v = + setStaticObjectField c f _v Linear.>>= deleteLocalRef + +SET_STATIC_FIELD(Boolean, Word8) +SET_STATIC_FIELD(Byte, CChar) +SET_STATIC_FIELD(Char, Word16) +SET_STATIC_FIELD(Short, Int16) +SET_STATIC_FIELD(Int, Int32) +SET_STATIC_FIELD(Long, Int64) +SET_STATIC_FIELD(Float, Float) +SET_STATIC_FIELD(Double, Double) + +getMethodID + :: MonadIO m + => JNI.JClass -- ^ A class object as returned by 'findClass' + -> JNI.String -- ^ Field name + #-> MethodSignature -- ^ JNI signature + #-> m (Unrestricted JMethodID) +getMethodID jclass = Unsafe.toLinear2 $ \methodname sig -> + liftPreludeIO (Unrestricted <$> JNI.getMethodID jclass methodname sig) + +getStaticMethodID + :: MonadIO m + => JNI.JClass -- ^ A class object as returned by 'findClass' + -> JNI.String -- ^ Field name + #-> MethodSignature -- ^ JNI signature + #-> m (Unrestricted JMethodID) +getStaticMethodID jclass = Unsafe.toLinear2 $ \methodname sig -> + liftPreludeIOU (JNI.getStaticMethodID jclass methodname sig) + +getObjectClass + :: MonadIO m => J ty #-> m (J ty, UnsafeUnrestrictedReference JNI.JClass) +getObjectClass = Unsafe.toLinear $ \o -> + liftPreludeIO ((,) o . UnsafeUnrestrictedReference <$> JNI.getObjectClass (unJ o)) + +-- | Creates a global reference to the object referred to by +-- the given reference. +-- +-- Arranges for a finalizer to call 'deleteGlobalRef' when the +-- global reference is no longer reachable on the Haskell side. +newGlobalRef + :: MonadIO m => J ty #-> m (J ty, UnsafeUnrestrictedReference (JNI.J ty)) +newGlobalRef = Unsafe.toLinear $ \o -> liftPreludeIO + ((,) o . UnsafeUnrestrictedReference <$> JNI.newGlobalRef (unJ o)) + +-- | Like 'newGlobalRef' but it deletes the input instead of returning it. +newGlobalRef_ + :: MonadIO m => J ty #-> m (UnsafeUnrestrictedReference (JNI.J ty)) +newGlobalRef_ j = + newGlobalRef j Linear.>>= \(j1, g) -> g Linear.<$ deleteLocalRef j1 + +deleteGlobalRef :: MonadIO m => JNI.J ty -> m () +deleteGlobalRef o = liftPreludeIO (JNI.deleteGlobalRef o) + +-- | Like 'newGlobalRef' but it doesn't attach a finalizer to destroy +-- the reference when it is not longer reachable. Use +-- 'deleteGlobalRefNonFinalized' to destroy this reference. +newGlobalRefNonFinalized + :: MonadIO m => J ty #-> m (J ty, UnsafeUnrestrictedReference (JNI.J ty)) +newGlobalRefNonFinalized = Unsafe.toLinear $ \o -> + liftPreludeIO ((,) o . UnsafeUnrestrictedReference <$> + JNI.newGlobalRefNonFinalized (unJ o) + ) + +-- | Like 'deleteGlobalRef' but it can be used only on references created with +-- 'newGlobalRefNonFinalized'. +deleteGlobalRefNonFinalized :: MonadIO m => J ty -> m () +deleteGlobalRefNonFinalized o = liftPreludeIO (JNI.deleteGlobalRef o) + +-- NB: Cannot add a finalizer to local references because it may +-- run in a thread where the reference is not valid. +newLocalRef :: MonadIO m => J ty #-> m (J ty, J ty) +newLocalRef = Unsafe.toLinear $ \o -> + liftPreludeIO ((,) o . J <$> JNI.newLocalRef (unJ o)) + +deleteLocalRef :: MonadIO m => J ty #-> m () +deleteLocalRef = Unsafe.toLinear $ \o -> + liftPreludeIO (JNI.deleteLocalRef (unJ o)) + +-- | Runs the given computation in a local frame, which ensures that +-- if it throws an exception, all live local references created during +-- the computation will be deleted. +withLocalFrame :: Linear.IO (Unrestricted a) -> IO a +withLocalFrame = withLocalFrameWithSize 30 + +withLocalFrame_ :: Linear.IO () -> IO () +withLocalFrame_ = withLocalFrameWithSize_ 30 + +withLocalFrameWithSize :: Int32 -> Linear.IO (Unrestricted a) -> IO a +withLocalFrameWithSize capacity linearIO = do + bracket_ + (JNI.pushLocalFrame capacity) + (JNI.popLocalFrame jnull) + (Linear.withLinearIO linearIO) + +withLocalFrameWithSize_ :: Int32 -> Linear.IO () -> IO () +withLocalFrameWithSize_ capacity linearIO = do + bracket_ + (JNI.pushLocalFrame capacity) + (JNI.popLocalFrame jnull) + (Linear.withLinearIO (linearIO Linear.>> Linear.return (Unrestricted ()))) + +#define CALL_METHOD(name, hs_rettype) \ +call/**/name/**/Method :: MonadIO m => J a #-> JMethodID #-> [JValue] #-> m (J a, Unrestricted hs_rettype); \ +call/**/name/**/Method = Unsafe.toLinear3 $ \obj method args -> \ + liftPreludeIO Prelude.$ \ + (,) obj . Unrestricted <$> JNI.call/**/name/**/Method (unJ obj) method (toJNIJValues args) \ + Prelude.<* deleteLinearJObjects args + +deleteLinearJObjects :: [JValue] -> IO () +deleteLinearJObjects = mapM_ Prelude.$ \case + JObject j -> (JNI.deleteLocalRef j) + _ -> return () + +callVoidMethod :: MonadIO m => J a #-> JMethodID #-> [JValue] #-> m (J a) +callVoidMethod = Unsafe.toLinear3 $ \obj method args -> + liftPreludeIO Prelude.$ + obj <$ JNI.callVoidMethod (unJ obj) method (toJNIJValues args) + Prelude.<* deleteLinearJObjects args + +callObjectMethod + :: MonadIO m + => J a + #-> JMethodID + #-> [JValue] + #-> m (J a, JObject) +callObjectMethod = Unsafe.toLinear3 $ \obj method args -> + liftPreludeIO Prelude.$ + (,) obj . J <$> JNI.callObjectMethod (unJ obj) method (toJNIJValues args) + Prelude.<* deleteLinearJObjects args + +CALL_METHOD(Boolean, Bool) +CALL_METHOD(Byte, CChar) +CALL_METHOD(Char, Word16) +CALL_METHOD(Short, Int16) +CALL_METHOD(Int, Int32) +CALL_METHOD(Long, Int64) +CALL_METHOD(Float, Float) +CALL_METHOD(Double, Double) + +#define CALL_STATIC_METHOD(name, hs_rettype) \ +callStatic/**/name/**/Method :: MonadIO m => JNI.JClass -> JMethodID #-> [JValue] #-> m (Unrestricted hs_rettype); \ +callStatic/**/name/**/Method cls = Unsafe.toLinear2 $ \method args -> \ + liftPreludeIOU Prelude.$ \ + JNI.callStatic/**/name/**/Method cls method (toJNIJValues args) \ + Prelude.<* deleteLinearJObjects args + +callStaticObjectMethod + :: MonadIO m + => JNI.JClass + -> JMethodID + #-> [JValue] + #-> m JObject +callStaticObjectMethod jclass = Unsafe.toLinear2 $ \method args -> + liftPreludeIO Prelude.$ do + J <$> JNI.callStaticObjectMethod jclass method (toJNIJValues args) + Prelude.<* deleteLinearJObjects args + +CALL_STATIC_METHOD(Void, ()) +CALL_STATIC_METHOD(Boolean, Bool) +CALL_STATIC_METHOD(Byte, CChar) +CALL_STATIC_METHOD(Char, Word16) +CALL_STATIC_METHOD(Short, Int16) +CALL_STATIC_METHOD(Int, Int32) +CALL_STATIC_METHOD(Long, Int64) +CALL_STATIC_METHOD(Float, Float) +CALL_STATIC_METHOD(Double, Double) + +newObjectArray :: MonadIO m => Int32 -> JNI.JClass -> m JObjectArray +newObjectArray sz cls = liftPreludeIO (J <$> JNI.newObjectArray sz cls) + +#define NEW_ARRAY(name) \ +new/**/name/**/Array :: MonadIO m => Int32 -> m J/**/name/**/Array; \ +new/**/name/**/Array sz = liftPreludeIO (J <$> JNI.new/**/name/**/Array sz) + +NEW_ARRAY(Boolean) +NEW_ARRAY(Byte) +NEW_ARRAY(Char) +NEW_ARRAY(Short) +NEW_ARRAY(Int) +NEW_ARRAY(Long) +NEW_ARRAY(Float) +NEW_ARRAY(Double) + +newString :: MonadIO m => Ptr Word16 -> Int32 -> m JString +newString ptr len = liftPreludeIO (J <$> JNI.newString ptr len) + +getArrayLength :: MonadIO m => JArray a #-> m (JArray a, Unrestricted Int32) +getArrayLength = Unsafe.toLinear $ \o -> + liftPreludeIO ((,) o . Unrestricted <$> JNI.getArrayLength (unJ o)) + +getStringLength :: MonadIO m => JString #-> m (JString, Int32) +getStringLength = Unsafe.toLinear $ \o -> + liftPreludeIO ((,) o <$> JNI.getStringLength (unJ o)) + +#define GET_ARRAY_ELEMENTS(name, hs_rettype) \ +get/**/name/**/ArrayElements :: MonadIO m => J/**/name/**/Array #-> m (J/**/name/**/Array, Unrestricted (Ptr hs_rettype)); \ +get/**/name/**/ArrayElements = Unsafe.toLinear $ \a -> \ + liftPreludeIO Prelude.$ \ + (,) a . Unrestricted <$> \ + JNI.get/**/name/**/ArrayElements (unJ a) + +GET_ARRAY_ELEMENTS(Boolean, Word8) +GET_ARRAY_ELEMENTS(Byte, CChar) +GET_ARRAY_ELEMENTS(Char, Word16) +GET_ARRAY_ELEMENTS(Short, Int16) +GET_ARRAY_ELEMENTS(Int, Int32) +GET_ARRAY_ELEMENTS(Long, Int64) +GET_ARRAY_ELEMENTS(Float, Float) +GET_ARRAY_ELEMENTS(Double, Double) + +getStringChars :: MonadIO m => JString #-> m (JString, Ptr Word16) +getStringChars = Unsafe.toLinear $ \jstr -> + liftPreludeIO ((,) jstr <$> JNI.getStringChars (unJ jstr)) + +#define SET_ARRAY_REGION(name, hs_argtype) \ +set/**/name/**/ArrayRegion :: MonadIO m => J/**/name/**/Array #-> Int32 -> Int32 -> Ptr hs_argtype -> m J/**/name/**/Array; \ +set/**/name/**/ArrayRegion = Unsafe.toLinear $ \array start len buf -> \ + liftPreludeIO (array <$ JNI.set/**/name/**/ArrayRegion (unJ array) start len buf) + +SET_ARRAY_REGION(Boolean, Word8) +SET_ARRAY_REGION(Byte, CChar) +SET_ARRAY_REGION(Char, Word16) +SET_ARRAY_REGION(Short, Int16) +SET_ARRAY_REGION(Int, Int32) +SET_ARRAY_REGION(Long, Int64) +SET_ARRAY_REGION(Float, Float) +SET_ARRAY_REGION(Double, Double) + +#define RELEASE_ARRAY_ELEMENTS(name, hs_argtype) \ +release/**/name/**/ArrayElements :: MonadIO m => J/**/name/**/Array #-> Ptr hs_argtype #-> m J/**/name/**/Array; \ +release/**/name/**/ArrayElements = Unsafe.toLinear2 $ \array xs -> \ + liftPreludeIO (array <$ JNI.release/**/name/**/ArrayElements (unJ array) xs) + +RELEASE_ARRAY_ELEMENTS(Boolean, Word8) +RELEASE_ARRAY_ELEMENTS(Byte, CChar) +RELEASE_ARRAY_ELEMENTS(Char, Word16) +RELEASE_ARRAY_ELEMENTS(Short, Int16) +RELEASE_ARRAY_ELEMENTS(Int, Int32) +RELEASE_ARRAY_ELEMENTS(Long, Int64) +RELEASE_ARRAY_ELEMENTS(Float, Float) +RELEASE_ARRAY_ELEMENTS(Double, Double) + +releaseStringChars :: MonadIO m => JString #-> Ptr Word16 -> m JString +releaseStringChars = Unsafe.toLinear $ \jstr chars -> + liftPreludeIO (jstr <$ JNI.releaseStringChars (unJ jstr) chars) + +getObjectArrayElement + :: (IsReferenceType a, MonadIO m) + => JArray a + #-> Int32 + #-> m (JArray a, J a) +getObjectArrayElement = Unsafe.toLinear2 $ \a i -> + liftPreludeIO ((,) a . J <$> JNI.getObjectArrayElement (unJ a) i) + +setObjectArrayElement + :: (IsReferenceType a, MonadIO m) + => JArray a + #-> Int32 + -> J a + #-> m (JArray a, J a) +setObjectArrayElement = Unsafe.toLinear $ \a i -> Unsafe.toLinear $ \o -> + liftPreludeIO ((a, o) <$ JNI.setObjectArrayElement (unJ a) i (unJ o)) + +setObjectArrayElement_ + :: (IsReferenceType a, MonadIO m) + => JArray a + #-> Int32 + -> J a + #-> m (JArray a) +setObjectArrayElement_ _a i _j = + setObjectArrayElement _a i _j Linear.>>= \(_a, _j) -> + _a Linear.<$ deleteLocalRef _j diff --git a/src/linear-types/Foreign/JNI/Types/Safe.hs b/src/linear-types/Foreign/JNI/Types/Safe.hs new file mode 100644 --- /dev/null +++ b/src/linear-types/Foreign/JNI/Types/Safe.hs @@ -0,0 +1,108 @@ +-- | Types used in the safe interface of JNI + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LinearTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeOperators #-} + +module Foreign.JNI.Types.Safe + ( module Foreign.JNI.Types.Safe + , JNI.IsReferenceType + , JNI.IsPrimitiveType + , JNI.JFieldID + , JNI.JMethodID + , JNI.JType(..) + , type (JNI.<>) + , JNI.JVM + , JNI.MethodSignature + , JNI.ReferenceTypeName + , JNI.Signature + , JNI.Sing + , JNI.methodSignature + , JNI.referenceTypeName + ) where + +import Data.Singletons +import Foreign.JNI.Types (type (<>), JType(..), IsReferenceType) +import qualified Foreign.JNI.Types as JNI +import qualified Unsafe.Linear as Unsafe + +-- | A wrapper over J references +-- +-- This wrapper is used to identify local references +-- which are tracked with linear types. +newtype J (a :: JType) = J { unJ :: JNI.J a } + deriving (Eq, Show) + +type role J representational + +-- | The null reference. +jnull :: J a +jnull = J JNI.jnull + +-- | Any object can be cast to @Object@. +upcast :: J a #-> JObject +upcast = Unsafe.toLinear (J . JNI.upcast . unJ) + +-- | Any array of a reference type can be casted to an array of @Object@s. +arrayUpcast :: IsReferenceType ty => J ('Array ty) #-> JObjectArray +arrayUpcast = Unsafe.toLinear (J . JNI.arrayUpcast . unJ) + +-- | Unsafe type cast. Should only be used to downcast. +unsafeCast :: J a #-> J b +unsafeCast = Unsafe.toLinear (J . JNI.unsafeCast . unJ) + +-- | Parameterize the type of an object, making its type a /generic type/. +unsafeGeneric :: J a #-> J (a <> g) +unsafeGeneric = Unsafe.toLinear (J . JNI.generic . unJ) + +-- | Get the base type of a generic type. +ungeneric :: J (a <> g) #-> J a +ungeneric = Unsafe.toLinear (J . JNI.unsafeUngeneric . unJ) + +-- | A union type for uniformly passing arguments to methods. +data JValue + = JValue JNI.JValue + | forall a. SingI a => JObject {-# UNPACK #-} !(J a) + +instance Show JValue where + show (JValue jvalue) = "JValue (" ++ show jvalue ++ ")" + show (JObject x) = "JObject " ++ show x + +instance Eq JValue where + (JValue x) == (JValue y) = x == y + (JObject j0) == (JObject j1) = upcast j0 == upcast j1 + _ == _ = False + +-- The array is valid only while evaluating @f@. +toJNIJValues :: [JValue] -> [JNI.JValue] +toJNIJValues = map $ \case + JValue jvalue -> jvalue + JObject (J j) -> JNI.JObject j + +-- | A type to wrap unrestricted references +-- +-- Unlike with linear references, the programmer is reponsible +-- for ensuring that the unrestricted references are destroyed +-- in timely fashion. +data UnsafeUnrestrictedReference a where + UnsafeUnrestrictedReference :: a -> UnsafeUnrestrictedReference a + +type JObject = J ('Class "java.lang.Object") +type JString = J ('Class "java.lang.String") +type JThrowable = J ('Class "java.lang.Throwable") +type JArray a = J ('Array a) +type JObjectArray = JArray ('Class "java.lang.Object") +type JBooleanArray = JArray ('Prim "boolean") +type JByteArray = JArray ('Prim "byte") +type JCharArray = JArray ('Prim "char") +type JShortArray = JArray ('Prim "short") +type JIntArray = JArray ('Prim "int") +type JLongArray = JArray ('Prim "long") +type JFloatArray = JArray ('Prim "float") +type JDoubleArray = JArray ('Prim "double") diff --git a/tests/Foreign/JNISpec.hs b/tests/Foreign/JNISpec.hs new file mode 100644 --- /dev/null +++ b/tests/Foreign/JNISpec.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Foreign.JNISpec where + +import Control.Concurrent (runInBoundThread) +import Control.Exception (try) +import Data.List (sort) +import Data.Singletons +import Foreign.JNI.Internal (jniMethodToJavaSignature) +import Foreign.JNI.String (fromChars) +import Foreign.JNI.Types +import Foreign.JNI.Unsafe +import qualified Foreign.JNI.Unsafe.Internal as Internal +import Foreign.JNI.Unsafe.Internal.Introspection +import Test.Hspec + +spec :: Spec +spec = do + describe "runInAttachedThread" $ do + it "can run jni calls in another thread" $ + runInBoundThread $ runInAttachedThread $ do + jclass <- findClass $ + referenceTypeName (sing :: Sing ('Class "java.lang.Long")) + deleteLocalRef jclass + + it "is needed to run jni calls in another thread" $ + runInBoundThread $ do + findClass (referenceTypeName (sing :: Sing ('Class "java.lang.Long"))) + `shouldThrow` \ThreadNotAttached -> True + + around_ (runInBoundThread . runInAttachedThread) $ do + describe "isInstanceOf" $ do + it "identifies a class name as a String" $ do + klong <- findClass (referenceTypeName (sing :: Sing ('Class "java.lang.Long"))) + name <- callObjectMethod klong classGetNameMethod [] + kstring <- findClass (referenceTypeName (sing :: Sing ('Class "java.lang.String"))) + isInstanceOf name kstring `shouldReturn` True + it "identifies a class name as an Object" $ do + klong <- findClass (referenceTypeName (sing :: Sing ('Class "java.lang.Long"))) + name <- callObjectMethod klong classGetNameMethod [] + kobject <- findClass (referenceTypeName (sing :: Sing ('Class "java.lang.Object"))) + isInstanceOf name kobject `shouldReturn` True + it "doesn't identify a class name as a Long" $ do + klong <- findClass (referenceTypeName (sing :: Sing ('Class "java.lang.Long"))) + name <- callObjectMethod klong classGetNameMethod [] + isInstanceOf name klong `shouldReturn` False + + describe "getMethodID" $ do + it "gives correct hints on a mistake" $ do + kstring <- findClass (referenceTypeName (sing :: Sing ('Class "java.lang.String"))) + let sig = methodSignature [] (sing @('Class "java.lang.String")) + result <- try $ getMethodID kstring (fromChars "replace") sig + case result of + Left e -> do + sort (noSuchMethodOverloadings e) `shouldBe` + [ "public java.lang.String java.lang.String.replace(char,char)" + , "public java.lang.String java.lang.String.replace(java.lang.CharSequence,java.lang.CharSequence)" + ] + _ -> expectationFailure "call should have failed with a NoSuchMethod exception" + + describe "jniMethodToJavaSignature" $ + it "converts JNI signatures correctly" $ do + jniMethodToJavaSignature "()J" `shouldBe` Right ([], "long") + jniMethodToJavaSignature "(I)B" `shouldBe` Right (["int"], "byte") + jniMethodToJavaSignature "(SF)V" `shouldBe` Right (["short", "float"], "void") + jniMethodToJavaSignature "(C[Ljava/lang/String;D)Z" + `shouldBe` Right (["char", "java.lang.String[]", "double"], "boolean") + + describe "showException" $ + it "correctly displays exceptions" $ do + kinteger <- findClass (referenceTypeName (sing :: Sing ('Class "java.lang.Integer"))) + let sig = methodSignature [] (sing :: Sing 'Void) + result <- try $ Internal.getMethodID kinteger (fromChars "toString") sig + case result of + Left (e :: JVMException) -> showException e `shouldReturn` "java.lang.NoSuchMethodError: toString\n" + _ -> expectationFailure "call should have failed with a JVMException" diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import Foreign.JNI (withJVM) +import qualified Spec +import Test.Hspec + +main :: IO () +main = withJVM [] $ hspec Spec.spec diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -F -pgmF HSPEC_DISCOVER -optF --module-name=Spec #-}