[Git][ghc/ghc][wip/amg/castz] 2 commits: Accept output change for ghci024

23 Jul 2025


      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.

    

Adam Gundry (＠adamgundry)

tags

participants (1)