Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC Commits: e7c9343f by Adam Gundry at 2025-07-23T20:53:56+01:00 Accept output change for ghci024 - - - - - 79d86db2 by Adam Gundry at 2025-07-23T20:53:56+01:00 Attempt to move cast zapping to the zonker - - - - - 6 changed files: - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Tc/Types/Evidence.hs - compiler/GHC/Tc/Zonk/Type.hs - testsuite/tests/ghci/scripts/ghci024.stdout Changes: ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -1783,6 +1783,7 @@ dsEvBind (EvBind { eb_lhs = v, eb_rhs = r, eb_info = info }) = do dsEvTerm :: EvTerm -> DsM CoreExpr dsEvTerm (EvExpr e) = return e +dsEvTerm (EvCastExpr e co _) = return (Cast e co) dsEvTerm (EvTypeable ty ev) = dsEvTypeable ty ev dsEvTerm (EvFun { et_tvs = tvs, et_given = given , et_binds = ev_binds, et_body = wanted_id }) ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -30,6 +30,7 @@ import GHC.Types.Avail ( Avails ) import GHC.Data.Bag ( Bag, bagToList ) import GHC.Types.Basic import GHC.Data.BooleanFormula +import GHC.Core ( Expr(Cast) ) import GHC.Core.Class ( className, classSCSelIds ) import GHC.Core.ConLike ( conLikeName ) import GHC.Core.FVs @@ -674,6 +675,7 @@ instance ToHie (Context (Located (WithUserRdr Name))) where evVarsOfTermList :: EvTerm -> [EvId] evVarsOfTermList (EvExpr e) = exprSomeFreeVarsList isEvVar e +evVarsOfTermList (EvCastExpr e co _ty) = exprSomeFreeVarsList isEvVar (Cast e co) -- TODO really evVarsOfTermList (EvTypeable _ ev) = case ev of EvTypeableTyCon _ e -> concatMap evVarsOfTermList e ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -36,8 +36,8 @@ import GHC.Core.Predicate import GHC.Core.Reduction import GHC.Core.Coercion import GHC.Core.Class( classHasSCs ) -import GHC.Core.TyCo.FVs -import GHC.Core.TyCo.Rep (Coercion(..)) +-- import GHC.Core.TyCo.FVs +-- import GHC.Core.TyCo.Rep (Coercion(..)) import GHC.Types.Id( idType ) import GHC.Types.Var( EvVar, tyVarKind ) @@ -52,7 +52,7 @@ import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Driver.Session -import GHC.Driver.DynFlags ( hasZapCasts ) +-- import GHC.Driver.DynFlags ( hasZapCasts ) import Data.List( deleteFirstsBy ) @@ -1457,12 +1457,12 @@ finish_rewrite (Reduction co new_pred) rewriters = assert (isEmptyRewriterSet rewriters) $ -- this is a Given, not a wanted - do { zap_casts <- hasZapCasts <$> getDynFlags + do { -- zap_casts <- hasZapCasts <$> getDynFlags ; let loc = ctEvLoc ev -- mkEvCast optimises ReflCo ev_rw_role = ctEvRewriteRole ev new_tm = assert (coercionRole co == ev_rw_role) - evCastCo (evId old_evar) (mkCastCoercion zap_casts new_pred (downgradeRole Representational ev_rw_role co)) + evCastCo (evId old_evar) (downgradeRole Representational ev_rw_role co) new_pred ; new_ev <- newGivenEvVar loc (new_pred, new_tm) ; continueWith $ CtGiven new_ev } @@ -1470,14 +1470,14 @@ finish_rewrite ev@(CtWanted (WantedCt { ctev_pred = old_pred, ctev_rewriters = rewriters, ctev_dest = dest })) (Reduction co new_pred) new_rewriters - = do { zap_casts <- hasZapCasts <$> getDynFlags + = do { -- zap_casts <- hasZapCasts <$> getDynFlags ; let loc = ctEvLoc ev rewriters' = rewriters S.<> new_rewriters ev_rw_role = ctEvRewriteRole ev ; mb_new_ev <- newWanted loc rewriters' new_pred ; massert (coercionRole co == ev_rw_role) ; setWantedEvTerm dest EvCanonical $ - evCastCo (getEvExpr mb_new_ev) (mkCastCoercion zap_casts old_pred (downgradeRole Representational ev_rw_role (mkSymCo co))) + evCastCo (getEvExpr mb_new_ev) (downgradeRole Representational ev_rw_role (mkSymCo co)) old_pred ; case mb_new_ev of Fresh new_ev -> continueWith $ CtWanted new_ev Cached _ -> stopWith ev "Cached wanted" } @@ -1492,10 +1492,10 @@ finish_rewrite -- -- See Note [Zapped casts] in GHC.Core.TyCo.Rep. -- -mkCastCoercion :: Bool -> Type -> Coercion -> CastCoercion -mkCastCoercion zap_casts lhs_ty co - | isSmallCo co || not zap_casts = CCoercion co - | otherwise = ZCoercion lhs_ty (shallowCoVarsOfCo co) +-- mkCastCoercion :: Bool -> Type -> Coercion -> CastCoercion +-- mkCastCoercion zap_casts lhs_ty co +-- | isSmallCo co || not zap_casts = CCoercion co +-- | otherwise = ZCoercion lhs_ty (shallowCoVarsOfCo co) -- | Is this coercion probably smaller than its type? This is a rough heuristic, -- but crucially we treat axioms (perhaps wrapped in Sym/Sub/etc.) as small @@ -1505,24 +1505,24 @@ mkCastCoercion zap_casts lhs_ty co -- -- so we want to cast by `CCoercion (axF <Int>)` rather than `ZCoercion SomeVeryBigType []`. -- -isSmallCo :: Coercion -> Bool -isSmallCo Refl{} = True -isSmallCo GRefl{} = True -isSmallCo AxiomCo{} = True -isSmallCo CoVarCo{} = True -isSmallCo (SymCo co) = isSmallCo co -isSmallCo (KindCo co) = isSmallCo co -isSmallCo (SubCo co) = isSmallCo co -isSmallCo TyConAppCo{} = False -isSmallCo AppCo{} = False -isSmallCo ForAllCo{} = False -isSmallCo FunCo{} = False -isSmallCo UnivCo{} = False -isSmallCo TransCo{} = False -isSmallCo SelCo{} = False -isSmallCo LRCo{} = False -isSmallCo InstCo{} = False -isSmallCo HoleCo{} = False +-- isSmallCo :: Coercion -> Bool +-- isSmallCo Refl{} = True +-- isSmallCo GRefl{} = True +-- isSmallCo AxiomCo{} = True +-- isSmallCo CoVarCo{} = True +-- isSmallCo (SymCo co) = isSmallCo co +-- isSmallCo (KindCo co) = isSmallCo co +-- isSmallCo (SubCo co) = isSmallCo co +-- isSmallCo TyConAppCo{} = False +-- isSmallCo AppCo{} = False +-- isSmallCo ForAllCo{} = False +-- isSmallCo FunCo{} = False +-- isSmallCo UnivCo{} = False +-- isSmallCo TransCo{} = False +-- isSmallCo SelCo{} = False +-- isSmallCo LRCo{} = False +-- isSmallCo InstCo{} = False +-- isSmallCo HoleCo{} = False {- ******************************************************************* ===================================== compiler/GHC/Tc/Types/Evidence.hs ===================================== @@ -502,6 +502,8 @@ mkGivenEvBind ev tm = EvBind { eb_info = EvBindGiven, eb_lhs = ev, eb_rhs = tm } data EvTerm = EvExpr EvExpr + | EvCastExpr EvExpr TcCastCoercion TcType + | EvTypeable Type EvTypeable -- Dictionary for (Typeable ty) | EvFun -- /\as \ds. let binds in v @@ -530,10 +532,10 @@ evCoercion co = EvExpr (Coercion co) -- | d |> co evCast :: EvExpr -> TcCoercion -> EvTerm evCast et tc | isReflCo tc = EvExpr et - | otherwise = evCastCo et (CCoercion tc) + | otherwise = EvExpr (Cast et (CCoercion tc)) -evCastCo :: EvExpr -> TcCastCoercion -> EvTerm -evCastCo et tc = EvExpr (Cast et tc) +evCastCo :: EvExpr -> TcCoercion -> TcType -> EvTerm +evCastCo et co co_res_ty = EvCastExpr et (CCoercion co) co_res_ty -- Dictionary instance application evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm @@ -889,6 +891,7 @@ findNeededEvVars ev_binds seeds evVarsOfTerm :: EvTerm -> VarSet evVarsOfTerm (EvExpr e) = exprSomeFreeVars isEvVar e +evVarsOfTerm (EvCastExpr e co _ty) = exprSomeFreeVars isEvVar (Cast e co) -- TODO safe to ignore ty here? evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev evVarsOfTerm (EvFun {}) = emptyVarSet -- See Note [Free vars of EvFun] @@ -985,6 +988,7 @@ instance Outputable EvBind where instance Outputable EvTerm where ppr (EvExpr e) = ppr e + ppr (EvCastExpr e co ty) = text "EvCastExpr" <+> ppr e <+> ppr co <+> ppr ty ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty ppr (EvFun { et_tvs = tvs, et_given = gs, et_binds = bs, et_body = w }) = hang (text "\\" <+> sep (map pprLamBndr (tvs ++ gs)) <+> arrow) ===================================== compiler/GHC/Tc/Zonk/Type.hs ===================================== @@ -59,6 +59,7 @@ import GHC.Tc.Zonk.TcType ( tcInitTidyEnv, tcInitOpenTidyEnv , writeMetaTyVarRef , checkCoercionHole + , unpackCoercionHole_maybe , zonkCoVar ) import GHC.Core.Type @@ -97,6 +98,9 @@ import Control.Monad import Control.Monad.Trans.Class ( lift ) import Data.List.NonEmpty ( NonEmpty ) import Data.Foldable ( toList ) +import Data.Semigroup + +import GHC.Driver.DynFlags ( getDynFlags, hasZapCasts ) {- Note [What is zonking?] ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1762,9 +1766,49 @@ Wrinkles: ************************************************************************ -} +zonkShallowCoVarsOfCo :: TcCoercion -> ZonkTcM CoVarSet +zonkShallowCoVarsOfCo co + = unZCVSM $ go_co co + where + go_hole :: CoercionHole -> ZonkTcM CoVarSet + go_hole hole + = do { m_co <- lift $ liftZonkM $ unpackCoercionHole_maybe hole + ; case m_co of + Nothing -> return emptyVarSet -- Not filled (TODO emit log message?) + Just co -> unZCVSM (go_co co) } -- Filled: look inside + + go_co :: Coercion -> ZonkCoVarSetMonoid + (_, _, go_co, _) = foldTyCo folder () + + folder :: TyCoFolder () ZonkCoVarSetMonoid + folder = TyCoFolder { tcf_view = noView + , tcf_tyvar = \ _ _ -> mempty + , tcf_covar = \ _ cv -> ZCVSM (pure (unitVarSet cv)) + , tcf_hole = \ _ -> ZCVSM . go_hole + , tcf_tycobinder = \ _ _ _ -> () } + +newtype ZonkCoVarSetMonoid = ZCVSM { unZCVSM :: ZonkTcM CoVarSet } + +instance Semigroup ZonkCoVarSetMonoid where + ZCVSM l <> ZCVSM r = ZCVSM (unionVarSet <$> l <*> r) + +instance Monoid ZonkCoVarSetMonoid where + mempty = ZCVSM (return emptyVarSet) + + + zonkEvTerm :: EvTerm -> ZonkTcM EvTerm zonkEvTerm (EvExpr e) = EvExpr <$> zonkCoreExpr e +zonkEvTerm (EvCastExpr e (CCoercion co) co_res_ty) + = do { zap_casts <- hasZapCasts <$> lift getDynFlags + ; co_res_ty' <- zonkTcTypeToTypeX co_res_ty + ; if zap_casts + then EvCastExpr <$> zonkCoreExpr e <*> (ZCoercion co_res_ty' <$> zonkShallowCoVarsOfCo co) <*> pure co_res_ty' + else EvExpr <$> zonkCoreExpr (Cast e (CCoercion co)) + } +zonkEvTerm ev@(EvCastExpr _ (ZCoercion{}) _) + = pprPanic "zonkEvTerm: ZCoercion" (ppr ev) zonkEvTerm (EvTypeable ty ev) = EvTypeable <$> zonkTcTypeToTypeX ty <*> zonkEvTypeable ev zonkEvTerm (EvFun { et_tvs = tvs, et_given = evs ===================================== testsuite/tests/ghci/scripts/ghci024.stdout ===================================== @@ -15,6 +15,7 @@ other dynamic, non-language, flag settings: -fshow-warning-groups -fprefer-byte-code -fbreak-points + -fno-zap-casts warning settings: -Wpattern-namespace-specifier ~~~~~~~~~~ Testing :set -a View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/32459579d089bd4a389a3c1b56ef6f2... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/32459579d089bd4a389a3c1b56ef6f2... You're receiving this email because of your account on gitlab.haskell.org.