Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: 5c1b0929 by Simon Peyton Jones at 2026-01-06T13:43:50+00:00 More on coercion bindings Allow in letrec; indeed make the invariants for letrec the same as the invariants for top-level bindings. ToDo: document this - - - - - 9 changed files: - compiler/GHC/Core/Coercion/Opt.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/CoreToStg/Prep.hs - compiler/GHC/Types/Var/Env.hs - hadrian/src/Flavour.hs Changes: ===================================== compiler/GHC/Core/Coercion/Opt.hs ===================================== @@ -445,12 +445,7 @@ opt_co4' env sym rep r (CoVarCo cv) where Pair ty1 ty2 = coVarTypes cv1 - cv1 = case lookupInScope (lcInScopeSet env) cv of - Just cv1 -> cv1 - Nothing -> warnPprTrace True - "opt_co: not in scope" - (ppr cv $$ ppr env) - cv + cv1 = refineFromInScope (lcInScopeSet env) cv -- cv1 might have a substituted kind! opt_co4' _ _ _ _ (HoleCo h) ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -588,22 +588,8 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty -- Check the let-can-float invariant -- See Note [Core let-can-float invariant] in GHC.Core - ; checkL ( isTopLevel top_lvl - || isJoinId binder - || mightBeLiftedType binder_ty - || (isNonRec rec_flag && exprOkForSpeculation rhs)) $ - badBndrTyMsg binder (text "unlifted") - - -- Check that if the binder is at the top level the binding - -- satisfies exprIsTopLevelBindable - -- See Note [Core top-level string literals]. - ; checkL ( not (isTopLevel top_lvl) - || exprIsTopLevelBindable rhs binder_ty - || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed - ) $ - mkTopNonLitStrMsg binder - - ; flags <- getLintFlags + ; checkL (bindingIsOk top_lvl rec_flag binder binder_ty rhs) $ + mkLetErr binder rhs -- Check that a join-point binder has a valid type -- NB: lintIdBinder has checked that it is not top-level bound @@ -612,6 +598,7 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty JoinPoint arity -> checkL (isValidJoinPointType arity binder_ty) (mkInvalidJoinPointMsg binder binder_ty) + ; flags <- getLintFlags ; when (lf_check_inline_loop_breakers flags && isStableUnfolding (realIdUnfolding binder) && isStrongLoopBreaker (idOccInfo binder) @@ -659,6 +646,28 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty -- We should check the unfolding, if any, but this is tricky because -- the unfolding is a SimplifiableCoreExpr. Give up for now. +bindingIsOk :: TopLevelFlag -> RecFlag -> OutId -> OutType -> CoreExpr -> Bool +bindingIsOk top_lvl rec_flag binder binder_ty rhs + | isCoVar binder + = isCoArg rhs + + | isJoinId binder + = not (isTopLevel top_lvl) + + -- Not a JoinId nor a CoVar + | isTopLevel top_lvl + = exprIsTopLevelBindable rhs binder_ty + || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed + + -- So not top level, not JoinId, not CoVar + | isRec rec_flag + = exprIsTopLevelBindable rhs binder_ty + + -- Not top level, not recursive + | otherwise + = mightBeLiftedType binder_ty + || exprOkForSpeculation rhs + -- | Checks the RHS of bindings. It only differs from 'lintCoreExpr' -- in that it doesn't reject occurrences of the function 'makeStatic' when they -- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and @@ -3829,11 +3838,6 @@ mkRhsMsg binder what ty hsep [text "Binder's type:", ppr (idType binder)], hsep [text "Rhs type:", ppr ty]] -badBndrTyMsg :: Id -> SDoc -> SDoc -badBndrTyMsg binder what - = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder - , text "Binder's type:" <+> ppr (idType binder) ] - mkNonTopExportedMsg :: Id -> SDoc mkNonTopExportedMsg binder = hsep [text "Non-top-level binder is marked as exported:", ppr binder] @@ -3842,10 +3846,6 @@ mkNonTopExternalNameMsg :: Id -> SDoc mkNonTopExternalNameMsg binder = hsep [text "Non-top-level binder has an external name:", ppr binder] -mkTopNonLitStrMsg :: Id -> SDoc -mkTopNonLitStrMsg binder - = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] - mkKindErrMsg :: TyVar -> Type -> SDoc mkKindErrMsg tyvar arg_ty = vcat [text "Kinds don't match in type application:", ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -624,7 +624,7 @@ reSimplifying :: SimplEnv -> Bool reSimplifying (SimplEnv { seInlineDepth = n }) = n>0 --------------------- -extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv +extendIdSubst :: HasDebugCallStack => SimplEnv -> Id -> SimplSR -> SimplEnv extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res = assertPpr (isId var && not (isCoVar var)) (ppr var) $ env { seIdSubst = extendVarEnv subst var res } @@ -934,8 +934,6 @@ addJoinFlts = appOL mkRecFloats :: SimplFloats -> SimplFloats -- Flattens the floats into a single Rec group, -- They must either all be lifted LetFloats or all JoinFloats --- --- ToDo: explain about CoVar floats mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff , sfJoinFloats = jbs , sfInScope = in_scope }) @@ -953,17 +951,7 @@ mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff flatten_rec :: OrdList OutBind -> OrdList OutBind -- Put CoVar bindings first (guaranteed non-recursive) -- then one recursive value binding - flatten_rec bs = let !(covar_bs, prs) = foldrOL do_one (nilOL, []) bs - in covar_bs `snocOL` Rec prs - - do_one :: OutBind -> (OrdList OutBind,[(OutId,OutExpr)]) - -> (OrdList OutBind,[(OutId,OutExpr)]) - do_one bind (cvbs, prs) - = case bind of - NonRec bndr rhs - | isCoVar bndr -> (bind `consOL` cvbs, prs) - | otherwise -> (cvbs, (bndr,rhs):prs) - Rec prs1 -> (cvbs, prs1 ++ prs) + flatten_rec bs = unitOL (Rec (flattenBinds (fromOL bs))) wrapFloats :: SimplFloats -> OutExpr -> OutExpr -- Wrap the floats around the expression @@ -1037,14 +1025,6 @@ substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v -- -- See also Note [In-scope set as a substitution] in GHC.Core.Opt.Simplify. -refineFromInScope :: InScopeSet -> Var -> Var -refineFromInScope in_scope v - | isLocalId v = case lookupInScope in_scope v of - Just v' -> v' - Nothing -> pprPanic "refineFromInScope" (ppr in_scope $$ ppr v) - -- c.f #19074 for a subtle place where this went wrong - | otherwise = v - lookupRecBndr :: SimplEnv -> InId -> OutId -- Look up an Id which has been put into the envt by simplRecBndrs, -- but where we have not yet done its RHS @@ -1388,7 +1368,7 @@ substCoVarBndr env cv (Subst in_scope' _ tv_env' cv_env', cv') -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') -substCo :: SimplEnv -> Coercion -> Coercion +substCo :: HasDebugCallStack => SimplEnv -> Coercion -> Coercion substCo env co = Coercion.substCo (getTCvSubst env) co ------------------ ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -258,11 +258,11 @@ simplRecBind env0 bind_cxt pairs0 = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt ; return (env', (bndr, bndr', rhs)) } + go :: SimplEnv -> [(InId, OutId, InExpr)] -> SimplM (SimplFloats, SimplEnv) go env [] = return (emptyFloats env, env) go env ((old_bndr, new_bndr, rhs) : pairs) - = do { (float, env1) <- simplRecOrTopPair env bind_cxt - old_bndr new_bndr rhs + = do { (float, env1) <- simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs ; (floats, env2) <- go env1 pairs ; return (float `addFloats` floats, env2) } @@ -842,6 +842,10 @@ makeTrivial env top_lvl dmd occ_fs expr ; simplTrace "makeTrivial:co" (ppr (Cast triv_expr triv_co)) $ return (floats1 `addLetFlts` floats2, Cast triv_expr triv_co) } + | Coercion co <- expr + = do { (floats, triv_co) <- makeCoTrivial co + ; return (floats, Coercion triv_co) } + | otherwise -- 'expr' is not of form (Cast e co) = do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr ; uniq <- getUniqueM @@ -950,12 +954,16 @@ completeBind :: BindContext -- Binder /can/ be a JoinId -- Precondition: rhs obeys the let-can-float invariant completeBind bind_cxt (old_bndr, unf_se) (new_bndr, new_rhs, env) - | isCoVar old_bndr - = case new_rhs of - Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co) - _ -> return (mkFloatBind env (NonRec new_bndr new_rhs)) - - | otherwise + | isCoVar old_bndr + = case new_rhs of + Coercion co -- Inline if it is trivial + | postInlineUnconditionally env bind_cxt old_bndr new_bndr new_rhs + -> return (emptyFloats env, extendCvSubst env old_bndr co) + _otherwise -> -- Can't inline anything other than a Coercion inside a coercion + -- So retain the binding insteadd + return (mkFloatBind env (NonRec new_bndr new_rhs)) + + | otherwise -- Non-CoVars = assert (isId new_bndr) $ do { let old_info = idInfo old_bndr old_unf = realUnfoldingInfo old_info @@ -982,8 +990,8 @@ completeBind bind_cxt (old_bndr, unf_se) (new_bndr, new_rhs, env) return ( emptyFloats env , extendIdSubst env old_bndr $ DoneEx unf_rhs (idJoinPointHood new_bndr)) } - -- Use the substitution to make quite, quite sure that the - -- substitution will happen, since we are going to discard the binding + -- Use the substitution to make quite, quite sure that the + -- substitution will happen, since we are going to discard the binding else -- Keep the binding; do cast worker/wrapper -- simplTrace "completeBind" (vcat [ text "bndrs" <+> ppr old_bndr <+> ppr new_bndr ===================================== compiler/GHC/Core/Opt/Simplify/Utils.hs ===================================== @@ -59,7 +59,7 @@ import GHC.Core.Opt.Arity import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Opt.Simplify.Monad -import GHC.Core.Type hiding( substTy ) +import GHC.Core.Type hiding( substTy, extendCvSubst ) import GHC.Core.Coercion hiding( substCo ) import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon ) import GHC.Core.Multiplicity @@ -1499,7 +1499,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env | not pre_inline_unconditionally = Nothing | not active = Nothing | isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids] - | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally] + | isCoVar bndr, not (isCoArg rhs) = Nothing -- Note [Do not inline CoVars unconditionally] | isExitJoinId bndr = Nothing -- Note [Do not inline exit join points] -- in module Exitify | not (one_occ (idOccInfo bndr)) = Nothing @@ -1511,7 +1511,9 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env | otherwise = Nothing where unf = idUnfolding bndr - extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs) + extend_subst_with inl_rhs + | Coercion co <- inl_rhs = extendCvSubst env bndr co + | otherwise = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs) one_occ IAmDead = True -- Happens in ((\x.1) v) one_occ OneOcc{ occ_n_br = 1 @@ -1548,15 +1550,16 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env -- canInlineInLam => free vars of rhs are (Once in_lam) or Many, -- so substituting rhs inside a lambda doesn't change the occ info. -- Sadly, not quite the same as exprIsHNF. - canInlineInLam (Lit _) = True - canInlineInLam (Cast e _) = canInlineInLam e - canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e - canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e - canInlineInLam (Var v) = case idOccInfo v of - OneOcc { occ_in_lam = IsInsideLam } -> True - ManyOccs {} -> True - _ -> False - canInlineInLam _ = False + canInlineInLam (Lit _) = True + canInlineInLam (Coercion _) = True + canInlineInLam (Cast e _) = canInlineInLam e + canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e + canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e + canInlineInLam (Var v) = case idOccInfo v of + OneOcc { occ_in_lam = IsInsideLam } -> True + ManyOccs {} -> True + _ -> False + canInlineInLam _ = False -- not ticks. Counting ticks cannot be duplicated, and non-counting -- ticks around a Lam will disappear anyway. @@ -1646,7 +1649,6 @@ postInlineUnconditionally env bind_cxt old_bndr bndr rhs | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally] | isTopLevel (bindContextLevel bind_cxt) = False -- Note [Top level and postInlineUnconditionally] - | isCoVar bndr = False | exprIsTrivial rhs = True | BC_Join {} <- bind_cxt = False -- See point (1) of Note [Duplicating join points] -- in GHC.Core.Opt.Simplify.Iteration ===================================== compiler/GHC/Core/TyCo/FVs.hs ===================================== @@ -350,7 +350,8 @@ deepTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and synon where do_tcv is v = EndoOS do_it where - do_it acc | v `elemVarSet` is = acc + do_it acc | not (isLocalVar v) = acc + | v `elemVarSet` is = acc | v `elemVarSet` acc = acc | otherwise = appEndoOS (deep_ty (varType v)) $ acc `extendVarSet` v @@ -412,7 +413,8 @@ shallowTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and sy where do_tcv is v = EndoOS do_it where - do_it acc | v `elemVarSet` is = acc + do_it acc | not (isLocalVar v) = acc + | v `elemVarSet` is = acc | v `elemVarSet` acc = acc | otherwise = acc `extendVarSet` v @@ -475,7 +477,8 @@ deepCoVarFolder = TyCoFolder { tcf_view = noView do_covar is v = EndoOS do_it where - do_it acc | v `elemVarSet` is = acc + do_it acc | not (isLocalVar v) = acc + | v `elemVarSet` is = acc | v `elemVarSet` acc = acc | otherwise = appEndoOS (deep_cv_ty (varType v)) $ acc `extendVarSet` v @@ -706,7 +709,10 @@ tyCoFVsOfCo (SubCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in tyCoFVsOfCoVar :: CoVar -> FV tyCoFVsOfCoVar v fv_cand in_scope acc + | isLocalId v = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc + | otherwise + = emptyFV fv_cand in_scope acc tyCoFVsOfCos :: [Coercion] -> FV tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -2548,8 +2548,10 @@ extendCorePrepEnvList cpe@(CPE { cpe_subst = subst }) prs subst2 = extendIdSubstList subst1 [(id, Var id') | (id,id') <- prs] extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv +-- The Id can be a CoVar extendCorePrepEnvExpr cpe id expr - = cpe { cpe_subst = extendIdSubst (cpe_subst cpe) id expr } + = cpe { cpe_subst = extendSubst (cpe_subst cpe) id expr } + -- NB: extendSubst not extendIdSubst; the id can be a CoVar lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr lookupCorePrepEnv cpe id ===================================== compiler/GHC/Types/Var/Env.hs ===================================== @@ -55,9 +55,9 @@ module GHC.Types.Var.Env ( -- ** Operations on InScopeSets emptyInScopeSet, mkInScopeSet, mkInScopeSetList, delInScopeSet, extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, - getInScopeVars, lookupInScope, lookupInScope_Directly, + lookupInScope, lookupInScope_Directly, refineFromInScope, unionInScope, elemInScopeSet, uniqAway, - varSetInScope, + varSetInScope, getInScopeVars, unsafeGetFreshLocalUnique, -- * The RnEnv2 type @@ -191,6 +191,14 @@ unionInScope (InScope s1) (InScope s2) varSetInScope :: VarSet -> InScopeSet -> Bool varSetInScope vars (InScope s1) = vars `subVarSet` s1 +refineFromInScope :: HasDebugCallStack => InScopeSet -> Var -> Var +refineFromInScope in_scope v + | isLocalVar v = case lookupInScope in_scope v of + Just v' -> v' + Nothing -> pprPanic "refineFromInScope" (ppr in_scope $$ ppr v) + -- c.f #19074 for a subtle place where this went wrong + | otherwise = v + {- Note [Local uniques] ~~~~~~~~~~~~~~~~~~~~ ===================================== hadrian/src/Flavour.hs ===================================== @@ -70,7 +70,8 @@ flavourTransformers = M.fromList , "fully_static" =: fullyStatic , "host_fully_static" =: hostFullyStatic , "collect_timings" =: collectTimings - , "assertions" =: enableAssertions + , "assertions" =: enableAssertions Stage2 + , "assertions_stage1" =: enableAssertions Stage1 , "debug_ghc" =: debugGhc Stage2 , "debug_stage1_ghc" =: debugGhc Stage1 , "lint" =: enableLinting @@ -394,11 +395,11 @@ enableLateCCS = addArgs ? arg "-fprof-late" -- | Enable assertions for the stage2 compiler -enableAssertions :: Flavour -> Flavour -enableAssertions flav = flav { ghcDebugAssertions = f } +enableAssertions :: Stage -> Flavour -> Flavour +enableAssertions stage flav = flav { ghcDebugAssertions = f } where - f Stage2 = True - f st = ghcDebugAssertions flav st + f s | s == stage = True + | otherwise = ghcDebugAssertions flav s -- | Build the stage3 compiler using the non-moving GC. enableBootNonmovingGc :: Flavour -> Flavour View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5c1b0929866b379080e3f33a2aed445b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5c1b0929866b379080e3f33a2aed445b... You're receiving this email because of your account on gitlab.haskell.org.