diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -855,7 +855,7 @@ -- | The Arity returned is the number of value args the -- expression can be applied to without doing much work -exprEtaExpandArity :: ArityOpts -> CoreExpr -> Maybe SafeArityType +exprEtaExpandArity :: HasDebugCallStack => ArityOpts -> CoreExpr -> Maybe SafeArityType -- exprEtaExpandArity is used when eta expanding -- e ==> \xy -> e x y -- Nothing if the expression has arity 0 diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs --- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -2251,34 +2251,44 @@ (ApplyToVal { sc_arg = arg, sc_env = arg_se , sc_cont = cont, sc_hole_ty = fun_ty }) | fun_id `hasKey` runRWKey - , [ TyArg {}, TyArg {} ] <- rev_args - -- Do this even if (contIsStop cont) + , [ TyArg { as_arg_ty = hole_ty }, TyArg {} ] <- rev_args + -- Do this even if (contIsStop cont), or if seCaseCase is off. -- See Note [No eta-expansion in runRW#] = do { let arg_env = arg_se `setInScopeFromE` env - ty' = contResultType cont + overall_res_ty = contResultType cont + -- hole_ty is the type of the current runRW# application + (outer_cont, new_runrw_res_ty, inner_cont) + | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont) + | otherwise = (cont, hole_ty, mkBoringStop hole_ty) + -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] + -- If the argument is a literal lambda already, take a short cut - -- This isn't just efficiency; if we don't do this we get a beta-redex - -- every time, so the simplifier keeps doing more iterations. + -- This isn't just efficiency: + -- * If we don't do this we get a beta-redex every time, so the + -- simplifier keeps doing more iterations. + -- * Even more important: see Note [No eta-expansion in runRW#] ; arg' <- case arg of Lam s body -> do { (env', s') <- simplBinder arg_env s - ; body' <- simplExprC env' body cont + ; body' <- simplExprC env' body inner_cont ; return (Lam s' body') } -- Important: do not try to eta-expand this lambda -- See Note [No eta-expansion in runRW#] + _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy ; let (m,_,_) = splitFunTy fun_ty env' = arg_env `addNewInScopeIds` [s'] cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s' - , sc_env = env', sc_cont = cont - , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' } + , sc_env = env', sc_cont = inner_cont + , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty } -- cont' applies to s', then K ; body' <- simplExprC env' arg cont' ; return (Lam s' body') } - ; let rr' = getRuntimeRep ty' - call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg'] - ; return (emptyFloats env, call') } + ; let rr' = getRuntimeRep new_runrw_res_ty + call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg'] + ; rebuild env call' outer_cont } ---------- Simplify value arguments -------------------- rebuildCall env fun_info @@ -2291,7 +2301,8 @@ -- Strict arguments | isStrictArgInfo fun_info - , seCaseCase env + , seCaseCase env -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setInScopeFromE` env) arg (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty @@ -3110,7 +3121,9 @@ -------------------------------------------------- reallyRebuildCase env scrut case_bndr alts cont - | not (seCaseCase env) + | not (seCaseCase env) -- Only when case-of-case is on. + -- See GHC.Driver.Config.Core.Opt.Simplify + -- Note [Case-of-case and full laziness] = do { case_expr <- simplAlts env scrut case_bndr alts (mkBoringStop (contHoleType cont)) ; rebuild env case_expr cont } diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -47,7 +47,7 @@ import GHC.Core -- All of it import GHC.Core.Subst import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) -import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars +import GHC.Core.FVs ( exprFreeVars, bindFreeVars , rulesFreeVarsDSet, exprsOrphNames ) import GHC.Core.Utils ( exprType, mkTick, mkTicks , stripTicksTopT, stripTicksTopE @@ -1805,41 +1805,59 @@ vcat [ p $$ line | p <- bagToList results ] ] where + line = text (replicate 20 '-') env = RuleCheckEnv { rc_is_active = isActive phase , rc_id_unf = idUnfolding -- Not quite right -- Should use activeUnfolding , rc_pattern = rule_pat , rc_rules = rules , rc_ropts = ropts - } - results = unionManyBags (map (ruleCheckBind env) binds) - line = text (replicate 20 '-') + , rc_in_scope = emptyInScopeSet } -data RuleCheckEnv = RuleCheckEnv { - rc_is_active :: Activation -> Bool, - rc_id_unf :: IdUnfoldingFun, - rc_pattern :: String, - rc_rules :: Id -> [CoreRule], - rc_ropts :: RuleOpts -} + results = go env binds -ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc + go _ [] = emptyBag + go env (bind:binds) = let (env', ds) = ruleCheckBind env bind + in ds `unionBags` go env' binds + +data RuleCheckEnv = RuleCheckEnv + { rc_is_active :: Activation -> Bool + , rc_id_unf :: IdUnfoldingFun + , rc_pattern :: String + , rc_rules :: Id -> [CoreRule] + , rc_ropts :: RuleOpts + , rc_in_scope :: InScopeSet } + +extendInScopeRC :: RuleCheckEnv -> Var -> RuleCheckEnv +extendInScopeRC env@(RuleCheckEnv { rc_in_scope = in_scope }) v + = env { rc_in_scope = in_scope `extendInScopeSet` v } + +extendInScopeListRC :: RuleCheckEnv -> [Var] -> RuleCheckEnv +extendInScopeListRC env@(RuleCheckEnv { rc_in_scope = in_scope }) vs + = env { rc_in_scope = in_scope `extendInScopeSetList` vs } + +ruleCheckBind :: RuleCheckEnv -> CoreBind -> (RuleCheckEnv, Bag SDoc) -- The Bag returned has one SDoc for each call site found -ruleCheckBind env (NonRec _ r) = ruleCheck env r -ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs] +ruleCheckBind env (NonRec b r) = (env `extendInScopeRC` b, ruleCheck env r) +ruleCheckBind env (Rec prs) = (env', unionManyBags (map (ruleCheck env') rhss)) + where + (bs, rhss) = unzip prs + env' = env `extendInScopeListRC` bs ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc -ruleCheck _ (Var _) = emptyBag -ruleCheck _ (Lit _) = emptyBag -ruleCheck _ (Type _) = emptyBag -ruleCheck _ (Coercion _) = emptyBag -ruleCheck env (App f a) = ruleCheckApp env (App f a) [] -ruleCheck env (Tick _ e) = ruleCheck env e -ruleCheck env (Cast e _) = ruleCheck env e -ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e -ruleCheck env (Lam _ e) = ruleCheck env e -ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` - unionManyBags [ruleCheck env r | Alt _ _ r <- as] +ruleCheck _ (Var _) = emptyBag +ruleCheck _ (Lit _) = emptyBag +ruleCheck _ (Type _) = emptyBag +ruleCheck _ (Coercion _) = emptyBag +ruleCheck env (App f a) = ruleCheckApp env (App f a) [] +ruleCheck env (Tick _ e) = ruleCheck env e +ruleCheck env (Cast e _) = ruleCheck env e +ruleCheck env (Let bd e) = let (env', ds) = ruleCheckBind env bd + in ds `unionBags` ruleCheck env' e +ruleCheck env (Lam b e) = ruleCheck (env `extendInScopeRC` b) e +ruleCheck env (Case e b _ as) = ruleCheck env e `unionBags` + unionManyBags [ruleCheck (env `extendInScopeListRC` (b:bs)) r + | Alt _ bs r <- as] ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) @@ -1863,8 +1881,9 @@ vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), vcat (map check_rule rules)] where - n_args = length args - i_args = args `zip` [1::Int ..] + in_scope = rc_in_scope env + n_args = length args + i_args = args `zip` [1::Int ..] rough_args = map roughTopName args check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule @@ -1894,10 +1913,8 @@ mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, not (isJust (match_fn rule_arg arg))] - lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl where - in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg) renv = RV { rv_lcl = mkRnEnv2 in_scope , rv_tmpls = mkVarSet rule_bndrs , rv_fltR = mkEmptySubst in_scope diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -229,13 +229,14 @@ (env', r) = k env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)} --------------- -simple_opt_clo :: InScopeSet +simple_opt_clo :: HasCallStack + => InScopeSet -> SimpleClo -> OutExpr simple_opt_clo in_scope (e_env, e) = simple_opt_expr (soeSetInScope in_scope e_env) e -simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr +simple_opt_expr :: HasDebugCallStack => SimpleOptEnv -> InExpr -> OutExpr simple_opt_expr env expr = go expr where @@ -399,7 +400,8 @@ simple_app env e as = finish_app env (simple_opt_expr env e) as -finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr +finish_app :: HasCallStack + => SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr -- See Note [Eliminate casts in function position] finish_app env (Cast (Lam x e) co) as@(_:_) | not (isTyVar x) && not (isCoVar x) diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -1587,7 +1587,7 @@ Just (_, tys) -> Just tys Nothing -> Nothing -tyConAppArgs :: HasCallStack => Type -> [Type] +tyConAppArgs :: HasDebugCallStack => Type -> [Type] tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) -- | Attempts to tease a type apart into a type constructor and the application @@ -1627,7 +1627,7 @@ -- -- Consequently, you may need to zonk your type before -- using this function. -tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) +tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -- Defined here to avoid module loops between Unify and TcType. tcSplitTyConApp_maybe ty = case coreFullView ty of diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -23,9 +23,9 @@ -- * Properties of expressions exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes, mkFunctionType, - exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, - getIdFromTrivialExpr_maybe, - exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, + exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe, + trivial_expr_fold, + exprIsDupable, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprOkForSpecEval, exprIsWorkFree, exprIsConLike, isCheapApp, isExpandableApp, isSaturatedConApp, @@ -1046,20 +1046,37 @@ it off at source. -} +{-# INLINE trivial_expr_fold #-} +trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r +-- ^ The worker function for Note [exprIsTrivial] and Note [getIdFromTrivialExpr] +-- This is meant to have the code of both functions in one place and make it +-- easy to derive custom predicates. +-- +-- (trivial_expr_fold k_id k_triv k_not_triv e) +-- * returns (k_id x) if `e` is a variable `x` (with trivial wrapping) +-- * returns (k_lit x) if `e` is a trivial literal `l` (with trivial wrapping) +-- * returns k_triv if `e` is a literal, type, or coercion (with trivial wrapping) +-- * returns k_not_triv otherwise +-- +-- where "trivial wrapping" is +-- * Type application or abstraction +-- * Ticks other than `tickishIsCode` +-- * `case e of {}` an empty case +trivial_expr_fold k_id k_lit k_triv k_not_triv = go + where + go (Var v) = k_id v -- See Note [Variables are trivial] + go (Lit l) | litIsTrivial l = k_lit l + go (Type _) = k_triv + go (Coercion _) = k_triv + go (App f t) | not (isRuntimeArg t) = go f + go (Lam b e) | not (isRuntimeVar b) = go e + go (Tick t e) | not (tickishIsCode t) = go e -- See Note [Tick trivial] + go (Cast e _) = go e + go (Case e _ _ []) = go e -- See Note [Empty case is trivial] + go _ = k_not_triv + exprIsTrivial :: CoreExpr -> Bool --- If you modify this function, you may also --- need to modify getIdFromTrivialExpr -exprIsTrivial (Var _) = True -- See Note [Variables are trivial] -exprIsTrivial (Type _) = True -exprIsTrivial (Coercion _) = True -exprIsTrivial (Lit lit) = litIsTrivial lit -exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e -exprIsTrivial (Lam b e) = not (isRuntimeVar b) && exprIsTrivial e -exprIsTrivial (Tick t e) = not (tickishIsCode t) && exprIsTrivial e - -- See Note [Tick trivial] -exprIsTrivial (Cast e _) = exprIsTrivial e -exprIsTrivial (Case e _ _ []) = exprIsTrivial e -- See Note [Empty case is trivial] -exprIsTrivial _ = False +exprIsTrivial e = trivial_expr_fold (const True) (const True) True False e {- Note [getIdFromTrivialExpr] @@ -1079,24 +1096,13 @@ -} getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id -getIdFromTrivialExpr e - = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e)) - (getIdFromTrivialExpr_maybe e) - -getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id -- See Note [getIdFromTrivialExpr] --- Th equations for this should line up with those for exprIsTrivial -getIdFromTrivialExpr_maybe e - = go e +getIdFromTrivialExpr e = trivial_expr_fold id (const panic) panic panic e where - go (App f t) | not (isRuntimeArg t) = go f - go (Tick t e) | not (tickishIsCode t) = go e - go (Cast e _) = go e - go (Lam b e) | not (isRuntimeVar b) = go e - go (Case e _ _ []) = go e - go (Var v) = Just v - go _ = Nothing + panic = pprPanic "getIdFromTrivialExpr" (ppr e) +getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id +getIdFromTrivialExpr_maybe e = trivial_expr_fold Just (const Nothing) Nothing Nothing e {- ********************************************************************* * * diff --git a/compiler/GHC/Data/Maybe.hs b/compiler/GHC/Data/Maybe.hs --- a/compiler/GHC/Data/Maybe.hs +++ b/compiler/GHC/Data/Maybe.hs @@ -33,7 +33,7 @@ import Control.Exception (SomeException(..)) import Data.Maybe import Data.Foldable ( foldlM, for_ ) -import GHC.Utils.Misc (HasCallStack) +import GHC.Utils.Misc (HasDebugCallStack) import Data.List.NonEmpty ( NonEmpty ) import Control.Applicative( Alternative( (<|>) ) ) @@ -66,7 +66,7 @@ go Nothing action = action go result@(Just _) _action = return result -expectJust :: HasCallStack => String -> Maybe a -> a +expectJust :: HasDebugCallStack => String -> Maybe a -> a {-# INLINE expectJust #-} expectJust _ (Just x) = x expectJust err Nothing = error ("expectJust " ++ err) diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs --- a/compiler/GHC/Driver/Plugins.hs +++ b/compiler/GHC/Driver/Plugins.hs @@ -405,12 +405,12 @@ loadExternalPluginLib path = do -- load library loadDLL path >>= \case - Just errmsg -> pprPanic "loadExternalPluginLib" - (vcat [ text "Can't load plugin library" - , text " Library path: " <> text path - , text " Error : " <> text errmsg - ]) - Nothing -> do + Left errmsg -> pprPanic "loadExternalPluginLib" + (vcat [ text "Can't load plugin library" + , text " Library path: " <> text path + , text " Error : " <> text errmsg + ]) + Right _ -> do -- resolve objects resolveObjs >>= \case True -> return () diff --git a/compiler/GHC/Linker/Types.hs b/compiler/GHC/Linker/Types.hs --- a/compiler/GHC/Linker/Types.hs +++ b/compiler/GHC/Linker/Types.hs @@ -40,7 +40,8 @@ import GHC.Unit ( UnitId, Module ) import GHC.ByteCode.Types ( ItblEnv, AddrEnv, CompiledByteCode ) import GHC.Fingerprint.Type ( Fingerprint ) -import GHCi.RemoteTypes ( ForeignHValue ) +import GHCi.RemoteTypes ( ForeignHValue, RemotePtr ) +import GHCi.Message ( LoadedDLL ) import GHC.Types.Var ( Id ) import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv ) @@ -75,6 +76,53 @@ The LinkerEnv maps Names to actual closures (for interpreted code only), for use during linking. + +Note [Looking up symbols in the relevant objects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #23415, we determined that a lot of time (>10s, or even up to >35s!) was +being spent on dynamically loading symbols before actually interpreting code +when `:main` was run in GHCi. The root cause was that for each symbol we wanted +to lookup, we would traverse the list of loaded objects and try find the symbol +in each of them with dlsym (i.e. looking up a symbol was, worst case, linear in +the amount of loaded objects). + +To drastically improve load time (from +-38 seconds down to +-2s), we now: + +1. For every of the native objects loaded for a given unit, store the handles returned by `dlopen`. + - In `pkgs_loaded` of the `LoaderState`, which maps `UnitId`s to + `LoadedPkgInfo`s, where the handles live in its field `loaded_pkg_hs_dlls`. + +2. When looking up a Name (e.g. `lookupHsSymbol`), find that name's `UnitId` in + the `pkgs_loaded` mapping, + +3. And only look for the symbol (with `dlsym`) on the /handles relevant to that + unit/, rather than in every loaded object. + +Note [Symbols may not be found in pkgs_loaded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Currently the `pkgs_loaded` mapping only contains the dynamic objects +associated with loaded units. Symbols defined in a static object (e.g. from a +statically-linked Haskell library) are found via the generic `lookupSymbol` +function call by `lookupHsSymbol` when the symbol is not found in any of the +dynamic objects of `pkgs_loaded`. + +The rationale here is two-fold: + + * we have only observed major link-time issues in dynamic linking; lookups in + the RTS linker's static symbol table seem to be fast enough + + * allowing symbol lookups restricted to a single ObjectCode would require the + maintenance of a symbol table per `ObjectCode`, which would introduce time and + space overhead + +This fallback is further needed because we don't look in the haskell objects +loaded for the home units (see the call to `loadModuleLinkables` in +`loadDependencies`, as opposed to the call to `loadPackages'` in the same +function which updates `pkgs_loaded`). We should ultimately keep track of the +objects loaded (probably in `objs_loaded`, for which `LinkableSet` is a bit +unsatisfactory, see a suggestion in 51c5c4eb1f2a33e4dc88e6a37b7b7c135234ce9b) +and be able to lookup symbols specifically in them too (similarly to +`lookupSymbolInDLL`). -} newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) } @@ -146,11 +194,13 @@ { loaded_pkg_uid :: !UnitId , loaded_pkg_hs_objs :: ![LibrarySpec] , loaded_pkg_non_hs_objs :: ![LibrarySpec] + , loaded_pkg_hs_dlls :: ![RemotePtr LoadedDLL] + -- ^ See Note [Looking up symbols in the relevant objects] , loaded_pkg_trans_deps :: UniqDSet UnitId } instance Outputable LoadedPkgInfo where - ppr (LoadedPkgInfo uid hs_objs non_hs_objs trans_deps) = + ppr (LoadedPkgInfo uid hs_objs non_hs_objs _ trans_deps) = vcat [ppr uid , ppr hs_objs , ppr non_hs_objs @@ -159,10 +209,10 @@ -- | Information we can use to dynamically link modules into the compiler data Linkable = LM { - linkableTime :: !UTCTime, -- ^ Time at which this linkable was built + linkableTime :: !UTCTime, -- ^ Time at which this linkable was built -- (i.e. when the bytecodes were produced, -- or the mod date on the files) - linkableModule :: !Module, -- ^ The linkable module itself + linkableModule :: !Module, -- ^ The linkable module itself linkableUnlinked :: [Unlinked] -- ^ Those files and chunks of code we have yet to link. -- diff --git a/compiler/GHC/Runtime/Interpreter/Types.hs b/compiler/GHC/Runtime/Interpreter/Types.hs --- a/compiler/GHC/Runtime/Interpreter/Types.hs +++ b/compiler/GHC/Runtime/Interpreter/Types.hs @@ -51,6 +51,9 @@ , interpLoader :: !Loader -- ^ Interpreter loader + + , interpLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ()))) + -- ^ LookupSymbol cache } data InterpInstance @@ -107,9 +110,6 @@ -- ^ Values that need to be freed before the next command is sent. -- Finalizers for ForeignRefs can append values to this list -- asynchronously. - - , instLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ()))) - -- ^ LookupSymbol cache , instExtra :: !c -- ^ Instance specific extra fields diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs --- a/compiler/GHC/Tc/Types/Constraint.hs +++ b/compiler/GHC/Tc/Types/Constraint.hs @@ -83,7 +83,7 @@ ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId, ctEvRewriters, ctEvUnique, tcEvDestUnique, mkKindEqLoc, toKindLoc, toInvisibleLoc, mkGivenLoc, - ctEvRole, setCtEvPredType, setCtEvLoc, arisesFromGivens, + ctEvRole, setCtEvPredType, setCtEvLoc, tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList, -- RewriterSet @@ -1312,25 +1312,51 @@ insolubleWC :: WantedConstraints -> Bool insolubleWC (WC { wc_impl = implics, wc_simple = simples, wc_errors = errors }) = anyBag insolubleWantedCt simples + -- insolubleWantedCt: wanteds only: see Note [Given insolubles] || anyBag insolubleImplic implics || anyBag is_insoluble errors - - where + where is_insoluble (DE_Hole hole) = isOutOfScopeHole hole -- See Note [Insoluble holes] is_insoluble (DE_NotConcrete {}) = True insolubleWantedCt :: Ct -> Bool -- Definitely insoluble, in particular /excluding/ type-hole constraints -- Namely: --- a) an insoluble constraint as per 'insolubleCt', i.e. either +-- a) an insoluble constraint as per 'insolubleIrredCt', i.e. either -- - an insoluble equality constraint (e.g. Int ~ Bool), or -- - a custom type error constraint, TypeError msg :: Constraint -- b) that does not arise from a Given or a Wanted/Wanted fundep interaction +-- See Note [Insoluble Wanteds] +insolubleWantedCt ct + | CIrredCan ir_ct <- ct + -- CIrredCan: see (IW1) in Note [Insoluble Wanteds] + , IrredCt { ir_ev = ev } <- ir_ct + , CtWanted { ctev_loc = loc, ctev_rewriters = rewriters } <- ev + -- It's a Wanted + , insolubleIrredCt ir_ct + -- It's insoluble + , isEmptyRewriterSet rewriters + -- It has no rewriters; see (IW2) in Note [Insoluble Wanteds] + , not (isGivenLoc loc) + -- isGivenLoc: see (IW3) in Note [Insoluble Wanteds] + , not (isWantedWantedFunDepOrigin (ctLocOrigin loc)) + -- origin check: see (IW4) in Note [Insoluble Wanteds] + = True + + | otherwise + = False + +-- | Returns True of constraints that are definitely insoluble, +-- as well as TypeError constraints. +-- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. -- --- See Note [Given insolubles]. -insolubleWantedCt ct = insolubleCt ct && - not (arisesFromGivens ct) && - not (isWantedWantedFunDepOrigin (ctOrigin ct)) +-- The function is tuned for application /after/ constraint solving +-- i.e. assuming canonicalisation has been done +-- That's why it looks only for IrredCt; all insoluble constraints +-- are put into CIrredCan +insolubleCt :: Ct -> Bool +insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct +insolubleCt _ = False insolubleIrredCt :: IrredCt -> Bool -- Returns True of Irred constraints that are /definitely/ insoluble @@ -1360,18 +1386,6 @@ -- > Assert 'True _errMsg = () -- > Assert _check errMsg = errMsg --- | Returns True of constraints that are definitely insoluble, --- as well as TypeError constraints. --- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. --- --- The function is tuned for application /after/ constraint solving --- i.e. assuming canonicalisation has been done --- That's why it looks only for IrredCt; all insoluble constraints --- are put into CIrredCan -insolubleCt :: Ct -> Bool -insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct -insolubleCt _ = False - -- | Does this hole represent an "out of scope" error? -- See Note [Insoluble holes] isOutOfScopeHole :: Hole -> Bool @@ -1415,6 +1429,31 @@ Bottom line: insolubleWC (called in GHC.Tc.Solver.setImplicationStatus) should ignore givens even if they are insoluble. +Note [Insoluble Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~ +insolubleWantedCt returns True of a Wanted constraint that definitely +can't be solved. But not quite all such constraints; see wrinkles. + +(IW1) insolubleWantedCt is tuned for application /after/ constraint + solving i.e. assuming canonicalisation has been done. That's why + it looks only for IrredCt; all insoluble constraints are put into + CIrredCan + +(IW2) We only treat it as insoluble if it has an empty rewriter set. (See Note + [Wanteds rewrite Wanteds].) Otherwise #25325 happens: a Wanted constraint A + that is /not/ insoluble rewrites some other Wanted constraint B, so B has A + in its rewriter set. Now B looks insoluble. The danger is that we'll + suppress reporting B because of its empty rewriter set; and suppress + reporting A because there is an insoluble B lying around. (This suppression + happens in GHC.Tc.Errors.mkErrorItem.) Solution: don't treat B as insoluble. + +(IW3) If the Wanted arises from a Given (how can that happen?), don't + treat it as a Wanted insoluble (obviously). + +(IW4) If the Wanted came from a Wanted/Wanted fundep interaction, don't + treat the constraint as insoluble. See Note [Suppressing confusing errors] + in GHC.Tc.Errors + Note [Insoluble holes] ~~~~~~~~~~~~~~~~~~~~~~ Hole constraints that ARE NOT treated as truly insoluble: @@ -2055,9 +2094,6 @@ setCtEvLoc :: CtEvidence -> CtLoc -> CtEvidence setCtEvLoc ctev loc = ctev { ctev_loc = loc } - -arisesFromGivens :: Ct -> Bool -arisesFromGivens ct = isGivenCt ct || isGivenLoc (ctLoc ct) -- | Set the type of CtEvidence. -- diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs --- a/compiler/GHC/Tc/Types/Origin.hs +++ b/compiler/GHC/Tc/Types/Origin.hs @@ -67,6 +67,7 @@ import GHC.Utils.Panic import GHC.Stack import GHC.Utils.Monad +import GHC.Utils.Misc( HasDebugCallStack ) import GHC.Types.Unique import GHC.Types.Unique.Supply @@ -311,10 +312,10 @@ -- -- We're hoping to be able to get rid of this entirely, but for the moment -- it's still needed. -unkSkol :: HasCallStack => SkolemInfo +unkSkol :: HasDebugCallStack => SkolemInfo unkSkol = SkolemInfo (mkUniqueGrimily 0) unkSkolAnon -unkSkolAnon :: HasCallStack => SkolemInfoAnon +unkSkolAnon :: HasDebugCallStack => SkolemInfoAnon unkSkolAnon = UnkSkol callStack -- | Wrap up the origin of a skolem type variable with a new 'Unique', @@ -864,7 +865,7 @@ = ctoHerald <+> pprCtO simple_origin -- | Short one-liners -pprCtO :: HasCallStack => CtOrigin -> SDoc +pprCtO :: HasDebugCallStack => CtOrigin -> SDoc pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] pprCtO AppOrigin = text "an application" diff --git a/compiler/GHC/Tc/Types/Origin.hs-boot b/compiler/GHC/Tc/Types/Origin.hs-boot --- a/compiler/GHC/Tc/Types/Origin.hs-boot +++ b/compiler/GHC/Tc/Types/Origin.hs-boot @@ -1,6 +1,6 @@ module GHC.Tc.Types.Origin where -import GHC.Stack ( HasCallStack ) +import GHC.Utils.Misc ( HasDebugCallStack ) data SkolemInfoAnon data SkolemInfo @@ -11,4 +11,4 @@ data ClsInstOrQC = IsClsInst | IsQC CtOrigin -unkSkol :: HasCallStack => SkolemInfo +unkSkol :: HasDebugCallStack => SkolemInfo diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -580,7 +580,7 @@ , mtv_ref :: IORef MetaDetails , mtv_tclvl :: TcLevel } -- See Note [TcLevel invariants] -vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails +vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails vanillaSkolemTvUnk = SkolemTv unkSkol topTcLevel False instance Outputable TcTyVarDetails where diff --git a/compiler/GHC/Tc/Utils/TcType.hs-boot b/compiler/GHC/Tc/Utils/TcType.hs-boot --- a/compiler/GHC/Tc/Utils/TcType.hs-boot +++ b/compiler/GHC/Tc/Utils/TcType.hs-boot @@ -2,13 +2,13 @@ import GHC.Utils.Outputable( SDoc ) import GHC.Prelude ( Bool ) import {-# SOURCE #-} GHC.Types.Var ( TcTyVar ) -import GHC.Stack +import GHC.Utils.Misc( HasDebugCallStack ) data MetaDetails data TcTyVarDetails pprTcTyVarDetails :: TcTyVarDetails -> SDoc -vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails +vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails isMetaTyVar :: TcTyVar -> Bool isTyConableTyVar :: TcTyVar -> Bool isConcreteTyVar :: TcTyVar -> Bool diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -296,26 +296,28 @@ mkGlobalId = Var.mkGlobalVar -- | Make a global 'Id' without any extra information at all -mkVanillaGlobal :: Name -> Type -> Id +mkVanillaGlobal :: HasDebugCallStack => Name -> Type -> Id mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo -- | Make a global 'Id' with no global information but some generic 'IdInfo' -mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id -mkVanillaGlobalWithInfo = mkGlobalId VanillaId - +mkVanillaGlobalWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id +mkVanillaGlobalWithInfo nm = + assertPpr (not $ isFieldNameSpace $ nameNameSpace nm) + (text "mkVanillaGlobalWithInfo called on record field:" <+> ppr nm) $ + mkGlobalId VanillaId nm -- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal" mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id mkLocalId name w ty = mkLocalIdWithInfo name w (assert (not (isCoVarType ty)) ty) vanillaIdInfo -- | Make a local CoVar -mkLocalCoVar :: Name -> Type -> CoVar +mkLocalCoVar :: HasDebugCallStack => Name -> Type -> CoVar mkLocalCoVar name ty = assert (isCoVarType ty) $ Var.mkLocalVar CoVarId name ManyTy ty vanillaIdInfo -- | Like 'mkLocalId', but checks the type to see if it should make a covar -mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id +mkLocalIdOrCoVar :: HasDebugCallStack => Name -> Mult -> Type -> Id mkLocalIdOrCoVar name w ty -- We should assert (eqType w Many) in the isCoVarType case. -- However, currently this assertion does not hold. @@ -339,7 +341,10 @@ -- Note [Free type variables] mkExportedVanillaId :: Name -> Type -> Id -mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo +mkExportedVanillaId name ty = + assertPpr (not $ isFieldNameSpace $ nameNameSpace name) + (text "mkExportedVanillaId called on record field:" <+> ppr name) $ + Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo -- Note [Free type variables] diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -899,15 +899,25 @@ -- needs a wrapper. This wrapper is injected into the program later in the -- CoreTidy pass. See Note [Injecting implicit bindings] in GHC.Iface.Tidy, -- along with the accompanying implementation in getTyConImplicitBinds. - wrapper_reqd = - (not new_tycon + wrapper_reqd + | isTypeDataTyCon tycon + -- `type data` declarations never have data-constructor wrappers + -- Their data constructors only live at the type level, in the + -- form of PromotedDataCon, and therefore do not need wrappers. + -- See wrinkle (W0) in Note [Type data declarations] in GHC.Rename.Module. + = False + + | otherwise + = (not new_tycon -- (Most) newtypes have only a worker, with the exception -- of some newtypes written with GADT syntax. -- See dataConUserTyVarsNeedWrapper below. && (any isBanged (ev_ibangs ++ arg_ibangs))) -- Some forcing/unboxing (includes eq_spec) + || isFamInstTyCon tycon -- Cast result - || (dataConUserTyVarsNeedWrapper data_con + + || dataConUserTyVarsNeedWrapper data_con -- If the data type was written with GADT syntax and -- orders the type variables differently from what the -- worker expects, it needs a data con wrapper to reorder @@ -916,19 +926,7 @@ -- -- NB: All GADTs return true from this function, but there -- is one exception that we must check below. - && not (isTypeDataTyCon tycon)) - -- An exception to this rule is `type data` declarations. - -- Their data constructors only live at the type level and - -- therefore do not need wrappers. - -- See Note [Type data declarations] in GHC.Rename.Module. - -- - -- Note that the other checks in this definition will - -- return False for `type data` declarations, as: - -- - -- - They cannot be newtypes - -- - They cannot have strict fields - -- - They cannot be data family instances - -- - They cannot have datatype contexts + || not (null stupid_theta) -- If the data constructor has a datatype context, -- we need a wrapper in order to drop the stupid arguments. diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs --- a/compiler/GHC/Unit/Types.hs +++ b/compiler/GHC/Unit/Types.hs @@ -101,9 +101,9 @@ import GHC.Utils.Misc import GHC.Settings.Config (cProjectUnitId) -import Control.DeepSeq +import Control.DeepSeq (NFData(..)) import Data.Data -import Data.List (sortBy ) +import Data.List (sortBy) import Data.Function import Data.Bifunctor import qualified Data.ByteString as BS diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -249,15 +249,18 @@ seekBin :: BinHandle -> Bin a -> IO () seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do sz <- readFastMutInt sz_r - if (p >= sz) + if (p > sz) then do expandBin h p; writeFastMutInt ix_r p else writeFastMutInt ix_r p --- | SeekBin but without calling expandBin +-- | 'seekBinNoExpand' moves the index pointer to the location pointed to +-- by 'Bin a'. +-- This operation may 'panic', if the pointer location is out of bounds of the +-- buffer of 'BinHandle'. seekBinNoExpand :: BinHandle -> Bin a -> IO () seekBinNoExpand (BinMem _ ix_r sz_r _) (BinPtr !p) = do sz <- readFastMutInt sz_r - if (p >= sz) + if (p > sz) then panic "seekBinNoExpand: seek out of range" else writeFastMutInt ix_r p diff --git a/compiler/GHC/Utils/Lexeme.hs b/compiler/GHC/Utils/Lexeme.hs --- a/compiler/GHC/Utils/Lexeme.hs +++ b/compiler/GHC/Utils/Lexeme.hs @@ -227,10 +227,11 @@ , "module", "newtype", "of", "then", "type", "where" , "_" ] --- | All reserved operators. Taken from section 2.4 of the 2010 Report. +-- | All reserved operators. Taken from section 2.4 of the 2010 Report, +-- excluding @\@@ and @~@ that are allowed by GHC (see GHC Proposal #229). reservedOps :: Set.Set String reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->" - , "@", "~", "=>" ] + , "=>" ] -- | Does this string contain only dashes and has at least 2 of them? isDashes :: String -> Bool diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -485,7 +485,7 @@ -- | Extract the single element of a list and panic with the given message if -- there are more elements or the list was empty. -- Like 'expectJust', but for lists. -expectOnly :: HasCallStack => String -> [a] -> a +expectOnly :: HasDebugCallStack => String -> [a] -> a {-# INLINE expectOnly #-} #if defined(DEBUG) expectOnly _ [a] = a @@ -513,7 +513,7 @@ changeLast (x:xs) x' = x : changeLast xs x' -- | Like @expectJust msg . nonEmpty@; a better alternative to 'NE.fromList'. -expectNonEmpty :: HasCallStack => String -> [a] -> NonEmpty a +expectNonEmpty :: HasDebugCallStack => String -> [a] -> NonEmpty a {-# INLINE expectNonEmpty #-} expectNonEmpty _ (x:xs) = x:|xs expectNonEmpty msg [] = expectNonEmptyPanic msg diff --git a/compiler/ghc.cabal b/compiler/ghc.cabal --- a/compiler/ghc.cabal +++ b/compiler/ghc.cabal @@ -3,7 +3,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc -Version: 9.8.2 +Version: 9.8.3 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team @@ -110,9 +110,9 @@ exceptions == 0.10.*, semaphore-compat, stm, - ghc-boot == 9.8.2, - ghc-heap == 9.8.2, - ghci == 9.8.2 + ghc-boot == 9.8.3, + ghc-heap == 9.8.3, + ghci == 9.8.3 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.14 diff --git a/ghc-lib-parser.cabal b/ghc-lib-parser.cabal --- a/ghc-lib-parser.cabal +++ b/ghc-lib-parser.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib-parser -version: 9.8.2.20240223 +version: 9.8.3.20241022 license: BSD-3-Clause license-file: LICENSE category: Development @@ -68,7 +68,7 @@ manual: True description: Pass -DTHREADED_RTS to the C toolchain library - default-language: Haskell2010 + default-language: Haskell2010 exposed: False include-dirs: rts/include @@ -76,6 +76,8 @@ ghc-lib/stage0/compiler/build compiler libraries/containers/containers/include + if impl(ghc >= 8.8.1) + ghc-options: -fno-safe-haskell if flag(threaded-rts) ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS cc-options: -DTHREADED_RTS @@ -93,17 +95,19 @@ containers >= 0.6.2.1 && < 0.7, bytestring >= 0.11.4 && < 0.13, time >= 1.4 && < 1.13, + filepath >= 1 && < 1.5, exceptions == 0.10.*, parsec, binary == 0.8.*, - filepath >= 1 && < 1.5, directory >= 1 && < 1.4, array >= 0.1 && < 0.6, deepseq >= 1.4 && < 1.6, pretty == 1.1.*, transformers >= 0.5 && < 0.7, process >= 1 && < 1.7 - build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4 + if impl(ghc >= 9.10) + build-depends: ghc-internal + build-tool-depends: alex:alex >= 3.1, happy:happy > 1.20 && < 2.0 other-extensions: BangPatterns CPP diff --git a/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs b/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs --- a/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs +++ b/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs @@ -22,10 +22,10 @@ cProjectName = "The Glorious Glasgow Haskell Compilation System" cBooterVersion :: String -cBooterVersion = "9.4.5" +cBooterVersion = "9.8.2" cStage :: String cStage = show (1 :: Int) cProjectUnitId :: String -cProjectUnitId = "ghc-9.8.2-inplace" +cProjectUnitId = "ghc-9.8.3-inplace" diff --git a/ghc-lib/stage0/lib/settings b/ghc-lib/stage0/lib/settings --- a/ghc-lib/stage0/lib/settings +++ b/ghc-lib/stage0/lib/settings @@ -2,7 +2,7 @@ ,("C compiler flags", "--target=x86_64-apple-darwin -Qunused-arguments") ,("C++ compiler command", "/usr/bin/g++") ,("C++ compiler flags", "--target=x86_64-apple-darwin ") -,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains -Wl,-no_warn_duplicate_libraries") +,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains -Wl,-no_warn_duplicate_libraries") ,("C compiler supports -no-pie", "NO") ,("Haskell CPP command", "/usr/bin/gcc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs") diff --git a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs --- a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +++ b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs @@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String -cProjectGitCommitId = "f3225ed4b3f3c4309f9342c5e40643eeb0cc45da" +cProjectGitCommitId = "72e041753f8d2c5b1fae0465277b187c61f17634" cProjectVersion :: String -cProjectVersion = "9.8.2" +cProjectVersion = "9.8.3" cProjectVersionInt :: String cProjectVersionInt = "908" cProjectPatchLevel :: String -cProjectPatchLevel = "2" +cProjectPatchLevel = "3" cProjectPatchLevel1 :: String -cProjectPatchLevel1 = "2" +cProjectPatchLevel1 = "3" cProjectPatchLevel2 :: String cProjectPatchLevel2 = "0" diff --git a/ghc/ghc-bin.cabal b/ghc/ghc-bin.cabal --- a/ghc/ghc-bin.cabal +++ b/ghc/ghc-bin.cabal @@ -2,7 +2,7 @@ -- ./configure. Make sure you are editing ghc-bin.cabal.in, not ghc-bin.cabal. Name: ghc-bin -Version: 9.8.2 +Version: 9.8.3 Copyright: XXX -- License: XXX -- License-File: XXX @@ -39,8 +39,8 @@ filepath >= 1 && < 1.5, containers >= 0.5 && < 0.7, transformers >= 0.5 && < 0.7, - ghc-boot == 9.8.2, - ghc == 9.8.2 + ghc-boot == 9.8.3, + ghc == 9.8.3 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.14 @@ -58,7 +58,7 @@ Build-depends: deepseq >= 1.4 && < 1.6, ghc-prim >= 0.5.0 && < 0.12, - ghci == 9.8.2, + ghci == 9.8.3, haskeline == 0.8.*, exceptions == 0.10.*, time >= 1.8 && < 1.13 diff --git a/libraries/ghc-boot-th/ghc-boot-th.cabal b/libraries/ghc-boot-th/ghc-boot-th.cabal --- a/libraries/ghc-boot-th/ghc-boot-th.cabal +++ b/libraries/ghc-boot-th/ghc-boot-th.cabal @@ -3,7 +3,7 @@ -- ghc-boot-th.cabal.in, not ghc-boot-th.cabal. name: ghc-boot-th -version: 9.8.2 +version: 9.8.3 license: BSD3 license-file: LICENSE category: GHC diff --git a/libraries/ghc-boot/ghc-boot.cabal b/libraries/ghc-boot/ghc-boot.cabal --- a/libraries/ghc-boot/ghc-boot.cabal +++ b/libraries/ghc-boot/ghc-boot.cabal @@ -5,7 +5,7 @@ -- ghc-boot.cabal. name: ghc-boot -version: 9.8.2 +version: 9.8.3 license: BSD-3-Clause license-file: LICENSE category: GHC @@ -77,7 +77,7 @@ directory >= 1.2 && < 1.4, filepath >= 1.3 && < 1.5, deepseq >= 1.4 && < 1.6, - ghc-boot-th == 9.8.2 + ghc-boot-th == 9.8.3 if !os(windows) build-depends: unix >= 2.7 && < 2.9 diff --git a/libraries/ghc-heap/ghc-heap.cabal b/libraries/ghc-heap/ghc-heap.cabal --- a/libraries/ghc-heap/ghc-heap.cabal +++ b/libraries/ghc-heap/ghc-heap.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghc-heap -version: 9.8.2 +version: 9.8.3 license: BSD-3-Clause license-file: LICENSE maintainer: libraries@haskell.org diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -21,6 +21,7 @@ , QState(..) , getMessage, putMessage, getTHMessage, putTHMessage , Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe + , LoadedDLL ) where import Prelude -- See note [Why do we import Prelude here?] @@ -69,8 +70,9 @@ -- 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) - LoadDLL :: String -> Message (Maybe String) + LoadDLL :: String -> Message (Either String (RemotePtr LoadedDLL)) LoadArchive :: String -> Message () -- error? LoadObj :: String -> Message () -- error? UnloadObj :: String -> Message () -- error? @@ -394,6 +396,9 @@ instance Binary a => Binary (EvalResult a) +-- | A dummy type that tags pointers returned by 'LoadDLL'. +data LoadedDLL + -- SomeException can't be serialized because it contains dynamic -- types. However, we do very limited things with the exceptions that -- are thrown by interpreted computations: @@ -465,7 +470,7 @@ #define MIN_VERSION_ghc_heap(major1,major2,minor) (\ (major1) < 9 || \ (major1) == 9 && (major2) < 8 || \ - (major1) == 9 && (major2) == 8 && (minor) <= 2) + (major1) == 9 && (major2) == 8 && (minor) <= 3) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo @@ -527,6 +532,7 @@ 36 -> Msg <$> (Seq <$> get) 37 -> Msg <$> return RtsRevertCAFs 38 -> Msg <$> (ResumeSeq <$> get) + 40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get) _ -> error $ "Unknown Message code " ++ (show b) putMessage :: Message a -> Put @@ -570,6 +576,7 @@ Seq a -> putWord8 36 >> put a RtsRevertCAFs -> putWord8 37 ResumeSeq a -> putWord8 38 >> put a + LookupSymbolInDLL dll str -> putWord8 40 >> put dll >> put str -- ----------------------------------------------------------------------------- -- Reading/writing messages diff --git a/libraries/ghci/ghci.cabal b/libraries/ghci/ghci.cabal --- a/libraries/ghci/ghci.cabal +++ b/libraries/ghci/ghci.cabal @@ -2,7 +2,7 @@ -- ../../configure. Make sure you are editing ghci.cabal.in, not ghci.cabal. name: ghci -version: 9.8.2 +version: 9.8.3 license: BSD3 license-file: LICENSE category: GHC @@ -82,8 +82,8 @@ containers >= 0.5 && < 0.7, deepseq >= 1.4 && < 1.6, filepath == 1.4.*, - ghc-boot == 9.8.2, - ghc-heap == 9.8.2, + ghc-boot == 9.8.3, + ghc-heap == 9.8.3, template-haskell == 2.21.*, transformers >= 0.5 && < 0.7 diff --git a/libraries/template-haskell/template-haskell.cabal b/libraries/template-haskell/template-haskell.cabal --- a/libraries/template-haskell/template-haskell.cabal +++ b/libraries/template-haskell/template-haskell.cabal @@ -56,7 +56,7 @@ build-depends: base >= 4.11 && < 4.20, - ghc-boot-th == 9.8.2, + ghc-boot-th == 9.8.3, ghc-prim, pretty == 1.1.*