Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC Commits: 410f1a57 by Simon Peyton Jones at 2025-04-23T15:55:03+01:00 Wibbles - - - - - 8 changed files: - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/TyCo/FVs.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Types/Var.hs Changes: ===================================== compiler/GHC/Core/Lint.hs ===================================== @@ -3679,10 +3679,10 @@ lintVarOcc :: InVar -> LintM OutType lintVarOcc v_occ = do { in_var_env <- getInVarEnv ; case lookupVarEnv in_var_env v_occ of - Nothing | isGlobalId v_occ -> return (idType v_occ) - | otherwise -> failWithL (text "The" <+> ppr (whatItIs v_occ) - <+> quotes (ppr v_occ) - <+> text "is out of scope") + Nothing | isGlobalVar v_occ -> return (idType v_occ) + | otherwise -> failWithL (text "The" <+> ppr (whatItIs v_occ) + <+> quotes (ppr v_occ) + <+> text "is out of scope") Just (in_bndr, out_bndr) -> do { checkBndrOccCompatibility in_bndr v_occ ; return (varType out_bndr) } } ===================================== compiler/GHC/Core/Opt/OccurAnal.hs ===================================== @@ -1137,15 +1137,18 @@ occAnalRec :: OccEnv -> TopLevelFlag occAnalRec !_ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds })) (WUD body_uds binds) - | isDeadOcc occ -- Check for dead code: see Note [Dead code] - = WUD body_uds binds - + -- Currently we don't gather occ-info for tyvars, + -- so we never discard dead bindings -- Need to fix this | 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) + + | isDeadOcc occ -- Check for dead code: see Note [Dead code] + = WUD body_uds binds + | otherwise = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds ===================================== compiler/GHC/Core/TyCo/FVs.hs ===================================== @@ -392,7 +392,8 @@ shallowTcvFolder = TyCoFolder { tcf_view = noView -- See Note [Free vars and sy where do_tcv is v = Endo do_it where - do_it acc | v `elemVarSet` is = acc + do_it acc | isGlobalVar v = acc + | v `elemVarSet` is = acc | v `elemVarSet` acc = acc | otherwise = acc `extendVarSet` v @@ -448,7 +449,8 @@ deepCoVarFolder = TyCoFolder { tcf_view = noView do_covar is v = Endo do_it where - do_it acc | v `elemVarSet` is = acc + do_it acc | isGlobalVar v = acc + | v `elemVarSet` is = acc | v `elemVarSet` acc = acc | otherwise = appEndo (deep_cv_ty (varType v)) $ acc `extendVarSet` v @@ -599,9 +601,9 @@ tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys tyCoFVsOfType :: Type -> FV -- See Note [Free variables of types] tyCoFVsOfType (TyVarTy v) f bound_vars (acc_list, acc_set) - | not (f v) = (acc_list, acc_set) + | not (f v) = (acc_list, acc_set) | v `elemVarSet` bound_vars = (acc_list, acc_set) - | v `elemVarSet` acc_set = (acc_list, acc_set) + | v `elemVarSet` acc_set = (acc_list, acc_set) | otherwise = tyCoFVsOfType (tyVarKind v) f emptyVarSet -- See Note [Closing over free variable kinds] (v:acc_list, extendVarSet acc_set v) ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -2070,7 +2070,7 @@ freeNamesIfAppArgs IA_Nil = emptyNameSet freeNamesIfType :: IfaceType -> NameSet freeNamesIfType (IfaceFreeTyVar {}) = emptyNameSet freeNamesIfType (IfaceTyVar {}) = emptyNameSet -freeNamesIfType (IfaceExtTyVar {}) = emptyNameSet +freeNamesIfType (IfaceExtTyVar n) = unitNameSet n freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs t freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts ===================================== compiler/GHC/Iface/Tidy.hs ===================================== @@ -761,20 +761,20 @@ chooseExternalVars opts mod binds imp_id_rules search [] unfold_env occ_env = return (unfold_env, occ_env) - search ((idocc,referrer) : rest) unfold_env occ_env - | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env + search ((var_occ,referrer) : rest) unfold_env occ_env + | var_occ `elemVarEnv` unfold_env = search rest unfold_env occ_env | otherwise = do - (occ_env', name') <- tidyTopName mod name_cache (Just referrer) occ_env idocc + (occ_env', name') <- tidyTopName mod name_cache (Just referrer) occ_env var_occ let (new_ids, show_unfold) = addExternal opts refined_id - -- 'idocc' is an *occurrence*, but we need to see the + -- 'var_occ' is an *occurrence*, but we need to see the -- unfolding in the *definition*; so look up in binder_set - refined_id = case lookupVarSet binder_set idocc of + refined_id = case lookupVarSet binder_set var_occ of Just id -> id - Nothing -> warnPprTrace True "chooseExternalVars" (ppr idocc) idocc + Nothing -> warnPprTrace True "chooseExternalVars" (ppr var_occ) var_occ - unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold) + unfold_env' = extendVarEnv unfold_env var_occ (name',show_unfold) referrer' | isExportedId refined_id = refined_id | otherwise = referrer -- @@ -808,7 +808,7 @@ addExternal opts id = (new_needed_ids, show_unfold) where - new_needed_ids = bndrFvsInOrder show_unfold id + new_needed_ids = idBndrFvsInOrder show_unfold id idinfo = idInfo id unfolding = realUnfoldingInfo idinfo show_unfold = show_unfolding unfolding @@ -921,9 +921,9 @@ the free variables in the order that they are encountered. See Note [Choosing external Ids] -} -bndrFvsInOrder :: Bool -> Id -> [Var] -bndrFvsInOrder show_unfold id --- Gather the free vars of the RULES and unfolding of a binder +idBndrFvsInOrder :: Bool -> Id -> [Var] +idBndrFvsInOrder show_unfold id +-- Gather the free vars of the type, RULES and unfolding of an Id binder -- We always get the free vars of a *stable* unfolding, but -- for a *vanilla* one (VanillaSrc), the flag controls what happens: -- True <=> get fvs of even a *vanilla* unfolding @@ -933,107 +933,18 @@ bndrFvsInOrder show_unfold id -- For top-level bindings (call from addExternal, via bndrFvsInOrder) -- we say "True" if we are exposing that unfolding = fvVarList $ - go_unf (realUnfoldingInfo idinfo) `unionFV` - rulesFVs RhsOnly (ruleInfoRules (ruleInfo idinfo)) + tyCoFVsOfType (idType id) `unionFV` + unf_fvs `unionFV` + rules_fvs where idinfo = idInfo id - go_unf :: Unfolding -> FV - go_unf unf | show_unfold = unfoldingFVs unf - | otherwise = emptyFV + unf_fvs :: FV + unf_fvs | show_unfold = unfoldingFVs (realUnfoldingInfo idinfo) + | otherwise = emptyFV --- = run (dffvLetBndr show_unfold id) - -{- -run :: DFFV () -> [Id] -run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of - ((_,ids),_) -> ids - -newtype DFFV a - = DFFV (VarSet -- Envt: non-top-level things that are in scope - -- we don't want to record these as free vars - -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far - -> ((VarSet,[Var]),a)) -- Output state - deriving (Functor) - -instance Applicative DFFV where - pure a = DFFV $ \_ st -> (st, a) - (<*>) = ap - -instance Monad DFFV where - (DFFV m) >>= k = DFFV $ \env st -> - case m env st of - (st',a) -> case k a of - DFFV f -> f env st' - -extendScope :: Var -> DFFV a -> DFFV a -extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st) - -extendScopeList :: [Var] -> DFFV a -> DFFV a -extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st) - -insert :: Var -> DFFV () -insert v = DFFV $ \ env (set, ids) -> - let keep_me = isLocalId v && - not (v `elemVarSet` env) && - not (v `elemVarSet` set) - in if keep_me - then ((extendVarSet set v, v:ids), ()) - else ((set, ids), ()) - - -dffvExpr :: CoreExpr -> DFFV () -dffvExpr (Var v) = insert v -dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 -dffvExpr (Lam v e) = extendScope v (dffvExpr e) -dffvExpr (Tick (Breakpoint _ _ ids _) e) = mapM_ insert ids >> dffvExpr e -dffvExpr (Tick _other e) = dffvExpr e -dffvExpr (Cast e _) = dffvExpr e -dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) -dffvExpr (Let (Rec prs) e) = extendScopeList (map fst prs) $ - (mapM_ dffvBind prs >> dffvExpr e) -dffvExpr (Case e b _ as) = dffvExpr e >> extendScope b (mapM_ dffvAlt as) -dffvExpr _other = return () - -dffvAlt :: CoreAlt -> DFFV () -dffvAlt (Alt _ xs r) = extendScopeList xs (dffvExpr r) - -dffvBind :: (Var, CoreExpr) -> DFFV () -dffvBind(x,r) - | not (isId x) = dffvExpr r - | otherwise = dffvLetBndr False x >> dffvExpr r - -- Pass False because we are doing the RHS right here - -- If you say True you'll get *exponential* behaviour! - -dffvLetBndr :: Bool -> Id -> DFFV () --- Gather the free vars of the RULES and unfolding of a binder --- We always get the free vars of a *stable* unfolding, but --- for a *vanilla* one (VanillaSrc), the flag controls what happens: --- True <=> get fvs of even a *vanilla* unfolding --- False <=> ignore a VanillaSrc --- For nested bindings (call from dffvBind) we always say "False" because --- we are taking the fvs of the RHS anyway --- For top-level bindings (call from addExternal, via bndrFvsInOrder) --- we say "True" if we are exposing that unfolding -dffvLetBndr vanilla_unfold id - = do { go_unf (realUnfoldingInfo idinfo) - ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) } - where - idinfo = idInfo id - - go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) - | isStableSource src = dffvExpr rhs - | vanilla_unfold = dffvExpr rhs - | otherwise = return () - - go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args }) - = extendScopeList bndrs $ mapM_ dffvExpr args - go_unf _ = return () - - go_rule (BuiltinRule {}) = return () - go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs }) - = extendScopeList bndrs (dffvExpr rhs) --} + rules_fvs :: FV + rules_fvs = rulesFVs RhsOnly (ruleInfoRules (ruleInfo idinfo)) {- ************************************************************************ ===================================== compiler/GHC/Iface/Type.hs ===================================== @@ -761,8 +761,8 @@ substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType substIfaceType env ty = go ty where - go ty@(IfaceFreeTyVar tv) = ty - go ty@(IfaceExtTyVar tv) = ty + go ty@(IfaceFreeTyVar {}) = ty + go ty@(IfaceExtTyVar {}) = ty go (IfaceTyVar tv) = substIfaceTyVar env tv go (IfaceAppTy t ts) = IfaceAppTy (go t) (substIfaceAppArgs env ts) go (IfaceFunTy af w t1 t2) = IfaceFunTy af (go w) (go t1) (go t2) @@ -1148,8 +1148,8 @@ 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 tyvar -- This is the main reason for IfaceFreeTyVar! -ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [Free TyVars and CoVars in IfaceType] -ppr_ty _ (IfaceExtTyVar tyvar) = ppr tyvar +ppr_ty _ (IfaceTyVar tyvar) = text "{free}" <> ppr tyvar -- See Note [Free TyVars and CoVars in IfaceType] +ppr_ty _ (IfaceExtTyVar tyvar) = text "{ext}" <> ppr tyvar 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 @@ -2373,9 +2373,8 @@ putIfaceType bh (IfaceTupleTy s i tys) = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys } putIfaceType bh (IfaceLitTy n) = do { putByte bh 9; put_ bh n } -putIfaceType bh (IfaceExtTyVar tv) = do - putByte bh 10 - put_ bh tv +putIfaceType bh (IfaceExtTyVar tv) + = do { putByte bh 10; put_ bh tv } -- | Deserialises an 'IfaceType' from the given 'ReadBinHandle'. -- ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -726,7 +726,7 @@ tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type, tc_iface_decl _ _ (IfaceTv {ifName = name, ifTvKind = if_kind, ifTvUnf = if_type }) = do { kind <- tcIfaceType if_kind - ; unf_ty <- tcIfaceType if_type + ; unf_ty <- forkM (text "IfaceTv" <+> ppr name) $ tcIfaceType if_type ; return (ATyVar (mkTyVarWithUnfolding name kind unf_ty)) } tc_iface_decl _ _ (IfaceData {ifName = tc_name, ===================================== compiler/GHC/Types/Var.hs ===================================== @@ -62,7 +62,7 @@ module GHC.Types.Var ( -- ** Predicates isId, isTyVar, isTcTyVar, isCoVar, isNonCoVarId, isTyCoVar, - isLocalVar, isGlobalVar, + isLocalVar, isGlobalVar, isGlobalTyVar, isLocalId, isLocalId_maybe, isGlobalId, isExportedId, mustHaveLocalBinding, @@ -1297,6 +1297,12 @@ isGlobalVar (Id { idScope = LocalId {} }) = False isGlobalVar (TyVar { varName = n }) = isExternalName n isGlobalVar (TcTyVar {}) = False +isGlobalTyVar :: HasDebugCallStack => Var -> Bool +-- A TyVar with an External Name is always from another module +isGlobalTyVar (TyVar { varName = n }) = isExternalName n +isGlobalTyVar (TcTyVar {}) = False +isGlobalTyVar v = pprPanic "isGlobalTyVar" (ppr v) + -- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's -- that must have a binding in this module. The converse -- is not quite right: there are some global 'Id's that must have View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/410f1a5749a695dacd15bfd1d05a941a... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/410f1a5749a695dacd15bfd1d05a941a... You're receiving this email because of your account on gitlab.haskell.org.