diff --git a/WORKSPACE b/WORKSPACE index 20a486af..7aed9bb0 100644 --- a/WORKSPACE +++ b/WORKSPACE @@ -120,7 +120,15 @@ stack_snapshot( "path", # keep "path-io", # keep ], - extra_deps = { "zlib" : ["@zlib.dev//:zlib"] }, + extra_deps = + { + "zlib" : ["@zlib.dev//:zlib"], + "streaming-commons" : ["@zlib.dev//:zlib"], + }, + + # disable calling pkg-config + flags = {"zlib": ["-pkg-config"]}, + components_dependencies = { "attoparsec": """{"lib:attoparsec": ["lib:attoparsec-internal"]}""", }, @@ -135,7 +143,7 @@ stack_snapshot( "exe", ], }, - local_snapshot = "//:snapshot-9.0.2.yaml", + local_snapshot = "//:snapshot-9.10.2.yaml", # stack = "@stack_ignore_global_hints//:bin/stack" if ghc_version == "9.0.1" else None, ) @@ -156,10 +164,10 @@ filegroup( ) haskell_register_ghc_nixpkgs( - attribute_path = "haskell.compiler.ghc902", + attribute_path = "haskell.compiler.ghc9102", locale_archive = "@glibc_locales//:locale-archive", repositories = {"nixpkgs": "@nixpkgs"}, - version = "9.0.2", + version = "9.10.2", ghcopts = [ "-Werror", "-Wall", diff --git a/benchmarks/wizzardo-http/src/main/haskell/Language/Java/Function.hs b/benchmarks/wizzardo-http/src/main/haskell/Language/Java/Function.hs index 8eb5b926..175006c2 100644 --- a/benchmarks/wizzardo-http/src/main/haskell/Language/Java/Function.hs +++ b/benchmarks/wizzardo-http/src/main/haskell/Language/Java/Function.hs @@ -23,6 +23,7 @@ import qualified Control.Monad import qualified Control.Monad.IO.Class.Linear as Linear import qualified Control.Functor.Linear as Linear import Data.Int +import Data.Kind (Type) import Data.Singletons import qualified Data.Text as Text import qualified Foreign.JNI as JNI @@ -55,7 +56,7 @@ type JNIIntIntToObjFun (Int32 -> Int32 -> IO (Ptr NonLinear.JObject)) -- | A representation of a StablePtr that we can pass to Java -newtype StablePtrHandle a = StablePtrHandle Int64 +newtype StablePtrHandle (a :: Type) = StablePtrHandle Int64 deriving Coercible foreign import ccall "wrapper" wrapObjectFun diff --git a/inline-java.cabal b/inline-java.cabal index 0e9c6c72..21039b94 100644 --- a/inline-java.cabal +++ b/inline-java.cabal @@ -44,11 +44,11 @@ library Cabal >=1.24.2, directory >=1.2, filepath >=1, - ghc >=9.0.2 && <9.2, + ghc >=9.0.2 && <9.11, jni >=0.8 && <0.9, jvm >=0.6 && <0.7, language-java >=0.2, - linear-base ==0.1.0, + linear-base >=0.5 && <0.6, mtl >=2.2.1, process >=1.2, text >=1.2, diff --git a/jni/jni.cabal b/jni/jni.cabal index 5bb85d7e..34cf5cf4 100644 --- a/jni/jni.cabal +++ b/jni/jni.cabal @@ -44,8 +44,8 @@ library constraints >=0.8, deepseq >=1.4.2, inline-c >=0.6, - linear-base ==0.1.0, - singletons-base ==3.0, + linear-base >=0.5 && <0.6, + singletons-base >=3.4, stm >= 2.3, text >= 1.2.3 default-language: Haskell2010 diff --git a/jni/src/common/Foreign/JNI/Unsafe/Internal.hs b/jni/src/common/Foreign/JNI/Unsafe/Internal.hs index e64d2124..6cf3d711 100644 --- a/jni/src/common/Foreign/JNI/Unsafe/Internal.hs +++ b/jni/src/common/Foreign/JNI/Unsafe/Internal.hs @@ -310,9 +310,12 @@ 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 + | otherwise -> + throwIO $ JNIError locStr rc where - (_, loc):_ = getCallStack callStack + locStr = case getCallStack callStack of + (_, loc) : _ -> prettySrcLoc loc + _ -> "no location" attachCurrentThreadAsDaemon :: IO () attachCurrentThreadAsDaemon = do diff --git a/jvm-batching/src/main/haskell/Language/Java/Batching.hs b/jvm-batching/src/main/haskell/Language/Java/Batching.hs index b30c558f..65ea3ea2 100644 --- a/jvm-batching/src/main/haskell/Language/Java/Batching.hs +++ b/jvm-batching/src/main/haskell/Language/Java/Batching.hs @@ -162,7 +162,7 @@ import Data.Int import Data.Proxy (Proxy(..)) import Data.Singletons (SingI) import qualified Data.Text as Text -import qualified Data.Text.Foreign as Text +import qualified Data.Text.Encoding as Text import qualified Data.Vector as V import qualified Data.Vector.Mutable as VM import qualified Data.Vector.Storable as VS @@ -609,10 +609,14 @@ withStatic [d| instance BatchReify Text.Text where newBatchWriter _ = [java| new BatchWriters.StringArrayBatchWriter() |] - reifyBatch = reifyArrayBatch (const reify) $ \o n vs -> - (VS.unsafeWith (VS.unsafeSlice o n vs) $ \ptr -> - Text.fromPtr ptr (fromIntegral n) - ) + reifyBatch = + reifyArrayBatch (const reify) $ \o n vs -> + VS.unsafeWith (VS.unsafeSlice o n vs) $ \ptr -> + Text.decodeUtf16LEWith (\_ _ -> Just '?') <$> + BS.packCStringLen (castPtrWord16 ptr, fromIntegral n * 2) + where + castPtrWord16 :: Ptr Word16 -> Ptr CChar + castPtrWord16 = castPtr instance BatchReflect BS.ByteString where newBatchReader _ = [java| new BatchReaders.ByteArrayBatchReader() |] @@ -645,9 +649,12 @@ withStatic [d| instance BatchReflect Text.Text where newBatchReader _ = [java| new BatchReaders.StringArrayBatchReader() |] reflectBatch = reflectArrayBatch reflect Text.length $ \ts -> - Text.useAsPtr (Text.concat ts) $ \ptr len -> - (`VS.unsafeFromForeignPtr0` fromIntegral len) - <$> newForeignPtr_ ptr + BS.useAsCStringLen (Text.encodeUtf16LE (Text.concat ts)) $ \(ptr, len) -> + (`VS.unsafeFromForeignPtr0` (fromIntegral len `div` 2)) + <$> newForeignPtr_ (castPtrCChar ptr) + where + castPtrCChar :: Ptr CChar -> Ptr Word16 + castPtrCChar = castPtr instance Interpretation a => Interpretation (V.Vector a) where type Interp (V.Vector a) = 'Array (Interp a) diff --git a/jvm/jvm.cabal b/jvm/jvm.cabal index 391c9641..a7a1c1e9 100644 --- a/jvm/jvm.cabal +++ b/jvm/jvm.cabal @@ -33,7 +33,7 @@ library distributed-closure >=0.3, exceptions >=0.8, jni >=0.8.0 && <0.9, - linear-base ==0.1.0, + linear-base >=0.5 && <0.6, singletons >=2.6, text >=1.2, template-haskell, diff --git a/jvm/src/common/Language/Java/Internal.hs b/jvm/src/common/Language/Java/Internal.hs index 3399c8b9..01445b2e 100644 --- a/jvm/src/common/Language/Java/Internal.hs +++ b/jvm/src/common/Language/Java/Internal.hs @@ -8,8 +8,9 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module Language.Java.Internal ( newJ diff --git a/jvm/src/common/Language/Java/Unsafe.hs b/jvm/src/common/Language/Java/Unsafe.hs index 678d532c..769689f3 100644 --- a/jvm/src/common/Language/Java/Unsafe.hs +++ b/jvm/src/common/Language/Java/Unsafe.hs @@ -773,6 +773,15 @@ withStatic [d| reflect = reflectMVector newBooleanArray setBooleanArrayRegion . (unsafeCoerce :: IOVector W8Bool -> IOVector Word8) + instance Interpretation (IOVector CChar) where + type Interp (IOVector CChar) = 'Array ('Prim "byte") + + instance Reify (IOVector CChar) where + reify = reifyMVector getByteArrayElements releaseByteArrayElements + + instance Reflect (IOVector CChar) where + reflect = reflectMVector newByteArray setByteArrayRegion + instance Interpretation (IOVector Word16) where type Interp (IOVector Word16) = 'Array ('Prim "char") @@ -827,7 +836,8 @@ withStatic [d| instance Reflect (IOVector Double) where reflect = reflectMVector (newDoubleArray) (setDoubleArrayRegion) - instance Interpretation (IOVector a) => Interpretation (Vector a) where + instance (SingI (Interp (IOVector a)), IsReferenceType (Interp (IOVector a)), Interpretation (IOVector a)) + => Interpretation (Vector a) where type Interp (Vector a) = Interp (IOVector a) instance (Storable a, Reify (IOVector a)) => Reify (Vector a) where diff --git a/shell-stack.nix b/shell-stack.nix index 1caa0666..5cdff8e9 100644 --- a/shell-stack.nix +++ b/shell-stack.nix @@ -1,6 +1,6 @@ { pkgs ? import ./nixpkgs.nix { }, - ghcAttr ? "ghc902", + ghcAttr ? "ghc9102", }: with pkgs; diff --git a/snapshot-9.0.2.yaml b/snapshot-9.0.2.yaml deleted file mode 100644 index 85349d72..00000000 --- a/snapshot-9.0.2.yaml +++ /dev/null @@ -1,9 +0,0 @@ -resolver: lts-19.30 - -packages: -- github: tweag/distributed-closure - commit: b92e75ec81e646703c7bde4f578a7352ee34f1ad -- github: ekmett/exceptions - commit: d7b742dc129790778f7b6d3347af80c8d69f8fcd -- github: tweag/linear-base - commit: ec0b5aa6dc89f1d7c7e368b7387e363a5062e52d diff --git a/snapshot-9.10.2.yaml b/snapshot-9.10.2.yaml new file mode 100644 index 00000000..b485c05b --- /dev/null +++ b/snapshot-9.10.2.yaml @@ -0,0 +1,4 @@ +resolver: nightly-2025-07-12 + +packages: +- linear-base-0.5.0 diff --git a/src/GhcPlugins/Extras.hs b/src/GhcPlugins/Extras.hs index e16110e8..3c82db05 100644 --- a/src/GhcPlugins/Extras.hs +++ b/src/GhcPlugins/Extras.hs @@ -2,35 +2,37 @@ module GhcPlugins.Extras ( module GHC.Core.FamInstEnv + , module GHC.Core.Reduction , module GHC.Plugins , module GhcPlugins.Extras , module GHC.Core.TyCo.Rep + , module GHC.Types.ForeignStubs ) where -import Control.Monad.Writer hiding ((<>)) +import Control.Monad.Writer import Data.Data (Data) import Data.Maybe (mapMaybe) -import Data.IORef (readIORef) import GHC.Core.FamInstEnv +import GHC.Core.Reduction (Reduction(..)) import GHC.Core.TyCo.Rep +import GHC.Iface.Env (lookupNameCache) import GHC.Plugins import GHC.ThToHs (thRdrNameGuesses) -import GHC.Types.Name.Cache (lookupOrigNameCache, nsNames) +import GHC.Types.ForeignStubs import GHC.Utils.Error (ghcExit) import qualified Language.Haskell.TH as TH -- | Produces a name in GHC Core from a Template Haskell name. -- --- Yields Nothing if the name can't be found, which may happen if the --- module defining the named thing hasn't been loaded. +-- Yields Nothing if the name can't be found. findTHName :: TH.Name -> CoreM (Maybe Name) findTHName th_name = case thRdrNameGuesses th_name of Orig m occ : _ -> do hsc_env <- getHscEnv - nc <- liftIO $ readIORef (hsc_NC hsc_env) - return $ lookupOrigNameCache (nsNames nc) m occ + let nc = hsc_NC hsc_env + liftIO $ Just <$> lookupNameCache nc m occ _ -> return Nothing -- | Yields module annotations with values of the given type. @@ -43,9 +45,6 @@ getModuleAnnotations guts = failWith :: SDoc -> CoreM a failWith m = do errorMsg m - dflags <- getDynFlags - liftIO $ ghcExit dflags 1 + logger <- hsc_logger <$> getHscEnv + liftIO $ ghcExit logger 1 return (error "ghcExit returned!?") -- unreachable - -moduleUnitId :: GenModule Unit -> UnitId -moduleUnitId = toUnitId . moduleUnit diff --git a/src/Language/Java/Inline/Internal/QQMarker.hs b/src/Language/Java/Inline/Internal/QQMarker.hs index 8a99cbef..8c50e29e 100644 --- a/src/Language/Java/Inline/Internal/QQMarker.hs +++ b/src/Language/Java/Inline/Internal/QQMarker.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} diff --git a/src/Language/Java/Inline/Internal/QQMarker/Safe.hs b/src/Language/Java/Inline/Internal/QQMarker/Safe.hs index 6aff3c9c..acdb732b 100644 --- a/src/Language/Java/Inline/Internal/QQMarker/Safe.hs +++ b/src/Language/Java/Inline/Internal/QQMarker/Safe.hs @@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} diff --git a/src/Language/Java/Inline/Plugin.hs b/src/Language/Java/Inline/Plugin.hs index d0ef9734..86cfd113 100644 --- a/src/Language/Java/Inline/Plugin.hs +++ b/src/Language/Java/Inline/Plugin.hs @@ -9,13 +9,15 @@ {-# LANGUAGE ViewPatterns #-} module Language.Java.Inline.Plugin (plugin) where -import Control.Applicative ((<|>)) -import Control.Monad.Writer hiding ((<>)) +import Control.Monad (forM, when, zipWithM) +import Control.Monad.Writer import qualified Data.ByteString as BS import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder as Builder import Data.Char (chr, ord) import Data.List (find, intersperse, isSuffixOf) +import Data.Maybe (fromMaybe) +import Data.Monoid (Endo(..)) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Foreign.JNI.Types (JType(..)) @@ -83,9 +85,12 @@ plugin = defaultPlugin return guts { mg_binds = binds , mg_foreign = appendStubC (mg_foreign guts) $ - text bctable_header + CStub + ( text bctable_header $$ dotClasses dcs $$ cConstructors + ) + [] [] } -- The contents of bctable.h @@ -159,7 +164,7 @@ buildJava guts qqOccs jimports = do p_fam_env <- getPackageFamInstEnv let fam_envs = (p_fam_env, mg_fam_inst_env guts) methods <- forM qqOccs $ \QQOcc {..} -> do - let (_, normty) = normaliseType fam_envs Nominal (expandTypeSynonyms qqOccResTy) + let Reduction _ normty = normaliseType fam_envs Nominal (expandTypeSynonyms qqOccResTy) jTypeNames <- findJTypeNames resty <- case toJavaType jTypeNames normty of Just resty -> return resty @@ -202,8 +207,8 @@ buildJava guts qqOccs jimports = do (expandTypeSynonyms -> toJavaType jTypeNames -> Just jtype) = return $ mconcat ["final ", Builder.byteString jtype, " $", Builder.byteString name] - getArg _ line name t = GhcPlugins.Extras.failWith $ hsep - [ parens (text "line" <+> integer line) <> ":" + getArg _ lineN name t = GhcPlugins.Extras.failWith $ hsep + [ parens (text "line" <+> integer lineN) <> ":" , quotes (ftext (mkFastStringByteString name) <+> "::" <+> ppr t) , text "is not sufficiently instantiated to infer a java type." ] @@ -228,7 +233,7 @@ mangle m = mangleClassName (unitIdString $ moduleUnitId m) -- Call the java compiler and feeds it the given Java code in Builder form. buildBytecode :: [CommandLineOption] -> Builder -> CoreM [DotClass] buildBytecode args unit = do - let Just javac = find ("javac" `isSuffixOf`) args <|> return "javac" + let javac = fromMaybe "javac" $ find ("javac" `isSuffixOf`) args m <- getModule liftIO $ withSystemTempDirectory "inlinejava" $ \dir -> do let src = dir mangle m <.> "java" @@ -393,7 +398,7 @@ collectQQMarkers qqMarkerNames p0 = do expMarkers (Let bnd e) = Let <$> bindMarkers bnd <*> expMarkers e expMarkers (Case e0 b t alts) = do e0' <- expMarkers e0 - let expAlt (a, bs, e) = (,,) a bs <$> expMarkers e + let expAlt (Alt a bs e) = Alt a bs <$> expMarkers e alts' <- mapM expAlt alts return (Case e0' b t alts') expMarkers (Cast e c) = flip Cast c <$> expMarkers e diff --git a/src/Language/Java/Inline/Safe.hs b/src/Language/Java/Inline/Safe.hs index 554abc1f..cc70fdb4 100644 --- a/src/Language/Java/Inline/Safe.hs +++ b/src/Language/Java/Inline/Safe.hs @@ -79,16 +79,19 @@ java = Java.javaWithConfig Java.QQConfig { Java.qqMarker = 'Safe.qqMarker , Java.qqCallStatic = \qargs -> let (args, tolist) = splitAt 2 qargs - in -- XXX: We need to explicitly use the linear ($) so GHC is satisfied - -- that the argument is going to be used linearly in the variadic - -- function. - TH.appE + in TH.appE (foldl (flip TH.appE) (TH.appsE (TH.varE 'Safe.callStatic : args)) - (map (\q -> [| (Linear.$ $q) |]) tolist) + (map (\q -> [| flipLinearApp $q |]) tolist) ) [| Safe.End |] , Java.qqWrapMarker = \qExp -> [| liftPreludeIO loadJavaWrappers Linear.>> $qExp |] } + +-- XXX: We need to explicitly use the linear ($) so GHC is satisfied +-- that the argument is going to be used linearly in the variadic +-- function. +flipLinearApp :: a %1 -> (a %1 -> b) %1 -> b +flipLinearApp x f = f Linear.$ x diff --git a/stack.yaml b/stack.yaml index 87237745..37d13185 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-19.30 +resolver: nightly-2025-07-12 packages: - jni @@ -6,9 +6,10 @@ packages: - . extra-deps: -- github: tweag/distributed-closure - commit: b92e75ec81e646703c7bde4f578a7352ee34f1ad -- linear-base-0.1.0 +- linear-base-0.5.0 + +ghc-options: + "$locals": -Wall -Werror nix: shell-file: ./shell-stack.nix