Adam Gundry pushed to branch wip/amg/castz at Glasgow Haskell Compiler / GHC Commits: 307ee28a by Adam Gundry at 2025-11-25T14:26:41+00:00 Fumble around trying to fix optimisation bugs - - - - - 3 changed files: - compiler/GHC/Core/Opt/Arity.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/SimpleOpt.hs Changes: ===================================== compiler/GHC/Core/Opt/Arity.hs ===================================== @@ -2246,13 +2246,13 @@ etaInfoApp in_scope expr eis -- Beta-reduction if possible, pushing any intervening casts past -- the argument. See Note [The EtaInfo mechanism] go subst (Lam v e) (EI (b:bs) mco) - | Just (arg,mco') <- pushCoArg (exprType (Lam v e)) mco (varToCoreExpr b) + | Just (arg,_, mco') <- pushCoArg (exprType (Lam v e)) mco (varToCoreExpr b) = go (Core.extendSubst subst v arg) e (EI bs mco') -- Stop pushing down; just wrap the expression up -- See Note [Check for reflexive casts in eta expansion] go subst e (EI bs mco) = Core.substExprSC subst e - `mkCastCo` checkReflexiveCastCo (exprType e) mco -- TODO check type + `mkCastCo` checkReflexiveCastCo (exprType e) mco `mkVarApps` bs -------------- @@ -2359,12 +2359,12 @@ mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty -- with an explicit lambda having a non-function type mkEtaForAllMCo :: ForAllTyBinder -> Type -> CastCoercion -> CastCoercion -mkEtaForAllMCo (Bndr tcv vis) ty mco +mkEtaForAllMCo bdnr@(Bndr tcv vis) ty mco = case mco of ReflCastCo | vis == coreTyLamForAllTyFlag -> ReflCastCo | otherwise -> mk_fco (mkRepReflCo ty) CCoercion co -> mk_fco co - ZCoercion _ty2 cos -> ZCoercion ty cos -- TODO: is ty right? + ZCoercion tyR cos -> ZCoercion (mkForAllTy bdnr tyR) cos where mk_fco co = CCoercion (mkForAllCo tcv vis coreTyLamForAllTyFlag MRefl co) -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly @@ -2871,17 +2871,17 @@ Here we implement the "push rules" from FC papers: by pushing the coercion into the arguments -} -pushCoArgs :: Type -> CastCoercion -> [CoreArg] -> Maybe ([CoreArg], CastCoercion) -pushCoArgs _ co [] = return ([], co) +pushCoArgs :: Type -> CastCoercion -> [CoreArg] -> Maybe ([CoreArg], Type, CastCoercion) +pushCoArgs fun_ty co [] = return ([], fun_ty, co) pushCoArgs fun_ty co (arg:args) = do - { (arg', m_co1) <- pushCoArg fun_ty co arg + { (arg', ty, m_co1) <- pushCoArg fun_ty co arg ; if isReflCastCo m_co1 - then return (arg':args, ReflCastCo) - else do { (args', m_co2) <- pushCoArgs (funResultTy fun_ty) m_co1 args -- TODO check type - ; return (arg':args', m_co2) } + then return (arg':args, ty, ReflCastCo) + else do { (args', ty', m_co2) <- pushCoArgs ty m_co1 args + ; return (arg':args', ty', m_co2) } } -pushCoArg :: Type -> CastCoercion -> CoreArg -> Maybe (CoreArg, CastCoercion) +pushCoArg :: Type -> CastCoercion -> CoreArg -> Maybe (CoreArg, Type, CastCoercion) -- We have (fun |> co) arg, and we want to transform it to -- (fun arg) |> co -- This may fail, e.g. if (fun :: N) where N is a newtype @@ -2889,22 +2889,22 @@ pushCoArg :: Type -> CastCoercion -> CoreArg -> Maybe (CoreArg, CastCoercion) -- 'co' is always Representational pushCoArg fun_ty co arg | Type ty <- arg - = do { (ty', m_co') <- pushCastCoTyArg co ty - ; return (Type ty', m_co') } + = do { (ty', ty, m_co') <- pushCastCoTyArg co ty + ; return (Type ty', ty, m_co') } | otherwise - = do { (arg_mco, m_co') <- pushCastCoValArg fun_ty co - ; let arg_mco' = checkReflexiveCastCo (funArgTy fun_ty) arg_mco + = do { (arg_ty, arg_mco, res_ty, m_co') <- pushCastCoValArg fun_ty co + ; let arg_mco' = checkReflexiveCastCo arg_ty arg_mco -- checkReflexiveCastCo: see Note [Check for reflexive casts in eta expansion] -- The coercion is very often (arg_co -> res_co), but without -- the argument coercion actually being ReflCo - ; return (arg `mkCastCo` arg_mco', m_co') } + ; return (arg `mkCastCo` arg_mco', res_ty, m_co') } -pushCastCoTyArg :: CastCoercion -> Type -> Maybe (Type, CastCoercion) +pushCastCoTyArg :: CastCoercion -> Type -> Maybe (Type, Type, CastCoercion) pushCastCoTyArg (CCoercion co) ty = pushCoTyArg co ty -pushCastCoTyArg ReflCastCo ty = Just (ty, ReflCastCo) +pushCastCoTyArg ReflCastCo ty = Just (ty, error "TODO: asdasdad", ReflCastCo) pushCastCoTyArg (ZCoercion _fun_ty _cos) _ty = Nothing -- TODO do better -pushCoTyArg :: CoercionR -> Type -> Maybe (Type, CastCoercion) +pushCoTyArg :: CoercionR -> Type -> Maybe (Type, Type, CastCoercion) -- We have (fun |> co) @ty -- Push the coercion through to return -- (fun @ty') |> co' @@ -2916,11 +2916,11 @@ pushCoTyArg co ty -- -- = Just (ty, Nothing) | isReflCo co - = Just (ty, ReflCastCo) + = Just (ty, coercionLKind co2, ReflCastCo) | isForAllTy_ty tyL = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $ - Just (ty `mkCastTy` co1, CCoercion co2) + Just (ty `mkCastTy` co1, coercionLKind co2, CCoercion co2) | otherwise = Nothing @@ -2940,14 +2940,14 @@ pushCoTyArg co ty -- co2 :: ty1[ (ty|>co1)/a1 ] ~R ty2[ ty/a2 ] -- Arg of mkInstCo is always nominal, hence Nominal -pushCastCoValArg :: Type -> CastCoercion -> Maybe (CastCoercion, CastCoercion) -pushCastCoValArg _ ReflCastCo = Just (ReflCastCo, ReflCastCo) +pushCastCoValArg :: Type -> CastCoercion -> Maybe (Type, CastCoercion, Type, CastCoercion) +pushCastCoValArg tyL ReflCastCo = Just (funArgTy tyL, ReflCastCo, funResultTy tyL, ReflCastCo) pushCastCoValArg _ (CCoercion co) = pushCoValArg co pushCastCoValArg tyL (ZCoercion tyR cos) | isFunTy tyL -- TODO: do we need to check this or can we assume it? , isFunTy tyR , typeHasFixedRuntimeRep new_arg_ty - = Just (ZCoercion new_arg_ty cos, ZCoercion (funResultTy tyR) cos) + = Just (funArgTy tyL, ZCoercion new_arg_ty cos, funResultTy tyL, ZCoercion (funResultTy tyR) cos) | otherwise = Nothing where new_arg_ty = funArgTy tyR @@ -2963,7 +2963,7 @@ pushCastCoValArg tyL (ZCoercion tyR cos) -- If the LHS is well-typed, then so is the RHS. In particular, the argument -- @arg |> co_arg@ is guaranteed to have a fixed 'RuntimeRep', in the sense of -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete. -pushCoValArg :: CoercionR -> Maybe (CastCoercion, CastCoercion) +pushCoValArg :: CoercionR -> Maybe (Type, CastCoercion, Type, CastCoercion) pushCoValArg co -- The following is inefficient - don't do `eqType` here, the coercion -- optimizer will take care of it. See #14737. @@ -2971,7 +2971,7 @@ pushCoValArg co -- -- = Just (mkRepReflCo arg, Nothing) | isReflCo co - = Just (ReflCastCo, ReflCastCo) + = Just (old_arg_ty, ReflCastCo, funResultTy tyL, ReflCastCo) | isFunTy tyL , (_, co1, co2) <- decomposeFunCo co @@ -2990,7 +2990,7 @@ pushCoValArg co (vcat [ text "co:" <+> ppr co , text "old_arg_ty:" <+> ppr old_arg_ty , text "new_arg_ty:" <+> ppr new_arg_ty ]) $ - Just (coToCastCo (mkSymCo co1), coToCastCo co2) + Just (old_arg_ty, coToCastCo (mkSymCo co1), funResultTy tyL, coToCastCo co2) -- Critically, coToCastCo to checks for ReflCo; the whole coercion may not -- be reflexive, but either of its components might be -- We could use isReflexiveCo, but it's not clear if the benefit ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -1715,10 +1715,10 @@ simplCast env body co0 cont0 -- False: (mkTransCo co1 co2) is not fully optimised -- See Note [Avoid re-simplifying coercions] - addCoerce tyL co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = tail }) - | Just (arg_ty', m_co') <- pushCastCoTyArg co arg_ty + addCoerce tyL co co_is_opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail }) + | Just (arg_ty', res_ty, m_co') <- pushCastCoTyArg co arg_ty = {-#SCC "addCoerce-pushCoTyArg" #-} - do { tail' <- addCoerceM hole_ty m_co' co_is_opt tail -- TODO is hole_ty right? + do { tail' <- addCoerceM res_ty m_co' co_is_opt tail ; return (ApplyToTy { sc_arg_ty = arg_ty' , sc_cont = tail' , sc_hole_ty = tyL }) } @@ -1734,9 +1734,9 @@ simplCast env body co0 cont0 | not co_is_opt -- pushCoValArg duplicates the coercion, so optimise first = addCoerce tyL (optOutCastCoercion (zapSubstEnv env) co co_is_opt) True cont - | Just (m_co1, m_co2) <- pushCastCoValArg fun_ty co -- TODO check fun_ty + | Just (_, m_co1, res_ty, m_co2) <- pushCastCoValArg tyL co = {-#SCC "addCoerce-pushCoValArg" #-} - do { tail' <- addCoerceM (funResultTy fun_ty) m_co2 co_is_opt tail -- TODO check funResultTy fun_ty + do { tail' <- addCoerceM res_ty m_co2 co_is_opt tail ; if isReflCastCo m_co1 then return (cont { sc_cont = tail' , sc_hole_ty = tyL }) ; ===================================== compiler/GHC/Core/SimpleOpt.hs ===================================== @@ -1376,7 +1376,7 @@ exprIsConApp_maybe ise@(ISE in_scope id_unf) expr | not (tickishIsCode t) = go subst floats expr cont go subst floats (Cast expr co1) (CC args m_co2) -- TODO: is the subst_ty below needed? - | Just (args', m_co1') <- pushCoArgs (subst_ty subst (exprType expr)) (subst_cast_co subst co1) args + | Just (args', _, m_co1') <- pushCoArgs (subst_ty subst (exprType expr)) (subst_cast_co subst co1) args -- See Note [Push coercions in exprIsConApp_maybe] = go subst floats expr (CC args' (m_co1' `mkTransCastCo` m_co2)) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/307ee28a3679bfdece77c6868a7da893... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/307ee28a3679bfdece77c6868a7da893... You're receiving this email because of your account on gitlab.haskell.org.