Simon Peyton Jones pushed to branch wip/T27078 at Glasgow Haskell Compiler / GHC Commits: 964394aa by Simon Peyton Jones at 2026-04-13T23:03:33+01:00 Wibbles .. in response to RAE review - - - - - 2 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/SubstTypeLets.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -1311,7 +1311,7 @@ lambda-bound variables. So our solution is this: -* Use straightforward applicaion in the worker-wrapper pass, creating a eta-redex. +* Use straightforward applicaion in the worker-wrapper pass, creating a beta-redex. See the call to `mkApps` in GHC.Core.Opt.WorkWrap.Utils.mkWwBodies. * Tell Lint not to complain about a join-point invocation hidden under a @@ -1443,19 +1443,13 @@ lintValArg arg mult fun_ue ----------------- lintAltBinders :: UsageEnv - -> Var -- Case binder + -> Var -- Case binder -> Type -- Scrutinee type -> Type -- Constructor type -> [(Mult, OutVar)] -- Binders -> LintM UsageEnv -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism] -{- -lintAltBinders rhs_ue _case_bndr scrut_ty con_ty bndrs - = do { (res_ty, rhs_ue') <- lintApp (text ".") lintTyBndr lintValBndr con_ty bndrs - ; ensureEqTys res_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) - ; return rhs_ue } --} lintAltBinders rhs_ue _case_bndr scrut_ty con_ty [] = do { ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) ; return rhs_ue } @@ -2069,19 +2063,19 @@ lint_tyco_app msg fun_kind arg_tys ; return () } ---------------- -lintApp :: forall in_a acc. Outputable in_a => +lintApp :: forall a acc. Outputable a => SDoc - -> (in_a -> LintM Type) -- Lint the thing and return its value - -> (in_a -> Mult -> acc -> LintM (Kind, acc)) -- Lint the thing and return its type + -> (a -> LintM Type) -- Lint the thing and return its value + -> (a -> Mult -> acc -> LintM (Kind, acc)) -- Lint the thing and return its type -> Type - -> [in_a] -- The arguments, always "In" things - -> acc -- Used (only) for UsageEnv in /term/ applications + -> [a] -- The arguments + -> acc -- Used (only) for UsageEnv in /term/ applications -> LintM (Type,acc) -- lintApp is a performance-critical function, which deals with multiple -- applications such as (/\a./\b./\c. expr) @ta @tb @tc -- When returning the type of this expression we want to avoid substituting a:=ta, -- and /then/ substituting b:=tb, etc. That's quadratic, and can be a huge --- perf hole. So we gather all the arguments [in_a], and then gather the +-- perf hole. So we gather all the arguments [a], and then gather the -- substitution incrementally in the `go` loop. -- -- lintApp is used: @@ -2101,7 +2095,7 @@ lintApp msg lint_forall_arg lint_arrow_arg !orig_fun_ty all_args acc ; let init_subst = mkEmptySubst in_scope - go :: Subst -> Type -> acc -> [in_a] -> LintM (Type, acc) + go :: Subst -> Type -> acc -> [a] -> LintM (Type, acc) -- The Subst applies (only) to the fun_ty -- c.f. GHC.Core.Type.piResultTys, which has a similar loop @@ -2908,10 +2902,11 @@ data LintEnv , le_level :: LintLevel , le_in_scope :: InScopeSet - , le_in_vars :: VarEnv (Var, LintLevel) - -- Maps an Var (i.e. its unique) to its binding Var and level + , le_vars :: VarEnv (Var, LintLevel) + -- Maps a Var (i.e. its unique) to its binding Var and level -- /All/ in-scope variables are here (term variables, -- type variables, and coercion variables) + -- So the domain is the same as the le_in_scope in-scope set -- Used at an occurrence of the Var , le_joins :: UniqMap Id JoinOcc @@ -2922,7 +2917,6 @@ data LintEnv -- See Note [Linting linearity] -- Assigns usage environments to the alias-like binders, -- as found in non-recursive lets. - -- Domain is Ids , le_platform :: Platform -- ^ Target platform , le_diagOpts :: DiagOpts -- ^ Target platform @@ -3267,7 +3261,7 @@ initL cfg m init_level = 0 env = LE { le_flags = l_flags cfg , le_level = init_level - , le_in_vars = mkVarEnv [ (v,(v, init_level)) | v <- vars ] + , le_vars = mkVarEnv [ (v,(v, init_level)) | v <- vars ] , le_in_scope = mkInScopeSetList vars , le_joins = emptyUniqMap , le_loc = [] @@ -3366,9 +3360,9 @@ addInScopeId id thing_inside = LintM $ \ env errs -> unLintM thing_inside (add env) errs where - add env@(LE { le_level = level, le_in_vars = id_vars, le_joins = valid_joins + add env@(LE { le_level = level, le_vars = id_vars, le_joins = valid_joins , le_ue_aliases = aliases, le_in_scope = in_scope }) - = env { le_level = level1, le_in_vars = in_vars' + = env { le_level = level1, le_vars = in_vars' , le_in_scope = in_scope `extendInScopeSet` id , le_joins = valid_joins', le_ue_aliases = aliases' } where @@ -3388,16 +3382,16 @@ addInScopeId id thing_inside addInScopeTyCoVar :: TyCoVar -> LintM a -> LintM a -- This function clones to avoid shadowing of TyCoVars addInScopeTyCoVar tcv thing_inside - = LintM $ \ env@(LE { le_level = level, le_in_vars = in_vars + = LintM $ \ env@(LE { le_level = level, le_vars = in_vars , le_in_scope = in_scope }) errs -> let level' = level + 1 env' = env { le_level = level' , le_in_scope = in_scope `extendInScopeSet` tcv - , le_in_vars = extendVarEnv in_vars tcv (tcv, level') } + , le_vars = extendVarEnv in_vars tcv (tcv, level') } in unLintM thing_inside env' errs getInVarEnv :: LintM (VarEnv (Id, LintLevel)) -getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_in_vars env), errs)) +getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_vars env), errs)) markAllJoinsBad :: LintM a -> LintM a markAllJoinsBad m ===================================== compiler/GHC/Core/SubstTypeLets.hs ===================================== @@ -94,7 +94,7 @@ stlExpr :: Subst -> CoreExpr -> CoreExpr stlExpr subst (Let (NonRec tv (Type ty)) body) = -- This equation is the main payload of the entire pass! - stlExpr (extendTvSubst subst tv ty) body + stlExpr (extendTvSubst subst tv (substTy subst ty)) body stlExpr subst (Let bind body) = Let bind' (stlExpr subst' body) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/964394aa8a4daff4c22ff4b5b401d261... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/964394aa8a4daff4c22ff4b5b401d261... You're receiving this email because of your account on gitlab.haskell.org.