diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs --- a/benchmarks/Main.hs +++ b/benchmarks/Main.hs @@ -6,17 +6,30 @@ module Main where +import Control.DeepSeq (NFData(..)) +import Criterion.Main as Criterion import Data.Int -import Language.Java +import Data.Singletons (SomeSing(..)) +import qualified Foreign.Concurrent as Concurrent +import qualified Foreign.ForeignPtr as ForeignPtr import Foreign.JNI -import Criterion.Main as Criterion +import Foreign.Marshal.Alloc (mallocBytes, finalizerFree) +import Language.Java -incrementExact :: Int32 -> IO Int32 -incrementExact x = callStatic (sing :: Sing "java.lang.Math") "incrementExact" [coerce x] +newtype BoxObject = BoxObject JObject +newtype BoxClass = BoxClass JClass -jniIncrementExact :: JClass -> JMethodID -> Int32 -> IO Int32 -jniIncrementExact klass method x = callStaticIntMethod klass method [coerce x] +-- Not much sense in deepseq'ing foreign pointers. But needed for call to 'env' +-- below. +instance NFData BoxObject where rnf (BoxObject (J fptr)) = fptr `seq` () +instance NFData BoxClass where rnf (BoxClass (J fptr)) = fptr `seq` () +jabs :: Int32 -> IO Int32 +jabs x = callStatic "java.lang.Math" "abs" [coerce x] + +jniAbs :: JClass -> JMethodID -> Int32 -> IO Int32 +jniAbs klass method x = callStaticIntMethod klass method [coerce x] + intValue :: Int32 -> IO Int32 intValue x = do jx <- reflect x @@ -33,14 +46,13 @@ foreign import ccall unsafe getpid :: IO Int -main :: IO () -main = withJVM [] $ do - klass <- findClass "java/lang/Math" - method <- getStaticMethodID klass "incrementExact" "(I)I" - Criterion.defaultMain +benchCalls :: Benchmark +benchCalls = + env ini $ \ ~(BoxClass klass, method) -> + bgroup "Calls" [ bgroup "Java calls" - [ bench "static method call: unboxed single arg / unboxed return" $ nfIO $ incrementExact 1 - , bench "jni static method call: unboxed single arg / unboxed return" $ nfIO $ jniIncrementExact klass method 1 + [ bench "static method call: unboxed single arg / unboxed return" $ nfIO $ jabs 1 + , bench "jni static method call: unboxed single arg / unboxed return" $ nfIO $ jniAbs klass method 1 , bench "method call: no args / unboxed return" $ nfIO $ intValue 1 , bench "method call: boxed single arg / unboxed return" $ nfIO $ compareTo 1 1 ] @@ -49,3 +61,36 @@ , bench "ffi haskell" $ nfIO $ getpid ] ] + where + ini = do + klass <- findClass (referenceTypeName (SClass "java/lang/Math")) + method <- getStaticMethodID klass "abs" (methodSignature [SomeSing (sing :: Sing ('Prim "int"))] (SPrim "int")) + return (BoxClass klass, method) + +benchRefs :: Benchmark +benchRefs = + env (BoxObject <$> new []) $ \ ~(BoxObject jobj) -> + bgroup "References" + [ bench "local reference" $ nfIO $ do + _ <- newLocalRef jobj + return () + , bench "global reference" $ nfIO $ do + _ <- newGlobalRef jobj + return () + , bench "global reference (no finalizer)" $ nfIO $ do + _ <- newGlobalRefNonFinalized jobj + return () + , bench "Foreign.Concurrent.newForeignPtr" $ nfIO $ do + _ <- Concurrent.newForeignPtr (unsafeObjectToPtr jobj) (return ()) + return () + , bench "Foreign.ForeignPtr.newForeignPtr" $ nfIO $ do + -- Approximate cost of malloc: 50ns. Ideally would move out of benchmark + -- but finalizer not idempotent. + ptr <- mallocBytes 4 + _ <- ForeignPtr.newForeignPtr finalizerFree ptr + return () + ] + +main :: IO () +main = withJVM [] $ do + Criterion.defaultMain [benchCalls, benchRefs] diff --git a/jvm.cabal b/jvm.cabal --- a/jvm.cabal +++ b/jvm.cabal @@ -1,5 +1,5 @@ name: jvm -version: 0.2.2 +version: 0.3.0 synopsis: Call JVM methods from Haskell. description: Please see README.md. homepage: http://github.com/tweag/inline-java/tree/master/jvm#readme @@ -22,15 +22,15 @@ hs-source-dirs: src exposed-modules: Language.Java - Language.Java.TH build-depends: base >= 4.7 && < 5, bytestring >=0.10, + constraints >= 0.8, choice >= 0.1, distributed-closure >=0.3, - jni >= 0.3.0, + exceptions >= 0.8, + jni >= 0.4.0, singletons >= 2.0, - template-haskell >= 2.10, text >=1.2, vector >=0.11 default-language: Haskell2010 @@ -47,6 +47,7 @@ base, bytestring, hspec, + jni, jvm, text default-language: Haskell2010 @@ -59,7 +60,9 @@ build-depends: base >= 4.8 && < 5, criterion, + deepseq >= 1.4.2, jni, - jvm + jvm, + singletons default-language: Haskell2010 ghc-options: -threaded diff --git a/src/Language/Java.hs b/src/Language/Java.hs --- a/src/Language/Java.hs +++ b/src/Language/Java.hs @@ -39,60 +39,122 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE UndecidableInstances #-} module Language.Java ( module Foreign.JNI.Types + -- * JVM instance management , withJVM + -- * JVM calls , classOf , new + , newArray + , toArray , call , callStatic - , jvalue + , getStaticField + -- * Reference management + , push + , pushWithSizeHint + , Pop(..) + , pop + , popWithObject + , popWithValue + -- * Coercions + , CoercionFailure(..) , Coercible(..) + , jvalue + , jobject + -- * Conversions , Reify(..) , Reflect(..) - , Type(..) - , Uncurry , Interp + -- * Re-exports , sing ) where -import Control.Distributed.Closure import Control.Distributed.Closure.TH +import Control.Exception (Exception, throw, finally) import Control.Monad +import Control.Monad.Catch (MonadCatch, onException) +import Control.Monad.IO.Class import Data.Char (chr, ord) import qualified Data.Choice as Choice import qualified Data.Coerce as Coerce +import Data.Constraint (Dict(..)) import Data.Int +import Data.Proxy (Proxy(..)) +import Data.Typeable (Typeable, TypeRep, typeOf) import Data.Word import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Unsafe as BS -import Data.Singletons (SingI(..), fromSing) -import Data.String (fromString) +import Data.Singletons (SingI(..)) import qualified Data.Text.Foreign as Text import Data.Text (Text) -#if ! __GLASGOW_HASKELL__ == 800 +#if ! (__GLASGOW_HASKELL__ == 800 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 1) import qualified Data.Vector.Storable as Vector import Data.Vector.Storable (Vector) import qualified Data.Vector.Storable.Mutable as MVector import Data.Vector.Storable.Mutable (IOVector) -import Foreign (FunPtr, Ptr, Storable, newForeignPtr, withForeignPtr) +import Foreign (Ptr, Storable, withForeignPtr) +import Foreign.Concurrent (newForeignPtr) #endif import Foreign.C (CChar) -import Foreign.JNI +import Foreign.JNI hiding (throw) import Foreign.JNI.Types import qualified Foreign.JNI.String as JNI -import GHC.TypeLits (KnownSymbol, Symbol) +import GHC.TypeLits (KnownSymbol, symbolVal) import System.IO.Unsafe (unsafeDupablePerformIO) +data Pop a where + PopValue :: a -> Pop a + PopObject + :: (Coercible a ty, Coerce.Coercible a (J ty), IsReferenceType ty) + => a + -> Pop a + +-- | Open a new scope for allocating (JNI) local references to JVM objects. +push :: (MonadCatch m, MonadIO m) => m (Pop a) -> m a +push = pushWithSizeHint 4 + +-- | Like 'push', but specify explicitly a minimum size for the frame. You +-- probably don't need this. +pushWithSizeHint :: forall a m. (MonadCatch m, MonadIO m) => Int32 -> m (Pop a) -> m a +pushWithSizeHint capacity m = do + liftIO $ pushLocalFrame capacity + m `onException` handler >>= \case + PopValue x -> do + _ <- liftIO $ popLocalFrame jnull + return x + PopObject x -> do + liftIO $ Coerce.coerce <$> popLocalFrame (jobject x) + where + handler = liftIO $ popLocalFrame jnull + +-- | Equivalent to 'popWithValue ()'. +pop :: Monad m => m (Pop ()) +pop = return (PopValue ()) + +-- | Pop a frame and return a JVM object. +popWithObject + :: (Coercible a ty, Coerce.Coercible a (J ty), IsReferenceType ty, Monad m) + => a + -> m (Pop a) +popWithObject x = return (PopObject x) + +-- | Pop a frame and return a value. This value MUST NOT be an object reference +-- created in the popped frame. In that case use 'popWithObject' instead. +popWithValue :: Monad m => a -> m (Pop a) +popWithValue x = return (PopValue x) + -- Note [Class lookup memoization] -- -- By using unsafeDupablePerformIO, we mark the lookup actions as pure. When the @@ -124,42 +186,58 @@ -- | The identity instance. instance SingI ty => Coercible (J ty) ty +-- | A JNI call may cause a (Java) exception to be raised. This module raises it +-- as a Haskell exception wrapping the Java exception. +data CoercionFailure = CoercionFailure + { coercionActual :: JValue + , coercionExpected :: TypeRep + } + +instance Exception CoercionFailure + +instance Show CoercionFailure where + show (CoercionFailure actual expected) = + "Can't coerce " ++ show actual ++ " to " ++ show expected ++ "." + +withTypeRep :: Typeable a => (TypeRep -> a) -> a +withTypeRep f = let x = f (typeOf x) in x + instance Coercible Bool ('Prim "boolean") where coerce x = JBoolean (fromIntegral (fromEnum x)) unsafeUncoerce (JBoolean x) = toEnum (fromIntegral x) - unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible CChar ('Prim "byte") where coerce = JByte unsafeUncoerce (JByte x) = x - unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible Char ('Prim "char") where coerce x = JChar (fromIntegral (ord x)) unsafeUncoerce (JChar x) = chr (fromIntegral x) - unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible Word16 ('Prim "char") where coerce = JChar unsafeUncoerce (JChar x) = x - unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible Int16 ('Prim "short") where coerce = JShort unsafeUncoerce (JShort x) = x - unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible Int32 ('Prim "int") where coerce = JInt unsafeUncoerce (JInt x) = x - unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible Int64 ('Prim "long") where coerce = JLong unsafeUncoerce (JLong x) = x - unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible Float ('Prim "float") where coerce = JFloat unsafeUncoerce (JFloat x) = x - unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible Double ('Prim "double") where coerce = JDouble unsafeUncoerce (JDouble x) = x - unsafeUncoerce _ = error "unsafeUncoerce: value doesn't match target type." + unsafeUncoerce val = withTypeRep (throw . CoercionFailure val) instance Coercible () 'Void where coerce = error "Void value undefined." unsafeUncoerce _ = () @@ -168,14 +246,8 @@ unsafeUncoerce = Choice.fromBool . unsafeUncoerce -- | Get the Java class of an object or anything 'Coercible' to one. -classOf - :: ( Coercible a ('Class sym) - , KnownSymbol sym - ) - => a - -> Sing sym --- Silence redundant constraint warning. -classOf x = sing `const` coerce x +classOf :: forall a sym. (Coercible a ('Class sym), KnownSymbol sym) => a -> JNI.String +classOf x = JNI.fromChars (symbolVal (Proxy :: Proxy sym)) `const` coerce x -- | Creates a new instance of the class whose name is resolved from the return -- type. For instance, @@ -195,11 +267,62 @@ new args = do let argsings = map jtypeOf args voidsing = sing :: Sing 'Void - klass = unsafeDupablePerformIO $ - findClass (referenceTypeName (sing :: Sing ('Class sym))) - >>= newGlobalRef + klass = unsafeDupablePerformIO $ do + lk <- findClass (referenceTypeName (sing :: Sing ('Class sym))) + gk <- newGlobalRef lk + deleteLocalRef lk + return gk Coerce.coerce <$> newObject klass (methodSignature argsings voidsing) args +-- | Creates a new Java array of the given size. The type of the elements +-- of the resulting array is determined by the return type a call to +-- 'newArray' has, at the call site, and must not be left ambiguous. +-- +-- To create a Java array of 50 booleans: +-- +-- @ +-- do arr :: 'J' (''Array' (''Prim' "boolean")) <- 'newArray' 50 +-- return arr +-- @ +newArray + :: forall ty. + SingI ty + => Int32 + -> IO (J ('Array ty)) +{-# INLINE newArray #-} +newArray sz = do + let tysing = sing :: Sing ty + case tysing of + SPrim "boolean" -> unsafeCast <$> newBooleanArray sz + SPrim "byte" -> unsafeCast <$> newByteArray sz + SPrim "char" -> unsafeCast <$> newCharArray sz + SPrim "short" -> unsafeCast <$> newShortArray sz + SPrim "int" -> unsafeCast <$> newIntArray sz + SPrim "long" -> unsafeCast <$> newLongArray sz + SPrim "float" -> unsafeCast <$> newFloatArray sz + SPrim "double" -> unsafeCast <$> newDoubleArray sz + SVoid -> fail "newArray of void" + _ -> case singToIsReferenceType tysing of + Nothing -> fail $ "newArray of " ++ show tysing + Just Dict -> do + let klass = unsafeDupablePerformIO $ do + lk <- findClass (referenceTypeName tysing) + gk <- newGlobalRef lk + deleteLocalRef lk + return gk + unsafeCast <$> newObjectArray sz klass + +-- | Creates an array from a list of references. +toArray + :: forall ty. (SingI ty, IsReferenceType ty) + => [J ty] + -> IO (J ('Array ty)) +toArray xs = do + let n = fromIntegral (length xs) + jxs <- newArray n + zipWithM_ (setObjectArrayElement jxs) [0 .. n - 1] xs + return jxs + -- | The Swiss Army knife for calling Java methods. Give it an object or -- any data type coercible to one, the name of a method, and a list of -- arguments. Based on the type indexes of each argument, and based on the @@ -219,9 +342,11 @@ call obj mname args = do let argsings = map jtypeOf args retsing = sing :: Sing ty2 - klass = unsafeDupablePerformIO $ - findClass (referenceTypeName (sing :: Sing ty1)) - >>= newGlobalRef + klass = unsafeDupablePerformIO $ do + lk <- findClass (referenceTypeName (sing :: Sing ty1)) + gk <- newGlobalRef lk + deleteLocalRef lk + return gk method = unsafeDupablePerformIO $ getMethodID klass mname (methodSignature argsings retsing) case retsing of SPrim "boolean" -> unsafeUncoerce . coerce <$> callBooleanMethod obj method args @@ -239,14 +364,22 @@ _ -> unsafeUncoerce . coerce <$> callObjectMethod obj method args -- | Same as 'call', but for static methods. -callStatic :: forall a ty sym. Coercible a ty => Sing (sym :: Symbol) -> JNI.String -> [JValue] -> IO a +callStatic + :: forall a ty. Coercible a ty + => JNI.String -- ^ Class name + -> JNI.String -- ^ Method name + -> [JValue] -- ^ Arguments + -> IO a {-# INLINE callStatic #-} callStatic cname mname args = do let argsings = map jtypeOf args retsing = sing :: Sing ty - klass = unsafeDupablePerformIO $ - findClass (referenceTypeName (SClass (fromString (fromSing cname)))) - >>= newGlobalRef + klass = unsafeDupablePerformIO $ do + lk <- findClass + (referenceTypeName (SClass (JNI.toChars cname))) + gk <- newGlobalRef lk + deleteLocalRef lk + return gk method = unsafeDupablePerformIO $ getStaticMethodID klass mname (methodSignature argsings retsing) case retsing of SPrim "boolean" -> unsafeUncoerce . coerce <$> callStaticBooleanMethod klass method args @@ -263,43 +396,49 @@ return (unsafeUncoerce undefined) _ -> unsafeUncoerce . coerce <$> callStaticObjectMethod klass method args +-- | Get a static field. +getStaticField + :: forall a ty. Coercible a ty + => JNI.String -- ^ Class name + -> JNI.String -- ^ Static field name + -> IO a +{-# INLINE getStaticField #-} +getStaticField cname fname = do + let retsing = sing :: Sing ty + klass = unsafeDupablePerformIO $ + findClass (referenceTypeName (SClass (JNI.toChars cname))) + >>= newGlobalRef + field = unsafeDupablePerformIO $ getStaticFieldID klass fname (signature retsing) + case retsing of + SPrim "boolean" -> unsafeUncoerce . coerce . w2b <$> getStaticBooleanField klass field + SPrim "byte" -> unsafeUncoerce . coerce <$> getStaticByteField klass field + SPrim "char" -> unsafeUncoerce . coerce <$> getStaticCharField klass field + SPrim "short" -> unsafeUncoerce . coerce <$> getStaticShortField klass field + SPrim "int" -> unsafeUncoerce . coerce <$> getStaticIntField klass field + SPrim "long" -> unsafeUncoerce . coerce <$> getStaticLongField klass field + SPrim "float" -> unsafeUncoerce . coerce <$> getStaticFloatField klass field + SPrim "double" -> unsafeUncoerce . coerce <$> getStaticDoubleField klass field + SVoid -> fail "getStaticField cannot yield an object of type void" + _ -> unsafeUncoerce . coerce <$> getStaticObjectField klass field + where + w2b :: Word8 -> Bool + w2b = toEnum . fromIntegral + -- | Inject a value (of primitive or reference type) to a 'JValue'. This -- datatype is useful for e.g. passing arguments as a list of homogeneous type. -- Synonym for 'coerce'. jvalue :: Coercible a ty => a -> JValue jvalue = coerce --- | Classifies Java types according to whether they are base types (data) or --- higher-order types (objects representing functions). -data Type a - = Fun [Type a] (Type a) -- ^ Pure function - | Act [Type a] (Type a) -- ^ IO action - | Proc [Type a] -- ^ Procedure (i.e void returning action) - | Base a -- ^ Any first-order type. - --- | Haskell functions are curried, but Java functions are not. This type family --- maps Haskell types to an uncurried (non-inductive) type representation, --- useful to select the right 'Reify' / 'Reflect' instance without overlap. -type family Uncurry (a :: *) :: Type * where - Uncurry (Closure (a -> b -> c -> d -> IO ())) = 'Proc '[Uncurry a, Uncurry b, Uncurry c, Uncurry d] - Uncurry (Closure (a -> b -> c -> IO ())) = 'Proc '[Uncurry a, Uncurry b, Uncurry c] - Uncurry (Closure (a -> b -> IO ())) = 'Proc '[Uncurry a, Uncurry b] - Uncurry (Closure (a -> IO ())) = 'Proc '[Uncurry a] - Uncurry (IO ()) = 'Proc '[] - Uncurry (Closure (a -> b -> c -> d -> IO e)) = 'Act '[Uncurry a, Uncurry b, Uncurry c, Uncurry d] (Uncurry e) - Uncurry (Closure (a -> b -> c -> IO d)) = 'Act '[Uncurry a, Uncurry b, Uncurry c] (Uncurry d) - Uncurry (Closure (a -> b -> IO c)) = 'Act '[Uncurry a, Uncurry b] (Uncurry c) - Uncurry (Closure (a -> IO b)) = 'Act '[Uncurry a] (Uncurry b) - Uncurry (Closure (IO a)) = 'Act '[] (Uncurry a) - Uncurry (Closure (a -> b -> c -> d -> e)) = 'Fun '[Uncurry a, Uncurry b, Uncurry c, Uncurry d] (Uncurry e) - Uncurry (Closure (a -> b -> c -> d)) = 'Fun '[Uncurry a, Uncurry b, Uncurry c] (Uncurry d) - Uncurry (Closure (a -> b -> c)) = 'Fun '[Uncurry a, Uncurry b] (Uncurry c) - Uncurry (Closure (a -> b)) = 'Fun '[Uncurry a] (Uncurry b) - Uncurry a = 'Base a +-- | If @ty@ is a reference type, then it should be possible to get an object +-- from a value. +jobject :: (Coercible a ty, IsReferenceType ty) => a -> J ty +jobject x + | JObject jobj <- coerce x = unsafeCast jobj + | otherwise = error "impossible" -- | Map a Haskell type to the symbolic representation of a Java type. type family Interp (a :: k) :: JType -type instance Interp ('Base a) = Interp a -- | Extract a concrete Haskell value from the space of Java objects. That is to -- say, unmarshall a Java object to a Haskell value. Unlike coercing, in general @@ -308,35 +447,49 @@ -- Instances of this class /must/ guarantee that the result is managed on the -- Haskell heap. That is, the Haskell runtime has /global ownership/ of the -- result. -class (Interp (Uncurry a) ~ ty, SingI ty, IsReferenceType ty) - => Reify a ty where - reify :: J ty -> IO a +-- +-- WARNING: The default method just creates a global reference to the Java +-- object. Widespread use of this mechanism can cause memory problems since +-- objects in the Java heap cause no pressure on the Haskell garbage collector. +-- If the Haskell's GC is not executed by the time the Java heap is full, the +-- Java code might sporadically fail with OutOfMemory exceptions. +-- +class (SingI (Interp a), IsReferenceType (Interp a)) + => Reify a where + reify :: J (Interp a) -> IO a + default reify :: Coercible a (Interp a) => J (Interp a) -> IO a + reify x = (unsafeUncoerce . JObject) <$> newGlobalRef x + -- | Inject a concrete Haskell value into the space of Java objects. That is to -- say, marshall a Haskell value to a Java object. Unlike coercing, in general -- reflection induces allocations and copies. -- -- Instances of this class /must not/ claim global ownership. -class (Interp (Uncurry a) ~ ty, SingI ty, IsReferenceType ty) - => Reflect a ty where - reflect :: a -> IO (J ty) +class (SingI (Interp a), IsReferenceType (Interp a)) + => Reflect a where + reflect :: a -> IO (J (Interp a)) -#if ! __GLASGOW_HASKELL__ == 800 -foreign import ccall "wrapper" wrapFinalizer - :: (Ptr a -> IO ()) - -> IO (FunPtr (Ptr a -> IO ())) + default reflect :: Coercible a (Interp a) => a -> IO (J (Interp a)) + reflect x = newLocalRef (jobject x) +#if ! (__GLASGOW_HASKELL__ == 800 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 1) reifyMVector :: Storable a => (JArray ty -> IO (Ptr a)) -> (JArray ty -> Ptr a -> IO ()) -> JArray ty -> IO (IOVector a) -reifyMVector mk finalize jobj = do +reifyMVector mk finalize jobj0 = do + -- jobj might be finalized before the finalizer of fptr runs. + -- Therefore, we create a global reference without an attached + -- finalizer. + -- See https://ghc.haskell.org/trac/ghc/ticket/13439 + jobj <- newGlobalRefNonFinalized jobj0 n <- getArrayLength jobj ptr <- mk jobj - ffinalize <- wrapFinalizer (finalize jobj) - fptr <- newForeignPtr ffinalize ptr + fptr <- newForeignPtr ptr $ finalize jobj ptr + `finally` deleteGlobalRefNonFinalized jobj return (MVector.unsafeFromForeignPtr0 fptr (fromIntegral n)) reflectMVector @@ -353,31 +506,17 @@ #endif withStatic [d| - type instance Interp (J ty) = ty - - -- Use this instance to claim global ownership of a Java object on the - -- Haskell heap until the Haskell garbage collector determines that it is - -- inaccessible. Objects that need to survive the dynamic scope delimited by - -- the topmost Java frame on the call stack must have global ownership. - instance (SingI ty, IsReferenceType ty) => Reify (J ty) ty where - reify x = newGlobalRef x - - -- Use this instance to relinquish global ownership of a Java object. You - -- /must not/ refer to the argument anywhere after a call to 'reflect'. - instance (SingI ty, IsReferenceType ty) => Reflect (J ty) ty where - reflect x = newLocalRef x - type instance Interp () = 'Class "java.lang.Object" - instance Reify () ('Class "java.lang.Object") where + instance Reify () where reify _ = return () - instance Reflect () ('Class "java.lang.Object") where + instance Reflect () where reflect () = new [] type instance Interp ByteString = 'Array ('Prim "byte") - instance Reify ByteString ('Array ('Prim "byte")) where + instance Reify ByteString where reify jobj = do n <- getArrayLength (unsafeCast jobj) bytes <- getByteArrayElements jobj @@ -387,7 +526,7 @@ releaseByteArrayElements jobj bytes return bs - instance Reflect ByteString ('Array ('Prim "byte")) where + instance Reflect ByteString where reflect bs = BS.unsafeUseAsCStringLen bs $ \(content, n) -> do arr <- newByteArray (fromIntegral n) setByteArrayRegion arr 0 (fromIntegral n) content @@ -395,84 +534,130 @@ type instance Interp Bool = 'Class "java.lang.Boolean" - instance Reify Bool ('Class "java.lang.Boolean") where + instance Reify Bool where reify jobj = do - klass <- findClass "java/lang/Boolean" - method <- getMethodID klass "booleanValue" "()Z" + let method = unsafeDupablePerformIO $ do + klass <- findClass + (referenceTypeName (SClass "java.lang.Boolean")) + m <- getMethodID klass "booleanValue" + (methodSignature [] (SPrim "boolean")) + deleteLocalRef klass + return m callBooleanMethod jobj method [] - instance Reflect Bool ('Class "java.lang.Boolean") where + instance Reflect Bool where reflect x = new [JBoolean (fromIntegral (fromEnum x))] + type instance Interp CChar = 'Class "java.lang.Byte" + + instance Reify CChar where + reify jobj = do + let method = unsafeDupablePerformIO $ do + klass <- findClass (referenceTypeName (SClass "java.lang.Byte")) + m <- getMethodID klass "byteValue" + (methodSignature [] (SPrim "byte")) + deleteLocalRef klass + return m + callByteMethod jobj method [] + + instance Reflect CChar where + reflect x = Language.Java.new [JByte x] + type instance Interp Int16 = 'Class "java.lang.Short" - instance Reify Int16 ('Class "java.lang.Short") where + instance Reify Int16 where reify jobj = do - klass <- findClass "java/lang/Short" - method <- getMethodID klass "shortValue" "()S" + let method = unsafeDupablePerformIO $ do + klass <- findClass (referenceTypeName (SClass "java.lang.Short")) + m <- getMethodID klass "shortValue" + (methodSignature [] (SPrim "short")) + deleteLocalRef klass + return m callShortMethod jobj method [] - instance Reflect Int16 ('Class "java.lang.Short") where + instance Reflect Int16 where reflect x = new [JShort x] type instance Interp Int32 = 'Class "java.lang.Integer" - instance Reify Int32 ('Class "java.lang.Integer") where + instance Reify Int32 where reify jobj = do - klass <- findClass "java/lang/Integer" - method <- getMethodID klass "intValue" "()I" + let method = unsafeDupablePerformIO $ do + klass <- findClass + (referenceTypeName (SClass "java.lang.Integer")) + m <- getMethodID klass "intValue" + (methodSignature [] (SPrim "int")) + deleteLocalRef klass + return m callIntMethod jobj method [] - instance Reflect Int32 ('Class "java.lang.Integer") where + instance Reflect Int32 where reflect x = new [JInt x] type instance Interp Int64 = 'Class "java.lang.Long" - instance Reify Int64 ('Class "java.lang.Long") where + instance Reify Int64 where reify jobj = do - klass <- findClass "java/lang/Long" - method <- getMethodID klass "longValue" "()J" + let method = unsafeDupablePerformIO $ do + klass <- findClass (referenceTypeName (SClass "java.lang.Long")) + m <- getMethodID klass "longValue" + (methodSignature [] (SPrim "long")) + deleteLocalRef klass + return m callLongMethod jobj method [] - instance Reflect Int64 ('Class "java.lang.Long") where + instance Reflect Int64 where reflect x = new [JLong x] type instance Interp Word16 = 'Class "java.lang.Character" - instance Reify Word16 ('Class "java.lang.Character") where + instance Reify Word16 where reify jobj = do - klass <- findClass "java/lang/Character" - method <- getMethodID klass "charValue" "()C" + let method = unsafeDupablePerformIO $ do + klass <- findClass + (referenceTypeName (SClass "java.lang.Character")) + m <- getMethodID klass "charValue" + (methodSignature [] (SPrim "char")) + deleteLocalRef klass + return m fromIntegral <$> callCharMethod jobj method [] - instance Reflect Word16 ('Class "java.lang.Character") where + instance Reflect Word16 where reflect x = new [JChar x] type instance Interp Double = 'Class "java.lang.Double" - instance Reify Double ('Class "java.lang.Double") where + instance Reify Double where reify jobj = do - klass <- findClass "java/lang/Double" - method <- getMethodID klass "doubleValue" "()D" + let method = unsafeDupablePerformIO $ do + klass <- findClass (referenceTypeName (SClass "java.lang.Double")) + m <- getMethodID klass "doubleValue" + (methodSignature [] (SPrim "double")) + deleteLocalRef klass + return m callDoubleMethod jobj method [] - instance Reflect Double ('Class "java.lang.Double") where + instance Reflect Double where reflect x = new [JDouble x] type instance Interp Float = 'Class "java.lang.Float" - instance Reify Float ('Class "java.lang.Float") where + instance Reify Float where reify jobj = do - klass <- findClass "java/lang/Float" - method <- getMethodID klass "floatValue" "()F" + let method = unsafeDupablePerformIO $ do + klass <- findClass (referenceTypeName (SClass "java.lang.Float")) + m <- getMethodID klass "floatValue" + (methodSignature [] (SPrim "float")) + deleteLocalRef klass + return m callFloatMethod jobj method [] - instance Reflect Float ('Class "java.lang.Float") where + instance Reflect Float where reflect x = new [JFloat x] type instance Interp Text = 'Class "java.lang.String" - instance Reify Text ('Class "java.lang.String") where + instance Reify Text where reify jobj = do sz <- getStringLength jobj cs <- getStringChars jobj @@ -480,46 +665,49 @@ releaseStringChars jobj cs return txt - instance Reflect Text ('Class "java.lang.String") where + instance Reflect Text where reflect x = Text.useAsPtr x $ \ptr len -> newString ptr (fromIntegral len) -- Instances can't be compiled on GHC 8.0.1 due to -- https://ghc.haskell.org/trac/ghc/ticket/12082. -#if ! __GLASGOW_HASKELL__ == 800 +#if ! (__GLASGOW_HASKELL__ == 800 && __GLASGOW_HASKELL_PATCHLEVEL1__ == 1) type instance Interp (IOVector Int32) = 'Array ('Prim "int") - instance Reify (IOVector Int32) ('Array ('Prim "int")) where + instance Reify (IOVector Int32) where reify = reifyMVector (getIntArrayElements) (releaseIntArrayElements) - instance Reflect (IOVector Int32) ('Array ('Prim "int")) where + instance Reflect (IOVector Int32) where reflect = reflectMVector (newIntArray) (setIntArrayRegion) type instance Interp (Vector Int32) = 'Array ('Prim "int") - instance Reify (Vector Int32) ('Array ('Prim "int")) where + instance Reify (Vector Int32) where reify = Vector.freeze <=< reify - instance Reflect (Vector Int32) ('Array ('Prim "int")) where + instance Reflect (Vector Int32) where reflect = reflect <=< Vector.thaw #endif - type instance Interp [a] = 'Array (Interp (Uncurry a)) + type instance Interp [a] = 'Array (Interp a) - instance Reify a ty => Reify [a] ('Array ty) where + instance Reify a => Reify [a] where reify jobj = do n <- getArrayLength jobj forM [0..n-1] $ \i -> do - x <- getObjectArrayElement jobj i - reify x + jx <- getObjectArrayElement jobj i + x <- reify jx + deleteLocalRef jx + return x - instance Reflect a ty => Reflect [a] ('Array ty) where + instance Reflect a => Reflect [a] where reflect xs = do let n = fromIntegral (length xs) - array <- findClass (referenceTypeName (sing :: Sing ty)) - >>= newObjectArray n - forM_ (zip [0..n-1] xs) $ \(i, x) -> - setObjectArrayElement array i =<< reflect x - return (unsafeCast array) + array <- newArray n :: IO (J ('Array (Interp a))) + forM_ (zip [0..n-1] xs) $ \(i, x) -> do + jx <- reflect x + setObjectArrayElement array i jx + deleteLocalRef jx + return array |] diff --git a/src/Language/Java/TH.hs b/src/Language/Java/TH.hs deleted file mode 100644 --- a/src/Language/Java/TH.hs +++ /dev/null @@ -1,46 +0,0 @@ --- | Optional code macros for convenience. - -{-# LANGUAGE TemplateHaskell #-} - -module Language.Java.TH (makeConversions) where - -import Control.Distributed.Closure.TH (withStatic) -import qualified Language.Haskell.TH as TH -import Language.Java - --- | Define instances of the three conversion classes, 'Coercible', 'Reify' and --- 'Reflect' for the given datatype. Example usage: --- --- @ --- import qualified Language.Java.TH as Java --- --- newtype JOptionPane = JOptionPane (J ('Class "javax.swing.JOptionPane")) --- Java.makeConversions ''JOptionPane --- @ --- --- This is equivalent to: --- --- @ --- newtype JOptionPane = JOptionPane (J ('Class "javax.swing.JOptionPane")) --- instance Coercible JOptionPane ('Class "javax.swing.JOptionPane") --- instance Reify JOptionPane ('Class "javax.swing.JOptionPane") --- instance Reflect JOptionPane ('Class "javax.swing.JOptionPane") --- @ -makeConversions :: TH.Name -> TH.Q [TH.Dec] -makeConversions x = do - info <- TH.reify x - let ty_x = return (TH.ConT x) - ty_cls = case info of - TH.TyConI (TH.DataD [] _ _ _ [cstr] _) -> case cstr of - TH.NormalC _ [(_, TH.AppT (TH.ConT nm) ty)] | nm == ''J -> return ty - TH.RecC _ [(_, _, TH.AppT (TH.ConT nm) ty)] | nm == ''J -> return ty - _ -> notsupported - _ -> notsupported - withStatic [d| - instance Coercible $ty_x $ty_cls - instance Reify $ty_x $ty_cls - instance Reflect $ty_x $ty_cls - |] - where - notsupported = fail - "makeConversions failed. Only newtype wrappers of (J ty) are supported." diff --git a/tests/Language/JavaSpec.hs b/tests/Language/JavaSpec.hs --- a/tests/Language/JavaSpec.hs +++ b/tests/Language/JavaSpec.hs @@ -2,12 +2,15 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} module Language.JavaSpec where import Data.Int import qualified Data.Text as Text import Data.Text (Text) +import Foreign.JNI (getArrayLength) import Language.Java import Test.Hspec @@ -16,42 +19,72 @@ describe "callStatic" $ do it "can call double-returning static functions" $ do jstr <- reflect ("1.2345" :: Text) - callStatic (sing :: Sing "java.lang.Double") "parseDouble" [coerce jstr] + callStatic "java.lang.Double" "parseDouble" [coerce jstr] `shouldReturn` (1.2345 :: Double) it "can call int-returning static functions" $ do jstr <- reflect ("12345" :: Text) - callStatic (sing :: Sing "java.lang.Integer") "parseInt" [coerce jstr] + callStatic "java.lang.Integer" "parseInt" [coerce jstr] `shouldReturn` (12345 :: Int32) it "can call String-returning static functions" $ do jstr <- callStatic - (sing :: Sing "java.lang.Integer") + "java.lang.Integer" "toString" [coerce (12345 :: Int32)] reify jstr `shouldReturn` ("12345" :: Text) + it "can get static fields" $ do + getStaticField "java.lang.Math" "PI" + `shouldReturn` (pi :: Double) + + it "can get enum values" $ do + monday :: J ('Class "java.time.DayOfWeek") <- + getStaticField "java.time.DayOfWeek" "MONDAY" + call monday "getValue" [] + `shouldReturn` (1 :: Int32) + it "short doesn't under- or overflow" $ do maxshort <- reflect (Text.pack (show (maxBound :: Int16))) minshort <- reflect (Text.pack (show (minBound :: Int16))) - callStatic (sing :: Sing "java.lang.Short") "parseShort" [coerce maxshort] + callStatic "java.lang.Short" "parseShort" [coerce maxshort] `shouldReturn` (maxBound :: Int16) - callStatic (sing :: Sing "java.lang.Short") "parseShort" [coerce minshort] + callStatic "java.lang.Short" "parseShort" [coerce minshort] `shouldReturn` (minBound :: Int16) it "int doesn't under- or overflow" $ do maxint <- reflect (Text.pack (show (maxBound :: Int32))) minint <- reflect (Text.pack (show (minBound :: Int32))) - callStatic (sing :: Sing "java.lang.Integer") "parseInt" [coerce maxint] + callStatic "java.lang.Integer" "parseInt" [coerce maxint] `shouldReturn` (maxBound :: Int32) - callStatic (sing :: Sing "java.lang.Integer") "parseInt" [coerce minint] + callStatic "java.lang.Integer" "parseInt" [coerce minint] `shouldReturn` (minBound :: Int32) it "long doesn't under- or overflow" $ do maxlong <- reflect (Text.pack (show (maxBound :: Int64))) minlong <- reflect (Text.pack (show (minBound :: Int64))) - callStatic (sing :: Sing "java.lang.Long") "parseLong" [coerce maxlong] + callStatic "java.lang.Long" "parseLong" [coerce maxlong] `shouldReturn` (maxBound :: Int64) - callStatic (sing :: Sing "java.lang.Long") "parseLong" [coerce minlong] + callStatic "java.lang.Long" "parseLong" [coerce minlong] `shouldReturn` (minBound :: Int64) + + describe "newArray" $ do + it "Supports object arrays" $ do + jxs <- newArray 10 + getArrayLength (jxs :: J ('Array ('Class "java.lang.Object"))) + `shouldReturn` 10 + + it "supports generics" $ do + jxs <- newArray 10 + getArrayLength (jxs :: + J ('Array ('Class "java.util.List" <> '[ 'Class "java.lang.Long"])) + ) + `shouldReturn` 10 + + describe "reify" $ do + -- Applications need extra conversions if the following doesn't hold. + it "can get Integer when Long is expected" $ do + let i = maxBound :: Int32 + j <- new [coerce i] :: IO (J ('Class "java.lang.Integer")) + reify (unsafeCast j) `shouldReturn` (fromIntegral i :: Int64)