[Git][ghc/ghc][wip/T20264] Some small wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Dec 5 17:33:33 UTC 2024
Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC
Commits:
3edad0d5 by Simon Peyton Jones at 2024-12-05T17:33:03+00:00
Some small wibbles
- - - - -
5 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Types/Var.hs
- compiler/GHC/Utils/Outputable.hs
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -2952,6 +2952,8 @@ data LintEnv
-- /All/ in-scope variables are here (term variables,
-- type variables, and coercion variables)
-- Used at an occurrence of the InVar
+ -- We need the binding InVar so Lint can check that the unfolding at an
+ -- occurrence is equal to the unfolding at the binding site.
, le_joins :: IdSet -- Join points in scope that are valid
-- A subset of the InScopeSet in le_subst
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -1804,16 +1804,23 @@ abstractVars :: Level -> LevelEnv -> DVarSet -> AbsVars
-- 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 $
- dep_anal $
- filter abstract_me $
- dVarSetElems $
- mapUnionDVarSet close $
- substFreeVars subst $
- dVarSetElems in_fvs
+ pprTrace "abstractVars"
+ (vcat [ text "r7:" <+> ppr r7
+ , text "r1:" <+> ppr r1
+ , text "r2:" <+> ppr r3
+ , text "r3:" <+> ppr r3
+ , text "subst:" <+> ppr subst ]) r7
+ where
+ r7 = map zap r6
+ r6 = dep_anal r5
+ r5 = filter abstract_me r4
+ r4 = dVarSetElems r3
+ r3 = mapUnionDVarSet close r2
+ r2 = substFreeVars subst r1
+ r1 = 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
+
abstract_me v = case lookupVarEnv lvl_env v of
Just lvl -> dest_lvl `ltLvl` lvl
Nothing -> False
@@ -1830,8 +1837,8 @@ abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
close :: Var -> DVarSet
close v | Just ty <- tyVarUnfolding_maybe v
= close_set (tyCoVarsOfTypeDSet ty) `extendDVarSet` v
- | otherwise
- = close_set (tyCoVarsOfTypeDSet (varType v)) `extendDVarSet` v
+ | otherwise -- We have already got the free vars of its kind
+ = unitDVarSet v
dep_anal vs = scopedSort tcvs ++ ids
where
=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -1061,19 +1061,12 @@ pprArrow (mb_conc, ppr_mult) af mult
| otherwise
= ppr (funTyFlagTyCon af)
-ppr_tv_occ :: TyVar -> SDoc
-ppr_tv_occ tv
- = sdocOption sdocPrintTyVarUnfoldings $ \print_unf ->
- ppr tv <> case tyVarUnfolding_maybe tv of
- Just ty | print_unf -> braces (ppr ty)
- _ -> empty
-
ppr_ty :: PprPrec -> IfaceType -> SDoc
ppr_ty ctxt_prec ty
| not (isIfaceRhoType ty) = ppr_sigma ShowForAllMust ctxt_prec ty
ppr_ty _ (IfaceForAllTy {}) = panic "ppr_ty" -- Covered by not.isIfaceRhoType
-ppr_ty _ (IfaceFreeTyVar tyvar) = ppr_tv_occ tyvar -- This is the main reason for IfaceFreeTyVar!
-ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [Free TyVars and CoVars in IfaceType]
+ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar!
+ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [Free TyVars and CoVars in IfaceType]
ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys
ppr_ty ctxt_prec (IfaceTupleTy i p tys) = ppr_tuple ctxt_prec i p tys -- always fully saturated
ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -357,36 +357,39 @@ instance Outputable Var where
-- don't display debug info with Code style (#25255)
ppr_code = ppr (varName var)
ppr_normal sty
- = sdocOption sdocSuppressVarKinds $ \supp_var_kinds ->
- getPprDebug $ \debug ->
- let
- pp_info = case var of
- TyVar { tv_unfolding = Just ty }
- | debug
- -> brackets (text "unf=" <> ppr ty)
-
- TyVar {}
- | debug
- -> brackets (text "tv")
-
- TcTyVar {tc_tv_details = d}
- | dumpStyle sty || debug
- -> brackets (pprTcTyVarDetails d)
-
- Id { idScope = s, id_details = d }
- | debug
- -> brackets (ppr_id_scope s <> pprIdDetails d)
-
- _ -> empty
- pp_mult = case varMultMaybe var of
- Just m -> text "mult=" <> ppr m
- Nothing -> empty
- in if
- | debug && not supp_var_kinds
- -> parens (hang (ppr (varName var) <+> pp_info <+> pp_mult)
- 2 (dcolon <+> pprKind (tyVarKind var)))
- | otherwise
- -> ppr (varName var) <> pp_info
+ = sdocOption sdocSuppressVarKinds $ \supp_var_kinds ->
+ sdocOption sdocPrintTyVarUnfoldings $ \print_tyvar_unf ->
+ getPprDebug $ \debug ->
+
+ let add_type_sig doc
+ | debug, not supp_var_kinds
+ = parens (doc <+> dcolon <+> pprKind (varType var))
+ | otherwise
+ = doc
+
+ pp_tv_unf | print_tyvar_unf, Just ty <- tyVarUnfolding_maybe var
+ = braces (equals <> pprKind ty)
+ | otherwise
+ = empty
+
+ in case var of
+ TyVar {}
+ -> add_type_sig $
+ ppr (varName var)
+ <> ppWhen debug (brackets (text "tv"))
+ <> pp_tv_unf
+
+ TcTyVar {tc_tv_details = d}
+ -> add_type_sig $
+ ppr (varName var)
+ <> ppWhen (debug || dumpStyle sty)
+ (brackets (pprTcTyVarDetails d))
+
+ Id { idScope = s, id_details = d }
+ -> add_type_sig $
+ ppr (varName var)
+ <> ppWhen debug
+ (brackets (ppr_id_scope s <> pprIdDetails d))
ppr_id_scope :: IdScope -> SDoc
ppr_id_scope GlobalId = text "gid"
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -506,6 +506,7 @@ traceSDocContext = defaultSDocContext
, sdocPrintExplicitRuntimeReps = True
, sdocPrintExplicitForalls = True
, sdocPrintEqualityRelations = True
+ , sdocPrintTyVarUnfoldings = True
}
withPprStyle :: PprStyle -> SDoc -> SDoc
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3edad0d536f32e9a0e81a7294628ab5432baaf07
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3edad0d536f32e9a0e81a7294628ab5432baaf07
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/20241205/c640ebb1/attachment-0001.html>
More information about the ghc-commits
mailing list