[Git][ghc/ghc][wip/T20264] Progress
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Oct 29 17:43:30 UTC 2024
Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC
Commits:
151ac275 by Simon Peyton Jones at 2024-10-29T17:43:02+00:00
Progress
- - - - -
19 changed files:
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/Seq.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Core/TyCo/Subst.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Tc/TyCl.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/Types/Id/Info.hs
- compiler/GHC/Types/Var.hs
Changes:
=====================================
compiler/GHC/Core/FVs.hs
=====================================
@@ -32,7 +32,7 @@ module GHC.Core.FVs (
idFVs,
idRuleVars, stableUnfoldingVars,
ruleFreeVars, rulesFreeVars,
- rulesFreeVarsDSet, mkRuleInfo,
+ mkRuleInfo,
ruleLhsFreeIds, ruleLhsFreeIdsList,
ruleRhsFreeVars, rulesRhsFreeIds,
@@ -472,11 +472,6 @@ ruleLhsFreeIdsList = fvVarList . filterFV isLocalId . ruleFVs LhsOnly
ruleFreeVars :: CoreRule -> VarSet
ruleFreeVars = fvVarSet . ruleFVs BothSides
--- | Those variables free in the both the left right hand sides of rules
--- returned as a deterministic set
-rulesFreeVarsDSet :: [CoreRule] -> DVarSet
-rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs BothSides rules
-
-- | Those variables free in both the left right hand sides of several rules
rulesFreeVars :: [CoreRule] -> VarSet
rulesFreeVars rules = fvVarSet $ rulesFVs BothSides rules
@@ -484,7 +479,7 @@ rulesFreeVars rules = fvVarSet $ rulesFVs BothSides rules
-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable
-- for putting into an 'IdInfo'
mkRuleInfo :: [CoreRule] -> RuleInfo
-mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules)
+mkRuleInfo rules = RuleInfo rules
{-
Note [Rule free var hack] (Not a hack any more)
@@ -632,7 +627,9 @@ idRuleVars id = fvVarSet $ idRuleFVs id
idRuleFVs :: Id -> FV
idRuleFVs id = assert (isId id) $
- FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id))
+ rulesFVs BothSides $
+ ruleInfoRules (idSpecialisation id)
+ -- BothSides: see Note [Rule dependency info] in OccurAnal
idUnfoldingVars :: Id -> VarSet
-- Produce free vars for an unfolding, but NOT for an ordinary
=====================================
compiler/GHC/Core/Make.hs
=====================================
@@ -8,7 +8,7 @@ module GHC.Core.Make (
mkCoreLams, mkWildCase, mkIfThenElse,
mkWildValBinder,
mkSingleAltCase,
- sortQuantVars, castBottomExpr,
+ castBottomExpr,
-- * Constructing boxed literals
mkLitRubbish,
@@ -69,7 +69,6 @@ import GHC.Core.Utils ( exprType, mkSingleAltCase, bindNonRec )
import GHC.Core.Type
import GHC.Core.Predicate ( isCoVarType )
import GHC.Core.TyCo.Compare ( eqType )
-import GHC.Core.Coercion ( isCoVar )
import GHC.Core.DataCon ( DataCon, dataConWorkId )
import GHC.Core.Multiplicity
@@ -84,7 +83,6 @@ import GHC.Utils.Panic
import GHC.Settings.Constants( mAX_TUPLE_SIZE )
import GHC.Data.FastString
-import Data.List ( partition )
import Data.Char ( ord )
infixl 4 `mkCoreApp`, `mkCoreApps`
@@ -99,15 +97,6 @@ infixl 4 `mkCoreApp`, `mkCoreApps`
-- | Sort the variables, putting type and covars first, in scoped order,
-- and then other Ids
--
--- It is a deterministic sort, meaning it doesn't look at the values of
--- Uniques. For explanation why it's important See Note [Unique Determinism]
--- in GHC.Types.Unique.
-sortQuantVars :: [Var] -> [Var]
-sortQuantVars vs = sorted_tcvs ++ ids
- where
- (tcvs, ids) = partition (isTyVar <||> isCoVar) vs
- sorted_tcvs = scopedSort tcvs
-
-- | Bind a binding group over an expression, using a @let@ or @case@ as
-- appropriate (see "GHC.Core#let_can_float_invariant")
mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -1716,8 +1716,8 @@ makeNode !env _imp_rule_edges bndr_set (bndr, rhs@(Type rhs_ty))
rhs_env = setNonTailCtxt OccRhs env
-- WUD unf_uds mb_unf'
- -- | Just unf <- tyVarUnfolding bndr = Just <$> occAnalTy rhs_env unf
- -- | otherwise = WUD emptyUDs Nothing
+ -- | Just unf <- tyVarUnfolding_maybe bndr = Just <$> occAnalTy rhs_env unf
+ -- | otherwise = WUD emptyUDs Nothing
rhs_uds = occAnalTy rhs_env rhs_ty
inl_uds = rhs_uds -- `andUDs` unf_uds
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -89,13 +89,11 @@ 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.Subst
-import GHC.Core.Make ( sortQuantVars )
-import GHC.Core.Type ( Type, tyCoVarsOfType
- , mightBeUnliftedType, closeOverKindsDSet
- , typeHasFixedRuntimeRep
- )
+import GHC.Core.Type ( Type, tyCoVarsOfType, mightBeUnliftedType, typeHasFixedRuntimeRep )
import GHC.Core.Multiplicity ( pattern ManyTy )
import GHC.Types.Id
@@ -127,6 +125,7 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import Data.Maybe
+import Data.List ( partition )
{-
************************************************************************
@@ -638,7 +637,7 @@ lvlMFE env strict_ctxt ann_expr
; var <- newLvlVar expr1 NotJoinPoint is_mk_static
; let var2 = annotateBotStr var float_n_lams mb_bot_str
; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)
- (mkVarApps (Var var2) abs_vars)) }
+ (mkAbsVarApps (Var var2) abs_vars)) }
-- OK, so the float has an unlifted type (not top-level bindable)
-- and no new value lambdas (float_is_new_lam is False)
@@ -652,13 +651,13 @@ lvlMFE env strict_ctxt ann_expr
, let [bx_bndr, ubx_bndr] = mkTemplateLocals [box_ty, expr_ty]
= do { expr1 <- lvlExpr rhs_env ann_expr
; let l1r = incMinorLvlFrom rhs_env
- float_rhs = mkLams abs_vars_w_lvls $
+ float_rhs = mkAbsLams abs_vars_w_lvls $
Case expr1 (stayPut l1r ubx_bndr) box_ty
[Alt DEFAULT [] (App boxing_expr (Var ubx_bndr))]
; var <- newLvlVar float_rhs NotJoinPoint is_mk_static
; let l1u = incMinorLvlFrom env
- use_expr = Case (mkVarApps (Var var) abs_vars)
+ use_expr = Case (mkAbsVarApps (Var var) abs_vars)
(stayPut l1u bx_bndr) expr_ty
[Alt (DataAlt box_dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)]
; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs)
@@ -1309,7 +1308,7 @@ lvlBind env (AnnRec pairs)
new_rhs_body <- lvlRhs body_env2 Recursive is_bot NotJoinPoint rhs_body
(poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]
return (Rec [(TB poly_bndr (FloatMe dest_lvl)
- , mkLams abs_vars_w_lvls $
+ , mkAbsLams abs_vars_w_lvls $
mkLams lam_bndrs2 $
Let (Rec [( TB new_bndr (StayPut rhs_lvl)
, mkLams lam_bndrs2 new_rhs_body)])
@@ -1399,7 +1398,7 @@ lvlRhs env rec_flag is_bot mb_join_arity expr
= lvlFloatRhs [] (le_ctxt_lvl env) env
rec_flag is_bot mb_join_arity expr
-lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag
+lvlFloatRhs :: AbsVars -> Level -> LevelEnv -> RecFlag
-> Bool -- Binding is for a bottoming function
-> JoinPointHood
-> CoreExprWithFVs
@@ -1410,7 +1409,7 @@ lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs
&& any isId bndrs
then lvlMFE body_env True body
else lvlExpr body_env body
- ; return (mkLams bndrs' body') }
+ ; return (mkAbsLams bndrs' body') }
where
(bndrs, body) | JoinPoint join_arity <- mb_join_arity
= collectNAnnBndrs join_arity rhs
@@ -1754,24 +1753,68 @@ lookupVar le v = case lookupVarEnv (le_env le) v of
Just (_, expr) -> expr
_ -> Var v
-abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]
- -- Find the variables in fvs, free vars of the target expression,
- -- whose level is greater than the destination level
- -- These are the ones we are going to abstract out
- --
- -- Note that to get reproducible builds, the variables need to be
- -- abstracted in deterministic order, not dependent on the values of
- -- Uniques. This is achieved by using DVarSets, deterministic free
- -- variable computation and deterministic sort.
- -- See Note [Unique Determinism] in GHC.Types.Unique for explanation of why
- -- Uniques are not deterministic.
+type AbsVars = [Var]
+ -- A list of variables to abstract, in the correct dependency order
+ -- May include type variables with unfoldings:
+ -- when abstracting, use a let
+ -- when applying, ignore
+ -- E.g [a, b=[a], x:a]
+ -- We might make
+ -- f = /\a let @b=[a] in \(x:a). blah
+ -- and at an application site say
+ -- f @ty arg
+
+mkAbsLams :: [LevelledBndr] -> Expr LevelledBndr -> Expr LevelledBndr
+mkAbsLams [] body = body
+mkAbsLams (bndr@(TB v _) : bndrs) body
+ | Just ty <- tyVarUnfolding_maybe v
+ = Let (NonRec bndr (Type ty)) (mkAbsLams bndrs body)
+ | otherwise
+ = Lam bndr (mkAbsLams bndrs body)
+
+mkAbsLamTypes :: AbsVars -> Type -> Type
+mkAbsLamTypes abs_vars ty
+ = pprTrace "mkAbsLamTypes" (
+ vcat [ text "abs_vars" <+> ppr abs_vars
+ , text "abs_lam_vars" <+> ppr abs_lam_vars
+ , text "tv_unf_prs" <+> ppr tv_unf_prs
+ , text "ty" <+> ppr ty
+ , text "mkLam" <+> ppr (mkLamTypes abs_lam_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)
+ 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
+mkAbsVarApps fun [] = fun
+mkAbsVarApps fun (a:as)
+ | Just {} <- tyVarUnfolding_maybe a = mkAbsVarApps fun as
+ | otherwise = mkAbsVarApps (App fun (varToCoreExpr a)) as
+
+abstractVars :: Level -> LevelEnv -> DVarSet -> AbsVars
+-- Find the variables in fvs, free vars of the target expression,
+-- whose level is greater than the destination level
+-- These are the ones we are going to abstract out
+--
+-- Note that to get reproducible builds, the variables need to be
+-- abstracted in deterministic order, not dependent on the values of
+-- Uniques. This is achieved by using DVarSets, deterministic free
+-- variable computation and deterministic sort.
+-- See Note [Unique Determinism] in GHC.Types.Unique for explanation of why
+-- Uniques are not deterministic.
abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
= -- NB: sortQuantVars might not put duplicates next to each other
- map zap $ sortQuantVars $
+ map zap $
+ dep_anal $
filter abstract_me $
dVarSetElems $
- closeOverKindsDSet $
- substDVarSet subst in_fvs
+ mapUnionDVarSet close $
+ substFreeVars subst $
+ dVarSetElems in_fvs
-- NB: it's important to call abstract_me only on the OutIds the
-- come from substDVarSet (not on fv, which is an InId)
where
@@ -1779,44 +1822,59 @@ abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
Just lvl -> dest_lvl `ltLvl` lvl
Nothing -> False
- -- We are going to lambda-abstract, so nuke any IdInfo,
- -- and add the tyvars of the Id (if necessary)
- zap v | isId v = warnPprTrace (isStableUnfolding (idUnfolding v) ||
- not (isEmptyRuleInfo (idSpecialisation v)))
- "absVarsOf: discarding info on" (ppr v) $
- setIdInfo v vanillaIdInfo
+
+ zap :: Var -> Var
+ -- zap: We are going to lambda-abstract, so nuke any IdInfo
+ -- But leave TyVar unfoldings alone
+ zap v | isId v = setIdInfo v vanillaIdInfo
| otherwise = v
+ close_set :: DVarSet -> DVarSet
+ close_set s = mapUnionDVarSet close (dVarSetElems s)
+
+ close :: Var -> DVarSet
+ close v | Just ty <- tyVarUnfolding_maybe v
+ = close_set (tyCoVarsOfTypeDSet ty) `extendDVarSet` v
+ | otherwise
+ = close_set (tyCoVarsOfTypeDSet (varType v)) `extendDVarSet` v
+
+ dep_anal vs = scopedSort tcvs ++ ids
+ where
+ (tcvs, ids) = partition (isTyVar <||> isCoVar) vs
+ -- NB: scopedSort is a deterministic sort, meaning it doesn't look at the values
+ -- of Uniques. For explanation why it's important See Note [Unique Determinism]
+ -- in GHC.Types.Unique.
+
+-----------------------------------------
type LvlM result = UniqSM result
initLvl :: UniqSupply -> UniqSM a -> a
initLvl = initUs_
-newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId]
+newPolyBndrs :: Level -> LevelEnv -> AbsVars -> [InId]
-> LvlM (LevelEnv, [OutId])
-- The envt is extended to bind the new bndrs to dest_lvl, but
-- the le_ctxt_lvl is unaffected
newPolyBndrs dest_lvl
env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env })
abs_vars bndrs
- = assert (all (not . isCoVar) bndrs) $ -- What would we add to the CoSubst in this case. No easy answer.
+ = assert (all (\b -> not (isCoVar b || isTyVar b)) bndrs) $ -- What would we add to the CoSubst in this case. No easy answer.
do { uniqs <- getUniquesM
; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs
bndr_prs = bndrs `zip` new_bndrs
env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs
- , le_subst = foldl' add_subst subst bndr_prs
, le_env = foldl' add_id id_env bndr_prs }
; return (env', new_bndrs) }
where
- add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)
- add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)
+ add_id env (v, v') = extendVarEnv env v ((v':abs_vars), mkAbsVarApps (Var v') abs_vars)
mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id
transfer_join_info bndr $
mkSysLocal str uniq (idMult bndr) poly_ty
where
str = fsLit "poly_" `appendFS` occNameFS (getOccName bndr)
- poly_ty = mkLamTypes abs_vars (substTyUnchecked subst (idType bndr))
+ poly_ty = mkAbsLamTypes abs_vars $
+ substTyUnchecked subst (idType bndr)
-- If we are floating a join point to top level, it stops being
-- a join point. Otherwise it continues to be a join point,
=====================================
compiler/GHC/Core/Opt/Specialise.hs
=====================================
@@ -1185,7 +1185,7 @@ specVar env@(SE { se_subst = Core.Subst in_scope ids _ _ }) v
-- probably has little effect, but it's the right thing.
-- We need zapSubst because `e` is an OutExpr
-specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
+specExpr, specExpr' :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
---------------- First the easy cases --------------------
specExpr env e = -- pprTrace "specExpr" (ppr e) $
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -49,7 +49,7 @@ import GHC.Core -- All of it
import GHC.Core.Subst
import GHC.Core.SimpleOpt ( exprIsLambda_maybe )
import GHC.Core.FVs ( exprFreeVars, bindFreeVars
- , rulesFreeVarsDSet, orphNamesOfExprs )
+ , orphNamesOfExprs )
import GHC.Core.Utils ( exprType, mkTick, mkTicks
, stripTicksTopT, stripTicksTopE
, isJoinBind, mkCastMCo )
@@ -336,12 +336,10 @@ pprRulesForUser rules
-}
extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo
-extendRuleInfo (RuleInfo rs1 fvs1) rs2
- = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1)
+extendRuleInfo (RuleInfo rs1) rs2 = RuleInfo (rs2 ++ rs1)
addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo
-addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2)
- = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2)
+addRuleInfo (RuleInfo rs1) (RuleInfo rs2) = RuleInfo (rs1 ++ rs2)
addIdSpecialisations :: Id -> [CoreRule] -> Id
addIdSpecialisations id rules
=====================================
compiler/GHC/Core/Seq.hs
=====================================
@@ -45,7 +45,7 @@ seqOneShot :: OneShotInfo -> ()
seqOneShot l = l `seq` ()
seqRuleInfo :: RuleInfo -> ()
-seqRuleInfo (RuleInfo rules fvs) = seqRules rules `seq` seqDVarSet fvs
+seqRuleInfo (RuleInfo rules) = seqRules rules
seqCaf :: CafInfo -> ()
seqCaf c = c `seq` ()
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -16,7 +16,7 @@ module GHC.Core.Subst (
substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC,
substUnfolding, substUnfoldingSC,
lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc,
- substTickish, substDVarSet, substIdInfo,
+ substTickish, substFreeVars, substIdInfo,
-- ** Operations on substitutions
emptySubst, mkEmptySubst, mkTCvSubst, mkOpenSubst, isEmptySubst,
@@ -524,9 +524,8 @@ substIdOcc subst v = case lookupIdSubst subst v of
------------------
-- | Substitutes for the 'Id's within the 'RuleInfo' given the new function 'Id'
substRuleInfo :: Subst -> Id -> RuleInfo -> RuleInfo
-substRuleInfo subst new_id (RuleInfo rules rhs_fvs)
+substRuleInfo subst new_id (RuleInfo rules)
= RuleInfo (map (substRule subst subst_ru_fn) rules)
- (substDVarSet subst rhs_fvs)
where
subst_ru_fn = const (idName new_id)
@@ -562,9 +561,9 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
(subst', bndrs') = substBndrs subst bndrs
------------------
-substDVarSet :: HasDebugCallStack => Subst -> DVarSet -> DVarSet
-substDVarSet subst@(Subst _ _ tv_env cv_env) fvs
- = mkDVarSet $ fst $ foldr subst_fv ([], emptyVarSet) $ dVarSetElems fvs
+substFreeVars :: HasDebugCallStack => Subst -> [Var] -> [Var]
+substFreeVars subst@(Subst _ _ tv_env cv_env) fvs
+ = fst $ foldr subst_fv ([], emptyVarSet) $ fvs
where
subst_fv :: Var -> ([Var], VarSet) -> ([Var], VarSet)
subst_fv fv acc
=====================================
compiler/GHC/Core/Tidy.hs
=====================================
@@ -331,7 +331,7 @@ tidyLetBndr rec_tidy_env env@(tidy_env, var_env) tv
let
ki' = tidyType env (tyVarKind tv)
name' = mkInternalName (varUnique tv) occ' noSrcSpan
- mb_unf = tyVarUnfolding tv
+ mb_unf = tyVarUnfolding_maybe tv
occ_info = tyVarOccInfo tv
tv' | Just unf <- mb_unf = mkTyVarWithUnfolding name' ki' (tidyType rec_tidy_env unf)
| otherwise = mkTyVar name' ki'
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -1077,7 +1077,10 @@ scopedSort = go [] []
| otherwise
= (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss)
where
- fv_tv = tyCoVarsOfType (tyVarKind tv)
+ -- If tv has an unfolding, expand it instead of looking at its kind
+ fv_tv = case tyVarUnfolding_maybe tv of
+ Just ty -> tyCoVarsOfType ty
+ Nothing -> tyCoVarsOfType (tyVarKind tv)
-- lists not in correspondence
insert _ _ _ = panic "scopedSort"
=====================================
compiler/GHC/Core/TyCo/Subst.hs
=====================================
@@ -1103,14 +1103,13 @@ cloneTyVarBndr subst@(Subst in_scope id_env tv_env cv_env) tv uniq
, tv')
where
old_ki = tyVarKind tv
- old_unf = tyVarUnfolding tv
tv1 | not (noFreeVarsOfType old_ki) -- Kind is not closed
= setTyVarKind tv (substTy subst old_ki)
| otherwise
= tv
- tv2 | Just unf <- old_unf
+ tv2 | Just unf <- tyVarUnfolding_maybe tv
, not (noFreeVarsOfType unf) -- Unfolding is not closed
= tv1 `setTyVarUnfolding` substTy subst unf
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -365,7 +365,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 (TyVarTy tv) = tyVarUnfolding_maybe tv
unfoldView _ = Nothing
rewriterView :: Type -> Maybe Type
@@ -378,7 +378,7 @@ rewriterView (TyConApp tc tys)
| isTypeSynonymTyCon tc
, isForgetfulSynTyCon tc || not (isFamFreeTyCon tc)
= expandSynTyConApp_maybe tc tys
-rewriterView (TyVarTy tv) = tyVarUnfolding tv
+rewriterView (TyVarTy tv) = tyVarUnfolding_maybe tv
rewriterView _other
= Nothing
@@ -392,7 +392,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 -- c.f. unfoldView
+coreView (TyVarTy tv) = tyVarUnfolding_maybe tv -- c.f. unfoldView
coreView _ = Nothing
-- See Note [Inlining coreView].
{-# INLINE coreView #-}
@@ -406,7 +406,7 @@ coreFullView ty@(TyConApp tc _)
| isTypeSynonymTyCon tc = core_full_view ty
coreFullView (TyVarTy tv)
-- c.f. unfoldView
- | Just ty <- tyVarUnfolding tv = core_full_view ty
+ | Just ty <- tyVarUnfolding_maybe tv = core_full_view ty
coreFullView ty = ty
{-# INLINE coreFullView #-}
@@ -2732,7 +2732,7 @@ 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 (TyVarTy tv)
- | Just ty <- tyVarUnfolding tv
+ | Just ty <- tyVarUnfolding_maybe tv
= sORTKind_maybe ty
sORTKind_maybe (TyConApp tc tys)
-- First, short-cuts for Type and Constraint that do no allocation
@@ -2883,8 +2883,8 @@ isConcreteTypeWith :: TyVarSet -> Type -> Bool
isConcreteTypeWith conc_tvs = go
where
go (TyVarTy tv)
- | Just ty <- tyVarUnfolding tv = go ty
- | otherwise = isConcreteTyVar tv || tv `elemVarSet` conc_tvs
+ | Just ty <- tyVarUnfolding_maybe tv = go ty
+ | otherwise = isConcreteTyVar tv || tv `elemVarSet` conc_tvs
go (AppTy ty1 ty2) = go ty1 && go ty2
go (TyConApp tc tys) = go_tc tc tys
go ForAllTy{} = False
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -438,8 +438,8 @@ toIfaceLetBndr tv
(toIfaceKind (tyVarKind tv))
info
where
- info | Just unf <- tyVarUnfolding tv = [HsTypeUnfold (toIfaceType unf)]
- | otherwise = []
+ info | Just unf <- tyVarUnfolding_maybe tv = [HsTypeUnfold (toIfaceType unf)]
+ | otherwise = []
toIfaceLetBndr id = IfLetBndr (mkIfLclName (occNameFS (getOccName id)))
(toIfaceType (idType id))
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -690,8 +690,7 @@ ds_app (XExpr (ConLikeTc con tvs tys)) _hs_args core_args
; let core_fun = mkLams tvs $ mkLams ids $
ds_con `mkTyApps` mkTyVarTys tvs
`mkVarApps` ids
- ; pprTrace "ds_conl" (ppr tvs) $
- return (mkApps core_fun core_args) }
+ ; return (mkApps core_fun core_args) }
ds_app (XExpr (HsRecSelTc (FieldOcc { foLabel = L _ sel_id }))) _hs_args core_args
= ds_app_rec_sel sel_id sel_id core_args
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -1064,7 +1064,7 @@ pprArrow (mb_conc, ppr_mult) af mult
ppr_tv_occ :: TyVar -> SDoc
ppr_tv_occ tv
= sdocOption sdocPrintTyVarUnfoldings $ \print_unf ->
- ppr tv <> case tyVarUnfolding tv of
+ ppr tv <> case tyVarUnfolding_maybe tv of
Just ty | print_unf -> braces (ppr ty)
_ -> empty
=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -3689,7 +3689,7 @@ tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map
; let bang_opts = SrcBangOpts (initBangOpts dflags)
; dc <- buildDataCon fam_envs bang_opts name is_infix rep_nm
stricts field_lbls
- tc_tvs ex_tvs user_tvbs
+ (binderVars tc_bndrs) ex_tvs user_tvbs
[{- no eq_preds -}] ctxt arg_tys
user_res_ty rep_tycon tag_map
-- NB: we put data_tc, the type constructor gotten from the
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1089,8 +1089,7 @@ zonkExpr (XExpr (ExpandedThingTc thing e))
zonkExpr (XExpr (ConLikeTc con tvs tys))
= runZonkBndrT (zonkTyBndrsX tvs) $ \ tvs' ->
do { tys' <- mapM zonkScaledTcTypeToTypeX tys
- ; pprTrace "zok-conl" (ppr tvs') $
- return (XExpr (ConLikeTc con tvs' tys')) }
+ ; return (XExpr (ConLikeTc con tvs' tys')) }
-- The tvs come straight from the data-con, and so are strictly redundant
-- See Wrinkles of Note [Typechecking data constructors] in GHC.Tc.Gen.Head
=====================================
compiler/GHC/Types/Id/Info.hs
=====================================
@@ -73,8 +73,7 @@ module GHC.Types.Id.Info (
-- ** The RuleInfo type
RuleInfo(..),
emptyRuleInfo,
- isEmptyRuleInfo, ruleInfoFreeVars,
- ruleInfoRules, setRuleInfoHead,
+ isEmptyRuleInfo, ruleInfoRules, setRuleInfoHead,
ruleInfo, setRuleInfo, tagSigInfo,
-- ** The CAFInfo type
@@ -98,7 +97,6 @@ import GHC.Core
import GHC.Core.Class
import {-# SOURCE #-} GHC.Builtin.PrimOps (PrimOp)
import GHC.Types.Name
-import GHC.Types.Var.Set
import GHC.Types.Basic
import GHC.Core.DataCon
import GHC.Core.TyCon
@@ -768,33 +766,21 @@ and put in the global list.
--
-- Records the specializations of this 'Id' that we know about
-- in the form of rewrite 'CoreRule's that target them
-data RuleInfo
- = RuleInfo
- [CoreRule]
- DVarSet -- Locally-defined free vars of *both* LHS and RHS
- -- of rules. I don't think it needs to include the
- -- ru_fn though.
- -- Note [Rule dependency info] in "GHC.Core.Opt.OccurAnal"
+newtype RuleInfo = RuleInfo [CoreRule]
-- | Assume that no specializations exist: always safe
emptyRuleInfo :: RuleInfo
-emptyRuleInfo = RuleInfo [] emptyDVarSet
+emptyRuleInfo = RuleInfo []
isEmptyRuleInfo :: RuleInfo -> Bool
-isEmptyRuleInfo (RuleInfo rs _) = null rs
-
--- | Retrieve the locally-defined free variables of both the left and
--- right hand sides of the specialization rules
-ruleInfoFreeVars :: RuleInfo -> DVarSet
-ruleInfoFreeVars (RuleInfo _ fvs) = fvs
+isEmptyRuleInfo (RuleInfo rs) = null rs
ruleInfoRules :: RuleInfo -> [CoreRule]
-ruleInfoRules (RuleInfo rules _) = rules
+ruleInfoRules (RuleInfo rules) = rules
-- | Change the name of the function the rule is keyed on all of the 'CoreRule's
setRuleInfoHead :: Name -> RuleInfo -> RuleInfo
-setRuleInfoHead fn (RuleInfo rules fvs)
- = RuleInfo (map (setRuleIdName fn) rules) fvs
+setRuleInfoHead fn (RuleInfo rules) = RuleInfo (map (setRuleIdName fn) rules)
{-
************************************************************************
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -104,7 +104,7 @@ module GHC.Types.Var (
mkTyVar, mkTyVarWithUnfolding, mkTcTyVar,
-- ** Taking 'TyVar's apart
- tyVarName, tyVarKind, tyVarUnfolding, tyVarOccInfo, tcTyVarDetails, setTcTyVarDetails,
+ tyVarName, tyVarKind, tyVarUnfolding_maybe, tyVarOccInfo, tcTyVarDetails, setTcTyVarDetails,
-- ** Modifying 'TyVar's
setTyVarName, setTyVarUnique, setTyVarKind, setTyVarUnfolding, setTyVarOccInfo,
@@ -470,6 +470,7 @@ updateVarTypeM upd var
result = do { ty' <- upd (varType var)
; return (var { varType = ty' }) }
+
{- *********************************************************************
* *
* FunTyFlag
@@ -1018,9 +1019,9 @@ tyVarName = varName
tyVarKind :: TyVar -> Kind
tyVarKind = varType
-tyVarUnfolding :: TyVar -> Maybe Type
-tyVarUnfolding (TyVar { tv_unfolding = unf }) = unf
-tyVarUnfolding _ = Nothing
+tyVarUnfolding_maybe :: TyVar -> Maybe Type
+tyVarUnfolding_maybe (TyVar { tv_unfolding = unf }) = unf
+tyVarUnfolding_maybe _ = Nothing
tyVarOccInfo :: TyVar -> OccInfo
tyVarOccInfo (TcTyVar {}) = noOccInfo
@@ -1057,7 +1058,7 @@ updateTyVarKindM update tv
updateTyVarUnfolding :: (Type -> Type) -> TyVar -> TyVar
updateTyVarUnfolding update tv
- | Just unf <- tyVarUnfolding tv
+ | Just unf <- tyVarUnfolding_maybe tv
= tv {tv_unfolding = Just (update unf)}
| otherwise
@@ -1065,7 +1066,7 @@ updateTyVarUnfolding update tv
updateTyVarUnfoldingM :: (Monad m) => (Type -> m Type) -> TyVar -> m TyVar
updateTyVarUnfoldingM update tv
- | Just unf <- tyVarUnfolding tv
+ | Just unf <- tyVarUnfolding_maybe tv
= do { unf' <- update unf
; return $ tv {tv_unfolding = Just unf'} }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/151ac2750e063f2bf76c5d9f15465b92fe3161ed
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/151ac2750e063f2bf76c5d9f15465b92fe3161ed
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/5075174d/attachment-0001.html>
More information about the ghc-commits
mailing list