[Git][ghc/ghc][wip/type-sharing] 5 commits: compiler: introduce type variable unfoldings
josephf (@josephf)
gitlab at gitlab.haskell.org
Thu Jul 4 09:13:13 UTC 2024
josephf pushed to branch wip/type-sharing at Glasgow Haskell Compiler / GHC
Commits:
4e5d33c7 by Joseph Fourment at 2024-07-04T11:09:39+02:00
compiler: introduce type variable unfoldings
The plan for #20264 is to introduce let-bound types to have observable sharing in types.
To avoid the need to carry an environment when dealing with occurrences of these type variables,
we embed the types they're bound to (if any) in a `tv_unfolding :: Maybe Type` attribute.
This way, one can look through let-bound type variables using `coreView` and friends.
In particular, definitional equality looks through unfoldings.
- - - - -
34dc7705 by Joseph Fourment at 2024-07-04T11:09:39+02:00
simple-opt: don't inline type-lets
- - - - -
e7cf9d01 by Joseph Fourment at 2024-07-04T11:09:39+02:00
specialise: fix type-lets in DFun unfoldings
During specialisation, a dictionary being specialised gets a new unfolding by turning
`DFun \ bndrs -> MkD @<T1> ... @<Tm> <op1> ... <opn>` into
`DFun \ spec_bndrs -> MkD @((\ bndrs -> TYPE: <T1>) spec_args) ... ((\ bndrs -> <opn>) spec_args)`
which in turns gets beta-reduced into
`DFun \ spec_bndrs -> MkD (let { bndrs = spec_args } in TYPE: <T1>) ... (let { bndrs = spec_args } in <opn>)`.
Previously, such let binders would immediately be substituted into the type so it didn't cause any issue,
but now we want to avoid inlining.
Arguments of the form `let { bndrs = spec_args } in TYPE: <T1>` are not considered as type arguments since they're
not of the canonical form `TYPE: something`.
This commit restores the previous behavior of substituting the specialised type arguments.
Alternatively, we could attach some floated type bindings to `DFun`s.
- - - - -
d8174aa1 by Joseph Fourment at 2024-07-04T11:09:40+02:00
occur-anal: implement occurence analysis for type variables
In order to find out let-bound type variables that are used only once, in the hope of inlining them,
we need to track type variables as well in the occurrence analiser. Just like Id's, we attach an
`OccInfo` to each (immutable) type variable, and we walk into types and coercions to accurately gather
occurrences.
- - - - -
80ffac20 by Joseph Fourment at 2024-07-04T11:12:07+02:00
simplifier: don't inline type-lets
Keep propagating type-lets further down the pipeline, in the simplifier.
We also update CallArity, CprAnal, DmdAnal, WorkWrap, and Specialise to ignore type-lets.
- - - - -
17 changed files:
- compiler/GHC/Core/Opt/CallArity.hs
- compiler/GHC/Core/Opt/CprAnal.hs
- compiler/GHC/Core/Opt/DmdAnal.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Opt/WorkWrap.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/TyCo/Compare.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Unfold/Make.hs
- compiler/GHC/Tc/Zonk/TcType.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/Types/Var.hs
Changes:
=====================================
compiler/GHC/Core/Opt/CallArity.hs
=====================================
@@ -23,6 +23,7 @@ import GHC.Types.Demand
import GHC.Utils.Misc
import Control.Arrow ( first, second )
+import GHC.Types.Var (isTyVar)
{-
@@ -559,7 +560,9 @@ addInterestingBinds int bind
-- Second argument is the demand from the body
callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)
-- Non-recursive let
-callArityBind boring_vars ae_body int (NonRec v rhs)
+callArityBind boring_vars ae_body int bind@(NonRec v rhs)
+ | isTyVar v
+ = (ae_body, bind)
| otherwise
= -- pprTrace "callArityBind:NonRec"
-- (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity])
=====================================
compiler/GHC/Core/Opt/CprAnal.hs
=====================================
@@ -499,6 +499,8 @@ cprAnalBind
-> CoreExpr
-> (Id, CoreExpr, AnalEnv)
cprAnalBind env id rhs
+ | isTyVar id
+ = (id, rhs, extendSigEnv env id topCprSig)
| isDFunId id -- Never give DFuns the CPR property; we'll never save allocs.
= (id, rhs, extendSigEnv env id topCprSig)
-- See Note [CPR for data structures]
=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -297,6 +297,9 @@ 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
+ | isTyVar var
+ -> dmdAnalBindLetDown top_lvl env dmd bind anal_body
NonRec id rhs
| useLetUp top_lvl id
-> dmdAnalBindLetUp top_lvl env_rhs id rhs anal_body
@@ -369,6 +372,9 @@ dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec
-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.
dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a)
dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of
+ NonRec tv rhs
+ | isTyVar tv
+ -> do_rest env emptyVarEnv [(tv, rhs)] (uncurry NonRec . only)
NonRec id rhs
| (env', weak_fv, id1, rhs1) <-
dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs
@@ -379,13 +385,16 @@ dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of
where
do_rest env' weak_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body')
where
- WithDmdType body_ty body' = anal_body env'
+ WithDmdType body_ty body' = anal_body env'
-- see Note [Lazy and unleashable free variables]
dmd_ty = addWeakFVs body_ty weak_fv
- WithDmdType final_ty id_dmds = findBndrsDmds env' dmd_ty (strictMap fst pairs1)
+ WithDmdType final_ty maybe_dmds = findBndrsDmds_maybe env' dmd_ty (strictMap fst pairs1)
-- Important to force this as build_bind might not force it.
- !pairs2 = strictZipWith do_one pairs1 id_dmds
- do_one (id', rhs') dmd = ((,) $! setBindIdDemandInfo top_lvl id' dmd) $! rhs'
+ !pairs2 = strictZipWith do_one pairs1 maybe_dmds
+ do_one (bndr', rhs') maybe_dmd
+ | isTyVar bndr' = (bndr', rhs')
+ | Just dmd <- maybe_dmd = ((,) $! setBindIdDemandInfo top_lvl bndr' dmd) $! rhs'
+ | otherwise = pprPanic "dmdAnalBindLetDown:do_one" (ppr bndr' $$ ppr rhs' $$ ppr maybe_dmd)
-- If the actual demand is better than the vanilla call
-- demand, you might think that we might do better to re-analyse
-- the RHS with the stronger demand.
@@ -2540,6 +2549,18 @@ findBndrsDmds env dmd_ty bndrs
in WithDmdType dmd_ty2 (dmd : dmds)
| otherwise = go dmd_ty bs
+findBndrsDmds_maybe :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Maybe Demand]
+findBndrsDmds_maybe env dmd_ty bndrs
+ = go dmd_ty bndrs
+ where
+ go dmd_ty [] = WithDmdType dmd_ty []
+ go dmd_ty (b:bs)
+ | isId b = let WithDmdType dmd_ty1 dmds = go dmd_ty bs
+ WithDmdType dmd_ty2 dmd = findBndrDmd env dmd_ty1 b
+ in WithDmdType dmd_ty2 (Just dmd : dmds)
+ | otherwise = let WithDmdType dmd_ty1 dmds = go dmd_ty bs
+ in WithDmdType dmd_ty1 (Nothing : dmds)
+
findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand
-- See Note [Trimming a demand to a type]
findBndrDmd env dmd_ty id
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -39,6 +39,7 @@ import GHC.Core.Opt.Arity ( joinRhsArity, isOneShotBndr )
import GHC.Core.Coercion
import GHC.Core.Predicate ( isDictId )
import GHC.Core.Type
+import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.FVs ( tyCoVarsOfMCo )
import GHC.Data.Maybe( orElse )
@@ -665,7 +666,7 @@ through A, so it should have ManyOcc. Bear this case in mind!
See addJoinPoint.
* At an occurrence of a join point, we do everything as normal, but add in the
- UsageDetails from the occ_join_points. See mkOneOcc.
+ UsageDetails from the occ_join_points. See mkOneIdOcc.
* Crucially, at the NonRec binding of the join point, in `occAnalBind`, we use
`orUDs`, not `andUDs` to combine the usage from the RHS with the usage from
@@ -721,7 +722,7 @@ There are a couple of tricky wrinkles
in f (case x of { K j -> ...; ... })
We can zap the entire occ_join_points when looking at the argument,
because `j` can't posibly occur -- it's a join point! And the smaller
- occ_join_points is, the better. Smaller to look up in mkOneOcc, and
+ occ_join_points is, the better. Smaller to look up in mkOneIdOcc, and
more important, less looking-up when checking (W2).
This is done in setNonTailCtxt. It's important /not/ to do this for
@@ -1142,6 +1143,13 @@ occAnalRec !_ lvl
(WUD body_uds binds)
| isDeadOcc occ -- Check for dead code: see Note [Dead code]
= WUD body_uds binds
+
+ | isTyVar bndr
+ = let (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr
+ !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds
+ !bndr' = tagged_bndr
+ in WUD (body_uds `andUDs` rhs_uds')
+ (NonRec bndr' rhs' : binds)
| otherwise
= let (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr
!(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds
@@ -1700,6 +1708,30 @@ rank (r, _, _) = r
makeNode :: OccEnv -> ImpRuleEdges -> VarSet
-> (Var, CoreExpr) -> LetrecNode
-- See Note [Recursive bindings: the grand plan]
+makeNode !env _imp_rule_edges bndr_set (bndr, Type rhs)
+ = assert (isTyVar bndr) $
+ DigraphNode { node_payload = details
+ , node_key = varUnique bndr
+ , node_dependencies = nonDetKeysUniqSet inl_fvs }
+ where
+ details = ND { nd_bndr = bndr'
+ , nd_rhs = WTUD (TUD 0 inl_uds) (Type rhs')
+ , nd_inl = inl_fvs
+ , nd_simple = True
+ , nd_weak_fvs = emptyVarSet
+ , nd_active_rule_fvs = emptyVarSet }
+
+ bndr' = bndr `setTyVarUnfolding` rhs'
+
+ rhs_env = setNonTailCtxt OccRhs env
+ -- WUD unf_uds mb_unf'
+ -- | Just unf <- tyVarUnfolding bndr = Just <$> occAnalTy rhs_env unf
+ -- | otherwise = WUD emptyUDs Nothing
+ WUD rhs_uds rhs' = occAnalTy rhs_env rhs
+
+ inl_uds = rhs_uds -- `andUDs` unf_uds
+ inl_fvs = udFreeVars bndr_set inl_uds
+
makeNode !env imp_rule_edges bndr_set (bndr, rhs)
= -- pprTrace "makeNode" (ppr bndr <+> ppr (sizeVarSet bndr_set)) $
DigraphNode { node_payload = details
@@ -2198,29 +2230,24 @@ occ_anal_lam_tail env expr@(Lam {})
= addInScope env rev_bndrs $ \env ->
let !(WUD usage body') = occ_anal_lam_tail env body
wrap_lam body bndr = Lam (tagLamBinder usage bndr) body
- in WUD (usage `addLamCoVarOccs` rev_bndrs)
+ in WUD (usage `addLamTyCoVarOccs` rev_bndrs)
(foldl' wrap_lam body' rev_bndrs)
-- For casts, keep going in the same lambda-group
-- See Note [Occurrence analysis for lambda binders]
occ_anal_lam_tail env (Cast expr co)
- = let WUD usage expr' = occ_anal_lam_tail env expr
+ = let WUD expr_uds expr' = occ_anal_lam_tail env expr
-- usage1: see Note [Gather occurrences of coercion variables]
- usage1 = addManyOccs usage (coVarsOfCo co)
+ WUD co_uds co' = occAnalCo env co
-- usage2: see Note [Occ-anal and cast worker/wrapper]
- usage2 = case expr of
- Var {} | isRhsEnv env -> markAllMany usage1
- _ -> usage1
+ co_uds' = case expr of
+ Var {} | isRhsEnv env -> markAllMany co_uds
+ _ -> co_uds
- -- usage3: you might think this was not necessary, because of
- -- the markAllNonTail in adjustTailUsage; but not so! For a
- -- join point, adjustTailUsage doesn't do this; yet if there is
- -- a cast, we must! Also: why markAllNonTail? See
- -- GHC.Core.Lint: Note Note [Join points and casts]
- usage3 = markAllNonTail usage2
+ uds = markAllNonTail (expr_uds `andUDs` co_uds')
- in WUD usage3 (Cast expr' co)
+ in WUD uds (Cast expr' co')
occ_anal_lam_tail env expr -- Not Lam, not Cast
= occAnal env expr
@@ -2427,6 +2454,140 @@ occAnalList env (e:es) = let
(WUD uds1 e') = occAnal env e
(WUD uds2 es') = occAnalList env es
in WUD (uds1 `andUDs` uds2) (e' : es')
+occAnalTys :: OccEnv -> [Type] -> WithUsageDetails [Type]
+occAnalTys !_ [] = WUD emptyDetails []
+occAnalTys env (t:ts) = let
+ (WUD uds1 t') = occAnalTy env t
+ (WUD uds2 ts') = occAnalTys env ts
+ in WUD (uds1 `andUDs` uds2) (t' : ts')
+
+occAnalTy :: OccEnv
+ -> Type
+ -> WithUsageDetails Type
+occAnalTy env (TyVarTy tv)
+ = let tv_usage = mkOneTyVarOcc env tv
+ -- WUD ki_usage tv_ki' = occAnalTy env ()
+ in WUD tv_usage (TyVarTy tv)
+occAnalTy env (AppTy t1 t2)
+ = let WUD t1_usage t1' = occAnalTy env t1
+ WUD t2_usage t2' = occAnalTy env t2
+ in WUD (t1_usage `andUDs` t2_usage) (mkAppTy t1' t2')
+occAnalTy _ ty@(LitTy {}) = WUD emptyDetails ty
+occAnalTy env (CastTy ty co)
+ = let WUD ty_usage ty' = occAnalTy env ty
+ WUD co_usage co' = occAnalCo env co
+ in WUD (ty_usage `andUDs` co_usage) (mkCastTy ty' co')
+occAnalTy env (CoercionTy co)
+ = let WUD co_usage co' = occAnalCo env co
+ in WUD co_usage (CoercionTy co')
+occAnalTy env fun@(FunTy _ w arg res)
+ = let WUD w_usage w' = occAnalTy env w
+ WUD arg_usage arg' = occAnalTy env arg
+ WUD res_usage res' = occAnalTy env res
+ all_usage = w_usage `andUDs` arg_usage `andUDs` res_usage
+ in WUD all_usage (fun { ft_mult = w', ft_arg = arg', ft_res = res' })
+occAnalTy env ty@(TyConApp tc tys)
+ | null tys
+ = WUD emptyDetails ty
+
+ | let WUD tys_usage tys' = occAnalTys env tys
+ = WUD tys_usage (mkTyConApp tc tys')
+occAnalTy env (ForAllTy (Bndr tv vis) inner)
+ = let WUD usage inner' = occAnalTy env inner
+ in WUD usage (ForAllTy (Bndr tv vis) inner')
+
+occAnalCos :: OccEnv -> [Coercion] -> WithUsageDetails [Coercion]
+occAnalCos _ [] = WUD emptyDetails []
+occAnalCos env (co:cos)
+ = let WUD uds1 co' = occAnalCo env co
+ WUD uds2 cos' = occAnalCos env cos
+ in WUD (uds1 `andUDs` uds2) (co' : cos')
+
+occAnalMCo :: OccEnv -> MCoercion -> WithUsageDetails MCoercion
+occAnalMCo _ MRefl = WUD emptyDetails MRefl
+occAnalMCo env (MCo co)
+ = let WUD usage co' = occAnalCo env co
+ in WUD usage (MCo co')
+
+occAnalCo :: OccEnv -> Coercion -> WithUsageDetails Coercion
+occAnalCo !env (Refl ty)
+ = let WUD usage ty' = occAnalTy env ty
+ in WUD usage (Refl ty')
+occAnalCo !env (GRefl r ty mco)
+ = let WUD usage1 ty' = occAnalTy env ty
+ WUD usage2 mco' = occAnalMCo env mco
+ in WUD (usage1 `andUDs` usage2) (mkGReflCo r ty' mco')
+occAnalCo !env (AppCo co1 co2)
+ = let WUD usage1 co1' = occAnalCo env co1
+ WUD usage2 co2' = occAnalCo env co2
+ in WUD (usage1 `andUDs` usage2) (mkAppCo co1' co2')
+occAnalCo !env (FunCo r afl afr cw c1 c2)
+ = let WUD cw_usage cw' = occAnalCo env cw
+ WUD c1_usage c1' = occAnalCo env c1
+ WUD c2_usage c2' = occAnalCo env c2
+ total_usage = cw_usage `andUDs` c1_usage `andUDs` c2_usage
+ in WUD total_usage (mkFunCo2 r afl afr cw' c1' c2')
+occAnalCo env (CoVarCo cv)
+ = let occ = mkOneIdOcc env cv NotInteresting 0
+ in WUD occ (mkCoVarCo cv)
+occAnalCo _ (HoleCo hole)
+ = pprPanic "occAnalCo:HoleCo" (ppr hole)
+occAnalCo env (UnivCo p r t1 t2)
+ = let WUD p_usage p' = occAnalProv env p
+ WUD t1_usage t1' = occAnalTy env t1
+ WUD t2_usage t2' = occAnalTy env t2
+ total_usage = p_usage `andUDs` t1_usage `andUDs` t2_usage
+ in WUD total_usage (mkUnivCo p' r t1' t2')
+occAnalCo env (SymCo co)
+ = let WUD usage co' = occAnalCo env co
+ in WUD usage (mkSymCo co')
+occAnalCo env (TransCo co1 co2)
+ = let WUD usage1 co1' = occAnalCo env co1
+ WUD usage2 co2' = occAnalCo env co2
+ in WUD (usage1 `andUDs` usage2) (mkTransCo co1' co2')
+occAnalCo env (AxiomRuleCo r cos)
+ = let WUD usage cos' = occAnalCos env cos
+ in WUD usage (AxiomRuleCo r cos')
+occAnalCo env (SelCo i co)
+ = let WUD usage co' = occAnalCo env co
+ in WUD usage (mkSelCo i co')
+occAnalCo env (LRCo lr co)
+ = let WUD usage co' = occAnalCo env co
+ in WUD usage (mkLRCo lr co')
+occAnalCo env (InstCo co arg)
+ = let WUD usage1 co' = occAnalCo env co
+ WUD usage2 arg' = occAnalCo env arg
+ in WUD (usage1 `andUDs` usage2) (mkInstCo co' arg')
+occAnalCo env (KindCo co)
+ = let WUD usage co' = occAnalCo env co
+ in WUD usage (mkKindCo co')
+occAnalCo env (SubCo co)
+ = let WUD usage co' = occAnalCo env co
+ in WUD usage (mkSubCo co')
+occAnalCo env (AxiomInstCo ax i cos)
+ = let WUD usage cos' = occAnalCos env cos
+ in WUD usage (mkAxiomInstCo ax i cos')
+occAnalCo env co@(TyConAppCo r tc cos)
+ | null cos
+ = WUD emptyDetails co
+
+ | otherwise
+ = let WUD usage cos' = occAnalCos env cos
+ in WUD usage (mkTyConAppCo r tc cos')
+occAnalCo env (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR
+ , fco_kind = kind_co, fco_body = co })
+ = let WUD usage1 kind_co' = occAnalCo env kind_co
+ WUD usage2 co' = occAnalCo env co
+ in WUD (usage1 `andUDs` usage2) (mkForAllCo tv visL visR kind_co' co')
+
+occAnalProv :: OccEnv -> UnivCoProvenance -> WithUsageDetails UnivCoProvenance
+occAnalProv env (PhantomProv co)
+ = let WUD usage co' = occAnalCo env co
+ in WUD usage (PhantomProv co')
+occAnalProv env (ProofIrrelProv co)
+ = let WUD usage co' = occAnalCo env co
+ in WUD usage (ProofIrrelProv co')
+occAnalProv _ p@(PluginProv _) = WUD emptyDetails p
occAnal :: OccEnv
-> CoreExpr
@@ -2442,11 +2603,12 @@ occAnal env expr@(Var _) = occAnalApp env (expr, [], [])
-- rules in them, so the *specialised* versions looked as if they
-- weren't used at all.
-occAnal _ expr@(Type ty)
- = WUD (addManyOccs emptyDetails (coVarsOfType ty)) expr
-occAnal _ expr@(Coercion co)
- = WUD (addManyOccs emptyDetails (coVarsOfCo co)) expr
- -- See Note [Gather occurrences of coercion variables]
+occAnal env (Type ty)
+ = let WUD usage ty' = occAnalTy env ty
+ in WUD usage (Type ty')
+occAnal env (Coercion co)
+ = let WUD usage co' = occAnalCo env co
+ in WUD usage (Coercion co')
{- Note [Gather occurrences of coercion variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2523,12 +2685,12 @@ occAnal env (Tick tickish body)
-- See #14242.
occAnal env (Cast expr co)
- = let (WUD usage expr') = occAnal env expr
- usage1 = addManyOccs usage (coVarsOfCo co)
- -- usage2: see Note [Gather occurrences of coercion variables]
- usage2 = markAllNonTail usage1
- -- usage3: calls inside expr aren't tail calls any more
- in WUD usage2 (Cast expr' co)
+ = let (WUD expr_uds expr') = occAnal env expr
+ WUD co_uds co' = occAnalCo env co
+ -- co_uds: see Note [Gather occurrences of coercion variables]
+ uds = markAllNonTail (expr_uds `andUDs` co_uds)
+ -- co_uds': calls inside expr aren't tail calls any more
+ in WUD uds (Cast expr' co')
occAnal env app@(App _ _)
= occAnalApp env (collectArgsTicks tickishFloatable app)
@@ -2660,7 +2822,7 @@ occAnalApp env (Var fun_id, args, ticks)
!(fun', fun_id') = lookupBndrSwap env fun_id
!(WUD args_uds app') = occAnalArgs env fun' args one_shots
- fun_uds = mkOneOcc env fun_id' int_cxt n_args
+ fun_uds = mkOneIdOcc env fun_id' int_cxt n_args
-- NB: fun_uds is computed for fun_id', not fun_id
-- See (BS1) in Note [The binder-swap substitution]
@@ -2923,7 +3085,7 @@ setNonTailCtxt ctxt !env
-- that might mean we don't record all occurrencs, and that means we
-- duplicate a redex.... a very nasty bug (which I encountered!). Hence
-- this DEBUG code which doesn't remove jx from the envt; it just gives it
- -- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch
+ -- emptyDetails, which in turn causes a panic in mkOneIdOcc. That will catch
-- this bug before it does any damage.
#ifdef DEBUG
zapped_jp_env = mapVarEnv (\ _ -> emptyVarEnv) (occ_join_points env)
@@ -3497,8 +3659,8 @@ For example, in (case x of A -> y; B -> y; C -> True),
-}
-type OccInfoEnv = IdEnv LocalOcc -- A finite map from an expression's
- -- free variables to their usage
+type OccInfoEnv = VarEnv LocalOcc -- A finite map from an expression's
+ -- free variables to their usage
data LocalOcc -- See Note [LocalOcc]
= OneOccL { lo_n_br :: {-# UNPACK #-} !BranchCount -- Number of syntactic occurrences
@@ -3562,9 +3724,17 @@ andUDs, orUDs
andUDs = combineUsageDetailsWith andLocalOcc
orUDs = combineUsageDetailsWith orLocalOcc
-mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails
-mkOneOcc !env id int_cxt arity
- | not (isLocalId id)
+mkOneTyVarOcc :: OccEnv -> TyVar -> UsageDetails
+mkOneTyVarOcc !_env tv
+ = mkSimpleDetails (unitVarEnv tv occ)
+ where
+ occ = OneOccL { lo_n_br = 1, lo_int_cxt = NotInteresting
+ , lo_tail = NoTailCallInfo }
+
+mkOneIdOcc :: OccEnv -> Var -> InterestingCxt -> JoinArity -> UsageDetails
+mkOneIdOcc !env id int_cxt arity
+ | assert (not (isTyVar id)) $
+ not (isLocalId id)
= emptyDetails
| Just join_uds <- lookupVarEnv (occ_join_points env) id
@@ -3582,8 +3752,7 @@ mkOneOcc !env id int_cxt arity
-- Add several occurrences, assumed not to be tail calls
add_many_occ :: Var -> OccInfoEnv -> OccInfoEnv
-add_many_occ v env | isId v = extendVarEnv env v (ManyOccL NoTailCallInfo)
- | otherwise = env
+add_many_occ v env = extendVarEnv env v (ManyOccL NoTailCallInfo)
-- Give a non-committal binder info (i.e noOccInfo) because
-- a) Many copies of the specialised thing can appear
-- b) We don't want to substitute a BIG expression inside a RULE
@@ -3598,13 +3767,14 @@ addManyOccs uds var_set
add_to env = nonDetStrictFoldUniqSet add_many_occ env var_set
-- It's OK to use nonDetStrictFoldUniqSet here because add_many_occ commutes
-addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails
--- Add any CoVars free in the type of a lambda-binder
+addLamTyCoVarOccs :: UsageDetails -> [Var] -> UsageDetails
+-- occAnalLamBndrs :: OccEnv -> UsageDetails -> [Var] -> WithUsageDetails [Var]
+-- Add any TyCoVars free in the type of a lambda-binder
-- See Note [Gather occurrences of coercion variables]
-addLamCoVarOccs uds bndrs
+addLamTyCoVarOccs uds bndrs
= foldr add uds bndrs
where
- add bndr uds = uds `addManyOccs` coVarsOfType (varType bndr)
+ add bndr uds = uds `addManyOccs` tyCoVarsOfType (varType bndr)
emptyDetails :: UsageDetails
emptyDetails = mkSimpleDetails emptyVarEnv
@@ -3806,7 +3976,6 @@ tagNonRecBinder :: TopLevelFlag -- At top level?
-> OccInfo -- Of scope
-> CoreBndr -- Binder
-> (IdWithOccInfo, JoinPointHood) -- Tagged binder
--- No-op on TyVars
-- Precondition: OccInfo is not IAmDead
tagNonRecBinder lvl occ bndr
| okForJoinPoint lvl bndr tail_call_info
@@ -3871,9 +4040,11 @@ tagRecBinders lvl body_uds details_s
setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr
setBinderOcc occ_info bndr
- | isTyVar bndr = bndr
- | occ_info == idOccInfo bndr = bndr
- | otherwise = setIdOccInfo bndr occ_info
+ | isTyVar bndr
+ , occ_info == tyVarOccInfo bndr = bndr
+ | isTyVar bndr = setTyVarOccInfo bndr occ_info
+ | occ_info == idOccInfo bndr = bndr
+ | otherwise = setIdOccInfo bndr occ_info
-- | Decide whether some bindings should be made into join points or not, based
-- on its occurrences. This is
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -21,15 +21,15 @@ module GHC.Core.Opt.Simplify.Env (
extendTvSubst, extendCvSubst,
zapSubstEnv, setSubstEnv, bumpCaseDepth,
getInScope, setInScopeFromE, setInScopeFromF,
- setInScopeSet, modifyInScope, addNewInScopeIds,
+ setInScopeSet, modifyInScope, addNewInScopeBndrs,
getSimplRules, enterRecGroupRHSs,
reSimplifying,
-- * Substitution results
SimplSR(..), mkContEx, substId, lookupRecBndr,
- -- * Simplifying 'Id' binders
- simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,
+ -- * Simplifying binders
+ simplTopBndrs, simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,
simplBinder, simplBinders,
substTy, substTyVar, getSubst,
substCo, substCoVar,
@@ -588,20 +588,39 @@ setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env }
setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv
setInScopeFromF env floats = env { seInScope = sfInScope floats }
-addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv
- -- The new Ids are guaranteed to be freshly allocated
-addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs
--- See Note [Bangs in the Simplifier]
- = let !in_scope1 = in_scope `extendInScopeSetList` vs
- !id_subst1 = id_subst `delVarEnvList` vs
- in
- env { seInScope = in_scope1,
- seIdSubst = id_subst1 }
- -- Why delete? Consider
- -- let x = a*b in (x, \x -> x+3)
- -- We add [x |-> a*b] to the substitution, but we must
- -- _delete_ it from the substitution when going inside
- -- the (\x -> ...)!
+addNewInScopeBndrs :: SimplEnv -> [CoreBndr] -> SimplEnv
+ -- The new binders are guaranteed to be freshly allocated
+addNewInScopeBndrs env bndrs
+ = go env bndrs
+ where
+ go env [] = env
+ go env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_subst }) (tv:bndrs)
+ | isTyVar tv
+ = let !in_scope1 = in_scope `extendInScopeSet` tv
+ !tv_subst1 = tv_subst `delVarEnv` tv
+ env1 = env { seInScope = in_scope1,
+ seTvSubst = tv_subst1 }
+ in go env1 bndrs
+ go env@(SimplEnv { seInScope = in_scope, seCvSubst = cv_subst }) (cv:bndrs)
+ | isCoVar cv
+ = let !in_scope1 = in_scope `extendInScopeSet` cv
+ !cv_subst1 = cv_subst `delVarEnv` cv
+ env1 = env { seInScope = in_scope1,
+ seCvSubst = cv_subst1 }
+ in go env1 bndrs
+ go env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) (v:bndrs)
+ = -- See Note [Bangs in the Simplifier]
+ let !in_scope1 = in_scope `extendInScopeSet` v
+ !id_subst1 = id_subst `delVarEnv` v
+ -- Why delete? Consider
+ -- let x = a*b in (x, \x -> x+3)
+ -- We add [x |-> a*b] to the substitution, but we must
+ -- _delete_ it from the substitution when going inside
+ -- the (\x -> ...)!
+ env1 = env { seInScope = in_scope1,
+ seIdSubst = id_subst1 }
+ in go env1 bndrs
+
modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv
-- The variable should already be in scope, but
@@ -776,6 +795,7 @@ unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $
where
flag (Rec {}) = FltLifted
flag (NonRec bndr rhs)
+ | isTyVar bndr = FltLifted
| not (isStrictId bndr) = FltLifted
| exprIsTickedString rhs = FltLifted
-- String literals can be floated freely.
@@ -964,6 +984,12 @@ refineFromInScope in_scope v
lookupRecBndr :: SimplEnv -> InId -> OutId
-- Look up an Id which has been put into the envt by simplRecBndrs,
-- but where we have not yet done its RHS
+-- lookupRecBndr (SimplEnv { seInScope = in_scope, seTvSubst = tvs }) v
+-- | isTyVar v
+-- = case lookupVarEnv tvs v of
+-- Just (DoneId v) -> v
+-- Just _ -> pprPanic "lookupRecBndr" (ppr v)
+-- Nothing -> refineFromInScope in_scope v
lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v
= case lookupVarEnv ids v of
Just (DoneId v) -> v
@@ -1030,30 +1056,63 @@ simplBinder !env bndr
---------------
simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
-- A non-recursive let binder
-simplNonRecBndr !env id
+simplNonRecBndr !env bndr
-- See Note [Bangs in the Simplifier]
- = do { let (!env1, id1) = substIdBndr env id
- ; seqId id1 `seq` return (env1, id1) }
+ = do { let (!env1, bndr1) = substBndr env bndr
+ ; seqVar bndr1 `seq` return (env1, bndr1) }
---------------
simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
-- Recursive let binders
-simplRecBndrs env@(SimplEnv {}) ids
+simplRecBndrs env@(SimplEnv {}) bndrs
-- See Note [Bangs in the Simplifier]
- = assert (all (not . isJoinId) ids) $
- do { let (!env1, ids1) = mapAccumL substIdBndr env ids
- ; seqIds ids1 `seq` return env1 }
+ = assert (all (not . isJoinId) bndrs) $
+ do { let (!env1, bndrs1) = mapAccumL substIdBndr env bndrs
+ ; seqVars bndrs1 `seq` return env1 }
---------------
-substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr)
+simplTopBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv
+simplTopBndrs env@(SimplEnv {}) bndrs
+ -- See Note [Bangs in the Simplifier]
+ = assert (all (not . isJoinId) bndrs) $
+ do { let (!env1, bndrs1) = mapAccumL substBndr env bndrs
+ ; seqVars bndrs1 `seq` return env1 }
+
+---------------
+substBndr :: HasDebugCallStack => SimplEnv -> InBndr -> (SimplEnv, OutBndr)
+substBndr env bndr
+ | isTyVar bndr = substTyVarBndr env bndr
+ | otherwise = substIdBndr env bndr
+
+---------------
+substIdBndr :: HasDebugCallStack => SimplEnv -> InBndr -> (SimplEnv, OutBndr)
-- Might be a coercion variable
substIdBndr env bndr
| isCoVar bndr = substCoVarBndr env bndr
| otherwise = substNonCoVarIdBndr env bndr
+---------------
+-- substTyVarBndr :: SimplEnv
+-- -> InBndr
+-- -> (SimplEnv, OutBndr)
+-- substTyVarBndr env@(SimplEnv { seInScope = in_scope, seTvSubst = tv_subst }) old_tv
+-- = assertPpr (isTyVar old_tv) (ppr old_tv)
+-- (env { seInScope = new_in_scope,
+-- seTvSubst = new_subst }, new_tv)
+-- where
+-- !tv1 = uniqAway in_scope old_tv
+-- !tv2 = substTyVarKind env tv1
+-- !new_tv = zapFragileTyVarInfo tv2 -- Zaps unfolding and fragile OccInfo
+-- !new_subst | new_tv /= old_tv
+-- = extendVarEnv tv_subst old_tv (DoneId new_tv)
+-- | otherwise
+-- = delVarEnv tv_subst old_tv
+--
+-- !new_in_scope = in_scope `extendInScopeSet` new_tv
+
---------------
substNonCoVarIdBndr
- :: SimplEnv
+ :: HasDebugCallStack => SimplEnv
-> InBndr -- Env and binder to transform
-> (SimplEnv, OutBndr)
-- Clone Id if necessary, substitute its type
@@ -1079,7 +1138,7 @@ substNonCoVarIdBndr env id = subst_id_bndr env id (\x -> x)
-- This is especially important for `substNonCoVarIdBndr` which
-- passes an identity lambda.
{-# INLINE subst_id_bndr #-}
-subst_id_bndr :: SimplEnv
+subst_id_bndr :: HasDebugCallStack => SimplEnv
-> InBndr -- Env and binder to transform
-> (OutId -> OutId) -- Adjust the type
-> (SimplEnv, OutBndr)
@@ -1124,6 +1183,15 @@ seqIds :: [Id] -> ()
seqIds [] = ()
seqIds (id:ids) = seqId id `seq` seqIds ids
+seqVar :: Var -> ()
+seqVar var
+ | isTyVar var = seqTyVar var
+ | otherwise = seqId var
+
+seqVars :: [Var] -> ()
+seqVars [] = ()
+seqVars (var:vars) = seqVar var `seq` seqVars vars
+
{-
Note [Arity robustness]
~~~~~~~~~~~~~~~~~~~~~~~
@@ -1308,3 +1376,4 @@ substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv
subst = Subst in_scope emptyIdSubstEnv tv_env cv_env
old_ty = idType id
old_w = varMult id
+
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -57,7 +57,7 @@ import GHC.Types.Demand
import GHC.Types.Unique ( hasKey )
import GHC.Types.Basic
import GHC.Types.Tickish
-import GHC.Types.Var ( isTyCoVar )
+import GHC.Types.Var ( isTyCoVar, setTyVarUnfolding )
import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )
import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
import GHC.Builtin.Names( runRWKey )
@@ -209,7 +209,7 @@ simplTopBinds env0 binds0
-- It's rather as if the top-level binders were imported.
-- See Note [Glomming] in "GHC.Core.Opt.OccurAnal".
-- See Note [Bangs in the Simplifier]
- ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)
+ ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplTopBndrs env0 (bindersOfBinds binds0)
; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0
; freeTick SimplifierDone
; return (floats, env2) }
@@ -229,6 +229,11 @@ simplTopBinds env0 binds0
simpl_bind env (Rec pairs)
= simplRecBind env (BC_Let TopLevel Recursive) pairs
simpl_bind env (NonRec b r)
+ | isTyVar b
+ = do { let bind_cxt = BC_Type TopLevel
+ ; (env', b') <- return (env, b) -- addBndrRules env b (lookupRecBndr env b) bind_cxt
+ ; simplRecOrTopPair env' bind_cxt b b' r }
+ | otherwise
= do { let bind_cxt = BC_Let TopLevel NonRecursive
; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt
; simplRecOrTopPair env' bind_cxt b b' r }
@@ -295,6 +300,12 @@ simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs
simplJoinBind is_rec cont
(old_bndr,env) (new_bndr,env) (rhs,env)
+ BC_Type top_lvl
+ | Type rhs_ty <- rhs -> simplTrace "SimplBind:type" (ppr old_bndr) $
+ simplTypeBind top_lvl
+ (old_bndr,env) (new_bndr,env) (rhs_ty,env)
+ | otherwise -> pprPanic "simplRecOrTopPair:Type" (ppr rhs)
+
BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $
simplLazyBind top_lvl is_rec
(old_bndr,env) (new_bndr,env) (rhs,env)
@@ -372,6 +383,27 @@ simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se)
; (bind_float, env2) <- completeBind (BC_Let top_lvl is_rec) (bndr,unf_se) (bndr1,rhs',env1)
; return (rhs_floats `addFloats` bind_float, env2) }
+--------------------------
+simplTypeBind :: TopLevelFlag
+ -> (InTyVar, SimplEnv)
+ -> (OutTyVar, SimplEnv)
+ -> (InType, SimplEnv)
+ -> SimplM (SimplFloats, SimplEnv)
+simplTypeBind top_lvl (bndr,unf_se) (bndr1,env) (rhs,rhs_se)
+ = assert (isTyVar bndr) $
+ pprTrace "simplTypeBind" (ppr bndr $$ ppr bndr1) $
+ do { let !rhs_env = rhs_se `setInScopeFromE` env
+ ; (rhs_env1, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env []
+ -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils
+ ; body <- simplType rhs_env rhs
+ ; (rhs_floats, expr_rhs') <- {-#SCC "prepareBinding" #-}
+ prepareBinding env top_lvl NonRecursive
+ False
+ bndr1 (emptyFloats rhs_env1) (Type body)
+ ; let env1 = env `setInScopeFromF` rhs_floats
+ ; (bind_float, env2) <- completeBind (BC_Type top_lvl) (bndr,unf_se) (bndr1,expr_rhs',env1)
+ ; return (rhs_floats `addFloats` bind_float, env2) }
+
--------------------------
simplJoinBind :: RecFlag
-> SimplCont
@@ -920,6 +952,10 @@ completeBind :: BindContext
-- Binder /can/ be a JoinId
-- Precondition: rhs obeys the let-can-float invariant
completeBind bind_cxt (old_bndr, unf_se) (new_bndr, new_rhs, env)
+ | Type new_ty <- new_rhs
+ = assert (isTyVar old_bndr) $
+ return (mkFloatBind env (NonRec (new_bndr `setTyVarUnfolding` new_ty) new_rhs))
+
| isCoVar old_bndr
= case new_rhs of
Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)
@@ -1247,11 +1283,20 @@ simplExprF1 env (Let (Rec pairs) body) cont
= {-#SCC "simplRecE" #-} simplRecE env pairs body cont
simplExprF1 env (Let (NonRec bndr rhs) body) cont
- | Type ty <- rhs -- First deal with type lets (let a = Type ty in e)
- = {-#SCC "simplExprF1-NonRecLet-Type" #-}
- assert (isTyVar bndr) $
- do { ty' <- simplType env ty
- ; simplExprF (extendTvSubst env bndr ty') body cont }
+ -- | Type ty <- rhs -- First deal with type lets (let a = Type ty in e)
+ -- = {-#SCC "simplExprF1-NonRecLet-Type" #-}
+ -- assert (isTyVar bndr) $
+ -- do { (env1, bndr1) <- simplNonRecBndr env bndr
+ -- ; (floats1, env2) <- simplTypeBind NotTopLevel (bndr,env) (bndr1,env1) (ty,env1)
+ -- ; (floats2, expr') <- simplNonRecBody env2 FromLet body cont
+ -- ; return (floats1 `addFloats` floats2, expr') }
+ -- | Coercion _co <- rhs
+ -- = {-#SCC "simplExprF1-NonRecLet-Coercion" #-}
+ -- assert (isCoVar bndr) $
+ -- do { (env1, bndr1) <- simplNonRecBndr env bndr
+ -- ; (floats1, env2) <- simplLazyBind NotTopLevel NonRecursive (bndr,env) (bndr1,env1) (rhs,env1)
+ -- ; (floats2, expr') <- simplNonRecBody env2 FromLet body cont
+ -- ; return (floats1 `addFloats` floats2, expr') }
| Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env
-- Because of the let-can-float invariant, it's ok to
@@ -1271,6 +1316,7 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont
= {-#SCC "simplNonRecE" #-}
simplNonRecE env FromLet bndr (rhs, env) body cont
+
{- Note [Avoiding space leaks in OutType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Since the simplifier is run for multiple iterations, we need to ensure
@@ -1900,6 +1946,14 @@ simplNonRecE :: HasDebugCallStack
-- Otherwise it may or may not satisfy it.
simplNonRecE env from_what bndr (rhs, rhs_se) body cont
+ | Type ty <- rhs
+ = assert (isTyVar bndr) $
+ do { (env1, bndr1) <- simplNonRecBndr env bndr
+ ; ty' <- simplType env ty
+ ; let (floats1, env2) = mkFloatBind env1 (NonRec (bndr1 `setTyVarUnfolding` ty') (Type ty'))
+ ; (floats2, expr') <- simplNonRecBody env2 from_what body cont
+ ; return (floats1 `addFloats` floats2, expr') }
+
| assert (isId bndr && not (isJoinId bndr) ) $
is_strict_bind
= -- Evaluate RHS strictly
@@ -2360,7 +2414,7 @@ rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
-- See Note [No eta-expansion in runRW#]
_ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy
; let (m,_,_) = splitFunTy fun_ty
- env' = arg_env `addNewInScopeIds` [s']
+ env' = arg_env `addNewInScopeBndrs` [s']
cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'
, sc_env = env', sc_cont = cont
, sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }
@@ -3826,7 +3880,7 @@ mkDupableContWithDmds env _
do { let rhs_ty = contResultType cont
(m,arg_ty,_) = splitFunTy fun_ty
; arg_bndr <- newId (fsLit "arg") m arg_ty
- ; let env' = env `addNewInScopeIds` [arg_bndr]
+ ; let env' = env `addNewInScopeBndrs` [arg_bndr]
; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont
; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }
where
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -86,6 +86,7 @@ import Control.Monad ( when )
import Data.List ( sortBy )
import GHC.Types.Name.Env
import Data.Graph
+import GHC.Types.Var (tyVarOccInfo)
{- *********************************************************************
* *
@@ -98,20 +99,26 @@ data BindContext
= BC_Let -- A regular let-binding
TopLevelFlag RecFlag
+ | BC_Type
+ TopLevelFlag
+
| BC_Join -- A join point with continuation k
RecFlag -- See Note [Rules and unfolding for join points]
SimplCont -- in GHC.Core.Opt.Simplify
bindContextLevel :: BindContext -> TopLevelFlag
bindContextLevel (BC_Let top_lvl _) = top_lvl
+bindContextLevel (BC_Type top_lvl) = top_lvl
bindContextLevel (BC_Join {}) = NotTopLevel
bindContextRec :: BindContext -> RecFlag
bindContextRec (BC_Let _ rec_flag) = rec_flag
+bindContextRec (BC_Type _) = NonRecursive
bindContextRec (BC_Join rec_flag _) = rec_flag
isJoinBC :: BindContext -> Bool
isJoinBC (BC_Let {}) = False
+isJoinBC (BC_Type {}) = False
isJoinBC (BC_Join {}) = True
@@ -1041,7 +1048,7 @@ interestingArg env e = go env 0 e
ValueArg -> ValueArg
_ -> NonTrivArg
where
- env' = env `addNewInScopeIds` bindersOf b
+ env' = env `addNewInScopeBndrs` bindersOf b
go_var n v
| isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that
@@ -1462,6 +1469,7 @@ preInlineUnconditionally
-- for unlifted, side-effect-ful bindings
preInlineUnconditionally env top_lvl bndr rhs rhs_env
| not pre_inline_unconditionally = Nothing
+ | isTyVar bndr = Nothing
| not active = Nothing
| isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids]
| isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally]
@@ -1597,6 +1605,7 @@ postInlineUnconditionally
-- Reason: we don't want to inline single uses, or discard dead bindings,
-- for unlifted, side-effect-ful bindings
postInlineUnconditionally env bind_cxt old_bndr bndr rhs
+ | BC_Type {} <- bind_cxt = False
| not active = False
| isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline
-- because it might be referred to "earlier"
@@ -2220,16 +2229,19 @@ abstractFloats uf_opts top_lvl main_tvs floats body
-- See wrinkle (AB5) in Note [Which type variables to abstract over]
-- for why we need to re-do dependency analysis
- to_sccs :: OutBind -> [SCC (Id, CoreExpr, VarSet)]
- to_sccs (NonRec id e) = [AcyclicSCC (id, e, emptyVarSet)] -- emptyVarSet: abstract doesn't need it
+ to_sccs :: OutBind -> [SCC (Var, CoreExpr, VarSet)]
+ to_sccs (NonRec v e) = [AcyclicSCC (v, e, emptyVarSet)] -- emptyVarSet: abstract doesn't need it
to_sccs (Rec prs) = sccs
where
- (ids,rhss) = unzip prs
- sccs = depAnal (\(id,_rhs,_fvs) -> [getName id])
- (\(_id,_rhs,fvs) -> nonDetStrictFoldVarSet ((:) . getName) [] fvs) -- Wrinkle (AB3)
- (zip3 ids rhss (map exprFreeVars rhss))
+ (vars,rhss) = unzip prs
+ sccs = depAnal (\(v,_rhs,_fvs) -> [getName v])
+ (\(_v,_rhs,fvs) -> nonDetStrictFoldVarSet ((:) . getName) [] fvs) -- Wrinkle (AB3)
+ (zip3 vars rhss (map exprFreeVars rhss))
abstract :: GHC.Core.Subst.Subst -> SCC (Id, CoreExpr, VarSet) -> SimplM (GHC.Core.Subst.Subst, OutBind)
+ abstract subst (AcyclicSCC (tv, rhs, _empty_var_set))
+ | isTyVar tv
+ = return (subst, NonRec tv rhs)
abstract subst (AcyclicSCC (id, rhs, _empty_var_set))
= do { (poly_id1, poly_app) <- mk_poly1 tvs_here id
; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1469,9 +1469,15 @@ specBind :: TopLevelFlag
-> SpecM ( [OutBind] -- New bindings
, body -- Body
, UsageDetails) -- And info to pass upstream
-
-- Returned UsageDetails:
-- No calls for binders of this bind
+
+specBind _top_lvl env bind@(NonRec _ (Type {})) do_body
+ -- Can't check that the binder is a type variable, otherwise the the variable is forced and
+ -- will trigger an infinite loop. Instead, we match on the structure of the RHS.
+ = do { (body, body_uds) <- do_body env
+ ; return ([bind], body, body_uds) }
+
specBind top_lvl env (NonRec fn rhs) do_body
= do { (rhs', rhs_uds) <- specExpr env rhs
=====================================
compiler/GHC/Core/Opt/WorkWrap.hs
=====================================
@@ -88,12 +88,16 @@ wwBind :: WwOpts
-- the caller will convert to Expr/Binding,
-- as appropriate.
-wwBind ww_opts (NonRec binder rhs) = do
- new_rhs <- wwExpr ww_opts rhs
- new_pairs <- tryWW ww_opts NonRecursive binder new_rhs
- return [NonRec b e | (b,e) <- new_pairs]
- -- Generated bindings must be non-recursive
- -- because the original binding was.
+wwBind ww_opts (NonRec binder rhs)
+ | isTyVar binder
+ = return [NonRec binder rhs]
+
+ | otherwise
+ = do { new_rhs <- wwExpr ww_opts rhs
+ ; new_pairs <- tryWW ww_opts NonRecursive binder new_rhs
+ ; return [NonRec b e | (b,e) <- new_pairs] }
+ -- Generated bindings must be non-recursive
+ -- because the original binding was.
wwBind ww_opts (Rec pairs)
= return . Rec <$> concatMapM do_one pairs
=====================================
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 )
+import GHC.Types.Var ( isNonCoVarId, tyVarUnfolding, setTyVarUnfolding )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Core.DataCon
@@ -437,6 +437,29 @@ simple_opt_bind env (Rec prs) top_level
where
(env', mb_pr) = simple_bind_pair env b (Just b') (env,r) top_level
+----------------------
+simple_bind_type :: SimpleOptEnv
+ -> InTyVar -> Maybe OutTyVar
+ -> (SimpleOptEnv, InType)
+ -> (SimpleOptEnv, Maybe (OutTyVar, OutType))
+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)
+
+ | 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
+ in (env', Just (out_bndr, out_ty))
+
----------------------
simple_bind_pair :: SimpleOptEnv
-> InVar -> Maybe OutVar
@@ -449,10 +472,15 @@ 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 ty <- in_rhs -- let a::* = TYPE ty in <body>
- , let out_ty = substTyUnchecked (soe_subst rhs_env) ty
- = assertPpr (isTyVar in_bndr) (ppr in_bndr $$ ppr in_rhs) $
- (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
+ | 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)
| Coercion co <- in_rhs
, let out_co = optCoercion (so_co_opts (soe_opts env)) (soe_subst rhs_env) co
@@ -523,8 +551,8 @@ simple_out_bind :: TopLevelFlag
-> (SimpleOptEnv, Maybe (OutVar, OutExpr))
simple_out_bind top_level env@(SOE { soe_subst = subst }) (in_bndr, out_rhs)
| Type out_ty <- out_rhs
- = assertPpr (isTyVar in_bndr) (ppr in_bndr $$ ppr out_ty $$ ppr out_rhs)
- (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)
+ = assertPpr (isTyVar in_bndr) (ppr in_bndr $$ ppr out_ty $$ ppr out_rhs) $
+ (env, Just (in_bndr `setTyVarUnfolding` out_ty, out_rhs))
| Coercion out_co <- out_rhs
= assert (isCoVar in_bndr)
=====================================
compiler/GHC/Core/TyCo/Compare.hs
=====================================
@@ -23,7 +23,7 @@ module GHC.Core.TyCo.Compare (
import GHC.Prelude
-import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe
+import GHC.Core.Type( typeKind, unfoldView, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe
, isLevityTy, isRuntimeRepTy, isMultiplicityTy )
import GHC.Core.TyCo.Rep
@@ -227,12 +227,17 @@ tc_eq_type keep_syns orig_ty1 orig_ty2
where
orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]
+ view
+ | keep_syns = unfoldView
+ | otherwise = coreView
+
go :: RnEnv2 -> Type -> Type -> Bool
-- See Note [Comparing nullary type synonyms]
go _ (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2 = True
+ go _ (TyVarTy tv1) (TyVarTy tv2) | tv1 == tv2 = True
- go env t1 t2 | not keep_syns, Just t1' <- coreView t1 = go env t1' t2
- go env t1 t2 | not keep_syns, Just t2' <- coreView t2 = go env t1 t2'
+ go env t1 t2 | Just t1' <- view t1 = go env t1' t2
+ go env t1 t2 | Just t2' <- view t2 = go env t1 t2'
go env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2
go _ (LitTy lit1) (LitTy lit2) = lit1 == lit2
@@ -606,6 +611,9 @@ nonDetCmpTypeX env orig_t1 orig_t2 =
go _ (TyConApp tc1 []) (TyConApp tc2 [])
| tc1 == tc2
= TEQ
+ go _ (TyVarTy tv1) (TyVarTy tv2)
+ | tv1 == tv2
+ = TEQ
go env t1 t2
| Just t1' <- coreView t1 = go env t1' t2
| Just t2' <- coreView t2 = go env t1 t2'
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -1106,12 +1106,21 @@ cloneTyVarBndr subst@(Subst in_scope id_env tv_env cv_env) tv uniq
, tv')
where
old_ki = tyVarKind tv
+ old_unf = tyVarUnfolding tv
no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed
+ no_unf_change = maybe True noFreeVarsOfType old_unf -- verify that kind is closed
tv1 | no_kind_change = tv
| otherwise = setTyVarKind tv (substTy subst old_ki)
- tv' = setVarUnique tv1 uniq
+ tv2 | Just unf <- tyVarUnfolding tv1
+ , not no_unf_change
+ = tv2 `setTyVarUnfolding` substTy subst unf
+
+ | otherwise
+ = tv1
+
+ tv' = setVarUnique tv2 uniq
cloneTyVarBndrs :: Subst -> [TyVar] -> UniqSupply -> (Subst, [TyVar])
cloneTyVarBndrs subst [] _usupply = (subst, [])
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -186,7 +186,7 @@ module GHC.Core.Type (
seqType, seqTypes,
-- * Other views onto Types
- coreView, coreFullView, rewriterView,
+ coreView, coreFullView, rewriterView, unfoldView,
tyConsOfType,
@@ -361,6 +361,11 @@ import GHC.Data.Maybe ( orElse, isJust, firstJust )
************************************************************************
-}
+unfoldView :: Type -> Maybe Type
+{-# INLINE unfoldView #-}
+unfoldView (TyVarTy tv) = tyVarUnfolding tv
+unfoldView _ = Nothing
+
rewriterView :: Type -> Maybe Type
-- Unwrap a type synonym only when either:
-- The type synonym is forgetful, or
@@ -371,6 +376,7 @@ rewriterView (TyConApp tc tys)
| isTypeSynonymTyCon tc
, isForgetfulSynTyCon tc || not (isFamFreeTyCon tc)
= expandSynTyConApp_maybe tc tys
+rewriterView (TyVarTy tv) = tyVarUnfolding tv
rewriterView _other
= Nothing
@@ -384,6 +390,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 _ = Nothing
-- See Note [Inlining coreView].
{-# INLINE coreView #-}
@@ -395,6 +402,8 @@ coreFullView, core_full_view :: Type -> Type
-- See Note [Inlining coreView].
coreFullView ty@(TyConApp tc _)
| isTypeSynonymTyCon tc = core_full_view ty
+coreFullView (TyVarTy tv)
+ | Just ty <- tyVarUnfolding tv = core_full_view ty
coreFullView ty = ty
{-# INLINE coreFullView #-}
@@ -2709,6 +2718,9 @@ 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 ty
sORTKind_maybe (TyConApp tc tys)
-- First, short-cuts for Type and Constraint that do no allocation
| tc_uniq == liftedTypeKindTyConKey = assert( null tys ) $ Just (TypeLike, liftedRepTy)
@@ -2849,7 +2861,9 @@ isFixedRuntimeRepKind k
isConcreteType :: Type -> Bool
isConcreteType = go
where
- go (TyVarTy tv) = isConcreteTyVar tv
+ go (TyVarTy tv)
+ | Just ty <- tyVarUnfolding tv = go ty
+ | otherwise = isConcreteTyVar tv
go (AppTy ty1 ty2) = go ty1 && go ty2
go (TyConApp tc tys) = go_tc tc tys
go ForAllTy{} = False
=====================================
compiler/GHC/Core/Unfold/Make.hs
=====================================
@@ -40,6 +40,9 @@ import Data.Maybe ( fromMaybe )
-- the very simple optimiser is used to optimise unfoldings
import {-# SOURCE #-} GHC.Core.SimpleOpt
+import GHC.Core.Subst (mkOpenSubst)
+import GHC.Core.Type (substTy)
+import GHC.Types.Var.Env (mkInScopeSetList)
@@ -180,10 +183,12 @@ specUnfolding opts spec_bndrs spec_app rule_lhs_args
-- to
-- \sbs. MkD ((\obs. <op1>) spec_args) ... ditto <opn>
where
- spec_arg arg = simpleOptExpr opts $
- spec_app (mkLams old_bndrs arg)
- -- The beta-redexes created by spec_app will be
- -- simplified away by simplOptExpr
+ spec_arg (Type t) = let subst = mkOpenSubst (mkInScopeSetList old_bndrs) (zip old_bndrs rule_lhs_args)
+ in Type (substTy subst t)
+ spec_arg arg = simpleOptExpr opts $
+ spec_app (mkLams old_bndrs arg)
+ -- The beta-redexes created by spec_app will be
+ -- simplified away by simplOptExpr
specUnfolding opts spec_bndrs spec_app rule_lhs_args
(CoreUnfolding { uf_src = src, uf_tmpl = tmpl
=====================================
compiler/GHC/Tc/Zonk/TcType.hs
=====================================
@@ -243,22 +243,22 @@ zonkTcTyVar :: TcTyVar -> ZonkM TcType
zonkTcTyVar tv
| isTcTyVar tv
= case tcTyVarDetails tv of
- SkolemTv {} -> zonk_kind_and_return
- RuntimeUnk {} -> zonk_kind_and_return
+ SkolemTv {} -> zonk_and_return
+ RuntimeUnk {} -> zonk_and_return
MetaTv { mtv_ref = ref }
-> do { cts <- readTcRef ref
; case cts of
- Flexi -> zonk_kind_and_return
+ Flexi -> zonk_and_return
Indirect ty -> do { zty <- zonkTcType ty
- ; writeTcRef ref (Indirect zty)
-- See Note [Sharing in zonking]
+ ; writeTcRef ref (Indirect zty)
; return zty } }
| otherwise -- coercion variable
- = zonk_kind_and_return
+ = zonk_and_return
where
- zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv
- ; return (mkTyVarTy z_tv) }
+ zonk_and_return = do { z_tv <- updateTyVarKindAndUnfoldingM zonkTcType tv
+ ; return (mkTyVarTy z_tv) }
-- Variant that assumes that any result of zonking is still a TyVar.
-- Should be used only on skolems and TyVarTvs
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -387,7 +387,7 @@ zonkTyVarOcc tv
-- This can happen for RuntimeUnk variables (which
-- should stay as RuntimeUnk), but I think it should
-- not happen for SkolemTv.
- mkTyVarTy <$> updateTyVarKindM zonkTcTypeToTypeX tv
+ mkTyVarTy <$> updateTyVarKindAndUnfoldingM zonkTcTypeToTypeX tv
Just tv' -> return (mkTyVarTy tv')
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -100,14 +100,15 @@ module GHC.Types.Var (
ExportFlag(..),
-- ** Constructing TyVar's
- mkTyVar, mkTcTyVar,
+ mkTyVar, mkTyVarWithUnfolding, mkTcTyVar,
-- ** Taking 'TyVar's apart
- tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails,
+ tyVarName, tyVarKind, tyVarUnfolding, tyVarOccInfo, tcTyVarDetails, setTcTyVarDetails,
-- ** Modifying 'TyVar's
- setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind,
- updateTyVarKindM,
+ setTyVarName, setTyVarUnique, setTyVarKind, setTyVarUnfolding, setTyVarOccInfo,
+ updateTyVarKind, updateTyVarKindM, updateTyVarUnfolding, updateTyVarUnfoldingM,
+ updateTyVarKindAndUnfoldingM,
nonDetCmpVar
) where
@@ -123,7 +124,7 @@ import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy )
import GHC.Types.Name hiding (varName)
import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique
, nonDetCmpUnique )
-import GHC.Types.Basic( TypeOrConstraint(..) )
+import GHC.Types.Basic( TypeOrConstraint(..), OccInfo, noOccInfo )
import GHC.Utils.Misc
import GHC.Utils.Binary
import GHC.Utils.Outputable
@@ -251,12 +252,15 @@ in its @VarDetails at .
data Var
= TyVar { -- Type and kind variables
-- see Note [Kind and type variables]
- varName :: !Name,
- realUnique :: {-# UNPACK #-} !Unique,
- -- ^ Key for fast comparison
- -- Identical to the Unique in the name,
- -- cached here for speed
- varType :: Kind -- ^ The type or kind of the 'Var' in question
+ varName :: !Name,
+ realUnique :: {-# UNPACK #-} !Unique,
+ -- ^ Key for fast comparison
+ -- Identical to the Unique in the name,
+ -- 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.
+ tv_occ_info :: OccInfo
}
| TcTyVar { -- Used only during type inference
@@ -346,6 +350,10 @@ instance Outputable Var where
getPprStyle $ \sty ->
let
ppr_var = case var of
+ (TyVar { tv_unfolding = Just ty })
+ | debug
+ -> brackets (text "unf =" <+> ppr ty)
+
(TyVar {})
| debug
-> brackets (text "tv")
@@ -1085,6 +1093,15 @@ tyVarName = varName
tyVarKind :: TyVar -> Kind
tyVarKind = varType
+tyVarUnfolding :: TyVar -> Maybe Type
+tyVarUnfolding (TyVar { tv_unfolding = unf }) = unf
+tyVarUnfolding _ = Nothing
+
+tyVarOccInfo :: TyVar -> OccInfo
+tyVarOccInfo (TcTyVar {}) = noOccInfo
+tyVarOccInfo tv = assertPpr (isTyVar tv) (ppr tv) $ tv_occ_info tv
+{-# NOINLINE tyVarOccInfo #-}
+
setTyVarUnique :: TyVar -> Unique -> TyVar
setTyVarUnique = setVarUnique
@@ -1094,6 +1111,17 @@ setTyVarName = setVarName
setTyVarKind :: TyVar -> Kind -> TyVar
setTyVarKind tv k = tv {varType = k}
+setTyVarUnfolding :: TyVar -> Type -> TyVar
+setTyVarUnfolding tv unf = tv {tv_unfolding = Just unf}
+
+setTyVarOccInfo :: TyVar -> OccInfo -> TyVar
+-- TODO: Surprisingly, TcTyVar's can occur after zonking, why?
+-- It could be caused by other parts of my changes though, but I wasn't able to find out where.
+-- For now, we just ignore them.
+-- setTyVarOccInfo tv@(TcTyVar {}) occ_info = pprPanic "setTyVarOccInfo" (ppr tv $$ ppr occ_info)
+setTyVarOccInfo tv@(TcTyVar {}) _occ_info = tv
+setTyVarOccInfo tv occ_info = assertPpr (isTyVar tv) (ppr tv) $ tv {tv_occ_info = occ_info}
+
updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar
updateTyVarKind update tv = tv {varType = update (tyVarKind tv)}
@@ -1102,12 +1130,44 @@ updateTyVarKindM update tv
= do { k' <- update (tyVarKind tv)
; return $ tv {varType = k'} }
+updateTyVarUnfolding :: (Type -> Type) -> TyVar -> TyVar
+updateTyVarUnfolding update tv
+ | Just unf <- tyVarUnfolding tv
+ = tv {tv_unfolding = Just (update unf)}
+
+ | otherwise
+ = tv
+
+updateTyVarUnfoldingM :: (Monad m) => (Type -> m Type) -> TyVar -> m TyVar
+updateTyVarUnfoldingM update tv
+ | Just unf <- tyVarUnfolding tv
+ = do { unf' <- update unf
+ ; return $ tv {tv_unfolding = Just unf'} }
+
+ | otherwise
+ = return tv
+
+updateTyVarKindAndUnfoldingM :: (Monad m) => (Type -> m Type) -> TyVar -> m TyVar
+updateTyVarKindAndUnfoldingM update tv
+ = do { tv' <- updateTyVarKindM update tv
+ ; updateTyVarUnfoldingM update tv' }
+
mkTyVar :: Name -> Kind -> TyVar
-mkTyVar name kind = TyVar { varName = name
- , realUnique = nameUnique name
- , varType = kind
+mkTyVar name kind = TyVar { varName = name
+ , realUnique = nameUnique name
+ , varType = kind
+ , tv_unfolding = Nothing
+ , tv_occ_info = noOccInfo
}
+mkTyVarWithUnfolding :: Name -> Kind -> Type -> TyVar
+mkTyVarWithUnfolding name kind unf = TyVar { varName = name
+ , realUnique = nameUnique name
+ , varType = kind
+ , tv_unfolding = Just unf
+ , tv_occ_info = noOccInfo
+ }
+
mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar
mkTcTyVar name kind details
= -- NB: 'kind' may be a coercion kind; cf, 'GHC.Tc.Utils.TcMType.newMetaCoVar'
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9c622629f53a23fc56814ce98fceb7b9d6d103e8...80ffac20b1ca82855908d73d69717901a02d034e
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/9c622629f53a23fc56814ce98fceb7b9d6d103e8...80ffac20b1ca82855908d73d69717901a02d034e
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/20240704/1e4273d5/attachment-0001.html>
More information about the ghc-commits
mailing list