Cheng Shao pushed to branch wip/ghci-messages-no-string at Glasgow Haskell Compiler / GHC Commits: 502e6ffe by Andrew Lelechenko at 2026-04-07T04:47:21-04:00 base: improve error message for Data.Char.chr As per https://github.com/haskell/core-libraries-committee/issues/384 - - - - - b21bd52e by Simon Peyton Jones at 2026-04-07T04:48:07-04:00 Refactor FunResCtxt a bit Fixes #27154 - - - - - 4b999500 by Cheng Shao at 2026-04-07T08:57:36+00: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> - - - - - 475642de by Cheng Shao at 2026-04-07T08:57:39+00: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> - - - - - 22 changed files: - 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/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/Head.hs - compiler/GHC/Tc/Types/ErrCtxt.hs - compiler/GHC/Tc/Utils/TcType.hs - compiler/GHC/Tc/Zonk/TcType.hs - libraries/base/changelog.md - libraries/base/tests/enum01.stdout - libraries/base/tests/enum01.stdout-alpha-dec-osf3 - libraries/base/tests/enum01.stdout-ws-64 - libraries/ghc-internal/src/GHC/Internal/Char.hs - libraries/ghci/GHCi/Message.hs - libraries/ghci/GHCi/ObjLink.hs - libraries/ghci/GHCi/Run.hs - testsuite/tests/driver/linkwhole/Main.hs - testsuite/tests/ghci/should_run/T18064.script - testsuite/tests/rts/KeepCafsMain.hs - utils/jsffi/dyld.mjs Changes: ===================================== 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/Tc/Errors/Ppr.hs ===================================== @@ -7710,12 +7710,8 @@ pprHsCtxt = \case PatSigErrCtxt sig_ty res_ty -> vcat [ hang (text "When checking that the pattern signature:") 4 (ppr sig_ty) - , nest 2 (hang (text "fits the type of its context:") 2 pp_res_ty) ] - where - -- Zonking will have turned Infer into Check - pp_res_ty = case res_ty of - Check ty -> ppr ty - Infer ir -> text "OOPS" <+> ppr ir + , nest 2 (hang (text "fits the type of its context:") + 2 (ppr (getCheckExpType res_ty))) ] PatCtxt pat -> hang (text "In the pattern:") 2 (ppr pat) @@ -7777,7 +7773,7 @@ pprHsCtxt = \case full_herald = pprExpectedFunTyHerald herald <+> speakNOf n_vis_args_in_call (text "visible argument") -- What are "visible" arguments? See Note [Visibility and arity] in GHC.Types.Basic - FunResCtxt fun n_val_args res_fun res_env n_fun n_env + FunResCtxt fun n_val_args fun_res_ty env_ty | -- Check for too few args -- fun_tau = a -> b, res_tau = Int n_fun > n_env @@ -7801,6 +7797,18 @@ pprHsCtxt = \case -> empty -- text "Debug" <+> vcat [ppr fun, ppr n_val_args, ppr res_fun, ppr res_env, ppr n_fun, ppr n_env] where + -- See Note [Splitting nested sigma types in mismatched + -- function types] + -- env_ty is an ExpRhoTy, but with simple subsumption it + -- is not /deeply/ skolemised, so still use tcSplitNestedSigmaTys + + (_,_,fun_tau) = tcSplitNestedSigmaTys fun_res_ty + (_, _, env_tau) = tcSplitNestedSigmaTys (getCheckExpType env_ty) + (args_fun, res_fun) = tcSplitFunTys fun_tau + (args_env, res_env) = tcSplitFunTys env_tau + n_fun = length args_fun + n_env = length args_env + not_fun ty -- ty is definitely not an arrow type, -- and cannot conceivably become one = case tcSplitTyConApp_maybe ty of ===================================== compiler/GHC/Tc/Gen/Head.hs ===================================== @@ -68,7 +68,6 @@ import GHC.Builtin.Names import GHC.Driver.DynFlags import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable -import GHC.Utils.Panic import GHC.Data.Maybe @@ -961,7 +960,8 @@ See Note [-fno-code mode]. * * ********************************************************************* -} -addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p] +addFunResCtxt :: HasDebugCallStack + => HsExpr GhcTc -> [HsExprArg p] -> TcType -> ExpRhoType -> TcM a -> TcM a -- When we have a mis-match in the return type of a function @@ -969,33 +969,10 @@ addFunResCtxt :: HsExpr GhcTc -> [HsExprArg p] -- But not in generated code, where we don't want -- to mention internal (rebindable syntax) function names addFunResCtxt fun args fun_res_ty env_ty thing_inside - = do { env_tv <- newFlexiTyVarTy liftedTypeKind - ; dumping <- doptM Opt_D_dump_tc_trace - ; msg <- mk_msg dumping env_tv - ; addErrCtxt msg thing_inside } + = addErrCtxt (FunResCtxt fun (count isValArg args) fun_res_ty env_ty) $ + thing_inside -- NB: use a landmark error context, so that an empty context -- doesn't suppress some more useful context - where - mk_msg dumping env_tv - = do { mb_env_ty <- readExpType_maybe env_ty - -- by the time the message is rendered, the ExpType - -- will be filled in (except if we're debugging) - ; env' <- case mb_env_ty of - Just env_ty -> return env_ty - Nothing -> do { massert dumping; return env_tv } - ; let -- See Note [Splitting nested sigma types in mismatched - -- function types] - (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res_ty - (_, _, env_tau) = tcSplitNestedSigmaTys env' - -- env_ty is an ExpRhoTy, but with simple subsumption it - -- is not deeply skolemised, so still use tcSplitNestedSigmaTys - (args_fun, res_fun) = tcSplitFunTys fun_tau - (args_env, res_env) = tcSplitFunTys env_tau - info = - FunResCtxt fun (count isValArg args) res_fun res_env - (length args_fun) (length args_env) - ; return info } - {- Note [Splitting nested sigma types in mismatched function types] ===================================== compiler/GHC/Tc/Types/ErrCtxt.hs ===================================== @@ -251,7 +251,10 @@ data HsCtxt -- | In the instance type signature of a class method. | MethSigCtxt !Name !TcType !TcType -- | In a pattern type signature. + | PatSigErrCtxt !TcType !ExpType + -- ExpType: see Note [ExpType in HsCtxt] + -- | In a pattern. | PatCtxt !(Pat GhcRn) -- | In a pattern synonym declaration. @@ -268,7 +271,10 @@ data HsCtxt -- | In a function call. | FunTysCtxt !ExpectedFunTyCtxt !Type !Int !Int -- | In the result of a function call. - | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int + + | FunResCtxt !(HsExpr GhcTc) !Int !TcType !ExpType + -- ExpType: see Note [ExpType in HsCtxt] + -- | In the declaration of a type constructor. | TyConDeclCtxt !Name !(TyConFlavour TyCon) -- | In a type or data family instance (or default instance). @@ -377,3 +383,14 @@ isHsCtxtLandmark (DerivBindCtxt{}) = True isHsCtxtLandmark (FunResCtxt{}) = True isHsCtxtLandmark (VDQWarningCtxt{}) = True isHsCtxtLandmark _ = False + +{- Note [ExpType in HsCtxt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A couple of HsCtxt constructors have ExpTypes in them. When zonking the +Infer{} case we read the hole, which should be filled in by now, and zonk +that type. Now we want to put it back: we use (Check ty') for this, so that +clients of a zonked HsCtxt don't need to be monadic. + +Result: after zonking, these ExpTypes are always (Check ty). It woudl be nice +to guarantee this statically, but it's hard to do so. +-} ===================================== compiler/GHC/Tc/Utils/TcType.hs ===================================== @@ -28,7 +28,7 @@ module GHC.Tc.Utils.TcType ( ExpType(..), ExpKind, InferResult(..), InferInstFlag(..), InferFRRFlag(..), ExpTypeFRR, ExpSigmaType, ExpSigmaTypeFRR, ExpRhoType, ExpRhoTypeFRR, - mkCheckExpType, + mkCheckExpType, getCheckExpType, checkingExpType_maybe, checkingExpType, ExpPatType(..), mkCheckExpFunPatTy, mkInvisExpPatType, @@ -440,11 +440,12 @@ data InferInstFlag -- Specifies whether the inference should return an uninstan | IIF_ShallowRho -- Trying to infer a shallow RhoType (no foralls or => at the top) -- Top-instantiate (only, regardless of DeepSubsumption) before filling the hole - -- Typically used when inferring the type of an expression + -- Used only for view patterns; see Note [View patterns and polymorphism] | IIF_DeepRho -- Trying to infer a possibly-deep RhoType (depending on DeepSubsumption) -- If DeepSubsumption is off, same as IIF_ShallowRho -- If DeepSubsumption is on, instantiate deeply before filling the hole + -- Typically used when inferring the type of an expression type ExpSigmaType = ExpType type ExpRhoType = ExpType @@ -490,6 +491,12 @@ instance Outputable InferResult where mkCheckExpType :: TcType -> ExpType mkCheckExpType = Check +getCheckExpType :: HasDebugCallStack => ExpType -> TcType +-- Expect a (Check ty). +-- See Note [ExpType in HsCtxt] in GHC.Tc.Types.ErrCtxt +getCheckExpType (Check ty) = ty +getCheckExpType (Infer ir) = pprPanic "getCheckExpType" (ppr ir) + -- | Returns the expected type when in checking mode. checkingExpType_maybe :: ExpType -> Maybe TcType checkingExpType_maybe (Check ty) = Just ty ===================================== compiler/GHC/Tc/Zonk/TcType.hs ===================================== @@ -818,19 +818,26 @@ zonkTidyHsCtxt env e@(FunAppCtxt{}) = return (env, e) zonkTidyHsCtxt env (FunTysCtxt ctxt ty i1 i2) = do (env', ty') <- zonkTidyTcType env ty return $ (env', FunTysCtxt ctxt ty' i1 i2) -zonkTidyHsCtxt env (FunResCtxt e i1 ty1 ty2 i2 i3) = do - (env', ty1') <- zonkTidyTcType env ty1 - (env', ty2') <- zonkTidyTcType env' ty2 - return $ (env', FunResCtxt e i1 ty1' ty2' i2 i3) +zonkTidyHsCtxt env (FunResCtxt e n ty1 env_ty) = do + (env', ty1') <- zonkTidyTcType env ty1 + (env', env_ty') <- zonkExpType env' env_ty + return $ (env', FunResCtxt e n ty1' env_ty') zonkTidyHsCtxt env (PatSigErrCtxt sig_ty res_ty) = do (env', sig_ty') <- zonkTidyTcType env sig_ty - (env', res_ty') <- - case res_ty of - Check ty -> zonkTidyTcType env' ty - Infer (IR {ir_ref = ref}) -> do -- inlining readExpTyp_maybe to avoid module dep loops - mb_ty <- liftIO $ readIORef ref - case mb_ty of - Nothing -> error "zonkTidyHsCtxt PatSigErrCtxt" - Just ty -> zonkTidyTcType env' ty - return (env', PatSigErrCtxt sig_ty' (Check res_ty')) + (env', res_ty') <- zonkExpType env' res_ty + return (env', PatSigErrCtxt sig_ty' res_ty') zonkTidyHsCtxt env p = return (env, p) + +zonkExpType :: TidyEnv -> ExpType -> ZonkM (TidyEnv, ExpType) +-- Zonk Infer{} to Check. The hole should have been filled in by now +zonkExpType env (Check ty) + = do { (env', ty') <- zonkTidyTcType env ty + ; return (env', Check ty') } +zonkExpType env (Infer ir@(IR { ir_ref = ref })) + = do { -- inlining readExpTyp_maybe to avoid module dep loops + ; mb_ty <- liftIO $ readIORef ref + ; case mb_ty of + Nothing -> pprPanic "zonkTidyHsCtxt PatSigErrCtxt" (ppr ir) + Just ty -> do { (env', ty') <- zonkTidyTcType env ty + ; return (env', Check ty') } } + ===================================== libraries/base/changelog.md ===================================== @@ -28,6 +28,7 @@ * Hide implementation details when throwing exceptions in throw and throwSTM. ([CLC proposal #387](https://github.com/haskell/core-libraries-committee/issues/387)) * Change `hIsReadable` and `hIsWritable` such that they always throw a respective exception when encountering a closed or semi-closed handle, not just in the case of a file handle. ([CLC proposal #371](github.com/haskell/core-libraries-committee/issues/371)) * Annotate `onException` continuation with `WhileHandling`. ([CLC Proposal #397](https://github.com/haskell/core-libraries-committee/issues/397)) + * Improve error message for `Data.Char.chr`. ([CLC Proposal #384](https://github.com/haskell/core-libraries-committee/issues/384)) ## 4.22.0.0 *TBA* * Shipped with GHC 9.14.1 ===================================== libraries/base/tests/enum01.stdout ===================================== @@ -81,7 +81,7 @@ Testing Enum Char: pred (maxBound::Char) = '\1114110' pred (minBound::Char) = error "Prelude.Enum.Char.pred: bad argument" (map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]) = "{\NUL\1114111" - (toEnum::Int->Char) (minBound::Int) = error "Prelude.chr: bad argument: (-2147483648)" + (toEnum::Int->Char) (minBound::Int) = error "Data.Char.chr: argument outside Unicode range: 0..1114111: (-2147483648)" (map fromEnum ['X',minBound,maxBound]) = [88,0,1114111] (take 7 ['\NUL' .. ]) = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK" (take 7 ['\250' .. ]) = "\250\251\252\253\254\255\256" ===================================== libraries/base/tests/enum01.stdout-alpha-dec-osf3 ===================================== @@ -65,7 +65,7 @@ Testing Enum Char: pred (maxBound::Char) = '\1114110' pred (minBound::Char) = error "Prelude.Enum.Char.pred: bad argument" (map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]) = "{\NUL\1114111" - (toEnum::Int->Char) (minBound::Int) = error "Prelude.chr: bad argument" + (toEnum::Int->Char) (minBound::Int) = error "Data.Char.chr: argument outside Unicode range: 0..1114111:" (map fromEnum ['X',minBound,maxBound]) = [88,0,1114111] (take 7 ['\NUL' .. ]) = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK" (take 7 ['\250' .. ]) = "\250\251\252\253\254\255\256" ===================================== libraries/base/tests/enum01.stdout-ws-64 ===================================== @@ -81,7 +81,7 @@ Testing Enum Char: pred (maxBound::Char) = '\1114110' pred (minBound::Char) = error "Prelude.Enum.Char.pred: bad argument" (map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]) = "{\NUL\1114111" - (toEnum::Int->Char) (minBound::Int) = error "Prelude.chr: bad argument: (-9223372036854775808)" + (toEnum::Int->Char) (minBound::Int) = error "Data.Char.chr: argument outside Unicode range: 0..1114111: (-9223372036854775808)" (map fromEnum ['X',minBound,maxBound]) = [88,0,1114111] (take 7 ['\NUL' .. ]) = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK" (take 7 ['\250' .. ]) = "\250\251\252\253\254\255\256" ===================================== libraries/ghc-internal/src/GHC/Internal/Char.hs ===================================== @@ -12,7 +12,7 @@ module GHC.Internal.Char import GHC.Internal.Classes (eqChar, neChar) import GHC.Internal.Base (otherwise, (++)) -import GHC.Internal.Err (errorWithoutStackTrace) +import GHC.Internal.Err (error) import GHC.Internal.Show import GHC.Internal.Prim (chr#, int2Word#, leWord#, Int#, Char#) import GHC.Internal.Types (Char(..), Int(..), isTrue#) @@ -29,4 +29,7 @@ safe_chr# i# {-# NOINLINE chr_error #-} chr_error :: Int# -> Char# -chr_error i# = errorWithoutStackTrace ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) (I# i#) "") +chr_error i# = error ("Data.Char.chr: argument outside Unicode range: 0..1114111: " ++ showSignedInt (I# 9#) (I# i#) "") +-- It's not really "Data.Char", but we assume that +-- the majority of users will import it from "base:Data.Char" +-- and not from "ghc-internal:GHC.Internal.Char". ===================================== 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 ===================================== 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/3506399809629de4e09c9aadc70100f... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/3506399809629de4e09c9aadc70100f... You're receiving this email because of your account on gitlab.haskell.org.