[Git][ghc/ghc][wip/T20264] More progress
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Oct 29 23:27:24 UTC 2024
Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC
Commits:
a81b6b90 by Simon Peyton Jones at 2024-10-29T23:27:05+00:00
More progress
- - - - -
4 changed files:
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Tc/TyCl.hs
Changes:
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -89,12 +89,9 @@ import GHC.Core
import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )
import GHC.Core.Utils
import GHC.Core.Opt.Arity ( exprBotStrictness_maybe, isOneShotBndr )
-import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeDSet, scopedSort )
-import GHC.Core.TyCo.Subst ( substTy, mkTvSubstPrs )
-import GHC.Core.FVs -- all of it
+import GHC.Core.FVs
import GHC.Core.Subst
-import GHC.Core.Type ( Type, tyCoVarsOfType, mightBeUnliftedType, typeHasFixedRuntimeRep )
-import GHC.Core.Multiplicity ( pattern ManyTy )
+import GHC.Core.Type
import GHC.Types.Id
import GHC.Types.Id.Info
@@ -1783,10 +1780,9 @@ mkAbsLamTypes abs_vars ty
, text "res" <+> ppr res ]) res
-- We can apply the subst at the end there is no shadowing in abs_vars
where
- res = substTy subst (mkLamTypes abs_lam_vars ty)
+ res = expandTyVarUnfoldings (mkVarEnv tv_unf_prs) (mkLamTypes abs_lam_vars ty)
abs_lam_vars = [ v | v <- abs_vars, isNothing (tyVarUnfolding_maybe v) ]
tv_unf_prs = [ (tv,ty) | tv <- abs_vars, Just ty <- [tyVarUnfolding_maybe tv] ]
- subst = mkTvSubstPrs tv_unf_prs
mkAbsVarApps :: Expr LevelledBndr -> AbsVars -> Expr LevelledBndr
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -173,7 +173,7 @@ module GHC.Core.Type (
anyFreeVarsOfType, anyFreeVarsOfTypes,
noFreeVarsOfType,
expandTypeSynonyms, expandSynTyConApp_maybe,
- typeSize, occCheckExpand,
+ typeSize, occCheckExpand, expandTyVarUnfoldings,
-- ** Closing over kinds
closeOverKindsDSet, closeOverKindsList,
@@ -292,6 +292,7 @@ import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Data.Maybe ( orElse, isJust, firstJust )
+import Data.Functor.Identity
-- $type_classification
-- #type_classification#
@@ -506,6 +507,28 @@ on its fast path must also be inlined, linked back to this Note.
* *
********************************************************************* -}
+expandTyVarUnfoldings :: TyVarEnv Type -> Type -> Type
+-- (expandTyvarUnfoldings tvs ty) replace any occurrences of tvs in ty
+-- with their unfoldings. There are no substitution or variable-capture
+-- issues: if we have (let @a = ty in body), then at all occurrences of `a`
+-- the free vars of `body` are also in scope, without having been shadowed.
+expandTyVarUnfoldings tvs ty
+ | isEmptyVarEnv tvs = ty
+ | otherwise = runIdentity (expand ty)
+ where
+ expand :: Type -> Identity Type
+ (expand, _, _, _)
+ = mapTyCo (TyCoMapper { tcm_tyvar = exp_tv, tcm_covar = exp_cv
+ , tcm_hole = exp_hole, tcm_tycobinder = exp_tcb
+ , tcm_tycon = pure })
+ exp_tv _ tv = case lookupVarEnv tvs tv of
+ Just ty -> pure ty
+ Nothing -> pure (TyVarTy tv)
+ exp_cv _ cv = pure (CoVarCo cv)
+ exp_hole _ cv = pprPanic "expand_tv_unf" (ppr cv)
+ exp_tcb :: () -> TyCoVar -> ForAllTyFlag -> (() -> TyCoVar -> Identity r) -> Identity r
+ exp_tcb _ tcv _ k = k () (updateVarType (runIdentity . expand) tcv)
+
expandTypeSynonyms :: Type -> Type
-- ^ Expand out all type synonyms. Actually, it'd suffice to expand out
-- just the ones that discard type variables (e.g. type Funny a = Int)
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -130,21 +130,27 @@ exprType :: HasDebugCallStack => CoreExpr -> Type
-- ^ Recover the type of a well-typed Core expression. Fails when
-- applied to the actual 'GHC.Core.Type' expression as it cannot
-- really be said to have a type
-exprType (Var var) = idType var
-exprType (Lit lit) = literalType lit
-exprType (Coercion co) = coercionType co
-exprType (Let bind body)
- | NonRec tv rhs <- bind -- See Note [Type bindings]
- , Type ty <- rhs = substTyWithUnchecked [tv] [ty] (exprType body)
- | otherwise = exprType body
-exprType (Case _ _ ty _) = ty
-exprType (Cast _ co) = coercionRKind co
-exprType (Tick _ e) = exprType e
-exprType (Lam binder expr) = mkLamType binder (exprType expr)
-exprType e@(App _ _)
- = case collectArgs e of
- (fun, args) -> applyTypeToArgs (exprType fun) args
-exprType (Type ty) = pprPanic "exprType" (ppr ty)
+exprType e = go emptyVarEnv e
+ where
+ -- When we get to a type, expand locally-bound tyvars, if any
+ expand = expandTyVarUnfoldings
+
+ go tvs (Var var) = expand tvs $ idType var
+ go tvs (Lit lit) = expand tvs $ literalType lit
+ go tvs (Coercion co) = expand tvs $ coercionType co
+ go tvs (Let bind body)
+ | NonRec tv rhs <- bind -- See Note [Type bindings]
+ , Type ty <- rhs = go (extendVarEnv tvs tv ty) body
+ | otherwise = go tvs body
+ go tvs (Case _ _ ty _) = expand tvs ty
+ go tvs (Cast _ co) = expand tvs $ coercionRKind co
+ go tvs (Tick _ e) = go tvs e
+ go tvs (Lam binder expr) = mkLamType (updateVarType (expand tvs) binder)
+ (go tvs expr)
+ go tvs e@(App _ _)
+ = case collectArgs e of
+ (fun, args) -> expand tvs $ applyTypeToArgs (exprType fun) args
+ go _ (Type ty) = pprPanic "exprType" (ppr ty)
coreAltType :: CoreAlt -> Type
-- ^ Returns the type of the alternatives right hand side
@@ -1273,6 +1279,9 @@ and that confuses the code generator (#11155). So best to kill
it off at source.
-}
+coercionIsTrivial :: Coercion -> Bool
+coercionIsTrivial co = coercionSize co < 10 -- Try this out
+
{-# INLINE trivial_expr_fold #-}
trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r
-- ^ The worker function for Note [exprIsTrivial] and Note [getIdFromTrivialExpr]
@@ -1294,14 +1303,14 @@ trivial_expr_fold k_id k_lit k_triv k_not_triv = go
-- If you change this function, be sure to change SetLevels.notWorthFloating
-- as well!
-- (Or yet better: Come up with a way to share code with this function.)
- go (Var v) = k_id v -- See Note [Variables are trivial]
- go (Lit l) | litIsTrivial l = k_lit l
- go (Type _) = k_triv
- go (Coercion _) = k_triv
- go (App f t) | not (isRuntimeArg t) = go f
- go (Lam b e) | not (isRuntimeVar b) = go e
- go (Tick t e) | not (tickishIsCode t) = go e -- See Note [Tick trivial]
- go (Cast e _) = go e
+ go (Var v) = k_id v -- See Note [Variables are trivial]
+ go (Lit l) | litIsTrivial l = k_lit l
+ go (Type _) = k_triv
+ go (Coercion co) | coercionIsTrivial co = k_triv
+ go (App f t) | not (isRuntimeArg t) = go f
+ go (Lam b e) | not (isRuntimeVar b) = go e
+ go (Tick t e) | not (tickishIsCode t)= go e -- See Note [Tick trivial]
+ go (Cast e co) | coercionIsTrivial co = go e
go (Case e b _ as)
| null as
= go e -- See Note [Empty case is trivial]
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -3646,11 +3646,10 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map
-- we're only doing this to find the right kind variables to
-- quantify over, and this type is fine for that purpose.
- -- exp_tvbndrs have explicit, user-written binding sites
- -- the kvs below are those kind variables entirely unmentioned by the user
- -- and discovered only by generalization
-
; kvs <- kindGeneralizeAll skol_info fake_ty
+ -- exp_tvbndrs have explicit, user-written binding sites
+ -- These `kvs` below are those kind variables entirely unmentioned
+ -- by the user and discovered only by generalization
; let all_skol_tvs = tc_tvs ++ kvs
; reportUnsolvedEqualities skol_info all_skol_tvs tclvl wanted
@@ -3661,7 +3660,7 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map
-- But that just doesn't seem worth it.
-- See test dependent/should_fail/T13780a
- -- Zonk to Types
+ -- Zonk to TyvVars and Types, instead of TcTyVars and TcTypes
; (tc_bndrs, kvs, exp_tvbndrs, arg_tys, ctxt) <- initZonkEnv NoFlexi $
runZonkBndrT (zonkTyVarBindersX tc_bndrs ) $ \ tc_bndrs ->
runZonkBndrT (zonkTyBndrsX kvs ) $ \ kvs ->
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a81b6b9024cc3f8c436c78c12d6976d36cc34a00
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a81b6b9024cc3f8c436c78c12d6976d36cc34a00
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241029/79cfebce/attachment-0001.html>
More information about the ghc-commits
mailing list