Andrei Borzenkov pushed to branch wip/sand-witch/make-set-field at Glasgow Haskell Compiler / GHC Commits: dc87a77b by Andrei Borzenkov at 2025-07-03T18:54:18+04:00 Remove leftover - - - - - 5055af9c by Andrei Borzenkov at 2025-07-03T20:59:13+04:00 Implement module caching - - - - - 15 changed files: - + compiler/GHC/Core/FieldInstEnv.hs - compiler/GHC/Driver/Env.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Tc/Instance/Class.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl/Utils.hs - compiler/GHC/Tc/TyCl/Utils.hs-boot - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/FieldLabel.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Unit/Module/ModDetails.hs - compiler/GHC/Unit/Module/ModIface.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC/Core/FieldInstEnv.hs ===================================== @@ -0,0 +1,27 @@ +module GHC.Core.FieldInstEnv + ( FieldInstEnv, + emptyFieldEnv, + lookupFieldEnv, + extendFieldEnv, + plusFieldEnv + ) where + +import GHC.Types.Unique.DFM +import GHC.Types.FieldLabel (FieldLabel) +import GHC.Unit.Module.ModDetails (FieldInst, FieldInfo) +import GHC.Prelude.Basic + +type FieldInstEnv = UniqDFM FieldLabel FieldInfo + +emptyFieldEnv :: FieldInstEnv +emptyFieldEnv = emptyUDFM + +lookupFieldEnv :: FieldInstEnv -> FieldLabel -> Maybe FieldInfo +lookupFieldEnv = lookupUDFM + +extendFieldEnv :: FieldInstEnv -> [FieldInst] -> FieldInstEnv +extendFieldEnv env [] = env -- Should be a most common case +extendFieldEnv env flds = addListToUDFM env flds + +plusFieldEnv :: FieldInstEnv -> FieldInstEnv -> FieldInstEnv +plusFieldEnv = plusUDFM \ No newline at end of file ===================================== compiler/GHC/Driver/Env.hs ===================================== @@ -89,6 +89,7 @@ import GHC.Builtin.Names import Data.IORef import qualified Data.Set as Set +import GHC.Core.FieldInstEnv runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env hsc = do @@ -245,22 +246,25 @@ hugCompleteSigsBelow hsc uid mn = foldr (++) [] <$> hugSomeThingsBelowUs (md_complete_matches . hm_details) False hsc uid mn -- | Find instances visible from the given set of imports -hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [(Module, FamInstEnv)], [FieldInst]) +hugInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> IO (InstEnv, [(Module, FamInstEnv)], FieldInstEnv) hugInstancesBelow hsc_env uid mnwib = do let mn = gwib_mod mnwib (insts, famInsts, fields) <- unzip3 . concat <$> hugSomeThingsBelowUs (\mod_info -> let details = hm_details mod_info + fam_inst = (mi_module $ hm_iface mod_info, extendFamInstEnvList emptyFamInstEnv $ md_fam_insts details) -- Don't include instances for the current module in if moduleName (mi_module (hm_iface mod_info)) == mn then [] - else [(md_insts details, [(mi_module $ hm_iface mod_info, extendFamInstEnvList emptyFamInstEnv $ md_fam_insts details)], md_fields details)]) + else [(md_insts details, [fam_inst], md_fields details)]) True -- Include -hi-boot hsc_env uid mnwib - return (foldl' unionInstEnv emptyInstEnv insts, concat famInsts, concat fields) + return ( foldl' unionInstEnv emptyInstEnv insts, + concat famInsts, + foldl' extendFieldEnv emptyFieldEnv fields) -- | Get things from modules in the transitive closure of the given module. -- ===================================== compiler/GHC/Iface/Make.hs ===================================== @@ -401,8 +401,7 @@ mkIface_ hsc_env cmp_fam_inst = comparing (nameOccName . ifFamInstTcName) cmp_fields :: IfaceFieldInst -> IfaceFieldInst -> Ordering - cmp_fields (tyCon1, fld1, _) (tyCon2, fld2, _) = - comparing nameOccName tyCon1 tyCon2 `mappend` + cmp_fields (fld1, _) (fld2, _) = lexicalCompareFieldLabel (flLabel fld1) (flLabel fld2) dflags = hsc_dflags hsc_env @@ -469,8 +468,8 @@ ifaceRoughMatchTcs tcs = map do_rough tcs -------------------------- fieldinstToIfaceFieldInst :: FieldInst -> IfaceFieldInst -fieldinstToIfaceFieldInst (tyCon, fld, fldInfo) - = (getName tyCon, fld, fldInfo) +fieldinstToIfaceFieldInst (fld, fldInfo) + = (fld, fmap getName fldInfo) -------------------------- coreRuleToIfaceRule :: CoreRule -> IfaceRule ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -1376,10 +1376,9 @@ tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs -} tcIfaceField :: IfaceFieldInst -> IfL FieldInst -- Improve pretty printing -tcIfaceField (tyConName, fieldInfo, bndr) = forkM (text "Field") $ do - thing <- tcIfaceImplicit tyConName - let !tyCon = tyThingTyCon thing - pure (tyCon, fieldInfo, bndr) +tcIfaceField (fieldInfo, bndrs) = forkM (text "Field") $ do + bndrs' <- traverse tcIfaceExtId bndrs + pure (fieldInfo, bndrs') {- ************************************************************************ ===================================== compiler/GHC/Tc/Instance/Class.hs ===================================== @@ -69,8 +69,8 @@ import GHC.Tc.Errors.Types import Data.Functor import Data.Maybe -import GHC.Types.Name.Env (lookupNameEnv) import qualified Data.List as List +import GHC.Core.FieldInstEnv (lookupFieldEnv) import {-# SOURCE #-} GHC.Tc.TyCl.Utils (mkSetFieldBinds, mkRecordSetterType, mkRecordModifierType) @@ -1322,7 +1322,10 @@ matchSetField dflags short_cut clas tys mb_ct_loc ; case lookupFieldLabel fam_inst_envs rdr_env tys of Just (tc, fl, gre, r_ty, a_ty) -> do { let sel_name = flSelector fl - ; (setter_id, modifier_id) <- lookupSetFieldBinds fl tc + ; MkFieldBinds { + fieldSetter = setter_id, + fieldModifier = modifier_id + } <- lookupSetFieldBinds fl tc ; (tv_prs, preds, setter_ty, modifier_ty) <- tc_inst_setfield_binds setter_id modifier_id @@ -1378,25 +1381,24 @@ matchSetField dflags short_cut clas tys mb_ct_loc -- See (HF1) in Note [HasField instances] try_user_instances = matchInstEnv dflags short_cut clas tys - lookupSetFieldBinds :: FieldLabel -> TyCon -> TcM (Id, Id) + lookupSetFieldBinds :: FieldLabel -> TyCon -> TcM (FieldBinds Id) lookupSetFieldBinds fl tycon = do - let sel_name = flSelector fl tcg_env <- getGblEnv let gbl_flds = tcg_fld_inst_env tcg_env req_flds = tcg_requested_fields tcg_env - case lookupNameEnv gbl_flds sel_name of + case lookupFieldEnv gbl_flds fl of Just binds -> pure binds Nothing -> do reqs <- readTcRef req_flds case List.lookup fl reqs of - Just ((setter, _), (modifier, _)) -> do - pure (setter, modifier) + Just binds -> do + pure (fmap fst binds) Nothing -> do - binds@((setter, _), (modifier,_)) <- mkSetFieldBinds tycon fl + binds <- mkSetFieldBinds tycon fl updTcRef req_flds ((fl, binds) : ) - pure (setter, modifier) + pure (fmap fst binds) tc_inst_setfield_binds setter_id modifier_id | null tyvars -- There may be overloading despite no type variables; ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -189,6 +189,7 @@ import Data.Foldable ( for_ ) import Data.Traversable ( for ) import Data.IORef( newIORef ) import GHC.Tc.TyCl.Utils (tcRecSetterBinds) +import GHC.Core.FieldInstEnv (plusFieldEnv) @@ -510,6 +511,7 @@ tcRnImports hsc_env import_decls tcg_rn_imports = rn_imports, tcg_default = foldMap subsume tc_defaults, tcg_inst_env = tcg_inst_env gbl `unionInstEnv` home_insts, + tcg_fld_inst_env = tcg_fld_inst_env gbl `plusFieldEnv` home_fields, tcg_fam_inst_env = unionFamInstEnv (tcg_fam_inst_env gbl) home_fam_inst_env }) $ do { ===================================== compiler/GHC/Tc/TyCl/Utils.hs ===================================== @@ -82,6 +82,9 @@ import qualified GHC.LanguageExtensions as LangExt import Language.Haskell.Syntax.Basic (FieldLabelString(..)) import Control.Monad +import GHC.Core.FieldInstEnv (extendFieldEnv) +import GHC.Data.Bag (listToBag) +import Data.Foldable (Foldable(toList)) {- ************************************************************************ @@ -911,18 +914,18 @@ tcRecSetterBinds = do flds <- readTcRef req_flds tcg_env <- tcRecSelBinds (get_ids_to_check flds) writeTcRef req_flds [] - let new_name_env = mkNameEnv $ map remove_binds flds + let new_fld_insts = map remove_binds flds pure (tcg_env { - tcg_fld_inst_env = tcg_fld_inst_env tcg_env `plusNameEnv` new_name_env + tcg_fld_inst_env = tcg_fld_inst_env tcg_env `extendFieldEnv` new_fld_insts, + tcg_fields = tcg_fields tcg_env `mappend` listToBag new_fld_insts }) where - remove_binds (n, ((setter, _), (modifier, _))) = (flSelector n, (setter, modifier)) - get_ids_to_check [] = [] - get_ids_to_check ( (_, (setter, modifier)) : flds) = - setter : modifier : get_ids_to_check flds + remove_binds = fmap (fmap fst) + get_ids_to_check = concatMap (toList . snd) -mkSetFieldBinds :: TyCon -> FieldLabel -> TcM ( (Id, LHsBind GhcRn), (Id, LHsBind GhcRn) ) + +mkSetFieldBinds :: TyCon -> FieldLabel -> TcM (FieldBinds (Id, LHsBind GhcRn) ) mkSetFieldBinds tycon fl = collectFieldLabelInfo all_cons idDetails fl FieldSelectors $ \_ _ -> mk_binds where @@ -937,11 +940,16 @@ mkSetFieldBinds tycon fl = in fl { flSelector = flSelector fl `setNameUnique` uniq `tidyNameOcc` newOcc } mk_binds cons_w_field rec_details ty_builder = do - setter_fl <- mk_field_lbl "setter_" <$> newUnique - modifier_fl <- mk_field_lbl "modifier_" <$> newUnique - let setter_bind = mkRecordSetterBind fl setter_fl all_cons cons_w_field rec_details ty_builder - modifier_bind = mkRecordModifierBind fl modifier_fl all_cons cons_w_field rec_details ty_builder - pure (setter_bind, modifier_bind) + let build_fld_bind prefix builder = do + new_fl <- mk_field_lbl prefix <$> newUnique + pure $ builder fl new_fl all_cons cons_w_field rec_details ty_builder + + setter_bind <- build_fld_bind "setter_" mkRecordSetterBind + modifier_bind <- build_fld_bind "modifier_" mkRecordModifierBind + pure MkFieldBinds { + fieldSetter = setter_bind, + fieldModifier = modifier_bind + } mkRecordSetterBind :: FieldLabel -> RecordBindBuilder (Id, LHsBind GhcRn) mkRecordSetterBind origFl fl = mk_record_bind 2 err_expr mkRecordSetterType mk_match fl where ===================================== compiler/GHC/Tc/TyCl/Utils.hs-boot ===================================== @@ -1,14 +1,14 @@ module GHC.Tc.TyCl.Utils where import GHC.Core.TyCon (TyCon) -import GHC.Types.FieldLabel (FieldLabel) +import GHC.Types.FieldLabel (FieldLabel, FieldBinds) import GHC.Tc.Utils.Monad (TcM) import GHC.Types.Var (Id) import Language.Haskell.Syntax.Binds (LHsBind) import GHC.Hs.Extension (GhcRn) import GHC.Core.Type (Type) -mkSetFieldBinds :: TyCon -> FieldLabel -> TcM ( (Id, LHsBind GhcRn), (Id, LHsBind GhcRn) ) +mkSetFieldBinds :: TyCon -> FieldLabel -> TcM ( FieldBinds (Id, LHsBind GhcRn) ) mkRecordSetterType :: Type -> Type -> Type ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -188,7 +188,8 @@ import Data.Dynamic ( Dynamic ) import Data.Map ( Map ) import Data.Typeable ( TypeRep ) import Data.Maybe ( mapMaybe ) -import GHC.Types.FieldLabel (FieldLabel) +import GHC.Types.FieldLabel (FieldLabel, FieldBinds) +import GHC.Core.FieldInstEnv (FieldInstEnv) -- | The import specification as written by the user, including -- the list of explicitly imported names. Used in 'ModIface' to @@ -561,7 +562,7 @@ data TcGblEnv -- they all have a non-empty gre_imp field. tcg_keep :: TcRef NameSet, - tcg_requested_fields :: TcRef [(FieldLabel, (FieldBind, FieldBind))], + tcg_requested_fields :: TcRef [(FieldLabel, FieldBinds (Id, LHsBind GhcRn))], tcg_th_used :: TcRef Bool, -- ^ @True@ \<=> Template Haskell syntax used. @@ -706,9 +707,6 @@ data TcGblEnv -- ^ See Note [Generating fresh names for FFI wrappers] } -type FieldInstEnv = NameEnv (Id, Id) -type FieldBind = (Id, LHsBind GhcRn) - -- NB: topModIdentity, not topModSemantic! -- Definition sites of orphan identities will be identity modules, not semantic -- modules. ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -242,6 +242,7 @@ import Control.Monad import qualified Data.Map as Map import GHC.Core.Coercion (isReflCo) +import GHC.Core.FieldInstEnv (emptyFieldEnv) {- @@ -330,7 +331,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this tcg_type_env_var = type_env_var, tcg_inst_env = emptyInstEnv, tcg_fam_inst_env = emptyFamInstEnv, - tcg_fld_inst_env = emptyNameEnv, + tcg_fld_inst_env = emptyFieldEnv, tcg_ann_env = emptyAnnEnv, tcg_complete_match_env = [], tcg_th_used = th_var, ===================================== compiler/GHC/Types/FieldLabel.hs ===================================== @@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable FieldLabelString +{-# LANGUAGE DerivingStrategies #-} {- % @@ -43,6 +44,7 @@ module GHC.Types.FieldLabel , DuplicateRecordFields(..) , FieldSelectors(..) , flIsOverloaded + , FieldBinds(..) ) where @@ -89,6 +91,9 @@ instance Outputable FieldLabel where <> ppr (flHasDuplicateRecordFields fl) <> ppr (flHasFieldSelector fl)) +instance Uniquable FieldLabel where + getUnique = getUnique . flSelector + instance Outputable FieldLabelString where ppr (FieldLabelString l) = ppr l @@ -151,3 +156,24 @@ flIsOverloaded :: FieldLabel -> Bool flIsOverloaded fl = flHasDuplicateRecordFields fl == DuplicateRecordFields || flHasFieldSelector fl == NoFieldSelectors + + +-- | A named tuple for carrying around binders +-- required for operations with fields +data FieldBinds a = MkFieldBinds + { fieldSetter :: a + , fieldModifier :: a + } deriving stock (Functor, Foldable, Traversable) + +instance Binary a => Binary (FieldBinds a) where + put_ h (MkFieldBinds s m) = do + put_ h s + put_ h m + + get h = do + s <- get h + m <- get h + pure (MkFieldBinds s m) + +instance NFData a => NFData (FieldBinds a) where + rnf (MkFieldBinds s m) = rnf s `seq` rnf m \ No newline at end of file ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -572,15 +572,12 @@ dictSelRule :: Int -> Arity -> RuleFun -- from it -- sel_i t1..tk (D t1..tk op1 ... opm) = opi -- -dictSelRule val_index n_ty_args _ id_unf fuck args +dictSelRule val_index n_ty_args _ id_unf _ args | (dict_arg : _) <- drop n_ty_args args - , Just (_, floats, con, _, con_args) <- exprIsConApp_maybe id_unf dict_arg - = Just (wrapFloats floats $ getNth con con_args val_index) + , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe id_unf dict_arg + = Just (wrapFloats floats $ getNth con_args val_index) | otherwise = Nothing - where - getNth con xs n = assertPpr (xs `lengthExceeds` n) (ppr fuck $$ ppr args $$ ppr n_ty_args $$ ppr con $$ ppr n $$ ppr xs) $ - xs !! n {- ************************************************************************ ===================================== compiler/GHC/Unit/Module/ModDetails.hs ===================================== @@ -8,14 +8,13 @@ where import GHC.Core ( CoreRule ) import GHC.Core.FamInstEnv import GHC.Core.InstEnv ( InstEnv, emptyInstEnv ) -import GHC.Core.TyCon import GHC.Types.Avail import GHC.Types.CompleteMatch import GHC.Types.DefaultEnv import GHC.Types.TypeEnv import GHC.Types.Annotations ( Annotation ) import GHC.Types.FieldLabel -import GHC.Types.Name (Name) +import GHC.Types.Var (Id) -- | The 'ModDetails' is essentially a cache for information in the 'ModIface' -- for home modules only. Information relating to packages will be loaded into @@ -46,8 +45,8 @@ data ModDetails = ModDetails -- ^ Complete match pragmas for this module } -type FieldInst = (TyCon, FieldLabel, FieldInfo) -type FieldInfo = (Name, Name) +type FieldInst = (FieldLabel, FieldInfo) +type FieldInfo = FieldBinds Id -- | Constructs an empty ModDetails emptyModDetails :: ModDetails ===================================== compiler/GHC/Unit/Module/ModIface.hs ===================================== @@ -153,7 +153,7 @@ import GHC.Utils.Binary import Control.DeepSeq import Control.Exception -import GHC.Types.FieldLabel (FieldLabel) +import GHC.Types.FieldLabel (FieldLabel, FieldBinds) {- Note [Interface file stages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -386,8 +386,8 @@ data IfacePublic_ phase = IfacePublic { -- These fields are hashes of different parts of the public interface. } -type IfaceFieldInst = (Name, FieldLabel, IfaceFieldInfo) -type IfaceFieldInfo = (IfExtName, IfExtName) +type IfaceFieldInst = (FieldLabel, IfaceFieldInfo) +type IfaceFieldInfo = FieldBinds IfExtName mkIfacePublic :: [IfaceExport] -> [IfaceDeclExts 'ModIfaceFinal] ===================================== compiler/ghc.cabal.in ===================================== @@ -365,6 +365,7 @@ Library GHC.Core.ConLike GHC.Core.DataCon GHC.Core.FamInstEnv + GHC.Core.FieldInstEnv GHC.Core.FVs GHC.Core.InstEnv GHC.Core.Lint View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1d422ed100fa28c72631882d91d42fd... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1d422ed100fa28c72631882d91d42fd... You're receiving this email because of your account on gitlab.haskell.org.