Matthew Pickering pushed to branch wip/iface-patch-9.10-backport at Glasgow Haskell Compiler / GHC Commits: dde170fc by Matthew Pickering at 2025-12-18T16:24:12+00:00 WIP: Lazy loading of IfaceDecl - - - - - 11 changed files: - compiler/GHC/Driver/Main.hs - compiler/GHC/Iface/Load.hs - compiler/GHC/Iface/Recomp.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/IfaceToCore.hs-boot - compiler/GHC/Tc/Utils/Backpack.hs - compiler/GHC/Unit/Module/ModIface.hs - compiler/GHC/Utils/Binary.hs - utils/haddock Changes: ===================================== compiler/GHC/Driver/Main.hs ===================================== @@ -1398,7 +1398,7 @@ hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do GHC.Utils.Touch.touch hie_file else -- See Note [Strictness in ModIface] - forceModIface iface + return () -------------------------------------------------------------- -- NoRecomp handlers ===================================== compiler/GHC/Iface/Load.hs ===================================== @@ -1172,7 +1172,7 @@ pprModIface unit_state iface , vcat (map pprUsage (mi_usages iface)) , vcat (map pprIfaceAnnotation (mi_anns iface)) , pprFixities (mi_fixities iface) - , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface] + , vcat [ppr ver $$ nest 2 (ppr decl) | (IfaceDeclBoxed ver _name _implicitBndrs decl) <- mi_decls iface] , case mi_extra_decls iface of Nothing -> empty Just eds -> text "extra decls:" ===================================== compiler/GHC/Iface/Recomp.hs ===================================== @@ -1061,31 +1061,36 @@ addFingerprints hsc_env iface0 -- take a strongly-connected group of declarations and compute -- its fingerprint. + mkBoxedDecl :: Fingerprint -> IfaceDecl -> IfaceDeclBoxed + mkBoxedDecl fingerprint decl = IfaceDeclBoxed fingerprint (ifName decl) (ifaceDeclImplicitBndrs decl) decl + fingerprint_group :: (OccEnv (OccName,Fingerprint), - [(Fingerprint,IfaceDecl)]) + [IfaceDeclBoxed]) -> SCC IfaceDeclABI -> IO (OccEnv (OccName,Fingerprint), - [(Fingerprint,IfaceDecl)]) + [IfaceDeclBoxed]) fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi) = do let hash_fn = mk_put_name local_env decl = abiDecl abi --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do hash <- computeFingerprint hash_fn abi - env' <- extend_hash_env local_env (hash,decl) - return (env', (hash,decl) : decls_w_hashes) + env' <- extend_hash_env local_env (mkBoxedDecl hash decl) + return (env', mkBoxedDecl hash decl : decls_w_hashes) + + fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis) = do let stable_abis = sortBy cmp_abiNames abis stable_decls = map abiDecl stable_abis local_env1 <- foldM extend_hash_env local_env - (zip (map mkRecFingerprint [0..]) stable_decls) + (zipWith mkBoxedDecl (map mkRecFingerprint [0..]) stable_decls) -- See Note [Fingerprinting recursive groups] let hash_fn = mk_put_name local_env1 -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do -- put the cycle in a canonical order hash <- computeFingerprint hash_fn stable_abis - let pairs = zip (map (bumpFingerprint hash) [0..]) stable_decls + let pairs = zipWith mkBoxedDecl (map (bumpFingerprint hash) [0..]) stable_decls -- See Note [Fingerprinting recursive groups] local_env2 <- foldM extend_hash_env local_env pairs return (local_env2, pairs ++ decls_w_hashes) @@ -1102,11 +1107,11 @@ addFingerprints hsc_env iface0 -- use when referencing those OccNames in later declarations. -- extend_hash_env :: OccEnv (OccName,Fingerprint) - -> (Fingerprint,IfaceDecl) - -> IO (OccEnv (OccName,Fingerprint)) - extend_hash_env env0 (hash,d) = + -> IfaceDeclBoxed + -> IO (OccEnv (OccName,Fingerprint)) + extend_hash_env env0 boxed = return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0 - (ifaceDeclFingerprints hash d)) + (ifaceDeclFingerprints boxed)) -- (local_env, decls_w_hashes) <- @@ -1179,38 +1184,11 @@ addFingerprints hsc_env iface0 mi_trust iface0) -- Make sure change of Safe Haskell mode causes recomp. - -- Note [Export hash depends on non-orphan family instances] - -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -- - -- Suppose we have: - -- - -- module A where - -- type instance F Int = Bool - -- - -- module B where - -- import A - -- - -- module C where - -- import B - -- - -- The family instance consistency check for C depends on the dep_finsts of - -- B. If we rename module A to A2, when the dep_finsts of B changes, we need - -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of - -- the exports of B, because C always considers them when checking - -- consistency. - -- - -- A full discussion is in #12723. - -- - -- We do NOT need to hash dep_orphs, because this is implied by - -- dep_orphan_hashes, and we do not need to hash ordinary class instances, - -- because there is no eager consistency check as there is with type families - -- (also we didn't store it anywhere!) - -- -- put the declarations in a canonical order, sorted by OccName - let sorted_decls :: [(Fingerprint, IfaceDecl)] + let sorted_decls :: [IfaceDeclBoxed] sorted_decls = Map.elems $ Map.fromList $ - [(getOccName d, e) | e@(_, d) <- decls_w_hashes] + [(getOccName name, e) | e@(IfaceDeclBoxed _ name _ _) <- decls_w_hashes] -- This key is safe because mi_extra_decls contains tidied things. getOcc (IfGblTopBndr b) = getOccName b @@ -1246,7 +1224,7 @@ addFingerprints hsc_env iface0 -- - flag abi hash -- - foreign stubs and files mod_hash <- computeFingerprint putNameLiterally - (map fst sorted_decls, + (map ifBoxedFingerprint sorted_decls, export_hash, -- includes orphan_hash mi_warns iface0, mi_foreign iface0) ===================================== compiler/GHC/Iface/Rename.hs ===================================== @@ -38,7 +38,6 @@ import GHC.Types.Name.Shape import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Error -import GHC.Utils.Fingerprint import GHC.Utils.Panic import qualified Data.Traversable as T @@ -416,8 +415,8 @@ rnIfaceFamInst d = do axiom <- rnIfaceGlobal (ifFamInstAxiom d) return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom } -rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl) -rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl +rnIfaceDecl' :: Rename IfaceDeclBoxed +rnIfaceDecl' (IfaceDeclBoxed fp _ _ decl) = mkBoxedDecl fp <$> rnIfaceDecl decl rnIfaceDecl :: Rename IfaceDecl rnIfaceDecl d@IfaceId{} = do ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -28,6 +28,8 @@ module GHC.Iface.Syntax ( IfaceImport(..), ImpIfaceList(..), + IfaceDeclBoxed(..), mkBoxedDecl, + -- * Binding names IfaceTopBndr, putIfaceTopBndr, getIfaceTopBndr, @@ -139,6 +141,31 @@ putIfaceTopBndr bh name = --pprTrace "putIfaceTopBndr" (ppr name) $ putEntry tbl bh (BindingName name) +-- | A wrapper around IfaceDecl which separates parts which are needed eagerly from parts which are needed lazily. +data IfaceDeclBoxed + = IfaceDeclBoxed { + ifBoxedFingerprint :: !Fingerprint, + ifBoxedName :: !IfaceTopBndr, + ifBoxedImplicitBndrs :: ![OccName], + ifBoxedDecl :: IfaceDecl + } + +mkBoxedDecl :: Fingerprint -> IfaceDecl -> IfaceDeclBoxed +mkBoxedDecl fingerprint decl = IfaceDeclBoxed fingerprint (ifName decl) (ifaceDeclImplicitBndrs decl) decl + +instance Binary IfaceDeclBoxed where + put_ bh (IfaceDeclBoxed fingerprint name implicitBndrs decl) = do + put_ bh fingerprint + put_ bh name + put_ bh implicitBndrs + lazyPut bh decl + get bh = do + fingerprint <- get bh + name <- get bh + implicitBndrs <- get @[OccName] bh + decl <- lazyGet bh + return $ IfaceDeclBoxed fingerprint name implicitBndrs decl + data IfaceDecl = IfaceId { ifName :: IfaceTopBndr, ifType :: IfaceType, @@ -587,11 +614,12 @@ ifaceConDeclImplicitBndrs (IfCon { -- different fingerprint! So we calculate the fingerprint of -- each binder by combining the fingerprint of the whole -- declaration with the name of the binder. (#5614, #7215) -ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)] -ifaceDeclFingerprints hash decl - = (getOccName decl, hash) : +ifaceDeclFingerprints :: IfaceDeclBoxed -> [(OccName,Fingerprint)] +ifaceDeclFingerprints (IfaceDeclBoxed hash name implicitBndrs _) + = (getOccName name, hash) : [ (occ, computeFingerprint' (hash,occ)) - | occ <- ifaceDeclImplicitBndrs decl ] + -- TODO: maybe more laziness here + | occ <- implicitBndrs ] where computeFingerprint' = unsafeDupablePerformIO ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -421,17 +421,17 @@ typecheckIfacesForMerging mod ifaces tc_env_vars = -- serialize them out. See Note [rnIfaceNeverExported] in GHC.Iface.Rename -- NB: But coercions are OK, because they will have the right OccName. let mk_decl_env decls - = mkOccEnv [ (getOccName decl, decl) - | decl <- decls + = mkOccEnv [ (getOccName name, decl) + | (name, decl) <- decls , case decl of IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns _ -> True ] - decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces + decl_envs = map (mk_decl_env . map (\(IfaceDeclBoxed _ name _ decl) -> (name, decl)) . mi_decls) ifaces :: [OccEnv IfaceDecl] decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs :: OccEnv IfaceDecl -- TODO: change tcIfaceDecls to accept w/o Fingerprint - names_w_things <- tcIfaceDecls ignore_prags (map (\x -> (fingerprint0, x)) + names_w_things <- tcIfaceDecls ignore_prags (map (\x -> mkBoxedDecl fingerprint0 x) (nonDetOccEnvElts decl_env)) let global_type_env = mkNameEnv names_w_things case lookupKnotVars tc_env_vars mod of @@ -947,19 +947,18 @@ mk_top_id (IfLclTopBndr raw_name iface_type info details) = do return new_id tcIfaceDecls :: Bool - -> [(Fingerprint, IfaceDecl)] + -> [IfaceDeclBoxed] -> IfL [(Name,TyThing)] tcIfaceDecls ignore_prags ver_decls = concatMapM (tc_iface_decl_fingerprint ignore_prags) ver_decls tc_iface_decl_fingerprint :: Bool -- Don't load pragmas into the decl pool - -> (Fingerprint, IfaceDecl) + -> IfaceDeclBoxed -> IfL [(Name,TyThing)] -- The list can be poked eagerly, but the -- TyThings are forkM'd thunks -tc_iface_decl_fingerprint ignore_prags (_version, decl) +tc_iface_decl_fingerprint ignore_prags (IfaceDeclBoxed _fingerprint main_name implicitBndrs decl) = do { -- Populate the name cache with final versions of all -- the names associated with the decl - let main_name = ifName decl -- Typecheck the thing, lazily -- NB. Firstly, the laziness is there in case we never need the @@ -1032,7 +1031,7 @@ tc_iface_decl_fingerprint ignore_prags (_version, decl) Nothing -> pprPanic "tc_iface_decl_fingerprint" (ppr main_name <+> ppr n $$ ppr (decl)) - ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl) + ; implicit_names <- mapM lookupIfaceTop implicitBndrs -- ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names) ; return $ (main_name, thing) : ===================================== compiler/GHC/IfaceToCore.hs-boot ===================================== @@ -2,7 +2,7 @@ module GHC.IfaceToCore where import GHC.Prelude import GHC.Iface.Syntax ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule - , IfaceAnnotation, IfaceCompleteMatch ) + , IfaceAnnotation, IfaceCompleteMatch, IfaceDeclBoxed ) import GHC.Types.TyThing ( TyThing ) import GHC.Tc.Types ( IfL ) import GHC.Core.InstEnv ( ClsInst ) @@ -11,7 +11,6 @@ import GHC.Core ( CoreRule ) import GHC.Types.CompleteMatch import GHC.Types.Annotations ( Annotation ) import GHC.Types.Name -import GHC.Fingerprint.Type tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] @@ -19,4 +18,4 @@ tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch] -tcIfaceDecls :: Bool -> [(Fingerprint, IfaceDecl)] -> IfL [(Name,TyThing)] +tcIfaceDecls :: Bool -> [IfaceDeclBoxed] -> IfL [(Name,TyThing)] ===================================== compiler/GHC/Tc/Utils/Backpack.hs ===================================== @@ -379,12 +379,12 @@ thinModIface avails iface = -- perhaps there might be two IfaceTopBndr that are the same -- OccName but different Name. Requires better understanding -- of invariants here. - & set_mi_decls (exported_decls ++ non_exported_decls ++ dfun_decls) + & set_mi_decls (exported_decls ++ non_exported_decls ++ dfun_decls) -- mi_insts = ..., -- mi_fam_insts = ..., where - decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs - filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface) + decl_pred occs name = nameOccName name `elemOccSet` occs + filter_decls occs = filter (decl_pred occs . ifBoxedName) (mi_decls iface) exported_occs = mkOccSet [ nameOccName n | a <- avails @@ -392,13 +392,13 @@ thinModIface avails iface = exported_decls = filter_decls exported_occs non_exported_occs = mkOccSet [ occName n - | (_, d) <- exported_decls + | IfaceDeclBoxed _ _ _ d <- exported_decls , n <- ifaceDeclNeverExportedRefs d ] non_exported_decls = filter_decls non_exported_occs dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True dfun_pred _ = False - dfun_decls = filter (dfun_pred . snd) (mi_decls iface) + dfun_decls = filter (dfun_pred . ifBoxedDecl) (mi_decls iface) -- | The list of 'Name's of *non-exported* 'IfaceDecl's which this -- 'IfaceDecl' may refer to. A non-exported 'IfaceDecl' should be kept ===================================== compiler/GHC/Unit/Module/ModIface.hs ===================================== @@ -121,8 +121,6 @@ import GHC.Utils.Fingerprint import GHC.Utils.Binary import Control.DeepSeq -import Control.Exception -import qualified GHC.Data.Strict as Strict {- Note [Interface file stages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -198,7 +196,7 @@ data ModIfacePhase -- a fingerprint, which is used for recompilation checks. type family IfaceDeclExts (phase :: ModIfacePhase) = decl | decl -> phase where IfaceDeclExts 'ModIfaceCore = IfaceDecl - IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl) + IfaceDeclExts 'ModIfaceFinal = IfaceDeclBoxed type family IfaceBackendExts (phase :: ModIfacePhase) = bk | bk -> phase where IfaceBackendExts 'ModIfaceCore = () @@ -656,13 +654,13 @@ emptyFullModIface mod = mi_hash_fn = emptyIfaceHashCache } } -- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' -mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] +mkIfaceHashCache :: [IfaceDeclBoxed] -> (OccName -> Maybe (OccName, Fingerprint)) mkIfaceHashCache pairs = \occ -> lookupOccEnv env occ where env = foldl' add_decl emptyOccEnv pairs - add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d) + add_decl env0 v = foldl' add env0 (ifaceDeclFingerprints v) where add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash) @@ -729,9 +727,8 @@ instance NFData (ModIfaceBackend) where `seq` rnf mi_fix_fn `seq` rnf mi_hash_fn - forceModIface :: ModIface -> IO () -forceModIface iface = () <$ (evaluate $ force iface) +forceModIface _ = return () -- | Records whether a module has orphans. An \"orphan\" is one of: -- @@ -774,7 +771,7 @@ to serialise the 'ModIface' to disk again. -- | Given a 'PartialModIface', turn it into a 'ModIface' by completing -- missing fields. completePartialModIface :: PartialModIface - -> [(Fingerprint, IfaceDecl)] + -> [IfaceDeclBoxed] -> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -> ModIfaceBackend -> ModIface ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -124,6 +124,8 @@ import GHC.Types.SrcLoc import GHC.Types.Unique import qualified GHC.Data.Strict as Strict import GHC.Utils.Outputable( JoinPointHood(..) ) +import GHCi.FFI +import GHCi.Message import Control.DeepSeq import Control.Monad ( when, (<$!>), unless, forM_, void ) @@ -157,6 +159,9 @@ import qualified Data.IntMap as IntMap #if MIN_VERSION_base(4,15,0) import GHC.ForeignPtr ( unsafeWithForeignPtr ) #endif +import GHC.Stack +import GHC.Utils.Outputable + import Unsafe.Coerce (unsafeCoerce) @@ -1321,7 +1326,7 @@ forwardGetRel bh get_A = do lazyPut :: Binary a => WriteBinHandle -> a -> IO () lazyPut = lazyPut' put_ -lazyGet :: Binary a => ReadBinHandle -> IO a +lazyGet :: (HasCallStack, Binary a) => ReadBinHandle -> IO a lazyGet = lazyGet' get lazyPut' :: (WriteBinHandle -> a -> IO ()) -> WriteBinHandle -> a -> IO () @@ -1334,13 +1339,20 @@ lazyPut' f bh a = do putAtRel bh pre_a q -- fill in slot before a with ptr to q seekBinWriter bh q -- finally carry on writing at q -lazyGet' :: (ReadBinHandle -> IO a) -> ReadBinHandle -> IO a +lazyGet' :: HasCallStack =>(ReadBinHandle -> IO a) -> ReadBinHandle -> IO a lazyGet' f bh = do p <- getRelBin bh -- a BinPtr p_a <- tellBinReader bh a <- unsafeInterleaveIO $ do -- NB: Use a fresh rbm_off_r variable in the child thread, for thread -- safety. + {- + stack <- cloneMyStack + decoded_stack <- decode stack + let printId (StackEntry fn mn _ _) = text fn <+> text mn + pprTraceM "lazyGet" (callStackDoc $$ vcat (map printId decoded_stack)) + -} + off_r <- newFastMutInt 0 let bh' = bh { rbm_off_r = off_r } seekBinReader bh' p_a ===================================== utils/haddock ===================================== @@ -1 +1 @@ -Subproject commit ba88561db028296eaf1ad58e9a0d51ef385b7eea +Subproject commit 4da264f42c35e3e302f8a8579d41f6521c7337ee View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dde170fc0974b459edb05db1ab1ac748... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dde170fc0974b459edb05db1ab1ac748... You're receiving this email because of your account on gitlab.haskell.org.