[Git][ghc/ghc][wip/type-sharing] 10 commits: prep: make type-lets pass through CorePrep
josephf (@josephf)
gitlab at gitlab.haskell.org
Wed Jul 24 12:35:06 UTC 2024
josephf pushed to branch wip/type-sharing at Glasgow Haskell Compiler / GHC
Commits:
dc71cd49 by Joseph Fourment at 2024-07-24T10:18:28+02:00
prep: make type-lets pass through CorePrep
As a first attempt, ignore type-lets in CorePrep to avoid crashes.
However, this is not enough: CorePrep also does some let-floating.
If we don't float type-lets along with value-level let-bindings,
the latter can float out of the scope of a type variable in use.
- - - - -
62a7ba90 by Joseph Fourment at 2024-07-24T10:49:48+02:00
simple-opt: fix simple_type_bind
Also:
- Inline small types using a new typeIsSmallEnoughToInline predicate
- Inline single-occurrence variables
- - - - -
bc8e90dc by Joseph Fourment at 2024-07-24T10:52:16+02:00
simple-opt: make beta-reduction use simple_bind_type
- - - - -
1c49b92e by Joseph Fourment at 2024-07-24T11:38:48+02:00
iface: add IfaceTypeLetBndr to represent non-top-level type-let binders
IfaceLetBndr isn't fit to represent type-let binders, as it includes a
bunch of vacuous flags for Ids only.
Instead of putting squares in circles, I added a new constructor for type binders.
The downside is that it breaks existing iface files, so since we can't bootstrap
yet so we have to bootstrap a cherry-picked branch and then checkout again to build
with --freeze1.
To avoid similar issues in the future, IfaceTyVarInfoItem serialises with a tag
despite there being only one constructor for now.
- - - - -
da70f53b by Joseph Fourment at 2024-07-24T11:39:59+02:00
dmd-anal: prefix unused variable with _ to avoid warning
- - - - -
f40b480a by Joseph Fourment at 2024-07-24T11:40:54+02:00
type: inline unfoldView in sORTKind_maybe
- - - - -
870d2858 by Joseph Fourment at 2024-07-24T11:41:18+02:00
tidy: deal with type-lets
- - - - -
af50043e by Joseph Fourment at 2024-07-24T14:13:50+02:00
notes: add Note [Type and coercion lets]
- - - - -
a1cab68d by Joseph Fourment at 2024-07-24T14:17:15+02:00
notes: update Note [Comparing nullary type synonyms] to account for type variables
While updating backlinks, I noticed the optimisation for type variables
could be performed in more places.
- - - - -
9324ed07 by Joseph Fourment at 2024-07-24T14:28:48+02:00
simplifier: inline single-occurring type-lets
- - - - -
17 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Core/TyCo/Compare.hs
- compiler/GHC/Core/TyCo/Rep.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/CoreToStg.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Iface/Rename.hs
- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/IfaceToCore.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Types/Var.hs
Changes:
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -297,7 +297,7 @@ dmdAnalBind
-- where the binding is in scope
-> WithDmdType (DmdResult CoreBind a)
dmdAnalBind top_lvl env dmd bind anal_body = case bind of
- NonRec var rhs
+ NonRec var _rhs
| isTyVar var
-> dmdAnalBindLetDown top_lvl env dmd bind anal_body
NonRec id rhs
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -60,7 +60,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( extendTvSubst, substTy )
import GHC.Core.Coercion hiding( substCo )
import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon )
import GHC.Core.Multiplicity
@@ -72,6 +72,7 @@ import GHC.Types.Id.Info
import GHC.Types.Tickish
import GHC.Types.Demand
import GHC.Types.Var.Set
+import GHC.Types.Var ( tyVarOccInfo, tyVarUnfolding )
import GHC.Types.Basic
import GHC.Data.OrdList ( isNilOL )
@@ -86,7 +87,6 @@ import Control.Monad ( when )
import Data.List ( sortBy )
import GHC.Types.Name.Env
import Data.Graph
-import GHC.Types.Var (tyVarOccInfo)
{- *********************************************************************
* *
@@ -1469,22 +1469,26 @@ preInlineUnconditionally
-- for unlifted, side-effect-ful bindings
preInlineUnconditionally env top_lvl bndr rhs rhs_env
| not pre_inline_unconditionally = Nothing
- | isTyVar bndr = Nothing
+ | isTyVar bndr
+ , not (one_occ (tyVarOccInfo bndr)) = Nothing
+ | isTyVar bndr
+ , Just unf <- tyVarUnfolding bndr = Just $! (extend_tv_subst_with unf)
| not active = Nothing
| isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids]
| isCoVar bndr = 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
- | not (isStableUnfolding unf) = Just $! (extend_subst_with rhs)
+ | not (isStableUnfolding unf) = Just $! (extend_id_subst_with rhs)
-- See Note [Stable unfoldings and preInlineUnconditionally]
| not (isInlinePragma inline_prag)
- , Just inl <- maybeUnfoldingTemplate unf = Just $! (extend_subst_with inl)
+ , Just inl <- maybeUnfoldingTemplate unf = Just $! (extend_id_subst_with inl)
| otherwise = Nothing
where
unf = idUnfolding bndr
- extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)
+ extend_id_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)
+ extend_tv_subst_with ty = extendTvSubst env bndr ty
one_occ IAmDead = True -- Happens in ((\x.1) v)
one_occ OneOcc{ occ_n_br = 1
@@ -2224,7 +2228,7 @@ abstractFloats uf_opts top_lvl main_tvs floats body
; return (float_binds, GHC.Core.Subst.substExpr subst body) }
where
is_top_lvl = isTopLevel top_lvl
- body_floats = letFloatBinds (sfLetFloats floats)
+ body_floats = letFloatBinds (sfLetFloats floats) ++ typeFloatBinds (sfTypeFloats floats)
empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats)
-- See wrinkle (AB5) in Note [Which type variables to abstract over]
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -32,7 +32,7 @@ import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm, zapLambdaBndrs
import GHC.Types.Literal
import GHC.Types.Id
import GHC.Types.Id.Info ( realUnfoldingInfo, setUnfoldingInfo, setRuleInfo, IdInfo (..) )
-import GHC.Types.Var ( isNonCoVarId, tyVarUnfolding, setTyVarUnfolding )
+import GHC.Types.Var ( isTcTyVar, isNonCoVarId, setTyVarUnfolding, tyVarOccInfo )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Core.DataCon
@@ -357,6 +357,11 @@ simple_app env e@(Lam {}) as@(_:_)
n_args = length as
do_beta env (Lam b body) (a:as)
+ | (t_env, Type t) <- a
+ , (env'', mb_tpr) <- simple_bind_type env b (t_env, t)
+ = assert (isTyVar b) $
+ wrapTypeLet mb_tpr $ do_beta env'' body as
+
| -- simpl binder before looking at its type
-- See Note [Dark corner with representation polymorphism]
needsCaseBinding (idType b') (snd a)
@@ -414,6 +419,14 @@ finish_app env fun args
----------------------
simple_opt_bind :: SimpleOptEnv -> InBind -> TopLevelFlag
-> (SimpleOptEnv, Maybe OutBind)
+simple_opt_bind env (NonRec b r) _top_level
+ | Type t <- r
+ = assert (isTyVar b) $
+ let (env', mb_pr) = simple_bind_type env b (env, t)
+ in (env', case mb_pr of
+ Nothing -> Nothing
+ Just (b, r) -> Just (NonRec b (Type r)))
+
simple_opt_bind env (NonRec b r) top_level
= (env', case mb_pr of
Nothing -> Nothing
@@ -439,26 +452,23 @@ simple_opt_bind env (Rec prs) top_level
----------------------
simple_bind_type :: SimpleOptEnv
- -> InTyVar -> Maybe OutTyVar
+ -> InTyVar
-> (SimpleOptEnv, InType)
-> (SimpleOptEnv, Maybe (OutTyVar, OutType))
+-- See Note [Type and coercion lets]
simple_bind_type env@(SOE { soe_subst = subst })
- in_bndr mb_out_bndr (rhs_env, in_rhs)
- | Just in_tyvar <- getTyVar_maybe in_rhs
- , Just unf <- tyVarUnfolding in_tyvar
- , let out_unf = substTyUnchecked (soe_subst rhs_env) unf
- , isAtomicTy out_unf
- = {- pprTrace "simple_bind_type" (ppr in_tyvar) $ -}
- (env { soe_subst = extendTvSubst subst in_bndr out_unf }, Nothing)
-
+ in_bndr (rhs_env, in_ty)
+ | occurs_once || typeIsSmallEnoughToInline out_ty
+ = (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
| otherwise
- = let
- out_ty = substTyUnchecked (soe_subst rhs_env) in_rhs
- (env', bndr1) = case mb_out_bndr of
- Just out_bndr -> (env, out_bndr)
- Nothing -> subst_opt_bndr env in_bndr
- out_bndr = setTyVarUnfolding bndr1 out_ty
+ = let (env', subst_bndr) = subst_opt_bndr env in_bndr
+ out_bndr | isTcTyVar subst_bndr = subst_bndr
+ | otherwise = subst_bndr `setTyVarUnfolding` out_ty
in (env', Just (out_bndr, out_ty))
+ where
+ out_ty = substTyUnchecked (soe_subst (soeSetInScope (soeInScope env) rhs_env)) in_ty
+ bndr_occ = tyVarOccInfo in_bndr
+ occurs_once {- syntactically -} = isOneOcc bndr_occ && occ_n_br bndr_occ == 1
----------------------
simple_bind_pair :: SimpleOptEnv
@@ -472,15 +482,8 @@ simple_bind_pair :: SimpleOptEnv
simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
in_bndr mb_out_bndr clo@(rhs_env, in_rhs)
top_level
- | Type in_ty <- in_rhs -- let a::* = TYPE ty in <body>
- = let
- (env', mb_out_bind_type) = simple_bind_type env in_bndr mb_out_bndr (rhs_env, in_ty)
- in
- case mb_out_bind_type of
- Just (out_bndr, out_ty)
- | isAtomicTy out_ty -> (env' { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
- | otherwise -> (env', Just (out_bndr, Type out_ty))
- Nothing -> (env', Nothing)
+ | Type in_ty <- in_rhs
+ = pprPanic "simple_bind_pair" (ppr in_bndr $$ ppr in_ty)
| Coercion co <- in_rhs
, let out_co = optCoercion (so_co_opts (soe_opts env)) (soe_subst rhs_env) co
@@ -805,6 +808,10 @@ wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
wrapLet Nothing body = body
wrapLet (Just (b,r)) body = Let (NonRec b r) body
+wrapTypeLet :: Maybe (TyVar,Type) -> CoreExpr -> CoreExpr
+wrapTypeLet Nothing body = body
+wrapTypeLet (Just (b,t)) body = Let (NonRec b (Type t)) body
+
{-
Note [Inline prag in simplOpt]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Tidy.hs
=====================================
@@ -52,6 +52,13 @@ tidyBind :: TidyEnv
-> (TidyEnv, CoreBind)
tidyBind env (NonRec bndr rhs)
+ | isTyVar bndr
+ = -- pprTrace "tidyBindNonRecType" (ppr bndr) $
+ let (env', bndr') = tidyLetBndr env env bndr
+ tidy_rhs = (tidyExpr env' rhs)
+ in (env', NonRec bndr' tidy_rhs)
+
+ | otherwise
= -- pprTrace "tidyBindNonRec" (ppr bndr) $
let cbv_bndr = (tidyCbvInfoLocal bndr rhs)
(env', bndr') = tidyLetBndr env env cbv_bndr
@@ -315,9 +322,25 @@ tidyIdBndr env@(tidy_env, var_env) id
tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings
-> TidyEnv -- The one to extend
- -> Id -> (TidyEnv, Id)
+ -> Var -> (TidyEnv, Var)
-- Used for local (non-top-level) let(rec)s
-- Just like tidyIdBndr above, but with more IdInfo
+tidyLetBndr rec_tidy_env env@(tidy_env, var_env) tv
+ | isTyVar tv
+ = case tidyOccName tidy_env (getOccName tv) of { (tidy_env', occ') ->
+ let
+ ki' = tidyType env (tyVarKind tv)
+ name' = mkInternalName (varUnique tv) occ' noSrcSpan
+ mb_unf = tyVarUnfolding tv
+ occ_info = tyVarOccInfo tv
+ tv' | Just unf <- mb_unf = mkTyVarWithUnfolding name' ki' (tidyType rec_tidy_env unf)
+ | otherwise = mkTyVar name' ki'
+ tv'' = tv' `setTyVarOccInfo` occ_info
+ var_env' = extendVarEnv var_env tv tv''
+
+ in
+ ((tidy_env', var_env'), tv') }
+
tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id
= case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') ->
let
=====================================
compiler/GHC/Core/TyCo/Compare.hs
=====================================
@@ -146,8 +146,9 @@ mayLookIdentical orig_ty1 orig_ty2
orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]
go :: RnEnv2 -> Type -> Type -> Bool
- -- See Note [Comparing nullary type synonyms]
+ -- See Note [Comparing nullary type synonyms and type variables]
go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = True
+ go _ (TyVarTy tv1) (TyVarTy tv2) | tv1 == tv2 = True
go env t1 t2 | Just t1' <- coreView t1 = go env t1' t2
go env t1 t2 | Just t2' <- coreView t2 = go env t1 t2'
@@ -228,13 +229,14 @@ tc_eq_type keep_syns orig_ty1 orig_ty2
orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]
view
- | keep_syns = unfoldView
+ | keep_syns = unfoldView -- We still want to look through let-bound type variables
+ -- See Note [Type and coercion lets] in GHC.Core
| otherwise = coreView
go :: RnEnv2 -> Type -> Type -> Bool
- -- See Note [Comparing nullary type synonyms]
+ -- See Note [Comparing nullary type synonyms and type variables]
go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = True
- go _ (TyVarTy tv1) (TyVarTy tv2) | tv1 == tv2 = True
+ go _ (TyVarTy tv1) (TyVarTy tv2) | tv1 == tv2 = True
go env t1 t2 | Just t1' <- view t1 = go env t1' t2
go env t1 t2 | Just t2' <- view t2 = go env t1 t2'
@@ -462,8 +464,8 @@ But the left is an AppTy while the right is a TyConApp. The solution is
to use splitAppTyNoView_maybe to break up the TyConApp into its pieces and
then continue. Easy to do, but also easy to forget to do.
-Note [Comparing nullary type synonyms]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Comparing nullary type synonyms and type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the task of testing equality between two 'Type's of the form
TyConApp tc []
@@ -491,6 +493,10 @@ since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications
whenever possible. See Note [Using synonyms to compress types] in
GHC.Core.Type for details.
+As coreView also expands let-bound type variables (c.f. Note [Type and coercion lets]
+in GHC.Core) into their unfolding, we want the same short-cutting behavior.
+After all, type variables are similar in nature to nullary type synonyms.
+
-}
eqType :: Type -> Type -> Bool
@@ -607,7 +613,7 @@ nonDetCmpTypeX env orig_t1 orig_t2 =
-- Returns both the resulting ordering relation between
-- the two types and whether either contains a cast.
go :: RnEnv2 -> Type -> Type -> TypeOrdering
- -- See Note [Comparing nullary type synonyms]
+ -- See Note [Comparing nullary type synonyms and type variables]
go _ (TyConApp tc1 []) (TyConApp tc2 [])
| tc1 == tc2
= TEQ
=====================================
compiler/GHC/Core/TyCo/Rep.hs
=====================================
@@ -62,6 +62,7 @@ module GHC.Core.TyCo.Rep (
-- * Sizes
typeSize, typesSize, coercionSize, provSize,
+ typeIsSmallEnoughToInline,
-- * Multiplicities
Scaled(..), scaledMult, scaledThing, mapScaledType, Mult
@@ -1930,6 +1931,9 @@ provSize (PhantomProv co) = 1 + coercionSize co
provSize (ProofIrrelProv co) = 1 + coercionSize co
provSize (PluginProv _) = 1
+typeIsSmallEnoughToInline :: Type -> Bool
+typeIsSmallEnoughToInline ty = typeSize ty <= 1
+
{-
************************************************************************
* *
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -118,6 +118,8 @@ module GHC.Core.Type (
isValidJoinPointType,
tyConAppNeedsKindSig,
+ typeIsSmallEnoughToInline,
+
-- * Space-saving construction
mkTYPEapp, mkTYPEapp_maybe,
mkCONSTRAINTapp, mkCONSTRAINTapp_maybe,
@@ -362,6 +364,7 @@ import GHC.Data.Maybe ( orElse, isJust, firstJust )
-}
unfoldView :: Type -> Maybe Type
+-- Look through type variables, see Note [Type and coercion lets] in GHC.Core
{-# INLINE unfoldView #-}
unfoldView (TyVarTy tv) = tyVarUnfolding tv
unfoldView _ = Nothing
@@ -390,7 +393,7 @@ coreView :: Type -> Maybe Type
-- By being non-recursive and inlined, this case analysis gets efficiently
-- joined onto the case analysis that the caller is already doing
coreView (TyConApp tc tys) = expandSynTyConApp_maybe tc tys
-coreView (TyVarTy tv) = tyVarUnfolding tv
+coreView (TyVarTy tv) = tyVarUnfolding tv -- c.f. unfoldView
coreView _ = Nothing
-- See Note [Inlining coreView].
{-# INLINE coreView #-}
@@ -403,6 +406,7 @@ coreFullView, core_full_view :: Type -> Type
coreFullView ty@(TyConApp tc _)
| isTypeSynonymTyCon tc = core_full_view ty
coreFullView (TyVarTy tv)
+ -- c.f. unfoldView
| Just ty <- tyVarUnfolding tv = core_full_view ty
coreFullView ty = ty
{-# INLINE coreFullView #-}
@@ -2718,8 +2722,8 @@ sORTKind_maybe :: Kind -> Maybe (TypeOrConstraint, Type)
--
-- This is a "hot" function. Do not call splitTyConApp_maybe here,
-- to avoid the faff with FunTy
-sORTKind_maybe ty
- | Just ty <- unfoldView ty
+sORTKind_maybe (TyVarTy tv)
+ | Just ty <- tyVarUnfolding tv
= sORTKind_maybe ty
sORTKind_maybe (TyConApp tc tys)
-- First, short-cuts for Type and Constraint that do no allocation
=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -1065,10 +1065,14 @@ unify_ty :: UMEnv
-- See Note [Specification of unification]
-- Respects newtypes, PredTypes
-- See Note [Computing equality on types] in GHC.Core.Type
+
+-- See Note [Comparing nullary type synonyms and type variables] in GHC.Core.TyCo.Compare
unify_ty _env (TyConApp tc1 []) (TyConApp tc2 []) _kco
- -- See Note [Comparing nullary type synonyms] in GHC.Core.TyCo.Compare
| tc1 == tc2
= return ()
+unify_ty _env (TyVarTy tv1) (TyVarTy tv2) _kco
+ | tv1 == tv2
+ = return ()
unify_ty env ty1 ty2 kco
-- Now handle the cases we can "look through": synonyms and casts.
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -53,8 +53,9 @@ module GHC.Core.Utils (
-- * StaticPtr
collectMakeStaticArgs,
- -- * Join points
+ -- * Predicates on binds
isJoinBind,
+ isTypeBind,
-- * Tag inference
mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId,
@@ -2653,17 +2654,22 @@ collectMakeStaticArgs _ = Nothing
{-
************************************************************************
* *
-\subsection{Join points}
+\subsection{Predicates on binds}
* *
************************************************************************
-}
--- | Does this binding bind a join point (or a recursive group of join points)?
isJoinBind :: CoreBind -> Bool
isJoinBind (NonRec b _) = isJoinId b
isJoinBind (Rec ((b, _) : _)) = isJoinId b
isJoinBind _ = False
+-- | Does this binding bind a type?
+isTypeBind :: CoreBind -> Bool
+-- See Note [Type and coercion lets] in GHC.Core
+isTypeBind (NonRec b (Type _)) = isTyVar b
+isTypeBind _ = False
+
dumpIdInfoOfProgram :: Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc
dumpIdInfoOfProgram dump_locals ppr_id_info binds = vcat (map printId ids)
where
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -432,7 +432,15 @@ toIfaceBang _ (HsStrict _) = IfStrict
toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang
toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang
-toIfaceLetBndr :: Id -> IfaceLetBndr
+toIfaceLetBndr :: Var -> IfaceLetBndr
+toIfaceLetBndr tv
+ | isTyVar tv = IfTypeLetBndr (occNameFS (getOccName (tyVarName tv)))
+ (toIfaceKind (tyVarKind tv))
+ info
+ where
+ info | Just unf <- tyVarUnfolding tv = [HsTypeUnfold (toIfaceType unf)]
+ | otherwise = []
+
toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id))
(toIfaceType (idType id))
(toIfaceIdInfo (idInfo id))
=====================================
compiler/GHC/CoreToStg.hs
=====================================
@@ -52,7 +52,7 @@ import GHC.Builtin.PrimOps
import GHC.Utils.Outputable
import GHC.Utils.Monad
-import GHC.Utils.Misc (HasDebugCallStack)
+import GHC.Utils.Misc (HasDebugCallStack, HasCallStack)
import GHC.Utils.Panic
import Control.Monad (ap)
@@ -228,7 +228,7 @@ import Control.Monad (ap)
-- --------------------------------------------------------------
-coreToStg :: CoreToStgOpts -> Module -> ModLocation -> CoreProgram
+coreToStg :: HasCallStack => CoreToStgOpts -> Module -> ModLocation -> CoreProgram
-> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
coreToStg opts at CoreToStgOpts
{ coreToStg_ways = ways
@@ -260,7 +260,7 @@ coreToStg opts at CoreToStgOpts
(all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod
coreTopBindsToStg
- :: CoreToStgOpts
+ :: HasCallStack => CoreToStgOpts
-> Module
-> IdEnv HowBound -- environment for the bindings
-> CollectedCCs
@@ -273,13 +273,13 @@ coreTopBindsToStg opts this_mod env ccs (b:bs)
| NonRec _ rhs <- b, isTyCoArg rhs
= coreTopBindsToStg opts this_mod env1 ccs1 bs
| otherwise
- = (env2, ccs2, b':bs')
+ = assertPpr (not (isTypeBind b)) (ppr b) $ (env2, ccs2, b':bs')
where
(env1, ccs1, b' ) = coreTopBindToStg opts this_mod env ccs b
(env2, ccs2, bs') = coreTopBindsToStg opts this_mod env1 ccs1 bs
coreTopBindToStg
- :: CoreToStgOpts
+ :: HasCallStack => CoreToStgOpts
-> Module
-> IdEnv HowBound
-> CollectedCCs
@@ -304,6 +304,7 @@ coreTopBindToStg opts at CoreToStgOpts
(ccs', (id', stg_rhs)) =
initCts platform env $
+ pprTrace "coreTopBindToStg" (ppr id $$ ppr rhs) $
coreToTopStgRhs opts this_mod ccs (id,rhs)
bind = StgTopLifted $ StgNonRec id' stg_rhs
@@ -331,7 +332,7 @@ coreTopBindToStg opts at CoreToStgOpts
(env', ccs', bind)
coreToTopStgRhs
- :: CoreToStgOpts
+ :: HasCallStack => CoreToStgOpts
-> Module
-> CollectedCCs
-> (Id,CoreExpr)
@@ -375,7 +376,7 @@ coreToTopStgRhs opts this_mod ccs (bndr, rhs)
-- handle with the function coreToPreStgRhs.
coreToStgExpr
- :: HasDebugCallStack => CoreExpr
+ :: HasCallStack => CoreExpr
-> CtsM StgExpr
-- The second and third components can be derived in a simple bottom up pass, not
@@ -693,9 +694,10 @@ data PreStgRhs = PreStgRhs [Id] StgExpr Type -- The [Id] is empty for thunks
-- Convert the RHS of a binding from Core to STG. This is a wrapper around
-- coreToStgExpr that can handle value lambdas.
-coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs
+coreToPreStgRhs :: HasCallStack => CoreExpr -> CtsM PreStgRhs
coreToPreStgRhs expr
- = extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $
+ = pprTrace "coreToPreStgRhs" (ppr expr) $
+ extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $
do { body' <- coreToStgExpr body
; return (PreStgRhs args' body' (exprType body)) }
where
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -242,7 +242,10 @@ corePrepTopBinds initialCorePrepEnv binds
= go initialCorePrepEnv binds
where
go _ [] = return emptyFloats
- go env (bind : binds) = do (env', floats, maybe_new_bind)
+ go env (bind : binds) | isTypeBind bind
+ = go env binds
+ | otherwise
+ = do (env', floats, maybe_new_bind)
<- cpeBind TopLevel env bind
massert (isNothing maybe_new_bind)
-- Only join points get returned this way by
@@ -775,6 +778,9 @@ cpeRhsE env expr@(Var {}) = cpeApp env expr
cpeRhsE env expr@(App {}) = cpeApp env expr
cpeRhsE env (Let bind body)
+ | isTypeBind bind
+ = cpeRhsE env body
+ | otherwise
= do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind
; (body_floats, body') <- cpeRhsE env' body
; let expr' = case maybe_bind' of Just bind' -> Let bind' body'
=====================================
compiler/GHC/Iface/Rename.hs
=====================================
@@ -583,12 +583,19 @@ rnIfaceAxBranch d = do
rnIfaceIdInfo :: Rename IfaceIdInfo
rnIfaceIdInfo = mapM rnIfaceInfoItem
+rnIfaceTyVarInfo :: Rename IfaceTyVarInfo
+rnIfaceTyVarInfo = mapM rnIfaceTyVarInfoItem
+
rnIfaceInfoItem :: Rename IfaceInfoItem
rnIfaceInfoItem (HsUnfold lb if_unf)
= HsUnfold lb <$> rnIfaceUnfolding if_unf
rnIfaceInfoItem i
= pure i
+rnIfaceTyVarInfoItem :: Rename IfaceTyVarInfoItem
+rnIfaceTyVarInfoItem (HsTypeUnfold if_unf)
+ = HsTypeUnfold <$> rnIfaceType if_unf
+
rnIfaceUnfolding :: Rename IfaceUnfolding
rnIfaceUnfolding (IfCoreUnfold src cache guide if_expr)
= IfCoreUnfold src cache guide <$> rnIfaceExpr if_expr
@@ -650,6 +657,8 @@ rnIfaceConAlt alt = pure alt
rnIfaceLetBndr :: Rename IfaceLetBndr
rnIfaceLetBndr (IfLetBndr fs ty info jpi)
= IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info <*> pure jpi
+rnIfaceLetBndr (IfTypeLetBndr fs ki info)
+ = IfTypeLetBndr fs <$> rnIfaceType ki <*> rnIfaceTyVarInfo info
rnIfaceLamBndr :: Rename IfaceLamBndr
rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot
=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -16,6 +16,7 @@ module GHC.Iface.Syntax (
IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..),
IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
+ IfaceTyVarInfo, IfaceTyVarInfoItem(..),
IfaceWarnings(..), IfaceWarningTxt(..), IfaceStringLiteral(..),
IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
IfaceClassBody(..), IfaceBooleanFormula(..),
@@ -420,6 +421,11 @@ data IfGuidance
-- implicit ones are needed here, because they are not put in
-- interface files
+type IfaceTyVarInfo = [IfaceTyVarInfoItem]
+
+data IfaceTyVarInfoItem
+ = HsTypeUnfold IfaceType
+
data IfaceIdDetails
= IfVanillaId
| IfWorkerLikeId [CbvMark]
@@ -653,10 +659,14 @@ data IfaceBindingX r b
| IfaceRec [(b, r)]
deriving (Functor, Foldable, Traversable, Ord, Eq)
--- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
+-- IfaceLetBndr is like IfaceIdBndr, but has additional information too
-- It's used for *non-top-level* let/rec binders
--- See Note [IdInfo on nested let-bindings]
-data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo JoinPointHood
+data IfaceLetBndr
+ -- See Note [IdInfo on nested let-bindings]
+ = IfLetBndr IfLclName IfaceType IfaceIdInfo JoinPointHood
+
+ -- See Note [Type and coercion lets]
+ | IfTypeLetBndr IfLclName IfaceKind IfaceTyVarInfo
data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDetails
| IfGblTopBndr IfaceTopBndr
@@ -1531,6 +1541,9 @@ ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc
ppr_bind (IfLetBndr b ty info ji, rhs)
= sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr ji <+> ppr info),
equals <+> pprIfaceExpr noParens rhs]
+ppr_bind (IfTypeLetBndr b ki info, rhs)
+ = sep [hang (char '@' <> ppr b <+> dcolon <+> ppr ki) 2 (ppr info),
+ equals <+> pprIfaceExpr noParens rhs]
------------------
pprIfaceTickish :: IfaceTickish -> SDoc
@@ -1577,6 +1590,10 @@ instance Outputable IfaceInfoItem where
ppr (HsLFInfo lf_info) = text "LambdaFormInfo:" <+> ppr lf_info
ppr (HsTagSig tag_sig) = text "TagSig:" <+> ppr tag_sig
+instance Outputable IfaceTyVarInfoItem where
+ ppr (HsTypeUnfold unf) = text "Unfolding"
+ <> colon <+> ppr unf
+
instance Outputable IfaceUnfolding where
ppr (IfCoreUnfold src _ guide e)
= sep [ text "Core:" <+> ppr src <+> ppr guide, ppr e ]
@@ -1816,6 +1833,8 @@ freeNamesIfLetBndr :: IfaceLetBndr -> NameSet
-- local INLINE pragmas), so look there too
freeNamesIfLetBndr (IfLetBndr _name ty info _ji) = freeNamesIfType ty
&&& freeNamesIfIdInfo info
+freeNamesIfLetBndr (IfTypeLetBndr _name ki info) = freeNamesIfKind ki
+ &&& freeNamesIfTyVarInfo info
freeNamesIfTvBndr :: IfaceTvBndr -> NameSet
freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k
@@ -1827,11 +1846,17 @@ freeNamesIfIdBndr (_, _fs,k) = freeNamesIfKind k
freeNamesIfIdInfo :: IfaceIdInfo -> NameSet
freeNamesIfIdInfo = fnList freeNamesItem
+freeNamesIfTyVarInfo :: IfaceTyVarInfo -> NameSet
+freeNamesIfTyVarInfo = fnList freeNamesTyVarItem
+
freeNamesItem :: IfaceInfoItem -> NameSet
freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u
freeNamesItem (HsLFInfo (IfLFCon n)) = unitNameSet n
freeNamesItem _ = emptyNameSet
+freeNamesTyVarItem :: IfaceTyVarInfoItem -> NameSet
+freeNamesTyVarItem (HsTypeUnfold u) = freeNamesIfType u
+
freeNamesIfUnfold :: IfaceUnfolding -> NameSet
freeNamesIfUnfold (IfCoreUnfold _ _ _ e) = freeNamesIfExpr e
freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es
@@ -2405,6 +2430,15 @@ instance Binary IfaceInfoItem where
7 -> HsLFInfo <$> get bh
_ -> HsTagSig <$> get bh
+instance Binary IfaceTyVarInfoItem where
+ put_ bh (HsTypeUnfold ad) = putByte bh 0 >> put_ bh ad
+
+ get :: BinHandle -> IO IfaceTyVarInfoItem
+ get bh = do
+ h <- getByte bh
+ case h of
+ _ -> HsTypeUnfold <$> get bh
+
instance Binary IfaceUnfolding where
put_ bh (IfCoreUnfold s c g e) = do
putByte bh 0
@@ -2654,15 +2688,31 @@ instance (Binary r, Binary b) => Binary (IfaceBindingX b r) where
instance Binary IfaceLetBndr where
put_ bh (IfLetBndr a b c d) = do
+ putByte bh 0
put_ bh a
put_ bh b
put_ bh c
put_ bh d
- get bh = do a <- get bh
- b <- get bh
- c <- get bh
- d <- get bh
- return (IfLetBndr a b c d)
+
+ put_ bh (IfTypeLetBndr a b c) = do
+ putByte bh 1
+ put_ bh a
+ put_ bh b
+ put_ bh c
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do
+ a <- get bh
+ b <- get bh
+ c <- get bh
+ d <- get bh
+ return (IfLetBndr a b c d)
+ _ -> do
+ a <- get bh
+ b <- get bh
+ c <- get bh
+ return (IfTypeLetBndr a b c)
instance Binary IfaceTopBndrInfo where
put_ bh (IfLclTopBndr lcl ty info dets) = do
@@ -2816,6 +2866,10 @@ instance NFData IfaceInfoItem where
HsLFInfo lf_info -> lf_info `seq` () -- TODO: seq further?
HsTagSig sig -> sig `seq` ()
+instance NFData IfaceTyVarInfoItem where
+ rnf = \case
+ HsTypeUnfold unf -> rnf unf
+
instance NFData IfGuidance where
rnf = \case
IfNoGuidance -> ()
@@ -2864,6 +2918,8 @@ instance NFData IfaceMaybeRhs where
instance NFData IfaceLetBndr where
rnf (IfLetBndr nm ty id_info join_info) =
rnf nm `seq` rnf ty `seq` rnf id_info `seq` rnf join_info
+ rnf (IfTypeLetBndr nm ki tv_info) =
+ rnf nm `seq` rnf ki `seq` rnf tv_info
instance NFData IfaceFamTyConFlav where
rnf = \case
=====================================
compiler/GHC/IfaceToCore.hs
=====================================
@@ -1592,6 +1592,22 @@ tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)
; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)
; return (Let (NonRec id rhs') body') }
+tcIfaceExpr (IfaceLet (IfaceNonRec (IfTypeLetBndr fs ki info) rhs) body)
+ = case rhs of
+ IfaceType ty ->
+ do { name <- newIfaceName (mkVarOccFS fs)
+ ; ki' <- tcIfaceType ki
+ ; mb_unf <- extract_unf info
+ ; let tv | Just unf <- mb_unf = mkTyVarWithUnfolding name ki' unf
+ | otherwise = mkTyVar name ki'
+ ; ty' <- tcIfaceType ty
+ ; body' <- extendIfaceTyVarEnv [tv] (tcIfaceExpr body)
+ ; return (Let (NonRec tv (Type ty')) body') }
+ _ -> pprPanic "tcIfaceExpr:IfaceTypeLet" (ppr rhs)
+ where
+ extract_unf [] = return Nothing
+ extract_unf (HsTypeUnfold unf : _) = Just <$> tcIfaceType unf
+
tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
= do { ids <- mapM tc_rec_bndr (map fst pairs)
; extendIfaceIdEnv ids $ do
@@ -1603,11 +1619,16 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
= do { name <- newIfaceName (mkVarOccFS fs)
; ty' <- tcIfaceType ty
; return (mkLocalId name ManyTy ty' `asJoinId_maybe` ji) }
+ tc_rec_bndr (IfTypeLetBndr fs ki _)
+ = pprPanic "tcIfaceExpr" (char '@' <> ppr fs <+> dcolon <+> ppr ki)
+
tc_pair (IfLetBndr _ _ info _, rhs) id
= do { rhs' <- tcIfaceExpr rhs
; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}
NotTopLevel (idName id) (idType id) info
; return (setIdInfo id id_info, rhs') }
+ tc_pair (IfTypeLetBndr fs ki _, ty) tv
+ = pprPanic "tcIfaceExpr" (char '@' <> ppr fs <+> dcolon <+> ppr ki $$ ppr ty $$ ppr tv)
tcIfaceExpr (IfaceTick tickish expr) = do
expr' <- tcIfaceExpr expr
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -305,7 +305,8 @@ can_eq_nc
-> Type -> Type -- RHS, after and before type-synonym expansion, resp
-> TcS (StopOrContinue (Either IrredCt EqCt))
--- See Note [Comparing nullary type synonyms] in GHC.Core.TyCo.Compare
+-- See Note [Comparing nullary type synonyms and type variables] in GHC.Core.TyCo.Compare
+-- We don't need it for (immutable) type variables because they don't exist at this stage.
can_eq_nc _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2
| tc1 == tc2
= canEqReflexive ev eq_rel ty1
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -259,7 +259,7 @@ data Var
-- cached here for speed
varType :: Kind, -- ^ The type or kind of the 'Var' in question
tv_unfolding :: Maybe Type, -- ^ The type to which the variable is bound to,
- -- if any.
+ -- if any, see Note [Type and coercion lets] in GHC.Core
tv_occ_info :: OccInfo
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/80ffac20b1ca82855908d73d69717901a02d034e...9324ed073bb61115a061f8a1bdcc50a97f0cb4f7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/80ffac20b1ca82855908d73d69717901a02d034e...9324ed073bb61115a061f8a1bdcc50a97f0cb4f7
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/20240724/3d276bfd/attachment-0001.html>
More information about the ghc-commits
mailing list