Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 3f40c16e by Matthew Pickering at 2026-04-07T11:57:18-04:00 packaging: correctly propagate build/host/target to bindist configure script At the moment the host and target which we will produce a compiler for is fixed at the initial configure time. Therefore we need to persist the choice made at this time into the installation bindist as well so we look for the right tools, with the right prefixes at install time. In the future, we want to provide a bit more control about what kind of bindist we produce so the logic about what the host/target will have to be written by hadrian rather than persisted by the configure script. In particular with cross compilers we want to either build a normal stage 2 cross bindist or a stage 3 bindist, which creates a bindist which has a native compiler for the target platform. Fixes #21970 Co-authored-by: Sven Tennie <sven.tennie@gmail.com> - - - - - 971f0fab by Sven Tennie at 2026-04-07T11:57:18-04:00 Cross --host and --target no longer required for cross (#21970) We set sane defaults in the configure script. Thus, these paramenters aren't required any longer. - - - - - 7b618251 by Sven Tennie at 2026-04-07T11:57:18-04:00 ci: Define USER_CONF_CC_OPTS_STAGE2 for aarch64/mingw ghc-toolchain doesn't see $CONF_CC_OPTS_STAGE2 when the bindist gets configured. So, the hack to override the compiler gets lost. - - - - - 4d8586fe by Cheng Shao at 2026-04-07T11:57:20-04:00 compiler: improve Binary instance of Array This patch improves the `Binary` instance of `Array`: - We no longer allocate intermediate lists. When serializing an `Array`, we iterate over the elements directly; when deserializing it, we allocate the result `Array` and fill it in a loop. - Now we only serialize the array bounds tuple; the length field is not needed. Closes #27109. - - - - - 0f7bbd95 by Cheng Shao at 2026-04-07T11:57:21-04:00 ghci: use ShortByteString for LookupSymbol/LookupSymbolInDLL/LookupClosure messages This patch refactors ghci to use `ShortByteString` for `LookupSymbol`/`LookupSymbolInDLL`/`LookupClosure` messages as the first part of #27147. Co-authored-by: Codex <codex@openai.com> - - - - - 720af979 by Cheng Shao at 2026-04-07T11:57:21-04:00 ghci: use ShortByteString for MkCostCentres message This patch refactors ghci to use `ShortByteString` for `MkCostCentres` messages as a first part of #27147. This also considerably lowers the memory overhead of breakpoints when cost center profiling is enabled. ------------------------- Metric Decrease: interpreter_steplocal ------------------------- Co-authored-by: Codex <codex@openai.com> - - - - - 24 changed files: - .gitlab/ci.sh - .gitlab/generate-ci/gen_ci.hs - .gitlab/jobs.yaml - compiler/GHC/ByteCode/Breakpoints.hs - compiler/GHC/Driver/Plugins.hs - compiler/GHC/HsToCore/Breakpoints.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Runtime/Interpreter.hs - compiler/GHC/Utils/Binary.hs - configure.ac - distrib/configure.ac.in - hadrian/cfg/system.config.in - hadrian/src/Oracles/Setting.hs - hadrian/src/Rules/Generate.hs - hadrian/src/Settings/Default.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/ObjLink.hs - libraries/ghci/GHCi/Run.hs - m4/fptools_set_platform_vars.m4 - m4/ghc_toolchain.m4 - testsuite/tests/driver/linkwhole/Main.hs - testsuite/tests/ghci/should_run/T18064.script - testsuite/tests/rts/KeepCafsMain.hs - utils/jsffi/dyld.mjs Changes: ===================================== .gitlab/ci.sh ===================================== @@ -628,20 +628,6 @@ function install_bindist() { *) read -r -a args <<< "${INSTALL_CONFIGURE_ARGS:-}" - if [[ "${CROSS_TARGET:-no_cross_target}" =~ "mingw" ]]; then - # We suppose that host target = build target. - # By the fact above it is clearly turning out which host value is - # for currently built compiler. - # The fix for #21970 will probably remove this if-branch. - local -r CROSS_HOST_GUESS=$($SHELL ./config.guess) - args+=( "--target=$CROSS_TARGET" "--host=$CROSS_HOST_GUESS" ) - - # FIXME: The bindist configure script shouldn't need to be reminded of - # the target platform. See #21970. - elif [ -n "${CROSS_TARGET:-}" ]; then - args+=( "--target=$CROSS_TARGET" "--host=$CROSS_TARGET" ) - fi - run ${CONFIGURE_WRAPPER:-} ./configure \ --prefix="$instdir" \ "${args[@]+"${args[@]}"}" || fail "bindist configure failed" ===================================== .gitlab/generate-ci/gen_ci.hs ===================================== @@ -1316,6 +1316,13 @@ cross_jobs = [ -- unexpected triple. . setVariable "CFLAGS" cflags . setVariable "CONF_CC_OPTS_STAGE2" cflags + -- For bindists `$USER_CONF_CC_OPTS_STAGE2` is not automatically set + -- to `$CONF_CC_OPTS_STAGE2`. But, we still have to deal with the hack + -- mentioned in the previous comment. + -- + -- TODO: It would be nice to get rid of this hack. This would probably + -- involve setting the toolchain up in a different way. + . setVariable "USER_CONF_CC_OPTS_STAGE2" cflags ) where llvm_prefix = "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-" cflags = "-fuse-ld=" ++ llvm_prefix ++ "ld --rtlib=compiler-rt" ===================================== .gitlab/jobs.yaml ===================================== @@ -331,6 +331,7 @@ "STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings", "STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip", "TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate", + "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt", "WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres" } }, @@ -412,6 +413,7 @@ "STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings", "STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip", "TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm", + "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt", "WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres" } }, @@ -1123,6 +1125,7 @@ "STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings", "STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip", "TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate", + "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt", "WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres", "XZ_OPT": "-9" } @@ -1205,6 +1208,7 @@ "STRINGS": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strings", "STRIP": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-strip", "TEST_ENV": "aarch64-linux-deb12-wine-int_native-cross_aarch64-unknown-mingw32-validate+llvm", + "USER_CONF_CC_OPTS_STAGE2": "-fuse-ld=/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-ld --rtlib=compiler-rt", "WindresCmd": "/opt/llvm-mingw-linux/bin/aarch64-w64-mingw32-windres", "XZ_OPT": "-9" } ===================================== compiler/GHC/ByteCode/Breakpoints.hs ===================================== @@ -37,6 +37,7 @@ import GHC.Prelude import GHC.Types.SrcLoc import GHC.Types.Name.Occurrence import Control.DeepSeq +import qualified Data.ByteString.Short as SBS import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IM @@ -235,8 +236,8 @@ getBreakVars = getBreakXXX modBreaks_vars getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String] getBreakDecls = getBreakXXX modBreaks_decls --- | Get the decls for this breakpoint -getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO ((String, String)) +-- | Get the cost centre info for this breakpoint +getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO (SBS.ShortByteString, SBS.ShortByteString) getBreakCCS = getBreakXXX modBreaks_ccs -- | Internal utility to access a ModBreaks field at a particular breakpoint index ===================================== compiler/GHC/Driver/Plugins.hs ===================================== @@ -405,7 +405,7 @@ loadExternalPlugins ps = do symbol | null unit = ztmp | otherwise = zEncodeString unit ++ "_" ++ ztmp - plugin <- lookupSymbol symbol >>= \case + plugin <- lookupSymbol (utf8EncodeShortByteString symbol) >>= \case Nothing -> pprPanic "loadExternalPlugins" (vcat [ text "Symbol not found" , text " Library path: " <> text path ===================================== compiler/GHC/HsToCore/Breakpoints.hs ===================================== @@ -23,6 +23,7 @@ module GHC.HsToCore.Breakpoints import GHC.Prelude import Data.Array +import qualified Data.ByteString.Short as SBS import GHC.HsToCore.Ticks (Tick (..)) import GHC.Data.SizedSeq @@ -31,6 +32,7 @@ import GHC.Types.Name (OccName) import GHC.Types.Tickish (BreakTickIndex, BreakpointId(..)) import GHC.Unit.Module (Module) import GHC.Utils.Binary +import GHC.Utils.Encoding (utf8EncodeShortByteString) import GHC.Utils.Outputable import Data.List (intersperse) import Data.Coerce @@ -59,7 +61,7 @@ data ModBreaks , modBreaks_decls :: !(Array BreakTickIndex [String]) -- ^ An array giving the names of the declarations enclosing each breakpoint. -- See Note [Field modBreaks_decls] - , modBreaks_ccs :: !(Array BreakTickIndex (String, String)) + , modBreaks_ccs :: !(Array BreakTickIndex (SBS.ShortByteString, SBS.ShortByteString)) -- ^ Array pointing to cost centre info for each breakpoint; -- actual 'CostCentre' allocation is done at link-time. , modBreaks_module :: !Module @@ -89,8 +91,8 @@ mkModBreaks interpreterProfiled modl extendedMixEntries | interpreterProfiled = listArray (0, count - 1) - [ ( concat $ intersperse "." $ tick_path t, - renderWithContext defaultSDocContext $ ppr $ tick_loc t + [ ( utf8EncodeShortByteString $ concat $ intersperse "." $ tick_path t, + utf8EncodeShortByteString $ renderWithContext defaultSDocContext $ ppr $ tick_loc t ) | t <- entries ] ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -1846,7 +1846,7 @@ allocateCCS interp ce mbss ccs <- {- one ccs ptr per tick index -} mkCostCentres interp - (moduleNameString $ moduleName modBreaks_module) + (moduleNameFS $ moduleName modBreaks_module) (elems modBreaks_ccs) return $ M.fromList $ zipWith (\el ix -> (BreakpointId modBreaks_module ix, el)) ccs [0..] ===================================== compiler/GHC/Runtime/Interpreter.hs ===================================== @@ -107,6 +107,7 @@ import Control.Monad.IO.Class import Control.Monad.Catch as MC (mask) import Data.Binary import Data.ByteString (ByteString) +import qualified Data.ByteString.Short as SBS import Foreign hiding (void) import qualified GHC.Exts.Heap as Heap import GHC.Stack.CCS (CostCentre,CostCentreStack) @@ -352,9 +353,15 @@ evalStringToIOString interp fhv str = mallocData :: Interp -> ByteString -> IO (RemotePtr ()) mallocData interp bs = interpCmd interp (MallocData bs) -mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre] -mkCostCentres interp mod ccs = - interpCmd interp (MkCostCentres mod ccs) +mkCostCentres :: Interp -> FastString -> [(SBS.ShortByteString, SBS.ShortByteString)] -> IO [RemotePtr CostCentre] +mkCostCentres interp mod ccs = do + rp <- modifyMVar (interpStringCache interp) $ \fs_env -> + case lookupFsEnv fs_env mod of + Just rp -> pure (fs_env, rp) + Nothing -> do + rp <- fmap head $ interpCmd interp $ MallocStrings [bytesFS mod] + pure (extendFsEnv fs_env mod rp, rp) + interpCmd interp $ MkCostCentres rp ccs -- | Create a set of BCOs that may be mutually recursive. createBCOs :: Interp -> [ResolvedBCO] -> IO [HValueRef] @@ -413,7 +420,7 @@ evalBreakpointToId :: EvalBreakpoint -> InternalBreakpointId evalBreakpointToId eval_break = let mkUnitId u = fsToUnit $ mkFastStringShortByteString u - toModule u n = mkModule (mkUnitId u) (mkModuleName n) + toModule u n = mkModule (mkUnitId u) (mkModuleNameFS (mkFastStringShortByteString n)) in InternalBreakpointId { ibi_info_mod = toModule (eb_info_mod_unit eval_break) (eb_info_mod eval_break) @@ -465,27 +472,27 @@ lookupSymbol :: Interp -> InterpSymbol s -> IO (Maybe (Ptr ())) lookupSymbol interp str = withSymbolCache interp str $ case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS (interpSymbolToCLabel str))) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str))) #endif ExternalInterp ext -> case ext of ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do uninterruptibleMask_ $ - sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str))) + sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str))) ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) ExtWasm i -> withWasmInterp i $ \inst -> fmap fromRemotePtr <$> do uninterruptibleMask_ $ - sendMessage inst (LookupSymbol (unpackFS (interpSymbolToCLabel str))) + sendMessage inst (LookupSymbol (fastStringToShortByteString (interpSymbolToCLabel str))) lookupSymbolInDLL :: Interp -> RemotePtr LoadedDLL -> InterpSymbol s -> IO (Maybe (Ptr ())) lookupSymbolInDLL interp dll str = withSymbolCache interp str $ case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER) - InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str))) + InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str))) #endif ExternalInterp ext -> case ext of ExtIServ i -> withIServ i $ \inst -> fmap fromRemotePtr <$> do uninterruptibleMask_ $ - sendMessage inst (LookupSymbolInDLL dll (unpackFS (interpSymbolToCLabel str))) + sendMessage inst (LookupSymbolInDLL dll (fastStringToShortByteString (interpSymbolToCLabel str))) ExtJS {} -> pprPanic "lookupSymbol not supported by the JS interpreter" (ppr str) -- wasm dyld doesn't track which symbol comes from which .so ExtWasm {} -> lookupSymbol interp str @@ -519,7 +526,7 @@ interpSymbolToCLabel s = eliminateInterpSymbol s interpretedInterpSymbol $ \is - lookupClosure :: Interp -> InterpSymbol s -> IO (Maybe HValueRef) lookupClosure interp str = - interpCmd interp (LookupClosure (unpackFS (interpSymbolToCLabel str))) + interpCmd interp (LookupClosure (fastStringToShortByteString (interpSymbolToCLabel str))) -- | 'withSymbolCache' tries to find a symbol in the 'interpLookupSymbolCache' -- which maps symbols to the address where they are loaded. ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -142,6 +142,7 @@ import Control.DeepSeq import Control.Monad ( when, (<$!>), unless, forM_, void ) import Foreign hiding (bit, setBit, clearBit, shiftL, shiftR, void) import Data.Array +import Data.Array.Base (traverseArray_, unsafeFreezeIOArray) import Data.Array.IO import Data.Array.Unsafe import qualified Data.Binary as Binary @@ -970,11 +971,12 @@ instance Binary a => Binary (NonEmpty a) where instance (Ix a, Binary a, Binary b) => Binary (Array a b) where put_ bh arr = do put_ bh $ bounds arr - put_ bh $ elems arr + traverseArray_ (put_ bh) arr + get bh = do - bounds <- get bh - xs <- get bh - return $ listArray bounds xs + (l, u) <- get bh + marr <- newGenArray (l, u) $ \_ -> get bh + unsafeFreezeIOArray marr instance Binary a => Binary (SmallArray a) where put_ bh sa = do ===================================== configure.ac ===================================== @@ -255,6 +255,7 @@ if test "${WithGhc}" != "" then bootstrap_host=`"${WithGhc}" --info | grep '^ ,("Host platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'` bootstrap_target=`"${WithGhc}" --info | grep '^ ,("Target platform"' | sed -e 's/.*,"//' -e 's/")//' | tr -d '\r'` + bootstrap_build="$bootstrap_host" if test "$bootstrap_host" != "$bootstrap_target" then echo "Bootstrapping GHC is a cross compiler. This probably isn't going to work" @@ -394,8 +395,33 @@ then else TargetPlatformFull="${target_alias}" fi + +if test -z "${build_alias}" +then + # --target wasn't given; use result from AC_CANONICAL_TARGET + BuildPlatformFull="${build}" +else + BuildPlatformFull="${build_alias}" +fi +if test -z "${host_alias}" +then + # --target wasn't given; use result from AC_CANONICAL_TARGET + HostPlatformFull="${host}" +else + HostPlatformFull="${host_alias}" +fi +if test "$CrossCompiling" = "YES" +then + # Use value passed by user from --target= + CrossCompilePrefix="${TargetPlatformFull}-" +else + CrossCompilePrefix="" +fi + AC_SUBST(CrossCompiling) AC_SUBST(TargetPlatformFull) +AC_SUBST(BuildPlatformFull) +AC_SUBST(HostPlatformFull) dnl ** Which gcc to use? dnl -------------------------------------------------------------- ===================================== distrib/configure.ac.in ===================================== @@ -15,7 +15,18 @@ dnl-------------------------------------------------------------------- dnl * Deal with arguments telling us gmp is somewhere odd dnl-------------------------------------------------------------------- +build_alias=@BuildPlatformFull@ +host_alias=@HostPlatformFull@ +target_alias=@TargetPlatformFull@ + +dnl this makes sure `./configure --target=<cross-compile-target>` +dnl works as expected, since we're slightly modifying how Autoconf +dnl interprets build/host/target and how this interacts with $CC tests +test -n "$target_alias" && ac_tool_prefix=$target_alias- + dnl Various things from the source distribution configure +bootstrap_build=@BuildPlatform@ +bootstrap_host=@HostPlatform@ bootstrap_target=@TargetPlatform@ bootstrap_llvm_target=@LlvmTarget@ ===================================== hadrian/cfg/system.config.in ===================================== @@ -50,6 +50,9 @@ use-ghc-toolchain = @EnableGhcToolchain@ # And we can reconstruct the platform info using targetPlatformTriple # Q: What is TargetPlatformFull? target-platform-full = @TargetPlatformFull@ +build-platform-full = @BuildPlatformFull@ +host-platform-full = @HostPlatformFull@ + cross-compiling = @CrossCompiling@ ===================================== hadrian/src/Oracles/Setting.hs ===================================== @@ -69,6 +69,8 @@ data Setting = CursesIncludeDir | ProjectPatchLevel2 | SystemGhc | TargetPlatformFull + | BuildPlatformFull + | HostPlatformFull | BourneShell | EmsdkVersion @@ -107,6 +109,8 @@ setting key = lookupSystemConfig $ case key of ProjectPatchLevel2 -> "project-patch-level2" SystemGhc -> "system-ghc" TargetPlatformFull -> "target-platform-full" + BuildPlatformFull -> "build-platform-full" + HostPlatformFull -> "host-platform-full" BourneShell -> "bourne-shell" EmsdkVersion -> "emsdk-version" ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -424,6 +424,8 @@ bindistRules = do , interpolateVar "TablesNextToCode" $ yesNo <$> getTarget tgtTablesNextToCode , interpolateVar "TargetHasLibm" $ yesNo <$> getTarget tgtHasLibm , interpolateVar "TargetPlatform" $ getTarget targetPlatformTriple + , interpolateVar "BuildPlatform" $ interp $ queryBuild targetPlatformTriple + , interpolateVar "HostPlatform" $ interp $ queryHost targetPlatformTriple , interpolateVar "TargetWordBigEndian" $ getTarget isBigEndian , interpolateVar "TargetWordSize" $ getTarget wordSize , interpolateVar "Unregisterised" $ yesNo <$> getTarget tgtUnregisterised @@ -431,6 +433,9 @@ bindistRules = do , interpolateVar "UseLibffiForAdjustors" $ yesNo <$> getTarget tgtUseLibffiForAdjustors , interpolateVar "GhcWithSMP" $ yesNo <$> targetSupportsSMP , interpolateVar "BaseUnitId" $ pkgUnitId Stage1 base + , interpolateVar "TargetPlatformFull" (setting TargetPlatformFull) + , interpolateVar "BuildPlatformFull" (setting BuildPlatformFull) + , interpolateVar "HostPlatformFull" (setting HostPlatformFull) ] where interp = interpretInContext (semiEmptyTarget Stage2) ===================================== hadrian/src/Settings/Default.hs ===================================== @@ -122,7 +122,11 @@ stage0Packages = do -- for upper stages. As we only use stage0 to build upper stages, -- this should be fine. ++ [ terminfo | not windowsHost, not cross ] - ++ [ timeout | windowsHost ] + ++ [ timeout | windowsHost ] + -- Due to some weird logic, we need ghcToolchainBin in Stage0 and + -- Stage1 packages if we're cross compiling. "Stage2 cross-compilers" + -- will solve this. + ++ [ ghcToolchainBin | cross ] -- | Packages built in 'Stage1' by default. You can change this in "UserSettings". stage1Packages :: Action [Package] @@ -181,12 +185,12 @@ stage1Packages = do , transformers , unlit , xhtml + , ghcToolchainBin , if winTarget then win32 else unix ] , when (not cross) [ hpcBin , runGhc - , ghcToolchainBin ] , when (winTarget && not cross) [ -- See Note [Hadrian's ghci-wrapper package] ===================================== libraries/ghci/GHCi/Message.hs ===================================== @@ -86,9 +86,9 @@ data Message a where -- These all invoke the corresponding functions in the RTS Linker API. InitLinker :: Message () - LookupSymbol :: String -> Message (Maybe (RemotePtr ())) - LookupSymbolInDLL :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ())) - LookupClosure :: String -> Message (Maybe HValueRef) + LookupSymbol :: !BS.ShortByteString -> Message (Maybe (RemotePtr ())) + LookupSymbolInDLL :: !(RemotePtr LoadedDLL) -> !BS.ShortByteString -> Message (Maybe (RemotePtr ())) + LookupClosure :: !BS.ShortByteString -> Message (Maybe HValueRef) LoadDLLs :: [String] -> Message (Either String [RemotePtr LoadedDLL]) LoadArchive :: String -> Message () -- error? LoadObj :: String -> Message () -- error? @@ -162,8 +162,8 @@ data Message a where -- | Create a set of CostCentres with the same module name MkCostCentres - :: String -- module, RemotePtr so it can be shared - -> [(String,String)] -- (name, SrcSpan) + :: !(RemotePtr ()) -- ModuleName + -> ![(BS.ShortByteString, BS.ShortByteString)] -- (name, SrcSpan) -> Message [RemotePtr CostCentre] -- | Show a 'CostCentreStack' as a @[String]@ @@ -430,7 +430,7 @@ data EvalStatus_ a b instance Binary a => Binary (EvalStatus_ a b) data EvalBreakpoint = EvalBreakpoint - { eb_info_mod :: String -- ^ Breakpoint info module + { eb_info_mod :: !BS.ShortByteString -- ^ Breakpoint info module , eb_info_mod_unit :: BS.ShortByteString -- ^ Breakpoint tick module unit id , eb_info_index :: Int -- ^ Breakpoint info index } ===================================== libraries/ghci/GHCi/ObjLink.hs ===================================== @@ -31,6 +31,8 @@ import GHCi.RemoteTypes import GHCi.Message (LoadedDLL) import Control.Exception (throwIO, ErrorCall(..)) import Control.Monad ( when ) +import qualified Data.ByteString.Short as BS +import Data.Char (ord) import Data.Foldable import Foreign.C import Foreign.Marshal.Alloc ( alloca, free ) @@ -104,15 +106,15 @@ unloadObj f = throwIO $ ErrorCall $ "unloadObj: unsupported on wasm for " <> f purgeObj :: String -> IO () purgeObj f = throwIO $ ErrorCall $ "purgeObj: unsupported on wasm for " <> f -lookupSymbol :: String -> IO (Maybe (Ptr a)) -lookupSymbol sym = do - r <- js_lookupSymbol $ toJSString sym +lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a)) +lookupSymbol sym@(BS.SBS ba#) = do + r <- js_lookupSymbolPtr ba# (BS.length sym) evaluate $ if r == nullPtr then Nothing else Just r -foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbol($1)" - js_lookupSymbol :: JSString -> IO (Ptr a) +foreign import javascript unsafe "__ghc_wasm_jsffi_dyld.lookupSymbolPtr($1,$2)" + js_lookupSymbolPtr :: ByteArray# -> Int -> IO (Ptr a) -lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a)) +lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a)) lookupSymbolInDLL _ _ = pure Nothing resolveObjs :: IO Bool @@ -149,27 +151,27 @@ initObjLinker :: ShouldRetainCAFs -> IO () initObjLinker RetainCAFs = c_initLinker_ 1 initObjLinker _ = c_initLinker_ 0 -lookupSymbol :: String -> IO (Maybe (Ptr a)) +lookupSymbol :: BS.ShortByteString -> IO (Maybe (Ptr a)) lookupSymbol str_in = do let str = prefixUnderscore str_in - withCAString str $ \c_str -> do + BS.useAsCString str $ \c_str -> do addr <- c_lookupSymbol c_str if addr == nullPtr then return Nothing else return (Just addr) -lookupSymbolInDLL :: Ptr LoadedDLL -> String -> IO (Maybe (Ptr a)) +lookupSymbolInDLL :: Ptr LoadedDLL -> BS.ShortByteString -> IO (Maybe (Ptr a)) lookupSymbolInDLL dll str_in = do let str = prefixUnderscore str_in - withCAString str $ \c_str -> do + BS.useAsCString str $ \c_str -> do addr <- c_lookupSymbolInNativeObj dll c_str if addr == nullPtr then return Nothing else return (Just addr) -prefixUnderscore :: String -> String +prefixUnderscore :: BS.ShortByteString -> BS.ShortByteString prefixUnderscore - | cLeadingUnderscore = ('_':) + | cLeadingUnderscore = BS.cons (fromIntegral (ord '_')) | otherwise = id -- | loadDLL loads a dynamic library using the OS's native linker @@ -298,7 +300,7 @@ isWindowsHost = False #endif -lookupClosure :: String -> IO (Maybe HValueRef) +lookupClosure :: BS.ShortByteString -> IO (Maybe HValueRef) lookupClosure str = do m <- lookupSymbol str case m of ===================================== libraries/ghci/GHCi/Run.hs ===================================== @@ -34,7 +34,7 @@ import Control.DeepSeq import Control.Exception import Control.Monad import Data.ByteString (ByteString) -import qualified Data.ByteString.Short as BS +import qualified Data.ByteString.Short.Internal as BS import qualified Data.ByteString.Unsafe as B import GHC.Exts import qualified GHC.Exts.Heap as Heap @@ -135,12 +135,12 @@ foreign import javascript "((ptr,off) => globalThis.h$loadJS(h$decodeUtf8z(ptr,o foreign import javascript "((ptr,off) => globalThis.h$lookupClosure(h$decodeUtf8z(ptr,off)))" lookupJSClosure# :: CString -> State# RealWorld -> (# State# RealWorld, Int# #) -lookupJSClosure' :: String -> IO Int -lookupJSClosure' str = withCString str $ \cstr -> IO (\s -> +lookupJSClosure' :: BS.ShortByteString -> IO Int +lookupJSClosure' str = BS.useAsCString str $ \cstr -> IO (\s -> case lookupJSClosure# cstr s of (# s', r #) -> (# s', I# r #)) -lookupJSClosure :: String -> IO (Maybe HValueRef) +lookupJSClosure :: BS.ShortByteString -> IO (Maybe HValueRef) lookupJSClosure str = lookupJSClosure' str >>= \case 0 -> pure Nothing r -> pure (Just (RemoteRef (RemotePtr (fromIntegral r)))) @@ -359,7 +359,7 @@ withBreakAction opts breakMVar statusMVar mtid act if is_exception then pure Nothing else do - info_mod <- peekCString (Ptr info_mod#) + info_mod <- BS.packCString (Ptr info_mod#) info_mod_uid <- BS.packCString (Ptr info_mod_uid#) pure (Just (EvalBreakpoint info_mod info_mod_uid (I# infox#))) putMVar statusMVar $ EvalBreak apStack_r breakpoint resume_r ccs @@ -434,17 +434,24 @@ mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do pokeElemOff (ptr :: Ptr CChar) len 0 return (castRemotePtr (toRemotePtr ptr)) -mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre] +mkCostCentres :: RemotePtr () -> [(BS.ShortByteString, BS.ShortByteString)] -> IO [RemotePtr CostCentre] #if defined(PROFILING) mkCostCentres mod ccs = do - c_module <- newCString mod + let c_module = fromRemotePtr $ castRemotePtr mod mapM (mk_one c_module) ccs where mk_one c_module (decl_path,srcspan) = do - c_name <- newCString decl_path - c_srcspan <- newCString srcspan + c_name <- newCStringFromSBS decl_path + c_srcspan <- newCStringFromSBS srcspan toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan + newCStringFromSBS sbs = do + let len = BS.length sbs + buf <- mallocBytes $ len + 1 + BS.copyToPtr sbs 0 buf (fromIntegral len) + pokeByteOff buf len (0 :: Word8) + pure buf + foreign import ccall unsafe "mkCostCentre" c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre) #else ===================================== m4/fptools_set_platform_vars.m4 ===================================== @@ -77,9 +77,9 @@ dnl fi # compiler's target platform. AC_DEFUN([FPTOOLS_OVERRIDE_PLATFORM_FROM_BOOTSTRAP], [ - if test "$bootstrap_target" != "" + if test "$bootstrap_$1" != "" then - $1=$bootstrap_target + $1=$bootstrap_$1 echo "$1 platform inferred as: [$]$1" else echo "Can't work out $1 platform" ===================================== m4/ghc_toolchain.m4 ===================================== @@ -136,8 +136,10 @@ dnl and that we must compile ghc-toolchain before invoking it AC_DEFUN([FIND_GHC_TOOLCHAIN_BIN],[ case "$1" in YES) - # We're configuring the bindist, and the binary is already available - GHC_TOOLCHAIN_BIN="bin/ghc-toolchain-bin" + # We're configuring the bindist, and the binary is already available. + # For cross-compilation bindists, Hadrian names the binary with the + # cross-compile prefix (e.g. riscv64-linux-gnu-ghc-toolchain-bin). + GHC_TOOLCHAIN_BIN="bin/${CrossCompilePrefix}ghc-toolchain-bin" ;; NO) # We're in the source tree, so compile ghc-toolchain ===================================== testsuite/tests/driver/linkwhole/Main.hs ===================================== @@ -1,9 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Main (main) where import Control.Exception import Control.Monad +import Data.ByteString.Short (ShortByteString) import Foreign @@ -15,7 +17,7 @@ import GHCi.ObjLink rotateSO :: (FunPtr (IO (StablePtr a)) -> (IO (StablePtr a))) - -> String + -> ShortByteString -> (Maybe FilePath, FilePath) -> IO a rotateSO dynamicCall symName (old, newDLL) = do ===================================== testsuite/tests/ghci/should_run/T18064.script ===================================== @@ -1,2 +1,3 @@ +:set -XOverloadedStrings import GHCi.ObjLink lookupClosure "blah" ===================================== testsuite/tests/rts/KeepCafsMain.hs ===================================== @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + module Main (main) where import Foreign ===================================== utils/jsffi/dyld.mjs ===================================== @@ -1334,6 +1334,13 @@ class DyLD { } return 0; } + + lookupSymbolPtr(symPtr, symLen) { + const sym = new TextDecoder("utf-8", { fatal: true }).decode( + new Uint8Array(this.#memory.buffer, symPtr, symLen) + ); + return this.lookupSymbol(sym); + } } // The main entry point of dyld that may be run on node/browser, and View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7df6bd1694e8fe7c6a52673858639ee... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7df6bd1694e8fe7c6a52673858639ee... You're receiving this email because of your account on gitlab.haskell.org.