- ghc-commits - Haskell.org

[Git][ghc/ghc] Pushed new branch wip/mp/9.10.1-memory-backports
by Matthew Pickering (＠mpickering) 23 Dec '25

23 Dec '25

Matthew Pickering pushed new branch wip/mp/9.10.1-memory-backports at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/mp/9.10.1-memory-backports You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/iface-patch-9.10-backport] WIP: Lazy loading of IfaceDecl
by Matthew Pickering (＠mpickering) 23 Dec '25

23 Dec '25

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/dde170fc0974b459edb05db1ab1ac74… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dde170fc0974b459edb05db1ab1ac74… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] rts: opportunistically reclaim slop space in shrinkMutableByteArray#
by Marge Bot (＠marge-bot) 23 Dec '25

23 Dec '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: b26d134a by Cheng Shao at 2025-12-23T04:48:15-05:00 rts: opportunistically reclaim slop space in shrinkMutableByteArray# Previously, `shrinkMutableByteArray#` shrinks a `MutableByteArray#` in-place by assigning the new size to it, and zeroing the extra slop space. That slop space is not reclaimed and wasted. But it's often the case that we allocate a `MutableByteArray#` upfront, then shrink it shortly after, so the `MutableByteArray#` closure sits right at the end of a nursery block; this patch identifies such chances, and also shrink `bd->free` if possible, reducing heap space fragmentation. Co-authored-by: Codex <codex(a)openai.com> ------------------------- Metric Decrease: T10678 ------------------------- - - - - - 2 changed files: - rts/PrimOps.cmm - utils/deriveConstants/Main.hs Changes: ===================================== rts/PrimOps.cmm ===================================== @@ -204,12 +204,47 @@ stg_isMutableByteArrayWeaklyPinnedzh ( gcptr mba ) stg_shrinkMutableByteArrayzh ( gcptr mba, W_ new_size ) // MutableByteArray# s -> Int# -> State# s -> State# s { - ASSERT(new_size <= StgArrBytes_bytes(mba)); + W_ old_size, old_wds, new_wds; + W_ bd; + + old_size = StgArrBytes_bytes(mba); + ASSERT(new_size <= old_size); + old_wds = BYTES_TO_WDS(SIZEOF_StgArrBytes) + ROUNDUP_BYTES_TO_WDS(old_size); + new_wds = BYTES_TO_WDS(SIZEOF_StgArrBytes) + ROUNDUP_BYTES_TO_WDS(new_size); + + // Try to shrink bd->free as well, to reclaim slop space at the end + // of current block and avoid unnecessary fragmentation. But we + // must guarantee that: + // + // 1. mba is already at the end of current block (check bd->free). + // Otherwise we can't move closures that come after it anyway. + // 2. It's a nursery block that belongs to the current Capability, + // so check rCurrentAlloc (used by allocateMightFail) or + // pinned_object_block (used by allocatePinned). There's also no + // point if it's an older generation block, the mutator won't + // allocate into those blocks anyway. + // + // If check fails, fall back to the conservative code path: just + // zero the slop and return. + bd = Bdescr(mba); + if (bdescr_free(bd) != mba + WDS(old_wds) || + (bd != StgRegTable_rCurrentAlloc(BaseReg) && bd != Capability_pinned_object_block(MyCapability()))) { + OVERWRITING_CLOSURE_MUTABLE(mba, new_wds); + StgArrBytes_bytes(mba) = new_size; + // No need to call PROF_HEADER_CREATE. See Note [LDV profiling and resizing arrays] + return (); + } - OVERWRITING_CLOSURE_MUTABLE(mba, (BYTES_TO_WDS(SIZEOF_StgArrBytes) + - ROUNDUP_BYTES_TO_WDS(new_size))); + // Check passes, we can shrink bd->free! Also uninitialize the slop + // if zero_on_gc is enabled, to conform with debug RTS convention. StgArrBytes_bytes(mba) = new_size; - // No need to call PROF_HEADER_CREATE. See Note [LDV profiling and resizing arrays] + IF_DEBUG(zero_on_gc, + prim %memset(mba + WDS(new_wds), + 0xaa, + WDS(old_wds - new_wds), + 1); + ); + bdescr_free(bd) = mba + WDS(new_wds); return (); } @@ -223,18 +258,10 @@ stg_shrinkMutableByteArrayzh ( gcptr mba, W_ new_size ) stg_resizzeMutableByteArrayzh ( gcptr mba, W_ new_size ) // MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #) { - W_ new_size_wds; - - ASSERT(new_size >= 0); - - new_size_wds = ROUNDUP_BYTES_TO_WDS(new_size); - - if (new_size_wds <= BYTE_ARR_WDS(mba)) { - OVERWRITING_CLOSURE_MUTABLE(mba, (BYTES_TO_WDS(SIZEOF_StgArrBytes) + - new_size_wds)); - StgArrBytes_bytes(mba) = new_size; - // No need to call PROF_HEADER_CREATE. See Note [LDV profiling and resizing arrays] + ASSERT(new_size `ge` 0); + if (new_size <= StgArrBytes_bytes(mba)) { + call stg_shrinkMutableByteArrayzh(mba, new_size); return (mba); } else { (P_ new_mba) = call stg_newByteArrayzh(new_size); ===================================== utils/deriveConstants/Main.hs ===================================== @@ -395,6 +395,7 @@ wanteds os = concat ,fieldOffset Both "StgRegTable" "rCurrentTSO" ,fieldOffset Both "StgRegTable" "rCurrentNursery" ,fieldOffset Both "StgRegTable" "rHpAlloc" + ,structField C "StgRegTable" "rCurrentAlloc" ,structField C "StgRegTable" "rRet" ,structField C "StgRegTable" "rNursery" @@ -414,6 +415,7 @@ wanteds os = concat ,structField C "Capability" "weak_ptr_list_hd" ,structField C "Capability" "weak_ptr_list_tl" ,structField C "Capability" "n_run_queue" + ,structField C "Capability" "pinned_object_block" ,structField Both "bdescr" "start" ,structField Both "bdescr" "free" @@ -629,6 +631,8 @@ wanteds os = concat "RTS_FLAGS" "DebugFlags.sanity" ,structField_ C "RtsFlags_DebugFlags_weak" "RTS_FLAGS" "DebugFlags.weak" + ,structField_ C "RtsFlags_DebugFlags_zero_on_gc" + "RTS_FLAGS" "DebugFlags.zero_on_gc" ,structField_ C "RtsFlags_GcFlags_initialStkSize" "RTS_FLAGS" "GcFlags.initialStkSize" ,structField_ C "RtsFlags_MiscFlags_tickInterval" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b26d134a666dcc2ca92d9cffc17cd38… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b26d134a666dcc2ca92d9cffc17cd38… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][master] Add an operation `System.IO.hGetNewlineMode`
by Marge Bot (＠marge-bot) 23 Dec '25

23 Dec '25

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC Commits: a2d52b3b by Wolfgang Jeltsch at 2025-12-23T04:47:33-05:00 Add an operation `System.IO.hGetNewlineMode` This commit also contains some small code and documentation changes for related operations, for the sake of consistency. - - - - - 8 changed files: - libraries/base/changelog.md - libraries/base/src/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle.hs - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 Changes: ===================================== libraries/base/changelog.md ===================================== @@ -1,6 +1,7 @@ # Changelog for [`base` package](http://hackage.haskell.org/package/base) ## 4.23.0.0 *TBA* + * Add `System.IO.hGetNewlineMode`. ([CLC proposal #370](https://github.com/haskell/core-libraries-committee/issues/370)) * Add `{-# WARNING in "x-partial" #-}` to `Data.List.{init,last}`. Use `{-# OPTIONS_GHC -Wno-x-partial #-}` to disable it. ([CLC proposal #87](https://github.com/haskell/core-libraries-committee/issues/292)) ===================================== libraries/base/src/System/IO.hs ===================================== @@ -175,6 +175,7 @@ module System.IO -- Binary-mode 'Handle's do no newline translation at all. hSetNewlineMode, + hGetNewlineMode, Newline(..), nativeNewline, NewlineMode(..), ===================================== libraries/ghc-internal/src/GHC/Internal/IO/Handle.hs ===================================== @@ -40,7 +40,7 @@ module GHC.Internal.IO.Handle ( hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable, hSetEcho, hGetEcho, hIsTerminalDevice, - hSetNewlineMode, Newline(..), NewlineMode(..), nativeNewline, + hSetNewlineMode, hGetNewlineMode, Newline(..), NewlineMode(..), nativeNewline, noNewlineTranslation, universalNewlineMode, nativeNewlineMode, hShow, @@ -238,7 +238,7 @@ hSetBuffering handle mode = return Handle__{ haBufferMode = mode,.. } -- ----------------------------------------------------------------------------- --- hSetEncoding +-- Setting and getting the text encoding -- | The action 'hSetEncoding' @hdl@ @encoding@ changes the text encoding -- for the handle @hdl@ to @encoding@. The default encoding when a 'Handle' is @@ -624,16 +624,24 @@ hSetBinaryMode handle bin = haOutputNL = outputNL nl, .. } -- ----------------------------------------------------------------------------- --- hSetNewlineMode +-- Setting and getting the newline mode --- | Set the 'NewlineMode' on the specified 'Handle'. All buffered +-- | Set the 'NewlineMode' for the specified 'Handle'. All buffered -- data is flushed first. hSetNewlineMode :: Handle -> NewlineMode -> IO () -hSetNewlineMode handle NewlineMode{ inputNL=i, outputNL=o } = +hSetNewlineMode handle NewlineMode{..} = withAllHandles__ "hSetNewlineMode" handle $ \h_@Handle__{} -> do flushBuffer h_ - return h_{ haInputNL=i, haOutputNL=o } + return h_{ haInputNL = inputNL, haOutputNL = outputNL } + +-- | Return the current 'NewlineMode' for the specified 'Handle'. +-- +-- @since 4.23.0.0 +hGetNewlineMode :: Handle -> IO NewlineMode +hGetNewlineMode hdl = + withHandle_ "hGetNewlineMode" hdl $ \h_@Handle__{..} -> + return NewlineMode{ inputNL = haInputNL, outputNL = haOutputNL } -- ----------------------------------------------------------------------------- -- Duplicating a Handle ===================================== libraries/ghc-internal/src/GHC/Internal/System/IO.hs ===================================== @@ -214,6 +214,7 @@ module GHC.Internal.System.IO ( -- Binary-mode 'Handle's do no newline translation at all. -- hSetNewlineMode, + hGetNewlineMode, Newline(..), nativeNewline, NewlineMode(..), noNewlineTranslation, universalNewlineMode, nativeNewlineMode, ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -10263,6 +10263,7 @@ module System.IO where hGetEcho :: Handle -> IO GHC.Internal.Types.Bool hGetEncoding :: Handle -> IO (GHC.Internal.Maybe.Maybe TextEncoding) hGetLine :: Handle -> IO GHC.Internal.Base.String + hGetNewlineMode :: Handle -> IO NewlineMode hGetPosn :: Handle -> IO HandlePosn hIsClosed :: Handle -> IO GHC.Internal.Types.Bool hIsEOF :: Handle -> IO GHC.Internal.Types.Bool ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -13309,6 +13309,7 @@ module System.IO where hGetEcho :: Handle -> IO GHC.Internal.Types.Bool hGetEncoding :: Handle -> IO (GHC.Internal.Maybe.Maybe TextEncoding) hGetLine :: Handle -> IO GHC.Internal.Base.String + hGetNewlineMode :: Handle -> IO NewlineMode hGetPosn :: Handle -> IO HandlePosn hIsClosed :: Handle -> IO GHC.Internal.Types.Bool hIsEOF :: Handle -> IO GHC.Internal.Types.Bool ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -10543,6 +10543,7 @@ module System.IO where hGetEcho :: Handle -> IO GHC.Internal.Types.Bool hGetEncoding :: Handle -> IO (GHC.Internal.Maybe.Maybe TextEncoding) hGetLine :: Handle -> IO GHC.Internal.Base.String + hGetNewlineMode :: Handle -> IO NewlineMode hGetPosn :: Handle -> IO HandlePosn hIsClosed :: Handle -> IO GHC.Internal.Types.Bool hIsEOF :: Handle -> IO GHC.Internal.Types.Bool ===================================== testsuite/tests/interface-stability/base-exports.stdout-ws-32 ===================================== @@ -10263,6 +10263,7 @@ module System.IO where hGetEcho :: Handle -> IO GHC.Internal.Types.Bool hGetEncoding :: Handle -> IO (GHC.Internal.Maybe.Maybe TextEncoding) hGetLine :: Handle -> IO GHC.Internal.Base.String + hGetNewlineMode :: Handle -> IO NewlineMode hGetPosn :: Handle -> IO HandlePosn hIsClosed :: Handle -> IO GHC.Internal.Types.Bool hIsEOF :: Handle -> IO GHC.Internal.Types.Bool View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a2d52b3b385aaadb9941f53928de275… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a2d52b3b385aaadb9941f53928de275… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/iface-patch-9.10-backport
by Matthew Pickering (＠mpickering) 23 Dec '25

23 Dec '25

Matthew Pickering pushed new branch wip/iface-patch-9.10-backport at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/iface-patch-9.10-backport You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fix-26670] 4 commits: Do deep subsumption when computing valid hole fits
by recursion-ninja (＠recursion-ninja) 23 Dec '25

23 Dec '25

recursion-ninja pushed to branch wip/fix-26670 at Glasgow Haskell Compiler / GHC Commits: db1ce858 by sheaf at 2025-12-22T17:11:17-05:00 Do deep subsumption when computing valid hole fits This commit makes a couple of improvements to the code that computes "valid hole fits": 1. It uses deep subsumption for data constructors. This matches up the multiplicities, as per Note [Typechecking data constructors]. This fixes #26338 (test: LinearHoleFits). 2. It now suggests (non-unidirectional) pattern synonyms as valid hole fits. This fixes #26339 (test: PatSynHoleFit). 3. It uses 'stableNameCmp', to make the hole fit output deterministic. ------------------------- Metric Increase: hard_hole_fits ------------------------- - - - - - 72ee9100 by sheaf at 2025-12-22T17:11:17-05:00 Speed up hole fits with a quick pre-test This speeds up the machinery for valid hole fits by doing a small check to rule out obviously wrong hole fits, such as: 1. A hole fit identifier whose type has a different TyCon at the head, after looking through foralls and (=>) arrows, e.g.: hole_ty = Int cand_ty = Maybe a or hole_ty = forall a b. a -> b cand_ty = forall x y. Either x y 2. A hole fit identifier that is not polymorphic when the hole type is polymorphic, e.g. hole_ty = forall a. a -> a cand_ty = Int -> Int ------------------------- Metric Decrease: hard_hole_fits ------------------------- - - - - - 30e513ba by Cheng Shao at 2025-12-22T17:12:00-05:00 configure: remove unused win32-tarballs.md5sum This patch removes the unused `win32-tarballs.md5sum` file from the tree. The current mingw tarball download logic in `mk/get-win32-tarballs.py` fetches and checks against `SHA256SUM` from the same location where the tarballs are fetched, and this file has been unused for a few years. - - - - - 16b3dfb9 by Recursion Ninja at 2025-12-22T21:52:56-05:00 Decoupling Language.Haskell.Syntax.Binds from GHC.Types.Basic by transfering InlinePragma types between the modules. * Moved InlinePragma data-types to Language.Haskell.Syntax.Binds.InlinePragma * Partitioned of Arity type synonyms to GHC.Types.Arity * InlinePragma is now extensible via Trees That Grow * Activation is now extensible via Trees That Grow * Maybe Arity change to more descriptive InlineSaturation data-type * InlineSaturation information removed from InlinePragma during GHS parsing pass * Cleaned up the exposed module interfaces of the new modules - - - - - 94 changed files: - .gitattributes - compiler/GHC/Builtin/PrimOps/Ids.hs - compiler/GHC/Core.hs - compiler/GHC/Core/DataCon.hs - compiler/GHC/Core/Lint.hs - compiler/GHC/Core/Opt/CSE.hs - compiler/GHC/Core/Opt/CprAnal.hs - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Core/Opt/OccurAnal.hs - compiler/GHC/Core/Opt/Pipeline.hs - compiler/GHC/Core/Opt/Pipeline/Types.hs - compiler/GHC/Core/Opt/Simplify.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Simplify/Utils.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/Ppr.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/Core/SimpleOpt.hs - compiler/GHC/Core/Unfold/Make.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/Driver/Config/Core/Lint.hs - compiler/GHC/Driver/Config/Core/Opt/Simplify.hs - compiler/GHC/Hs/Binds.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Errors/Types.hs - compiler/GHC/HsToCore/Foreign/C.hs - compiler/GHC/HsToCore/Foreign/JavaScript.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Make.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Tidy.hs - compiler/GHC/IfaceToCore.hs - compiler/GHC/Parser.y - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/PostProcess.hs - compiler/GHC/Rename/Bind.hs - compiler/GHC/Tc/Deriv/Generics.hs - compiler/GHC/Tc/Errors/Hole.hs - compiler/GHC/Tc/Errors/Hole/FitTypes.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Errors/Types.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Gen/Arrow.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/Instance/Typeable.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/Unify.hs - compiler/GHC/ThToHs.hs - + compiler/GHC/Types/Arity.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Hint.hs - compiler/GHC/Types/Id.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Id/Make.hs - + compiler/GHC/Types/InlinePragma.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Binds.hs - + compiler/Language/Haskell/Syntax/Binds/InlinePragma.hs - compiler/Language/Haskell/Syntax/Decls.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/ghc.cabal.in - docs/users_guide/9.16.1-notes.rst - libraries/exceptions - − mk/win32-tarballs.md5sum - testsuite/tests/ghci/scripts/T8353.stderr - testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.stderr - testsuite/tests/perf/compiler/hard_hole_fits.stderr - testsuite/tests/plugins/test-hole-plugin.stderr - testsuite/tests/th/T15321.stderr - testsuite/tests/typecheck/should_compile/T13050.stderr - testsuite/tests/typecheck/should_compile/T14273.stderr - testsuite/tests/typecheck/should_compile/T14590.stderr - testsuite/tests/typecheck/should_compile/T25180.stderr - testsuite/tests/typecheck/should_compile/abstract_refinement_hole_fits.stderr - testsuite/tests/typecheck/should_compile/constraint_hole_fits.stderr - testsuite/tests/typecheck/should_compile/free_monad_hole_fits.stderr - testsuite/tests/typecheck/should_compile/hole_constraints.stderr - testsuite/tests/typecheck/should_compile/holes.stderr - testsuite/tests/typecheck/should_compile/holes2.stderr - testsuite/tests/typecheck/should_compile/holes3.stderr - testsuite/tests/typecheck/should_compile/refinement_hole_fits.stderr - testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr - testsuite/tests/typecheck/should_compile/type_in_type_hole_fits.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits_interactions.stderr - testsuite/tests/typecheck/should_fail/T14884.stderr The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7a5b0700cebe06a8bd3c813409eb74… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7a5b0700cebe06a8bd3c813409eb74… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: Do deep subsumption when computing valid hole fits
by Marge Bot (＠marge-bot) 23 Dec '25

23 Dec '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: db1ce858 by sheaf at 2025-12-22T17:11:17-05:00 Do deep subsumption when computing valid hole fits This commit makes a couple of improvements to the code that computes "valid hole fits": 1. It uses deep subsumption for data constructors. This matches up the multiplicities, as per Note [Typechecking data constructors]. This fixes #26338 (test: LinearHoleFits). 2. It now suggests (non-unidirectional) pattern synonyms as valid hole fits. This fixes #26339 (test: PatSynHoleFit). 3. It uses 'stableNameCmp', to make the hole fit output deterministic. ------------------------- Metric Increase: hard_hole_fits ------------------------- - - - - - 72ee9100 by sheaf at 2025-12-22T17:11:17-05:00 Speed up hole fits with a quick pre-test This speeds up the machinery for valid hole fits by doing a small check to rule out obviously wrong hole fits, such as: 1. A hole fit identifier whose type has a different TyCon at the head, after looking through foralls and (=>) arrows, e.g.: hole_ty = Int cand_ty = Maybe a or hole_ty = forall a b. a -> b cand_ty = forall x y. Either x y 2. A hole fit identifier that is not polymorphic when the hole type is polymorphic, e.g. hole_ty = forall a. a -> a cand_ty = Int -> Int ------------------------- Metric Decrease: hard_hole_fits ------------------------- - - - - - 30e513ba by Cheng Shao at 2025-12-22T17:12:00-05:00 configure: remove unused win32-tarballs.md5sum This patch removes the unused `win32-tarballs.md5sum` file from the tree. The current mingw tarball download logic in `mk/get-win32-tarballs.py` fetches and checks against `SHA256SUM` from the same location where the tarballs are fetched, and this file has been unused for a few years. - - - - - aba46b88 by Wolfgang Jeltsch at 2025-12-22T20:17:02-05:00 Add an operation `System.IO.hGetNewlineMode` This commit also contains some small code and documentation changes for related operations, for the sake of consistency. - - - - - 988619c7 by Cheng Shao at 2025-12-22T20:17:03-05:00 rts: opportunistically reclaim slop space in shrinkMutableByteArray# Previously, `shrinkMutableByteArray#` shrinks a `MutableByteArray#` in-place by assigning the new size to it, and zeroing the extra slop space. That slop space is not reclaimed and wasted. But it's often the case that we allocate a `MutableByteArray#` upfront, then shrink it shortly after, so the `MutableByteArray#` closure sits right at the end of a nursery block; this patch identifies such chances, and also shrink `bd->free` if possible, reducing heap space fragmentation. Co-authored-by: Codex <codex(a)openai.com> ------------------------- Metric Decrease: T10678 ------------------------- - - - - - 41 changed files: - .gitattributes - compiler/GHC/Core/DataCon.hs - compiler/GHC/Tc/Errors/Hole.hs - compiler/GHC/Tc/Errors/Hole/FitTypes.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Utils/Unify.hs - docs/users_guide/9.16.1-notes.rst - libraries/base/changelog.md - libraries/base/src/System/IO.hs - libraries/ghc-internal/src/GHC/Internal/IO/Handle.hs - libraries/ghc-internal/src/GHC/Internal/System/IO.hs - − mk/win32-tarballs.md5sum - rts/PrimOps.cmm - testsuite/tests/ghci/scripts/T8353.stderr - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - testsuite/tests/interface-stability/base-exports.stdout-ws-32 - testsuite/tests/overloadedrecflds/should_fail/DRFHoleFits.stderr - testsuite/tests/perf/compiler/hard_hole_fits.stderr - testsuite/tests/plugins/test-hole-plugin.stderr - testsuite/tests/th/T15321.stderr - testsuite/tests/typecheck/should_compile/T13050.stderr - testsuite/tests/typecheck/should_compile/T14273.stderr - testsuite/tests/typecheck/should_compile/T14590.stderr - testsuite/tests/typecheck/should_compile/T25180.stderr - testsuite/tests/typecheck/should_compile/abstract_refinement_hole_fits.stderr - testsuite/tests/typecheck/should_compile/constraint_hole_fits.stderr - testsuite/tests/typecheck/should_compile/free_monad_hole_fits.stderr - testsuite/tests/typecheck/should_compile/hole_constraints.stderr - testsuite/tests/typecheck/should_compile/holes.stderr - testsuite/tests/typecheck/should_compile/holes2.stderr - testsuite/tests/typecheck/should_compile/holes3.stderr - testsuite/tests/typecheck/should_compile/refinement_hole_fits.stderr - testsuite/tests/typecheck/should_compile/subsumption_sort_hole_fits.stderr - testsuite/tests/typecheck/should_compile/type_in_type_hole_fits.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr - testsuite/tests/typecheck/should_compile/valid_hole_fits_interactions.stderr - testsuite/tests/typecheck/should_fail/T14884.stderr - utils/deriveConstants/Main.hs The diff was not included because it is too large. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f969370e57afc59bcb1c2a987f7818… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f969370e57afc59bcb1c2a987f7818… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fix-26670] Removing TTG pass parameters in Core/Info/IFace code
by recursion-ninja (＠recursion-ninja) 23 Dec '25

23 Dec '25

recursion-ninja pushed to branch wip/fix-26670 at Glasgow Haskell Compiler / GHC Commits: 7a5b0700 by Recursion Ninja at 2025-12-22T20:06:56-05:00 Removing TTG pass parameters in Core/Info/IFace code - - - - - 15 changed files: - compiler/GHC/Core/Opt/Simplify/Iteration.hs - compiler/GHC/Core/Opt/Specialise.hs - compiler/GHC/Core/Opt/WorkWrap.hs - compiler/GHC/Core/Rules.hs - compiler/GHC/CoreToIface.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Tc/Gen/Sig.hs - compiler/GHC/Tc/TyCl/Instance.hs - compiler/GHC/Types/Id.hs - compiler/GHC/Types/Id/Info.hs - compiler/GHC/Types/Id/Make.hs - compiler/GHC/Types/InlinePragma.hs - compiler/Language/Haskell/Syntax/Binds/InlinePragma.hs - compiler/Language/Haskell/Syntax/Extension.hs Changes: ===================================== compiler/GHC/Core/Opt/Simplify/Iteration.hs ===================================== @@ -655,32 +655,19 @@ tryCastWorkerWrapper env _ _ bndr rhs -- All other bindings , text "rhs:" <+> ppr rhs ]) ; return (mkFloatBind env (NonRec bndr rhs)) } -mkCastWrapperInlinePrag :: InlinePragma GhcRn -> InlinePragma GhcRn +mkCastWrapperInlinePrag :: InlinePragma GhcTc -> InlinePragma GhcTc -- See Note [Cast worker/wrapper] mkCastWrapperInlinePrag prag = prag - -- Consider each field of the 'InlinePragma' constructor - -- and deterimine what is the appropriate definition for the - -- corresponding value used within a worker/wrapper. - -- - -- 1. 'inl_ext': Overwrite with defaults - -- > Changes <SOME> `setInlinePragmaSource` src_txt - `setInlinePragmaSaturation` AnySaturation - -- - -- 2. 'inl_inline': *Preserve* - -- See Note [Worker/wrapper for INLINABLE functions] + `setInlinePragmaSaturation` AnySaturation + `setInlinePragmaActivation` wrap_act + -- 1. 'Activation' is conditionally updated + -- See Note [Wrapper activation] -- in GHC.Core.Opt.WorkWrap - -- > Changes <NONE> - -- - -- 3. 'inl_act': Conditionally Update - -- See Note [Wrapper activation] + -- 2. 'InlineSpec' is also preserved + -- See Note [Worker/wrapper for INLINABLE functions] -- in GHC.Core.Opt.WorkWrap - -- > Changes <SOME> - `setInlinePragmaActivation` wrap_act - -- - -- 4. 'inl_rule': *Preserve* - -- RuleMatchInfo is (and must be) unaffected - -- > Changes <NONE> + -- 3. 'RuleMatchInfo' is (and must be) unaffected where -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap -- But simpler, because we don't need to disable during InitialPhase ===================================== compiler/GHC/Core/Opt/Specialise.hs ===================================== @@ -44,7 +44,7 @@ import GHC.Data.Bag import GHC.Data.OrdList import GHC.Data.List.SetOps -import GHC.Hs.Extension ( GhcPass, GhcRn ) +import GHC.Hs.Extension ( GhcPass ) import GHC.Types.Basic import GHC.Types.Unique.Supply @@ -1641,7 +1641,6 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- Copy InlinePragma information from the parent Id. -- So if f has INLINE[1] so does spec_fn - spec_inl_prag :: InlinePragma GhcRn spec_inl_prag | not is_local -- See Note [Specialising imported functions] , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal ===================================== compiler/GHC/Core/Opt/WorkWrap.hs ===================================== @@ -22,7 +22,7 @@ import GHC.Core.SimpleOpt import GHC.Data.FastString -import GHC.Hs.Extension (GhcPass, GhcRn) +import GHC.Hs.Extension (GhcPass, GhcTc) import GHC.Types.Var import GHC.Types.Id @@ -897,7 +897,7 @@ mkWWBindPair ww_opts fn_id fn_info fn_args fn_body work_uniq div fn_unfolding = realUnfoldingInfo fn_info fn_rules = ruleInfoRules (ruleInfo fn_info) -mkStrWrapperInlinePrag :: InlinePragma (GhcPass p) -> [CoreRule] -> InlinePragma GhcRn +mkStrWrapperInlinePrag :: InlinePragma (GhcPass p) -> [CoreRule] -> InlinePragma GhcTc mkStrWrapperInlinePrag (InlinePragma { inl_inline = fn_inl , inl_act = fn_act , inl_rule = rule_info }) rules ===================================== compiler/GHC/Core/Rules.hs ===================================== @@ -67,7 +67,7 @@ import GHC.Core.Make ( mkCoreLams ) import GHC.Core.Opt.OccurAnal( occurAnalyseExpr ) import GHC.Core.Rules.Config (roBuiltinRules) -import GHC.Hs.Extension ( GhcPass, GhcRn ) +import GHC.Hs.Extension ( GhcPass, GhcTc ) import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) import GHC.Builtin.Types ( anyTypeOfKind ) @@ -1930,7 +1930,7 @@ ruleCheckProgram ropts curr_phase rule_pat rules binds in ds `unionBags` go env' binds data RuleCheckEnv = RuleCheckEnv - { rc_is_active :: Activation GhcRn -> Bool + { rc_is_active :: Activation GhcTc -> Bool , rc_id_unf :: IdUnfoldingFun , rc_pattern :: String , rc_rules :: Id -> [CoreRule] ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -87,7 +87,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc -import GHC.Hs.Extension (GhcRn) +import GHC.Hs.Extension ( GhcRn ) import Data.Maybe ( isNothing, catMaybes ) ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -1020,7 +1020,7 @@ dsSpec_help poly_nm poly_id poly_rhs spec_inl orig_bndrs ds_call fn_unf = realIdUnfolding poly_id spec_unf = specUnfolding simpl_opts spec_bndrs mk_spec_body rule_lhs_args fn_unf spec_info = vanillaIdInfo - `setInlinePragInfo` specFunInlinePrag poly_id id_inl (demoteInlinePragmaTc spec_inl) + `setInlinePragInfo` specFunInlinePrag poly_id id_inl spec_inl `setUnfoldingInfo` spec_unf spec_id = mkLocalVar (idDetails poly_id) spec_name ManyTy spec_ty spec_info -- Specialised binding is toplevel, hence Many. @@ -1191,7 +1191,7 @@ getCastedVar (Var v) = Just (v, MRefl) getCastedVar (Cast (Var v) co) = Just (v, MCo co) getCastedVar _ = Nothing -specFunInlinePrag :: Id -> InlinePragma GhcRn -> InlinePragma GhcRn -> InlinePragma GhcRn +specFunInlinePrag :: Id -> InlinePragma GhcTc -> InlinePragma GhcTc -> InlinePragma GhcTc -- See Note [Activation pragmas for SPECIALISE] specFunInlinePrag poly_id id_inl spec_inl | not (isDefaultInlinePragma spec_inl) = spec_inl ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -84,7 +84,7 @@ import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..)) import GHC.Builtin.Types ( constraintKindTyConName ) import GHC.Stg.EnforceEpt.TagSig import GHC.Parser.Annotation (noLocA) -import GHC.Hs.Extension ( GhcRn ) +import GHC.Hs.Extension ( GhcRn, GhcTc ) import GHC.Hs.Doc ( WithHsDocIdentifiers(..) ) import GHC.Utils.Lexeme (isLexSym) @@ -460,7 +460,7 @@ data IfaceInfoItem = HsArity Arity | HsDmdSig DmdSig | HsCprSig CprSig - | HsInline (InlinePragma GhcRn) + | HsInline (InlinePragma GhcTc) | HsUnfold Bool -- True <=> isStrongLoopBreaker is true IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs ===================================== compiler/GHC/Tc/Gen/Sig.hs ===================================== @@ -620,11 +620,11 @@ addInlinePrags poly_id prags_for_me | inl@(L _ prag) : inls <- inl_prags = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag) ; unless (null inls) (warn_multiple_inlines inl inls) - ; return (poly_id `setInlinePragma` demoteInlinePragmaTc prag) } + ; return (poly_id `setInlinePragma` prag) } | otherwise = return poly_id where - inl_prags = [L loc (promoteInlinePragmaRn prag) | L loc (InlineSig _ _ prag) <- prags_for_me] + inl_prags = [L loc (witnessInlinePragmaPass prag) | L loc (InlineSig _ _ prag) <- prags_for_me] warn_multiple_inlines _ [] = return () @@ -987,7 +987,7 @@ tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl) tc_one hs_ty = do { spec_ty <- tcHsSigType (FunSigCtxt name NoRRC) hs_ty ; wrap <- tcSpecWrapper (FunSigCtxt name (lhsSigTypeContextSpan hs_ty)) poly_ty spec_ty - ; return (SpecPrag poly_id wrap (promoteInlinePragmaRn inl)) } + ; return (SpecPrag poly_id wrap (witnessInlinePragmaPass inl)) } tcSpecPrag poly_id (SpecSigE nm rule_bndrs spec_e inl) -- For running commentary, see Note [Handling new-form SPECIALISE pragmas] @@ -1050,7 +1050,7 @@ tcSpecPrag poly_id (SpecSigE nm rule_bndrs spec_e inl) , spe_bndrs = qevs ++ rule_bndrs' -- Dependency order -- does not matter , spe_call = lhs_call - , spe_inl = promoteInlinePragmaRn inl }] } + , spe_inl = witnessInlinePragmaPass inl }] } tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag) ===================================== compiler/GHC/Tc/TyCl/Instance.hs ===================================== @@ -2264,7 +2264,7 @@ mkDefMethBind :: SrcSpan -> DFunId -> Class -> Id -> Name mkDefMethBind loc dfun_id clas sel_id dm_name dm_spec = do { logger <- getLogger ; dm_id <- tcLookupId dm_name - ; let inline_prag = idInlinePragma dm_id + ; let inline_prag = witnessInlinePragmaPass $ idInlinePragma dm_id inline_prags | isAnyInlinePragma inline_prag = [noLocA (InlineSig noAnn fn inline_prag)] | otherwise ===================================== compiler/GHC/Types/Id.hs ===================================== @@ -150,7 +150,7 @@ import GHC.Core.DataCon import GHC.Core.Class import GHC.Core.Multiplicity -import GHC.Hs.Extension (GhcRn) +import GHC.Hs.Extension (GhcTc) import GHC.Types.RepType import GHC.Types.Demand @@ -796,7 +796,7 @@ alwaysActiveUnfoldingFun id -- | Returns an unfolding only if -- (a) not a strong loop breaker and -- (b) active in according to is_active -whenActiveUnfoldingFun :: (Activation GhcRn -> Bool) -> IdUnfoldingFun +whenActiveUnfoldingFun :: (Activation GhcTc -> Bool) -> IdUnfoldingFun whenActiveUnfoldingFun is_active id | is_active (idInlineActivation id) = idUnfolding id | otherwise = NoUnfolding @@ -944,19 +944,19 @@ The inline pragma tells us to be very keen to inline this Id, but it's still OK not to if optimisation is switched off. -} -idInlinePragma :: Id -> InlinePragma GhcRn +idInlinePragma :: Id -> InlinePragma GhcTc idInlinePragma id = inlinePragInfo (idInfo id) -setInlinePragma :: Id -> InlinePragma GhcRn -> Id +setInlinePragma :: Id -> InlinePragma GhcTc -> Id setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id -modifyInlinePragma :: Id -> (InlinePragma GhcRn -> InlinePragma GhcRn) -> Id +modifyInlinePragma :: Id -> (InlinePragma GhcTc -> InlinePragma GhcTc) -> Id modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id -idInlineActivation :: Id -> Activation GhcRn +idInlineActivation :: Id -> Activation GhcTc idInlineActivation id = inlinePragmaActivation (idInlinePragma id) -setInlineActivation :: Id -> Activation GhcRn -> Id +setInlineActivation :: Id -> Activation GhcTc -> Id setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act) idRuleMatchInfo :: Id -> RuleMatchInfo ===================================== compiler/GHC/Types/Id/Info.hs ===================================== @@ -52,7 +52,7 @@ module GHC.Types.Id.Info ( realUnfoldingInfo, unfoldingInfo, setUnfoldingInfo, hasInlineUnfolding, -- ** The InlinePragInfo type - InlinePragInfo, + InlinePragmaInfo, inlinePragInfo, setInlinePragInfo, -- ** The OccInfo type @@ -100,7 +100,6 @@ import GHC.Core.TyCon import GHC.Core.Type (mkTyConApp) import GHC.Core.PatSyn import GHC.Core.ConLike -import GHC.Hs.Extension import GHC.Types.ForeignCall import GHC.Unit.Module import GHC.Types.Demand @@ -439,7 +438,7 @@ data IdInfo -- See Note [Specialisations and RULES in IdInfo] realUnfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding - inlinePragInfo :: InlinePragma GhcRn, + inlinePragInfo :: InlinePragmaInfo, -- ^ Any inline pragma attached to the 'Id' occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program @@ -553,7 +552,7 @@ tagSigInfo = tagSig setRuleInfo :: IdInfo -> RuleInfo -> IdInfo setRuleInfo info sp = sp `seq` info { ruleInfo = sp } -setInlinePragInfo :: IdInfo -> InlinePragma GhcRn -> IdInfo +setInlinePragInfo :: IdInfo -> InlinePragmaInfo -> IdInfo setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } setOccInfo :: IdInfo -> OccInfo -> IdInfo @@ -704,27 +703,6 @@ ppArityInfo :: Int -> SDoc ppArityInfo 0 = empty ppArityInfo n = hsep [text "Arity", int n] -{- -************************************************************************ -* * -\subsection{Inline-pragma information} -* * -************************************************************************ --} - --- | Inline Pragma Information --- --- Tells when the inlining is active. --- When it is active the thing may be inlined, depending on how --- big it is. --- --- If there was an @INLINE@ pragma, then as a separate matter, the --- RHS will have been made to look small with a Core inline 'Note' --- --- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves --- entirely as a way to inhibit inlining until we want it -type InlinePragInfo = InlinePragma - {- ************************************************************************ * * ===================================== compiler/GHC/Types/Id/Make.hs ===================================== @@ -65,8 +65,6 @@ import GHC.Core.TyCon import GHC.Core.Class import GHC.Core.DataCon -import GHC.Hs.Extension (GhcRn) - import GHC.Types.Literal import GHC.Types.RepType ( countFunRepArgs, typePrimRep ) import GHC.Types.Name.Set @@ -608,7 +606,7 @@ mkDataConWorkId wkr_name data_con -- See Note [Strict fields in Core] `setLFInfo` wkr_lf_info - wkr_inline_prag :: InlinePragma GhcRn + wkr_inline_prag :: InlinePragmaInfo wkr_inline_prag = alwaysInlineConLikePragma wkr_arity = dataConRepArity data_con @@ -989,7 +987,7 @@ mkDataConRep dc_bang_opts fam_envs wrap_name data_con ; return (unbox_fn expr) } -dataConWrapperInlinePragma :: InlinePragma GhcRn +dataConWrapperInlinePragma :: InlinePragmaInfo -- See Note [DataCon wrappers are conlike] dataConWrapperInlinePragma = alwaysInlineConLikePragma ===================================== compiler/GHC/Types/InlinePragma.hs ===================================== @@ -24,6 +24,7 @@ module GHC.Types.InlinePragma -- ** InlinePragma -- *** Data-type InlinePragma(..) + , InlinePragmaInfo -- *** Constants , defaultInlinePragma , alwaysInlinePragma @@ -51,8 +52,7 @@ module GHC.Types.InlinePragma , setInlinePragmaSpec , setInlinePragmaRuleMatchInfo -- *** GHC pass conversions - , demoteInlinePragmaTc - , promoteInlinePragmaRn + , witnessInlinePragmaPass -- *** Pretty-printing , pprInline , pprInlineDebug @@ -148,6 +148,28 @@ instance NFData InlineSaturation where rnf (AppliedToAtLeast !w) = rnf w `seq` () rnf !AnySaturation = () + +{- +************************************************************************ +* * +\subsection{Inline-pragma information} +* * +************************************************************************ +-} + +-- | Inline Pragma Information +-- +-- Tells when the inlining is active. +-- When it is active the thing may be inlined, depending on how +-- big it is. +-- +-- If there was an @INLINE@ pragma, then as a separate matter, the +-- RHS will have been made to look small with a Core inline 'Note' +-- +-- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves +-- entirely as a way to inhibit inlining until we want it +type InlinePragmaInfo = InlinePragma GhcTc + data XInlinePragmaGhc = XInlinePragmaGhc { xinl_src :: SourceText -- ^ See Note [Pragma source text] @@ -181,6 +203,14 @@ type instance XInlinePragma GhcTc = XInlinePragmaGhc type instance XXInlinePragma (GhcPass _) = DataConCantHappen type instance XXActivation (GhcPass _) = XXActivationGhc +witnessInlinePragmaPass :: forall p q. + (XInlinePragma (GhcPass p) ~ XInlinePragmaGhc, XInlinePragma (GhcPass q) ~ XInlinePragmaGhc) + => InlinePragma (GhcPass p) -> InlinePragma (GhcPass q) +witnessInlinePragmaPass prag@(InlinePragma { inl_ext = src }) = + prag { inl_ext = src + , inl_act = coerceActivation $ inl_act prag + } + -- | The default 'InlinePragma' definition for GHC. -- The type and value of 'inl_ext' provided will differ -- between the passes of GHC. Consequently, it may be @@ -235,18 +265,6 @@ inlinePragmaSaturation :: forall p. (XInlinePragma (GhcPass p) ~ XInlinePragmaGh => InlinePragma (GhcPass p) -> InlineSaturation inlinePragmaSaturation = xinl_sat . inl_ext -promoteInlinePragmaRn :: InlinePragma GhcRn -> InlinePragma GhcTc -promoteInlinePragmaRn prag@(InlinePragma { inl_ext = src }) = - prag { inl_ext = src - , inl_act = coerceActivation $ inl_act prag - } - -demoteInlinePragmaTc :: InlinePragma GhcTc -> InlinePragma GhcRn -demoteInlinePragmaTc prag@(InlinePragma { inl_ext = src }) = - prag { inl_ext = src - , inl_act = coerceActivation $ inl_act prag - } - inlinePragmaSpec :: InlinePragma p -> InlineSpec inlinePragmaSpec = inl_inline @@ -339,6 +357,26 @@ coerceActivation = \case AlwaysActive -> AlwaysActive NeverActive -> NeverActive +activeInPhase :: PhaseNum -> Activation (GhcPass p) -> Bool +activeInPhase _ AlwaysActive = True +activeInPhase _ NeverActive = False +activeInPhase _ ActiveFinal = False +activeInPhase p (ActiveAfter n) = p <= n +activeInPhase p (ActiveBefore n) = p > n + +activeInFinalPhase :: Activation (GhcPass p) -> Bool +activeInFinalPhase AlwaysActive = True +activeInFinalPhase ActiveFinal = True +activeInFinalPhase (ActiveAfter {}) = True +activeInFinalPhase _ = False + +isNeverActive, isAlwaysActive :: Activation p -> Bool +isNeverActive NeverActive = True +isNeverActive _ = False + +isAlwaysActive AlwaysActive = True +isAlwaysActive _ = False + activateAfterInitial :: Activation (GhcPass p) -- ^ Active in the first phase after the initial phase activateAfterInitial = activeAfter (nextPhase InitialPhase) ===================================== compiler/Language/Haskell/Syntax/Binds/InlinePragma.hs ===================================== @@ -43,11 +43,6 @@ module Language.Haskell.Syntax.Binds.InlinePragma -- *** Data-type , Activation(..) , PhaseNum - -- *** Queries - , activeInPhase - , activeInFinalPhase - , isAlwaysActive - , isNeverActive ) where import Language.Haskell.Syntax.Extension @@ -310,23 +305,3 @@ instance NFData (XXActivation p) => NFData (Activation p) where ActiveBefore aa -> rnf aa ActiveAfter ab -> rnf ab XActivation x -> rnf x `seq` () - -activeInPhase :: PhaseNum -> Activation p -> Bool -activeInPhase _ AlwaysActive = True -activeInPhase _ NeverActive = False -activeInPhase _ (XActivation _) = False -activeInPhase p (ActiveAfter n) = p <= n -activeInPhase p (ActiveBefore n) = p > n - -activeInFinalPhase :: Activation p -> Bool -activeInFinalPhase AlwaysActive = True -activeInFinalPhase (XActivation {}) = True -activeInFinalPhase (ActiveAfter {}) = True -activeInFinalPhase _ = False - -isNeverActive, isAlwaysActive :: Activation p -> Bool -isNeverActive NeverActive = True -isNeverActive _ = False - -isAlwaysActive AlwaysActive = True -isAlwaysActive _ = False ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -241,8 +241,8 @@ type family XCompleteMatchSig x type family XXSig x -- Inline Pragma families -type family XInlinePragma x -type family XXInlinePragma x +type family XInlinePragma x +type family XXInlinePragma x -- Inline Activation family type family XXActivation x View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7a5b0700cebe06a8bd3c813409eb748… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7a5b0700cebe06a8bd3c813409eb748… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/hie-spans] - Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes
by Apoorv Ingle (＠ani) 23 Dec '25

23 Dec '25

Apoorv Ingle pushed to branch wip/ani/hie-spans at Glasgow Haskell Compiler / GHC Commits: 1d977793 by Apoorv Ingle at 2025-12-22T17:40:52-06:00 - Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes - Fixes T23540 - - - - - 27 changed files: - compiler/GHC.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/SrcLoc.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Logger.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Info.hs - utils/check-exact/ExactPrint.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -1617,6 +1617,7 @@ addSourceToTokens _ _ [] = [] addSourceToTokens loc buf (t@(L span _) : ts) = case span of UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts + GeneratedSrcSpan _ -> (t,"") : addSourceToTokens loc buf ts RealSrcSpan s _ -> (t,str) : addSourceToTokens newLoc newBuf ts where (newLoc, newBuf, str) = go "" loc buf @@ -1637,12 +1638,14 @@ showRichTokenStream ts = go startLoc ts "" where sourceFile = getFile $ map (getLoc . fst) ts getFile [] = panic "showRichTokenStream: No source file found" getFile (UnhelpfulSpan _ : xs) = getFile xs + getFile (GeneratedSrcSpan _ : xs) = getFile xs getFile (RealSrcSpan s _ : _) = srcSpanFile s startLoc = mkRealSrcLoc sourceFile 1 1 go _ [] = id go loc ((L span _, str):ts) = case span of UnhelpfulSpan _ -> go loc ts + GeneratedSrcSpan _ -> go loc ts RealSrcSpan s _ | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++) . (str ++) ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -486,10 +486,10 @@ getSrcSpanDs = do { env <- getLclEnv ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) } putSrcSpanDs :: SrcSpan -> DsM a -> DsM a -putSrcSpanDs (UnhelpfulSpan {}) thing_inside - = thing_inside putSrcSpanDs (RealSrcSpan real_span _) thing_inside = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside +putSrcSpanDs _ thing_inside + = thing_inside putSrcSpanDsA :: EpAnn ann -> DsM a -> DsM a putSrcSpanDsA loc = putSrcSpanDs (locA loc) ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -120,7 +120,7 @@ addTicksToBinds logger cfg , blackList = Set.fromList $ mapMaybe (\tyCon -> case getSrcSpan (tyConName tyCon) of RealSrcSpan l _ -> Just l - UnhelpfulSpan _ -> Nothing) + _ -> Nothing) tyCons , density = mkDensity tickish $ ticks_profAuto cfg , this_mod = mod @@ -1191,7 +1191,7 @@ getFileName = fileName `liftM` getEnv isGoodSrcSpan' :: SrcSpan -> Bool isGoodSrcSpan' pos@(RealSrcSpan _ _) = srcSpanStart pos /= srcSpanEnd pos -isGoodSrcSpan' (UnhelpfulSpan _) = False +isGoodSrcSpan' _ = False isGoodTickSrcSpan :: SrcSpan -> TM Bool isGoodTickSrcSpan pos = do @@ -1217,11 +1217,11 @@ bindLocals from (TM m) = TM $ \env st -> withBlackListed :: SrcSpan -> TM a -> TM a withBlackListed (RealSrcSpan ss _) = withEnv (\ env -> env { blackList = Set.insert ss (blackList env) }) -withBlackListed (UnhelpfulSpan _) = id +withBlackListed _ = id isBlackListed :: SrcSpan -> TM Bool isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st) -isBlackListed (UnhelpfulSpan _) = return False +isBlackListed _ = return False -- the tick application inherits the source position of its -- expression argument to support nested box allocations ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -251,6 +251,11 @@ getUnlocatedEvBinds file = do let node = Node (mkSourcedNodeInfo org ni) spn [] ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] in (xs,node:ys) + GeneratedSrcSpan spn + | srcSpanFile spn == file -> + let node = Node (mkSourcedNodeInfo org ni) spn [] + ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] + in (xs,node:ys) _ -> (mkNodeInfo e : xs,ys) (nis,asts) = foldr go ([],[]) elts @@ -419,6 +424,7 @@ getRealSpanA la = getRealSpan (locA la) getRealSpan :: SrcSpan -> Maybe Span getRealSpan (RealSrcSpan sp _) = Just sp +getRealSpan (GeneratedSrcSpan sp) = Just sp getRealSpan _ = Nothing grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns) @@ -606,36 +612,39 @@ instance ToHie (Context (Located a)) => ToHie (Context (LocatedN a)) where instance ToHie (Context (Located a)) => ToHie (Context (LocatedA a)) where toHie (C c (L l a)) = toHie (C c (L (locA l) a)) -instance ToHie (Context (Located Var)) where - toHie c = case c of - C context (L (RealSrcSpan span _) name') - | varUnique name' == mkBuiltinUnique 1 -> pure [] - -- `mkOneRecordSelector` makes a field var using this unique, which we ignore - | otherwise -> do - m <- lift $ gets name_remapping - org <- ask - let name = case lookupNameEnv m (varName name') of - Just var -> var - Nothing-> name' - ty = case isDataConId_maybe name' of +toHieCtxLocVar :: ContextInfo -> RealSrcSpan -> Var -> HieM [HieAST Type] +toHieCtxLocVar context span name' + | varUnique name' == mkBuiltinUnique 1 = pure [] + -- `mkOneRecordSelector` makes a field var using this unique, which we ignore + | otherwise = do + m <- lift $ gets name_remapping + org <- ask + let name = case lookupNameEnv m (varName name') of + Just var -> var + Nothing-> name' + ty = case isDataConId_maybe name' of Nothing -> varType name' Just dc -> dataConWrapperType dc -- insert the entity info for the name into the entity_infos map - insertEntityInfo (varName name) $ idEntityInfo name - insertEntityInfo (varName name') $ idEntityInfo name' - pure - [Node - (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ - M.singleton (Right $ varName name) + insertEntityInfo (varName name) $ idEntityInfo name + insertEntityInfo (varName name') $ idEntityInfo name' + pure [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ + M.singleton (Right $ varName name) (IdentifierDetails (Just ty) (S.singleton context))) - span - []] + span + []] + +instance ToHie (Context (Located Var)) where + toHie c = case c of + C context (L (RealSrcSpan span _) name') -> toHieCtxLocVar context span name' + C context (L (GeneratedSrcSpan span) name') -> toHieCtxLocVar context span name' C (EvidenceVarBind i _ sp) (L _ name) -> do addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp) pure [] _ -> pure [] + instance ToHie (Context (Located Name)) where toHie c = case c of C context (L (RealSrcSpan span _) name') ===================================== compiler/GHC/Iface/Ext/Utils.hs ===================================== @@ -322,6 +322,16 @@ getNameScopeAndBinding n asts = case nameSrcSpan n of scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets) let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) return $ Just (scopes, getFirst binding) + GeneratedSrcSpan sp -> do -- @Maybe + ast <- M.lookup (HiePath (srcSpanFile sp)) asts + defNode <- selectLargestContainedBy sp ast + getFirst $ foldMap First $ do -- @[] + node <- flattenAst defNode + dets <- maybeToList + $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo node + scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets) + let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) + return $ Just (scopes, getFirst binding) _ -> Nothing getScopeFromContext :: ContextInfo -> Maybe [Scope] @@ -377,6 +387,7 @@ selectSmallestContaining sp node definedInAsts :: M.Map HiePath (HieAST a) -> Name -> Bool definedInAsts asts n = case nameSrcSpan n of RealSrcSpan sp _ -> M.member (HiePath (srcSpanFile sp)) asts + GeneratedSrcSpan sp -> M.member (HiePath (srcSpanFile sp)) asts _ -> False getEvidenceBindDeps :: ContextInfo -> [Name] @@ -527,6 +538,10 @@ locOnly (RealSrcSpan span _) = do org <- ask let e = mkSourcedNodeInfo org $ emptyNodeInfo pure [Node e span []] +locOnly (GeneratedSrcSpan span) = do + org <- ask + let e = mkSourcedNodeInfo org $ emptyNodeInfo + pure [Node e span []] locOnly _ = pure [] locOnlyE :: Monad m => EpaLocation -> ReaderT NodeOrigin m [HieAST a] @@ -536,6 +551,7 @@ locOnlyE _ = pure [] mkScope :: (HasLoc a) => a -> Scope mkScope a = case getHasLoc a of (RealSrcSpan sp _) -> LocalScope sp + (GeneratedSrcSpan sp) -> LocalScope sp _ -> NoScope combineScopes :: Scope -> Scope -> Scope @@ -567,6 +583,7 @@ makeNode x spn = do org <- ask pure $ case spn of RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []] + GeneratedSrcSpan span -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []] _ -> [] where cons = mkFastString . show . toConstr $ x @@ -593,6 +610,8 @@ makeTypeNode x spn etyp = do pure $ case spn of RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []] + GeneratedSrcSpan span -> + [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []] _ -> [] where cons = mkFastString . show . toConstr $ x ===================================== compiler/GHC/Parser/HaddockLex.x ===================================== @@ -145,6 +145,7 @@ lexStringLiteral identParser (L l sl@(StringLiteral _ fs _)) plausibleIdents = case l of RealSrcSpan span _ -> [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) bs] UnhelpfulSpan reason -> [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc bs] + GeneratedSrcSpan span -> [(GeneratedSrcSpan span, tok) | (_, tok) <- alexScanTokens fakeLoc bs] fakeLoc = mkRealSrcLoc nilFS 0 0 @@ -166,6 +167,8 @@ lexHsDoc identParser doc = = [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) s] plausibleIdents (L (UnhelpfulSpan reason) (HsDocStringChunk s)) = [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason + plausibleIdents (L (GeneratedSrcSpan span) (HsDocStringChunk s)) + = [(GeneratedSrcSpan span, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason fakeLoc = mkRealSrcLoc nilFS 0 0 @@ -181,11 +184,12 @@ validateIdentWith identParser mloc str0 = buffer = stringBufferFromByteString str0 realSrcLc = case mloc of RealSrcSpan loc _ -> realSrcSpanStart loc + GeneratedSrcSpan{} -> mkRealSrcLoc nilFS 0 0 UnhelpfulSpan _ -> mkRealSrcLoc nilFS 0 0 pstate = initParserState pflags buffer realSrcLc in case unP identParser pstate of POk _ name -> Just $ case mloc of RealSrcSpan _ _ -> reLoc name - UnhelpfulSpan _ -> L mloc (unLoc name) -- Preserve the original reason + _ -> L mloc (unLoc name) -- Preserve the original reason _ -> Nothing } ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -502,11 +502,11 @@ rnExpr (ExplicitList _ exps) then return (ExplicitList noExtField exps', fvs) else do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName - --; loc <- getSrcSpanM -- See Note [Source locations for implicit function calls] + ; loc <- getRealSrcSpanM -- See Note [Source locations for implicit function calls] ; let rn_list = ExplicitList noExtField exps' lit_n = mkIntegralLit (length exps) hs_lit = genHsIntegralLit lit_n - exp_list = genHsApps' (wrapGenSpan from_list_n_name) [hs_lit, wrapGenSpan rn_list] + exp_list = genHsApps' (wrapGenSpan' loc from_list_n_name) [hs_lit, wrapGenSpan rn_list] ; return ( mkExpandedExpr rn_list exp_list , fvs `plusFV` fvs') } } ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -17,7 +17,7 @@ module GHC.Rename.Utils ( DeprecationWarnings(..), warnIfDeprecated, checkUnusedRecordWildcard, badQualBndrErr, typeAppErr, badFieldConErr, - wrapGenSpan, wrapNoSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps', genHsExpApps, + wrapGenSpan, wrapGenSpan', wrapNoSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps', genHsExpApps, genLHsApp, genAppType, genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat, genVarPat, genWildPat, @@ -701,6 +701,9 @@ wrapGenSpan :: (HasAnnotation an) => a -> GenLocated an a -- See Note [Rebindable syntax and XXExprGhcRn] wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x +wrapGenSpan' :: (HasAnnotation an) => RealSrcSpan -> a -> GenLocated an a +wrapGenSpan' s x = L (noAnnSrcSpan $ GeneratedSrcSpan s) x + wrapNoSpan :: (HasAnnotation an) => a -> GenLocated an a -- Wrap something in a "noSrcSpan" -- See Note [Rebindable syntax and XXExprGhcRn] ===================================== compiler/GHC/Runtime/Debugger/Breakpoints.hs ===================================== @@ -1,4 +1,3 @@ - -- | GHC API debugger module for finding and setting breakpoints. -- -- This module is user facing and is at least used by `GHCi` and `ghc-debugger` @@ -86,6 +85,7 @@ leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) -- | Returns the span of the largest tick containing the srcspan given enclosingTickSpan :: TickArray -> SrcSpan -> RealSrcSpan enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" +enclosingTickSpan _ (GeneratedSrcSpan _) = panic "generatedSrcSpan UnhelpfulSpan" enclosingTickSpan ticks (RealSrcSpan src _) = assert (inRange (bounds ticks) line) $ List.minimumBy leftmostLargestRealSrcSpan $ enclosing_spans @@ -295,4 +295,3 @@ getCurrentBreakModule = do return $ Just $ getBreakSourceMod ibi brks ix -> Just <$> getHistoryModule hug (resumeHistory r !! (ix-1)) - ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -114,18 +114,17 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts) | otherwise = pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt) -expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L _e_lspan e) (SyntaxExprRn then_op) _)) : lstmts) = +expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L _ e) (SyntaxExprRn then_op) _)) : lstmts) = -- See Note [BodyStmt] in Language.Haskell.Syntax.Expr -- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below -- stmts ~~> stmts' -- ---------------------------------------------- -- e ; stmts ~~> (>>) e stmts' - do expand_stmts_expr <- expand_do_stmts doFlavour lstmts - let expansion = genHsExpApps then_op -- (>>) - [ -- L e_lspan (mkExpandedStmt stmt doFlavour e) - wrapGenSpan e - , expand_stmts_expr ] - return $ L loc (mkExpandedStmt stmt doFlavour expansion) + do expand_stmts_expr <- expand_do_stmts doFlavour lstmts + let expansion = genHsExpApps then_op -- (>>) + [ wrapGenSpan e + , expand_stmts_expr ] + return $ L loc (mkExpandedStmt stmt doFlavour expansion) expand_do_stmts doFlavour ((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -1480,9 +1480,11 @@ instance TH.Quasi TcM where qLocation = do { m <- getModule ; l <- getSrcSpanM ; r <- case l of + RealSrcSpan s _ -> return s + GeneratedSrcSpan l -> pprPanic "qLocation: generatedSrcSpan" + (ppr l) UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" (ppr l) - RealSrcSpan s _ -> return s ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) , TH.loc_module = moduleNameString (moduleName m) , TH.loc_package = unitString (moduleUnit m) ===================================== compiler/GHC/Tc/Types/CtLoc.hs ===================================== @@ -253,8 +253,7 @@ setCtLocEnvLoc :: CtLocEnv -> SrcSpan -> CtLocEnv -- for the ctl_in_gen_code manipulation setCtLocEnvLoc env (RealSrcSpan loc _) = env { ctl_loc = loc, ctl_in_gen_code = False } - -setCtLocEnvLoc env loc@(UnhelpfulSpan _) +setCtLocEnvLoc env loc | isGeneratedSrcSpan loc = env { ctl_in_gen_code = True } | otherwise ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -62,7 +62,7 @@ module GHC.Tc.Utils.Monad( -- * Error management getSrcCodeOrigin, - getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, + getSrcSpanM, getRealSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, inGeneratedCode, wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, wrapLocMA_,wrapLocMA, @@ -1070,6 +1070,11 @@ getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (getLclEnvLoc env) Strict.Nothing) } +getRealSrcSpanM :: TcRn RealSrcSpan + -- Avoid clash with Name.getSrcLoc +getRealSrcSpanM = do { env <- getLclEnv; return $ getLclEnvLoc env } + + -- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool inGeneratedCode = lclEnvInGeneratedCode <$> getLclEnv @@ -1079,7 +1084,7 @@ setSrcSpan :: SrcSpan -> TcRn a -> TcRn a setSrcSpan (RealSrcSpan loc _) thing_inside = updLclCtxt (\env -> env { tcl_loc = loc }) thing_inside -setSrcSpan (UnhelpfulSpan _) thing_inside +setSrcSpan _ thing_inside = thing_inside getSrcCodeOrigin :: TcRn (Maybe SrcCodeOrigin) ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -787,7 +787,6 @@ getSeverityColour severity = case severity of SevIgnore -> const mempty getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc -getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty getCaretDiagnostic msg_class (RealSrcSpan span _) = caretDiagnostic <$> getSrcLine (srcSpanFile span) row where @@ -861,7 +860,7 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) = caretEllipsis | multiline = "..." | otherwise = "" caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis - +getCaretDiagnostic _ _ = pure empty -- -- Queries -- ===================================== compiler/GHC/Types/Hint/Ppr.hs ===================================== @@ -19,7 +19,7 @@ import GHC.Hs.Expr () -- instance Outputable import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace) -import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine) +import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine, UnhelpfulSpanReason(..)) import GHC.Unit.Module.Imported (ImportedModsVal(..)) import GHC.Unit.Types import GHC.Utils.Outputable @@ -424,6 +424,7 @@ pprSimilarName mb_tried_ns (SimilarRdrName rdr_name _gre_info how_in_scope) LocallyBoundAt loc -> case loc of UnhelpfulSpan l -> parens (ppr l) + GeneratedSrcSpan{} -> parens (ppr UnhelpfulGenerated) RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l)) ImportedBy is -> parens (text "imported from" <+> ppr (moduleName $ is_mod is)) ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -2077,9 +2077,12 @@ bestImport iss = NE.head $ NE.sortBy best iss -- False < True, so if e1 is explicit and e2 is not, we get GT compareGenerated UnhelpfulSpan{} UnhelpfulSpan{} = EQ - compareGenerated UnhelpfulSpan{} RealSrcSpan{} = LT - compareGenerated RealSrcSpan{} UnhelpfulSpan{} = GT + compareGenerated UnhelpfulSpan{} _ = LT + compareGenerated GeneratedSrcSpan{} UnhelpfulSpan{} = GT + compareGenerated GeneratedSrcSpan{} GeneratedSrcSpan{} = EQ + compareGenerated GeneratedSrcSpan{} _ = LT compareGenerated RealSrcSpan{} RealSrcSpan{} = EQ + compareGenerated RealSrcSpan{} _ = GT {- Note [Choosing the best import declaration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2212,6 +2215,7 @@ instance Outputable ImportSpec where pprLoc :: SrcSpan -> SDoc pprLoc (RealSrcSpan s _) = text "at" <+> ppr s pprLoc (UnhelpfulSpan {}) = empty +pprLoc (GeneratedSrcSpan {}) = empty -- | Indicate if the given name is the "@" operator opIsAt :: RdrName -> Bool ===================================== compiler/GHC/Types/SrcLoc.hs ===================================== @@ -306,7 +306,7 @@ lookupSrcLoc (UnhelpfulLoc _) = const Nothing lookupSrcSpan :: SrcSpan -> Map.Map RealSrcSpan a -> Maybe a lookupSrcSpan (RealSrcSpan l _) = Map.lookup l -lookupSrcSpan (UnhelpfulSpan _) = const Nothing +lookupSrcSpan _ = const Nothing instance Outputable RealSrcLoc where ppr (SrcLoc (LexicalFastString src_path) src_line src_col) @@ -387,6 +387,7 @@ instance Semigroup BufSpan where -- or a human-readable description of a location. data SrcSpan = RealSrcSpan !RealSrcSpan !(Strict.Maybe BufSpan) -- See Note [Why Maybe BufPos] + | GeneratedSrcSpan !RealSrcSpan -- Needed for HIE | UnhelpfulSpan !UnhelpfulSpanReason deriving (Eq, Show) -- Show is used by GHC.Parser.Lexer, because we @@ -426,6 +427,7 @@ messages, constructing a SrcSpan without a BufSpan. instance ToJson SrcSpan where json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")] + json (GeneratedSrcSpan {}) = JSNull json (RealSrcSpan rss _) = json rss instance ToJson RealSrcSpan where @@ -444,6 +446,7 @@ instance NFData RealSrcSpan where instance NFData SrcSpan where rnf (RealSrcSpan a1 a2) = rnf a1 `seq` rnf a2 rnf (UnhelpfulSpan a1) = rnf a1 + rnf (GeneratedSrcSpan {}) = rnf UnhelpfulGenerated instance NFData UnhelpfulSpanReason where rnf (UnhelpfulNoLocationInfo) = () @@ -454,7 +457,8 @@ instance NFData UnhelpfulSpanReason where getBufSpan :: SrcSpan -> Strict.Maybe BufSpan getBufSpan (RealSrcSpan _ mbspan) = mbspan -getBufSpan (UnhelpfulSpan _) = Strict.Nothing +getBufSpan _ = Strict.Nothing + -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty noSrcSpan, generatedSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan @@ -465,6 +469,7 @@ generatedSrcSpan = UnhelpfulSpan UnhelpfulGenerated isGeneratedSrcSpan :: SrcSpan -> Bool isGeneratedSrcSpan (UnhelpfulSpan UnhelpfulGenerated) = True +isGeneratedSrcSpan (GeneratedSrcSpan{}) = True isGeneratedSrcSpan _ = False isNoSrcSpan :: SrcSpan -> Bool @@ -515,6 +520,8 @@ mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2) combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful combineSrcSpans l (UnhelpfulSpan _) = l +combineSrcSpans (GeneratedSrcSpan _) r = r -- this seems more useful +combineSrcSpans l (GeneratedSrcSpan _) = l combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2) | srcSpanFile span1 == srcSpanFile span2 = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2) @@ -543,6 +550,7 @@ combineBufSpans span1 span2 = BufSpan start end -- | Convert a SrcSpan into one that represents only its first character srcSpanFirstCharacter :: SrcSpan -> SrcSpan srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l +srcSpanFirstCharacter l@(GeneratedSrcSpan {}) = l srcSpanFirstCharacter (RealSrcSpan span mbspan) = RealSrcSpan (mkRealSrcSpan loc1 loc2) (fmap mkBufSpan mbspan) where @@ -564,13 +572,13 @@ srcSpanFirstCharacter (RealSrcSpan span mbspan) = -- | Test if a 'SrcSpan' is "good", i.e. has precise location information isGoodSrcSpan :: SrcSpan -> Bool isGoodSrcSpan (RealSrcSpan _ _) = True -isGoodSrcSpan (UnhelpfulSpan _) = False +isGoodSrcSpan _ = False isOneLineSpan :: SrcSpan -> Bool -- ^ True if the span is known to straddle only one line. -- For "bad" 'SrcSpan', it returns False isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s -isOneLineSpan (UnhelpfulSpan _) = False +isOneLineSpan _ = False isZeroWidthSpan :: SrcSpan -> Bool -- ^ True if the span has a width of zero, as returned for "virtual" @@ -578,7 +586,7 @@ isZeroWidthSpan :: SrcSpan -> Bool -- For "bad" 'SrcSpan', it returns False isZeroWidthSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s && srcSpanStartCol s == srcSpanEndCol s -isZeroWidthSpan (UnhelpfulSpan _) = False +isZeroWidthSpan _ = False -- | Tests whether the first span "contains" the other span, meaning -- that it covers at least as much source code. True where spans are equal. @@ -620,11 +628,13 @@ srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c -- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanStart :: SrcSpan -> SrcLoc srcSpanStart (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) +srcSpanStart (GeneratedSrcSpan{}) = UnhelpfulLoc (unhelpfulSpanFS UnhelpfulGenerated) srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b) -- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanEnd :: SrcSpan -> SrcLoc srcSpanEnd (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) +srcSpanEnd (GeneratedSrcSpan{}) = UnhelpfulLoc (unhelpfulSpanFS UnhelpfulGenerated) srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b) realSrcSpanStart :: RealSrcSpan -> RealSrcLoc @@ -640,7 +650,7 @@ realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) -- | Obtains the filename for a 'SrcSpan' if it is "good" srcSpanFileName_maybe :: SrcSpan -> Maybe FastString srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s) -srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing +srcSpanFileName_maybe _ = Nothing srcSpanToRealSrcSpan :: SrcSpan -> Maybe RealSrcSpan srcSpanToRealSrcSpan (RealSrcSpan ss _) = Just ss @@ -717,6 +727,7 @@ pprUnhelpfulSpanReason r = ftext (unhelpfulSpanFS r) pprUserSpan :: Bool -> SrcSpan -> SDoc pprUserSpan _ (UnhelpfulSpan r) = pprUnhelpfulSpanReason r +pprUserSpan _ (GeneratedSrcSpan{}) = pprUnhelpfulSpanReason UnhelpfulGenerated pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc @@ -843,15 +854,19 @@ leftmost_largest = compareSrcSpanBy $ compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b -compareSrcSpanBy _ (RealSrcSpan _ _) (UnhelpfulSpan _) = LT +compareSrcSpanBy _ (RealSrcSpan _ _) _ = LT compareSrcSpanBy _ (UnhelpfulSpan _) (RealSrcSpan _ _) = GT -compareSrcSpanBy _ (UnhelpfulSpan _) (UnhelpfulSpan _) = EQ +compareSrcSpanBy _ (UnhelpfulSpan _) _ = EQ +compareSrcSpanBy _ (GeneratedSrcSpan _) (RealSrcSpan _ _) = GT +compareSrcSpanBy _ (GeneratedSrcSpan _) _ = EQ + -- | Determines whether a span encloses a given line and column index spans :: SrcSpan -> (Int, Int) -> Bool -spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" spans (RealSrcSpan span _) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span where loc = mkRealSrcLoc (srcSpanFile span) l c +spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" +spans (GeneratedSrcSpan _) _ = panic "spans GeneratedSrcSpan" -- | Determines whether a span is enclosed by another one isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -1952,13 +1952,19 @@ instance Binary BinSrcSpan where putByte bh 1 put_ bh s + put_ bh (BinSrcSpan (GeneratedSrcSpan ss)) = do + putByte bh 2 + put_ bh $ BinSpan ss + get bh = do h <- getByte bh case h of 0 -> do BinSpan ss <- get bh return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing) - _ -> do s <- get bh + 1 -> do s <- get bh return $ BinSrcSpan (UnhelpfulSpan s) + _ -> do BinSpan ss <- get bh + return $ BinSrcSpan (GeneratedSrcSpan ss) {- ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -398,7 +398,7 @@ jsonLogActionWithHandle out logflags msg_class srcSpan msg , ("endCol", json $ srcSpanEndCol rss) ] where file = unpackFS $ srcSpanFile rss - UnhelpfulSpan _ -> JSNull + _ -> JSNull -- | The default 'LogAction' prints to 'stdout' and 'stderr'. -- @@ -707,4 +707,3 @@ class HasLogger m where class ContainsLogger t where extractLogger :: t -> Logger - ===================================== ghc/GHCi/UI.hs ===================================== @@ -2692,8 +2692,9 @@ parseSpanArg s = do -- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@ -- while simply unpacking 'UnhelpfulSpan's showSrcSpan :: SrcSpan -> String -showSrcSpan (UnhelpfulSpan s) = unpackFS (unhelpfulSpanFS s) -showSrcSpan (RealSrcSpan spn _) = showRealSrcSpan spn +showSrcSpan (UnhelpfulSpan s) = unpackFS (unhelpfulSpanFS s) +showSrcSpan (GeneratedSrcSpan _) = unpackFS (unhelpfulSpanFS UnhelpfulGenerated) +showSrcSpan (RealSrcSpan spn _) = showRealSrcSpan spn -- | Variant of 'showSrcSpan' for 'RealSrcSpan's showRealSrcSpan :: RealSrcSpan -> String @@ -4235,14 +4236,14 @@ stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg mb_span <- getCurrentBreakSpan case mb_span of Nothing -> stepCmd [] - Just (UnhelpfulSpan _) -> liftIO $ putStrLn ( -- #14690 - ":steplocal is not possible." ++ - "\nCannot determine current top-level binding after " ++ - "a break on error / exception.\nUse :stepmodule.") - Just loc -> do + Just loc@(RealSrcSpan{}) -> do md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule current_toplevel_decl <- flip enclosingTickSpan loc <$> getTickArray md doContinue (GHC.LocalStep (RealSrcSpan current_toplevel_decl Strict.Nothing)) + Just _ -> liftIO $ putStrLn ( -- #14690 + ":steplocal is not possible." ++ + "\nCannot determine current top-level binding after " ++ + "a break on error / exception.\nUse :stepmodule.") stepModuleCmd :: GhciMonad m => String -> m () stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg @@ -4580,7 +4581,7 @@ listCmd "" = do printForUser $ text "Not stopped at a breakpoint; nothing to list" Just (RealSrcSpan pan _) -> listAround pan True - Just pan@(UnhelpfulSpan _) -> + Just pan@_ -> do resumes <- GHC.getResumeContext case resumes of [] -> panic "No resumes" ===================================== ghc/GHCi/UI/Info.hs ===================================== @@ -168,6 +168,7 @@ findName infos span0 mi string = Just name -> case getSrcSpan name of UnhelpfulSpan {} -> tryExternalModuleResolution + GeneratedSrcSpan {} -> tryExternalModuleResolution RealSrcSpan {} -> return (getName name) where rdrs = modInfo_rdrs mi ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -477,6 +477,7 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do dp = adjustDeltaForOffset off (ss2delta priorEndAfterComments r) Just (EpaSpan (UnhelpfulSpan r)) -> panic $ "enterAnn: UnhelpfulSpan:" ++ show r + Just (EpaSpan (GeneratedSrcSpan r)) -> panic $ "enterAnn: UnhelpfulSpan:" ++ show r when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ showAst (med,edp) when (isJust medr) $ setExtraDPReturn medr -- --------------------------------------------- @@ -737,7 +738,7 @@ printStringAtNC el str = do printStringAtAAC :: (Monad m, Monoid w) => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation printStringAtAAC capture (EpaSpan (RealSrcSpan r _)) s = printStringAtRsC capture r s -printStringAtAAC _capture (EpaSpan ss@(UnhelpfulSpan _)) _s = error $ "printStringAtAAC:ss=" ++ show ss +printStringAtAAC _capture (EpaSpan ss) _s = error $ "printStringAtAAC:ss=" ++ show ss printStringAtAAC capture (EpaDelta ss d cs) s = do mapM_ printOneComment $ concatMap tokComment cs pe1 <- getPriorEndD @@ -1356,7 +1357,7 @@ printOneComment c@(Comment _str loc _r _mo) = do let dp = ss2delta pe r debugM $ "printOneComment:(dp,pe,loc)=" ++ showGhc (dp,pe,loc) adjustDeltaForOffsetM dp - EpaSpan (UnhelpfulSpan _) -> return (SameLine 0) + EpaSpan _ -> return (SameLine 0) mep <- getExtraDP dp' <- case mep of Just (EpaDelta _ edp _) -> do ===================================== utils/check-exact/Parsers.hs ===================================== @@ -305,8 +305,6 @@ fixModuleHeaderComments (GHC.L l p) = GHC.L l p' where moveComments :: GHC.EpaLocation -> GHC.LHsDecl GHC.GhcPs -> GHC.EpAnnComments -> (GHC.LHsDecl GHC.GhcPs, GHC.EpAnnComments) - moveComments GHC.EpaDelta{} dd cs = (dd,cs) - moveComments (GHC.EpaSpan (GHC.UnhelpfulSpan _)) dd cs = (dd,cs) moveComments (GHC.EpaSpan (GHC.RealSrcSpan r _)) (GHC.L (GHC.EpAnn anc an csd) a) cs = (dd,css) where -- Move any comments on the decl that occur prior to the location @@ -318,12 +316,14 @@ fixModuleHeaderComments (GHC.L l p) = GHC.L l p' dd = GHC.L (GHC.EpAnn anc an csd') a css = cs <> GHC.EpaComments move + moveComments _ dd cs = (dd,cs) (ds',an') = rebalance (GHC.hsmodDecls p, GHC.hsmodAnn $ GHC.hsmodExt p) p' = p { GHC.hsmodExt = (GHC.hsmodExt p){ GHC.hsmodAnn = an' }, GHC.hsmodDecls = ds' } + rebalance :: ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule) -> ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule) rebalance (ds, GHC.EpAnn a an cs) = (ds1, GHC.EpAnn a an cs') ===================================== utils/check-exact/Transform.hs ===================================== @@ -255,6 +255,8 @@ setEntryDPDecl d dp = setEntryDP d dp setEntryDP :: LocatedAn t a -> DeltaPos -> LocatedAn t a setEntryDP (L (EpAnn (EpaSpan ss@(UnhelpfulSpan _)) an cs) a) dp = L (EpAnn (EpaDelta ss dp []) an cs) a +setEntryDP (L (EpAnn (EpaSpan ss@(GeneratedSrcSpan _)) an cs) a) dp + = L (EpAnn (EpaDelta ss dp []) an cs) a setEntryDP (L (EpAnn (EpaSpan ss) an (EpaComments [])) a) dp = L (EpAnn (EpaDelta ss dp []) an (EpaComments [])) a setEntryDP (L (EpAnn (EpaDelta ss d csd) an cs) a) dp @@ -320,14 +322,12 @@ getEntryDP _ = SameLine 1 addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation addEpaLocationDelta _off _anc (EpaDelta ss d cs) = EpaDelta ss d cs -addEpaLocationDelta _off _anc (EpaSpan ss@(UnhelpfulSpan _)) = EpaDelta ss (SameLine 0) [] addEpaLocationDelta off anc (EpaSpan ss@(RealSrcSpan r _)) = EpaDelta ss (adjustDeltaForOffset off (ss2deltaEnd anc r)) [] +addEpaLocationDelta _off _anc (EpaSpan ss) = EpaDelta ss (SameLine 0) [] -- Set the entry DP for an element coming after an existing keyword annotation setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t -setEntryDPFromAnchor _off (EpaDelta _ _ _) (L la a) = L la a -setEntryDPFromAnchor _off (EpaSpan (UnhelpfulSpan _)) (L la a) = L la a setEntryDPFromAnchor off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP ll dp' where dp' = case la of @@ -335,6 +335,8 @@ setEntryDPFromAnchor off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP (EpAnn (EpaSpan _) _ _) -> adjustDeltaForOffset off (SameLine 0) (EpAnn (EpaDelta _ dp _) _ _) -> adjustDeltaForOffset off dp +setEntryDPFromAnchor _off _ ll = ll + -- --------------------------------------------------------------------- -- |Take the annEntryDelta associated with the first item and @@ -902,7 +904,7 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where let off = case l of (EpaSpan (RealSrcSpan r _)) -> LayoutStartCol $ snd $ ss2pos r - (EpaSpan (UnhelpfulSpan _)) -> LayoutStartCol 0 + (EpaSpan _) -> LayoutStartCol 0 (EpaDelta _ (SameLine _) _) -> LayoutStartCol 0 (EpaDelta _ (DifferentLine _ c) _) -> LayoutStartCol c ex'' = setEntryDPFromAnchor off i ex ===================================== utils/check-exact/Utils.hs ===================================== @@ -530,9 +530,10 @@ sortEpaComments cs = sortBy cmp cs -- | Makes a comment which originates from a specific keyword. mkKWComment :: String -> NoCommentsLocation -> Comment -mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment kw (EpaSpan (RealSrcSpan ss mb)) ss (Just kw) -mkKWComment kw (EpaSpan (UnhelpfulSpan _)) = Comment kw (EpaDelta noSrcSpan (SameLine 0) NoComments) placeholderRealSpan (Just kw) mkKWComment kw (EpaDelta ss dp cs) = Comment kw (EpaDelta ss dp cs) placeholderRealSpan (Just kw) +mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment kw (EpaSpan (RealSrcSpan ss mb)) ss (Just kw) +mkKWComment kw (EpaSpan _) = Comment kw (EpaDelta noSrcSpan (SameLine 0) NoComments) placeholderRealSpan (Just kw) + sortAnchorLocated :: [GenLocated EpaLocation a] -> [GenLocated EpaLocation a] sortAnchorLocated = sortBy (compare `on` (epaLocationRealSrcSpan . getLoc)) ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs ===================================== @@ -155,6 +155,53 @@ parse parserOpts sDocContext fpath bs = case unP (go False []) initState of pure (plainTok : [spaceTok | not (BS.null spaceBStr)], inPrag') + GeneratedSrcSpan rsp -> do + let typ = if inPrag then TkPragma else classify tok + RealSrcLoc lStart _ = srcSpanStart sp -- safe since @sp@ is real + (spaceBStr, bStart) = spanPosition lInit lStart bInit + inPragDef = inPragma inPrag tok + + (bEnd', inPrag') <- case tok of + -- Update internal line + file position if this is a LINE pragma + ITline_prag _ -> tryOrElse (bEnd, inPragDef) $ do + L _ (ITinteger (IL{il_value = line})) <- tryP wrappedLexer + L _ (ITstring _ file) <- tryP wrappedLexer + L spF ITclose_prag <- tryP wrappedLexer + + let newLoc = mkRealSrcLoc file (fromIntegral line - 1) (srcSpanEndCol spF) + (bEnd'', _) <- lift getInput + lift $ setInput (bEnd'', newLoc) + + pure (bEnd'', False) + + -- Update internal column position if this is a COLUMN pragma + ITcolumn_prag _ -> tryOrElse (bEnd, inPragDef) $ do + L _ (ITinteger (IL{il_value = col})) <- tryP wrappedLexer + L spF ITclose_prag <- tryP wrappedLexer + + let newLoc = mkRealSrcLoc (srcSpanFile spF) (srcSpanEndLine spF) (fromIntegral col) + (bEnd'', _) <- lift getInput + lift $ setInput (bEnd'', newLoc) + + pure (bEnd'', False) + _ -> pure (bEnd, inPragDef) + + let tokBStr = splitStringBuffer bStart bEnd' + plainTok = + T.Token + { tkType = typ + , tkValue = tokBStr + , tkSpan = rsp + } + spaceTok = + T.Token + { tkType = TkSpace + , tkValue = spaceBStr + , tkSpan = mkRealSrcSpan lInit lStart + } + + pure (plainTok : [spaceTok | not (BS.null spaceBStr)], inPrag') + -- \| Parse whatever remains of the line as an unknown token (can't fail) unknownLine :: P ([T.Token], Bool) unknownLine = do ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs ===================================== @@ -103,6 +103,8 @@ spliceURL' maybe_mod maybe_name maybe_loc = run case span_ of RealSrcSpan span__ _ -> show $ srcSpanStartLine span__ + GeneratedSrcSpan span__ -> + show $ srcSpanStartLine span__ UnhelpfulSpan _ -> "" run "" = "" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1d97779331b62b7813ea859753c5335… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/1d97779331b62b7813ea859753c5335… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/ani/hie-spans] - Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes
by Apoorv Ingle (＠ani) 23 Dec '25

23 Dec '25

Apoorv Ingle pushed to branch wip/ani/hie-spans at Glasgow Haskell Compiler / GHC Commits: 8b97de5b by Apoorv Ingle at 2025-12-22T16:55:56-06:00 - Make a new variant `GeneratedSrcSpan` in `SrcSpan` for HIEAst Nodes - Fixes T23540 - - - - - 27 changed files: - compiler/GHC.hs - compiler/GHC/HsToCore/Monad.hs - compiler/GHC/HsToCore/Ticks.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Ext/Utils.hs - compiler/GHC/Parser/HaddockLex.x - compiler/GHC/Rename/Expr.hs - compiler/GHC/Rename/Utils.hs - compiler/GHC/Runtime/Debugger/Breakpoints.hs - compiler/GHC/Tc/Gen/Do.hs - compiler/GHC/Tc/Gen/Splice.hs - compiler/GHC/Tc/Types/CtLoc.hs - compiler/GHC/Tc/Utils/Monad.hs - compiler/GHC/Types/Error.hs - compiler/GHC/Types/Hint/Ppr.hs - compiler/GHC/Types/Name/Reader.hs - compiler/GHC/Types/SrcLoc.hs - compiler/GHC/Utils/Binary.hs - compiler/GHC/Utils/Logger.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Info.hs - utils/check-exact/ExactPrint.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs - utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs - utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs Changes: ===================================== compiler/GHC.hs ===================================== @@ -1617,6 +1617,7 @@ addSourceToTokens _ _ [] = [] addSourceToTokens loc buf (t@(L span _) : ts) = case span of UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts + GeneratedSrcSpan _ -> (t,"") : addSourceToTokens loc buf ts RealSrcSpan s _ -> (t,str) : addSourceToTokens newLoc newBuf ts where (newLoc, newBuf, str) = go "" loc buf @@ -1637,12 +1638,14 @@ showRichTokenStream ts = go startLoc ts "" where sourceFile = getFile $ map (getLoc . fst) ts getFile [] = panic "showRichTokenStream: No source file found" getFile (UnhelpfulSpan _ : xs) = getFile xs + getFile (GeneratedSrcSpan _ : xs) = getFile xs getFile (RealSrcSpan s _ : _) = srcSpanFile s startLoc = mkRealSrcLoc sourceFile 1 1 go _ [] = id go loc ((L span _, str):ts) = case span of UnhelpfulSpan _ -> go loc ts + GeneratedSrcSpan _ -> go loc ts RealSrcSpan s _ | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++) . (str ++) ===================================== compiler/GHC/HsToCore/Monad.hs ===================================== @@ -486,10 +486,10 @@ getSrcSpanDs = do { env <- getLclEnv ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) } putSrcSpanDs :: SrcSpan -> DsM a -> DsM a -putSrcSpanDs (UnhelpfulSpan {}) thing_inside - = thing_inside putSrcSpanDs (RealSrcSpan real_span _) thing_inside = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside +putSrcSpanDs _ thing_inside + = thing_inside putSrcSpanDsA :: EpAnn ann -> DsM a -> DsM a putSrcSpanDsA loc = putSrcSpanDs (locA loc) ===================================== compiler/GHC/HsToCore/Ticks.hs ===================================== @@ -120,7 +120,7 @@ addTicksToBinds logger cfg , blackList = Set.fromList $ mapMaybe (\tyCon -> case getSrcSpan (tyConName tyCon) of RealSrcSpan l _ -> Just l - UnhelpfulSpan _ -> Nothing) + _ -> Nothing) tyCons , density = mkDensity tickish $ ticks_profAuto cfg , this_mod = mod @@ -1191,7 +1191,7 @@ getFileName = fileName `liftM` getEnv isGoodSrcSpan' :: SrcSpan -> Bool isGoodSrcSpan' pos@(RealSrcSpan _ _) = srcSpanStart pos /= srcSpanEnd pos -isGoodSrcSpan' (UnhelpfulSpan _) = False +isGoodSrcSpan' _ = False isGoodTickSrcSpan :: SrcSpan -> TM Bool isGoodTickSrcSpan pos = do @@ -1217,11 +1217,11 @@ bindLocals from (TM m) = TM $ \env st -> withBlackListed :: SrcSpan -> TM a -> TM a withBlackListed (RealSrcSpan ss _) = withEnv (\ env -> env { blackList = Set.insert ss (blackList env) }) -withBlackListed (UnhelpfulSpan _) = id +withBlackListed _ = id isBlackListed :: SrcSpan -> TM Bool isBlackListed (RealSrcSpan pos _) = TM $ \ env st -> (Set.member pos (blackList env), noFVs, st) -isBlackListed (UnhelpfulSpan _) = return False +isBlackListed _ = return False -- the tick application inherits the source position of its -- expression argument to support nested box allocations ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -251,6 +251,11 @@ getUnlocatedEvBinds file = do let node = Node (mkSourcedNodeInfo org ni) spn [] ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] in (xs,node:ys) + GeneratedSrcSpan spn + | srcSpanFile spn == file -> + let node = Node (mkSourcedNodeInfo org ni) spn [] + ni = NodeInfo mempty [] $ M.fromList [mkNodeInfo e] + in (xs,node:ys) _ -> (mkNodeInfo e : xs,ys) (nis,asts) = foldr go ([],[]) elts @@ -419,6 +424,7 @@ getRealSpanA la = getRealSpan (locA la) getRealSpan :: SrcSpan -> Maybe Span getRealSpan (RealSrcSpan sp _) = Just sp +getRealSpan (GeneratedSrcSpan sp) = Just sp getRealSpan _ = Nothing grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns) @@ -606,36 +612,39 @@ instance ToHie (Context (Located a)) => ToHie (Context (LocatedN a)) where instance ToHie (Context (Located a)) => ToHie (Context (LocatedA a)) where toHie (C c (L l a)) = toHie (C c (L (locA l) a)) -instance ToHie (Context (Located Var)) where - toHie c = case c of - C context (L (RealSrcSpan span _) name') - | varUnique name' == mkBuiltinUnique 1 -> pure [] - -- `mkOneRecordSelector` makes a field var using this unique, which we ignore - | otherwise -> do - m <- lift $ gets name_remapping - org <- ask - let name = case lookupNameEnv m (varName name') of - Just var -> var - Nothing-> name' - ty = case isDataConId_maybe name' of +toHieCtxLocVar :: ContextInfo -> RealSrcSpan -> Var -> HieM [HieAST Type] +toHieCtxLocVar context span name' + | varUnique name' == mkBuiltinUnique 1 = pure [] + -- `mkOneRecordSelector` makes a field var using this unique, which we ignore + | otherwise = do + m <- lift $ gets name_remapping + org <- ask + let name = case lookupNameEnv m (varName name') of + Just var -> var + Nothing-> name' + ty = case isDataConId_maybe name' of Nothing -> varType name' Just dc -> dataConWrapperType dc -- insert the entity info for the name into the entity_infos map - insertEntityInfo (varName name) $ idEntityInfo name - insertEntityInfo (varName name') $ idEntityInfo name' - pure - [Node - (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ - M.singleton (Right $ varName name) + insertEntityInfo (varName name) $ idEntityInfo name + insertEntityInfo (varName name') $ idEntityInfo name' + pure [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] $ + M.singleton (Right $ varName name) (IdentifierDetails (Just ty) (S.singleton context))) - span - []] + span + []] + +instance ToHie (Context (Located Var)) where + toHie c = case c of + C context (L (RealSrcSpan span _) name') -> toHieCtxLocVar context span name' + C context (L (GeneratedSrcSpan span) name') -> toHieCtxLocVar context span name' C (EvidenceVarBind i _ sp) (L _ name) -> do addUnlocatedEvBind name (EvidenceVarBind i ModuleScope sp) pure [] _ -> pure [] + instance ToHie (Context (Located Name)) where toHie c = case c of C context (L (RealSrcSpan span _) name') ===================================== compiler/GHC/Iface/Ext/Utils.hs ===================================== @@ -322,6 +322,16 @@ getNameScopeAndBinding n asts = case nameSrcSpan n of scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets) let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) return $ Just (scopes, getFirst binding) + GeneratedSrcSpan sp -> do -- @Maybe + ast <- M.lookup (HiePath (srcSpanFile sp)) asts + defNode <- selectLargestContainedBy sp ast + getFirst $ foldMap First $ do -- @[] + node <- flattenAst defNode + dets <- maybeToList + $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo node + scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets) + let binding = foldMap (First . getBindSiteFromContext) (identInfo dets) + return $ Just (scopes, getFirst binding) _ -> Nothing getScopeFromContext :: ContextInfo -> Maybe [Scope] @@ -377,6 +387,7 @@ selectSmallestContaining sp node definedInAsts :: M.Map HiePath (HieAST a) -> Name -> Bool definedInAsts asts n = case nameSrcSpan n of RealSrcSpan sp _ -> M.member (HiePath (srcSpanFile sp)) asts + GeneratedSrcSpan sp -> M.member (HiePath (srcSpanFile sp)) asts _ -> False getEvidenceBindDeps :: ContextInfo -> [Name] @@ -527,6 +538,10 @@ locOnly (RealSrcSpan span _) = do org <- ask let e = mkSourcedNodeInfo org $ emptyNodeInfo pure [Node e span []] +locOnly (GeneratedSrcSpan span) = do + org <- ask + let e = mkSourcedNodeInfo org $ emptyNodeInfo + pure [Node e span []] locOnly _ = pure [] locOnlyE :: Monad m => EpaLocation -> ReaderT NodeOrigin m [HieAST a] @@ -536,6 +551,7 @@ locOnlyE _ = pure [] mkScope :: (HasLoc a) => a -> Scope mkScope a = case getHasLoc a of (RealSrcSpan sp _) -> LocalScope sp + (GeneratedSrcSpan sp) -> LocalScope sp _ -> NoScope combineScopes :: Scope -> Scope -> Scope @@ -567,6 +583,7 @@ makeNode x spn = do org <- ask pure $ case spn of RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []] + GeneratedSrcSpan span -> [Node (mkSourcedNodeInfo org $ simpleNodeInfo cons typ) span []] _ -> [] where cons = mkFastString . show . toConstr $ x @@ -593,6 +610,8 @@ makeTypeNode x spn etyp = do pure $ case spn of RealSrcSpan span _ -> [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []] + GeneratedSrcSpan span -> + [Node (mkSourcedNodeInfo org $ NodeInfo (S.singleton (NodeAnnotation cons typ)) [etyp] M.empty) span []] _ -> [] where cons = mkFastString . show . toConstr $ x ===================================== compiler/GHC/Parser/HaddockLex.x ===================================== @@ -145,6 +145,7 @@ lexStringLiteral identParser (L l sl@(StringLiteral _ fs _)) plausibleIdents = case l of RealSrcSpan span _ -> [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) bs] UnhelpfulSpan reason -> [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc bs] + GeneratedSrcSpan span -> [(GeneratedSrcSpan span, tok) | (_, tok) <- alexScanTokens fakeLoc bs] fakeLoc = mkRealSrcLoc nilFS 0 0 @@ -166,6 +167,8 @@ lexHsDoc identParser doc = = [(RealSrcSpan span' Strict.Nothing, tok) | (span', tok) <- alexScanTokens (realSrcSpanStart span) s] plausibleIdents (L (UnhelpfulSpan reason) (HsDocStringChunk s)) = [(UnhelpfulSpan reason, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason + plausibleIdents (L (GeneratedSrcSpan span) (HsDocStringChunk s)) + = [(GeneratedSrcSpan span, tok) | (_, tok) <- alexScanTokens fakeLoc s] -- preserve the original reason fakeLoc = mkRealSrcLoc nilFS 0 0 @@ -181,11 +184,12 @@ validateIdentWith identParser mloc str0 = buffer = stringBufferFromByteString str0 realSrcLc = case mloc of RealSrcSpan loc _ -> realSrcSpanStart loc + GeneratedSrcSpan{} -> mkRealSrcLoc nilFS 0 0 UnhelpfulSpan _ -> mkRealSrcLoc nilFS 0 0 pstate = initParserState pflags buffer realSrcLc in case unP identParser pstate of POk _ name -> Just $ case mloc of RealSrcSpan _ _ -> reLoc name - UnhelpfulSpan _ -> L mloc (unLoc name) -- Preserve the original reason + _ -> L mloc (unLoc name) -- Preserve the original reason _ -> Nothing } ===================================== compiler/GHC/Rename/Expr.hs ===================================== @@ -502,11 +502,11 @@ rnExpr (ExplicitList _ exps) then return (ExplicitList noExtField exps', fvs) else do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName - --; loc <- getSrcSpanM -- See Note [Source locations for implicit function calls] + ; loc <- getRealSrcSpanM -- See Note [Source locations for implicit function calls] ; let rn_list = ExplicitList noExtField exps' lit_n = mkIntegralLit (length exps) hs_lit = genHsIntegralLit lit_n - exp_list = genHsApps' (wrapGenSpan from_list_n_name) [hs_lit, wrapGenSpan rn_list] + exp_list = genHsApps' (wrapGenSpan' loc from_list_n_name) [hs_lit, wrapGenSpan rn_list] ; return ( mkExpandedExpr rn_list exp_list , fvs `plusFV` fvs') } } ===================================== compiler/GHC/Rename/Utils.hs ===================================== @@ -17,7 +17,7 @@ module GHC.Rename.Utils ( DeprecationWarnings(..), warnIfDeprecated, checkUnusedRecordWildcard, badQualBndrErr, typeAppErr, badFieldConErr, - wrapGenSpan, wrapNoSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps', genHsExpApps, + wrapGenSpan, wrapGenSpan', wrapNoSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genHsApps', genHsExpApps, genLHsApp, genAppType, genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat, genVarPat, genWildPat, @@ -701,6 +701,9 @@ wrapGenSpan :: (HasAnnotation an) => a -> GenLocated an a -- See Note [Rebindable syntax and XXExprGhcRn] wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x +wrapGenSpan' :: (HasAnnotation an) => RealSrcSpan -> a -> GenLocated an a +wrapGenSpan' s x = L (noAnnSrcSpan $ GeneratedSrcSpan s) x + wrapNoSpan :: (HasAnnotation an) => a -> GenLocated an a -- Wrap something in a "noSrcSpan" -- See Note [Rebindable syntax and XXExprGhcRn] ===================================== compiler/GHC/Runtime/Debugger/Breakpoints.hs ===================================== @@ -1,4 +1,3 @@ - -- | GHC API debugger module for finding and setting breakpoints. -- -- This module is user facing and is at least used by `GHCi` and `ghc-debugger` @@ -86,6 +85,7 @@ leftmostLargestRealSrcSpan = on compare realSrcSpanStart S.<> on (flip compare) -- | Returns the span of the largest tick containing the srcspan given enclosingTickSpan :: TickArray -> SrcSpan -> RealSrcSpan enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" +enclosingTickSpan _ (GeneratedSrcSpan _) = panic "generatedSrcSpan UnhelpfulSpan" enclosingTickSpan ticks (RealSrcSpan src _) = assert (inRange (bounds ticks) line) $ List.minimumBy leftmostLargestRealSrcSpan $ enclosing_spans @@ -295,4 +295,3 @@ getCurrentBreakModule = do return $ Just $ getBreakSourceMod ibi brks ix -> Just <$> getHistoryModule hug (resumeHistory r !! (ix-1)) - ===================================== compiler/GHC/Tc/Gen/Do.hs ===================================== @@ -14,7 +14,7 @@ module GHC.Tc.Gen.Do (expandDoStmts) where import GHC.Prelude -import GHC.Rename.Utils ( wrapGenSpan, genHsExpApps, genHsApp, genHsLet, +import GHC.Rename.Utils ( wrapGenSpan, wrapGenSpan', genHsExpApps, genHsApp, genHsLet, genHsLamDoExp, genHsCaseAltDoExp, genWildPat ) import GHC.Rename.Env ( irrefutableConLikeRn ) @@ -114,18 +114,17 @@ expand_do_stmts doFlavour (stmt@(L loc (BindStmt xbsrn pat e)): lstmts) | otherwise = pprPanic "expand_do_stmts: The impossible happened, missing bind operator from renamer" (text "stmt" <+> ppr stmt) -expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L _e_lspan e) (SyntaxExprRn then_op) _)) : lstmts) = +expand_do_stmts doFlavour (stmt@(L loc (BodyStmt _ (L _ e) (SyntaxExprRn then_op) _)) : lstmts) = -- See Note [BodyStmt] in Language.Haskell.Syntax.Expr -- See Note [Expanding HsDo with XXExprGhcRn] Equation (1) below -- stmts ~~> stmts' -- ---------------------------------------------- -- e ; stmts ~~> (>>) e stmts' - do expand_stmts_expr <- expand_do_stmts doFlavour lstmts - let expansion = genHsExpApps then_op -- (>>) - [ -- L e_lspan (mkExpandedStmt stmt doFlavour e) - wrapGenSpan e - , expand_stmts_expr ] - return $ L loc (mkExpandedStmt stmt doFlavour expansion) + do expand_stmts_expr <- expand_do_stmts doFlavour lstmts + let expansion = genHsExpApps then_op -- (>>) + [ wrapGenSpan e + , expand_stmts_expr ] + return $ L loc (mkExpandedStmt stmt doFlavour expansion) expand_do_stmts doFlavour ((L loc (RecStmt { recS_stmts = L stmts_loc rec_stmts ===================================== compiler/GHC/Tc/Gen/Splice.hs ===================================== @@ -1480,9 +1480,11 @@ instance TH.Quasi TcM where qLocation = do { m <- getModule ; l <- getSrcSpanM ; r <- case l of + RealSrcSpan s _ -> return s + GeneratedSrcSpan l -> pprPanic "qLocation: generatedSrcSpan" + (ppr l) UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" (ppr l) - RealSrcSpan s _ -> return s ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) , TH.loc_module = moduleNameString (moduleName m) , TH.loc_package = unitString (moduleUnit m) ===================================== compiler/GHC/Tc/Types/CtLoc.hs ===================================== @@ -253,8 +253,7 @@ setCtLocEnvLoc :: CtLocEnv -> SrcSpan -> CtLocEnv -- for the ctl_in_gen_code manipulation setCtLocEnvLoc env (RealSrcSpan loc _) = env { ctl_loc = loc, ctl_in_gen_code = False } - -setCtLocEnvLoc env loc@(UnhelpfulSpan _) +setCtLocEnvLoc env loc | isGeneratedSrcSpan loc = env { ctl_in_gen_code = True } | otherwise ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -62,7 +62,7 @@ module GHC.Tc.Utils.Monad( -- * Error management getSrcCodeOrigin, - getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, + getSrcSpanM, getRealSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, inGeneratedCode, wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_, wrapLocMA_,wrapLocMA, @@ -1070,6 +1070,11 @@ getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (getLclEnvLoc env) Strict.Nothing) } +getRealSrcSpanM :: TcRn RealSrcSpan + -- Avoid clash with Name.getSrcLoc +getRealSrcSpanM = do { env <- getLclEnv; return $ getLclEnvLoc env } + + -- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool inGeneratedCode = lclEnvInGeneratedCode <$> getLclEnv @@ -1079,7 +1084,7 @@ setSrcSpan :: SrcSpan -> TcRn a -> TcRn a setSrcSpan (RealSrcSpan loc _) thing_inside = updLclCtxt (\env -> env { tcl_loc = loc }) thing_inside -setSrcSpan (UnhelpfulSpan _) thing_inside +setSrcSpan _ thing_inside = thing_inside getSrcCodeOrigin :: TcRn (Maybe SrcCodeOrigin) ===================================== compiler/GHC/Types/Error.hs ===================================== @@ -787,7 +787,6 @@ getSeverityColour severity = case severity of SevIgnore -> const mempty getCaretDiagnostic :: MessageClass -> SrcSpan -> IO SDoc -getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty getCaretDiagnostic msg_class (RealSrcSpan span _) = caretDiagnostic <$> getSrcLine (srcSpanFile span) row where @@ -861,7 +860,7 @@ getCaretDiagnostic msg_class (RealSrcSpan span _) = caretEllipsis | multiline = "..." | otherwise = "" caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis - +getCaretDiagnostic _ _ = pure empty -- -- Queries -- ===================================== compiler/GHC/Types/Hint/Ppr.hs ===================================== @@ -19,7 +19,7 @@ import GHC.Hs.Expr () -- instance Outputable import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace) -import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine) +import GHC.Types.SrcLoc (SrcSpan(..), srcSpanStartLine, UnhelpfulSpanReason(..)) import GHC.Unit.Module.Imported (ImportedModsVal(..)) import GHC.Unit.Types import GHC.Utils.Outputable @@ -424,6 +424,7 @@ pprSimilarName mb_tried_ns (SimilarRdrName rdr_name _gre_info how_in_scope) LocallyBoundAt loc -> case loc of UnhelpfulSpan l -> parens (ppr l) + GeneratedSrcSpan{} -> parens (ppr UnhelpfulGenerated) RealSrcSpan l _ -> parens (text "line" <+> int (srcSpanStartLine l)) ImportedBy is -> parens (text "imported from" <+> ppr (moduleName $ is_mod is)) ===================================== compiler/GHC/Types/Name/Reader.hs ===================================== @@ -2077,9 +2077,12 @@ bestImport iss = NE.head $ NE.sortBy best iss -- False < True, so if e1 is explicit and e2 is not, we get GT compareGenerated UnhelpfulSpan{} UnhelpfulSpan{} = EQ - compareGenerated UnhelpfulSpan{} RealSrcSpan{} = LT - compareGenerated RealSrcSpan{} UnhelpfulSpan{} = GT + compareGenerated UnhelpfulSpan{} _ = LT + compareGenerated GeneratedSrcSpan{} UnhelpfulSpan{} = GT + compareGenerated GeneratedSrcSpan{} GeneratedSrcSpan{} = EQ + compareGenerated GeneratedSrcSpan{} _ = LT compareGenerated RealSrcSpan{} RealSrcSpan{} = EQ + compareGenerated RealSrcSpan{} _ = GT {- Note [Choosing the best import declaration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2212,6 +2215,7 @@ instance Outputable ImportSpec where pprLoc :: SrcSpan -> SDoc pprLoc (RealSrcSpan s _) = text "at" <+> ppr s pprLoc (UnhelpfulSpan {}) = empty +pprLoc (GeneratedSrcSpan {}) = empty -- | Indicate if the given name is the "@" operator opIsAt :: RdrName -> Bool ===================================== compiler/GHC/Types/SrcLoc.hs ===================================== @@ -306,7 +306,7 @@ lookupSrcLoc (UnhelpfulLoc _) = const Nothing lookupSrcSpan :: SrcSpan -> Map.Map RealSrcSpan a -> Maybe a lookupSrcSpan (RealSrcSpan l _) = Map.lookup l -lookupSrcSpan (UnhelpfulSpan _) = const Nothing +lookupSrcSpan _ = const Nothing instance Outputable RealSrcLoc where ppr (SrcLoc (LexicalFastString src_path) src_line src_col) @@ -387,6 +387,7 @@ instance Semigroup BufSpan where -- or a human-readable description of a location. data SrcSpan = RealSrcSpan !RealSrcSpan !(Strict.Maybe BufSpan) -- See Note [Why Maybe BufPos] + | GeneratedSrcSpan !RealSrcSpan -- Needed for HIE | UnhelpfulSpan !UnhelpfulSpanReason deriving (Eq, Show) -- Show is used by GHC.Parser.Lexer, because we @@ -426,6 +427,7 @@ messages, constructing a SrcSpan without a BufSpan. instance ToJson SrcSpan where json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")] + json (GeneratedSrcSpan {}) = JSNull json (RealSrcSpan rss _) = json rss instance ToJson RealSrcSpan where @@ -444,6 +446,7 @@ instance NFData RealSrcSpan where instance NFData SrcSpan where rnf (RealSrcSpan a1 a2) = rnf a1 `seq` rnf a2 rnf (UnhelpfulSpan a1) = rnf a1 + rnf (GeneratedSrcSpan {}) = rnf UnhelpfulGenerated instance NFData UnhelpfulSpanReason where rnf (UnhelpfulNoLocationInfo) = () @@ -454,7 +457,8 @@ instance NFData UnhelpfulSpanReason where getBufSpan :: SrcSpan -> Strict.Maybe BufSpan getBufSpan (RealSrcSpan _ mbspan) = mbspan -getBufSpan (UnhelpfulSpan _) = Strict.Nothing +getBufSpan _ = Strict.Nothing + -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty noSrcSpan, generatedSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan @@ -465,6 +469,7 @@ generatedSrcSpan = UnhelpfulSpan UnhelpfulGenerated isGeneratedSrcSpan :: SrcSpan -> Bool isGeneratedSrcSpan (UnhelpfulSpan UnhelpfulGenerated) = True +isGeneratedSrcSpan (GeneratedSrcSpan{}) = True isGeneratedSrcSpan _ = False isNoSrcSpan :: SrcSpan -> Bool @@ -515,6 +520,8 @@ mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2) combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful combineSrcSpans l (UnhelpfulSpan _) = l +combineSrcSpans (GeneratedSrcSpan _) r = r -- this seems more useful +combineSrcSpans l (GeneratedSrcSpan _) = l combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2) | srcSpanFile span1 == srcSpanFile span2 = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2) @@ -543,6 +550,7 @@ combineBufSpans span1 span2 = BufSpan start end -- | Convert a SrcSpan into one that represents only its first character srcSpanFirstCharacter :: SrcSpan -> SrcSpan srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l +srcSpanFirstCharacter l@(GeneratedSrcSpan {}) = l srcSpanFirstCharacter (RealSrcSpan span mbspan) = RealSrcSpan (mkRealSrcSpan loc1 loc2) (fmap mkBufSpan mbspan) where @@ -564,13 +572,13 @@ srcSpanFirstCharacter (RealSrcSpan span mbspan) = -- | Test if a 'SrcSpan' is "good", i.e. has precise location information isGoodSrcSpan :: SrcSpan -> Bool isGoodSrcSpan (RealSrcSpan _ _) = True -isGoodSrcSpan (UnhelpfulSpan _) = False +isGoodSrcSpan _ = False isOneLineSpan :: SrcSpan -> Bool -- ^ True if the span is known to straddle only one line. -- For "bad" 'SrcSpan', it returns False isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s -isOneLineSpan (UnhelpfulSpan _) = False +isOneLineSpan _ = False isZeroWidthSpan :: SrcSpan -> Bool -- ^ True if the span has a width of zero, as returned for "virtual" @@ -578,7 +586,7 @@ isZeroWidthSpan :: SrcSpan -> Bool -- For "bad" 'SrcSpan', it returns False isZeroWidthSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s && srcSpanStartCol s == srcSpanEndCol s -isZeroWidthSpan (UnhelpfulSpan _) = False +isZeroWidthSpan _ = False -- | Tests whether the first span "contains" the other span, meaning -- that it covers at least as much source code. True where spans are equal. @@ -620,11 +628,13 @@ srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c -- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanStart :: SrcSpan -> SrcLoc srcSpanStart (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) +srcSpanStart (GeneratedSrcSpan{}) = UnhelpfulLoc (unhelpfulSpanFS UnhelpfulGenerated) srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b) -- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanEnd :: SrcSpan -> SrcLoc srcSpanEnd (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r) +srcSpanEnd (GeneratedSrcSpan{}) = UnhelpfulLoc (unhelpfulSpanFS UnhelpfulGenerated) srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b) realSrcSpanStart :: RealSrcSpan -> RealSrcLoc @@ -640,7 +650,7 @@ realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) -- | Obtains the filename for a 'SrcSpan' if it is "good" srcSpanFileName_maybe :: SrcSpan -> Maybe FastString srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s) -srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing +srcSpanFileName_maybe _ = Nothing srcSpanToRealSrcSpan :: SrcSpan -> Maybe RealSrcSpan srcSpanToRealSrcSpan (RealSrcSpan ss _) = Just ss @@ -717,6 +727,7 @@ pprUnhelpfulSpanReason r = ftext (unhelpfulSpanFS r) pprUserSpan :: Bool -> SrcSpan -> SDoc pprUserSpan _ (UnhelpfulSpan r) = pprUnhelpfulSpanReason r +pprUserSpan _ (GeneratedSrcSpan{}) = pprUnhelpfulSpanReason UnhelpfulGenerated pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc @@ -843,15 +854,19 @@ leftmost_largest = compareSrcSpanBy $ compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b -compareSrcSpanBy _ (RealSrcSpan _ _) (UnhelpfulSpan _) = LT +compareSrcSpanBy _ (RealSrcSpan _ _) _ = LT compareSrcSpanBy _ (UnhelpfulSpan _) (RealSrcSpan _ _) = GT -compareSrcSpanBy _ (UnhelpfulSpan _) (UnhelpfulSpan _) = EQ +compareSrcSpanBy _ (UnhelpfulSpan _) _ = EQ +compareSrcSpanBy _ (GeneratedSrcSpan _) (RealSrcSpan _ _) = GT +compareSrcSpanBy _ (GeneratedSrcSpan _) _ = EQ + -- | Determines whether a span encloses a given line and column index spans :: SrcSpan -> (Int, Int) -> Bool -spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" spans (RealSrcSpan span _) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span where loc = mkRealSrcLoc (srcSpanFile span) l c +spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" +spans (GeneratedSrcSpan _) _ = panic "spans GeneratedSrcSpan" -- | Determines whether a span is enclosed by another one isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other ===================================== compiler/GHC/Utils/Binary.hs ===================================== @@ -1952,13 +1952,19 @@ instance Binary BinSrcSpan where putByte bh 1 put_ bh s + put_ bh (BinSrcSpan (GeneratedSrcSpan ss)) = do + putByte bh 2 + put_ bh $ BinSpan ss + get bh = do h <- getByte bh case h of 0 -> do BinSpan ss <- get bh return $ BinSrcSpan (RealSrcSpan ss Strict.Nothing) - _ -> do s <- get bh + 1 -> do s <- get bh return $ BinSrcSpan (UnhelpfulSpan s) + _ -> do BinSpan ss <- get bh + return $ BinSrcSpan (GeneratedSrcSpan ss) {- ===================================== compiler/GHC/Utils/Logger.hs ===================================== @@ -398,7 +398,7 @@ jsonLogActionWithHandle out logflags msg_class srcSpan msg , ("endCol", json $ srcSpanEndCol rss) ] where file = unpackFS $ srcSpanFile rss - UnhelpfulSpan _ -> JSNull + _ -> JSNull -- | The default 'LogAction' prints to 'stdout' and 'stderr'. -- @@ -707,4 +707,3 @@ class HasLogger m where class ContainsLogger t where extractLogger :: t -> Logger - ===================================== ghc/GHCi/UI.hs ===================================== @@ -2692,8 +2692,9 @@ parseSpanArg s = do -- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@ -- while simply unpacking 'UnhelpfulSpan's showSrcSpan :: SrcSpan -> String -showSrcSpan (UnhelpfulSpan s) = unpackFS (unhelpfulSpanFS s) -showSrcSpan (RealSrcSpan spn _) = showRealSrcSpan spn +showSrcSpan (UnhelpfulSpan s) = unpackFS (unhelpfulSpanFS s) +showSrcSpan (GeneratedSrcSpan _) = unpackFS (unhelpfulSpanFS UnhelpfulGenerated) +showSrcSpan (RealSrcSpan spn _) = showRealSrcSpan spn -- | Variant of 'showSrcSpan' for 'RealSrcSpan's showRealSrcSpan :: RealSrcSpan -> String @@ -4235,14 +4236,14 @@ stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg mb_span <- getCurrentBreakSpan case mb_span of Nothing -> stepCmd [] - Just (UnhelpfulSpan _) -> liftIO $ putStrLn ( -- #14690 - ":steplocal is not possible." ++ - "\nCannot determine current top-level binding after " ++ - "a break on error / exception.\nUse :stepmodule.") - Just loc -> do + Just loc@(RealSrcSpan{}) -> do md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule current_toplevel_decl <- flip enclosingTickSpan loc <$> getTickArray md doContinue (GHC.LocalStep (RealSrcSpan current_toplevel_decl Strict.Nothing)) + Just _ -> liftIO $ putStrLn ( -- #14690 + ":steplocal is not possible." ++ + "\nCannot determine current top-level binding after " ++ + "a break on error / exception.\nUse :stepmodule.") stepModuleCmd :: GhciMonad m => String -> m () stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg @@ -4580,7 +4581,7 @@ listCmd "" = do printForUser $ text "Not stopped at a breakpoint; nothing to list" Just (RealSrcSpan pan _) -> listAround pan True - Just pan@(UnhelpfulSpan _) -> + Just pan@_ -> do resumes <- GHC.getResumeContext case resumes of [] -> panic "No resumes" ===================================== ghc/GHCi/UI/Info.hs ===================================== @@ -168,6 +168,7 @@ findName infos span0 mi string = Just name -> case getSrcSpan name of UnhelpfulSpan {} -> tryExternalModuleResolution + GeneratedSrcSpan {} -> tryExternalModuleResolution RealSrcSpan {} -> return (getName name) where rdrs = modInfo_rdrs mi ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -477,6 +477,7 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do dp = adjustDeltaForOffset off (ss2delta priorEndAfterComments r) Just (EpaSpan (UnhelpfulSpan r)) -> panic $ "enterAnn: UnhelpfulSpan:" ++ show r + Just (EpaSpan (GeneratedSrcSpan r)) -> panic $ "enterAnn: UnhelpfulSpan:" ++ show r when (isJust med) $ debugM $ "enterAnn:(med,edp)=" ++ showAst (med,edp) when (isJust medr) $ setExtraDPReturn medr -- --------------------------------------------- @@ -737,7 +738,7 @@ printStringAtNC el str = do printStringAtAAC :: (Monad m, Monoid w) => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation printStringAtAAC capture (EpaSpan (RealSrcSpan r _)) s = printStringAtRsC capture r s -printStringAtAAC _capture (EpaSpan ss@(UnhelpfulSpan _)) _s = error $ "printStringAtAAC:ss=" ++ show ss +printStringAtAAC _capture (EpaSpan ss) _s = error $ "printStringAtAAC:ss=" ++ show ss printStringAtAAC capture (EpaDelta ss d cs) s = do mapM_ printOneComment $ concatMap tokComment cs pe1 <- getPriorEndD @@ -1356,7 +1357,7 @@ printOneComment c@(Comment _str loc _r _mo) = do let dp = ss2delta pe r debugM $ "printOneComment:(dp,pe,loc)=" ++ showGhc (dp,pe,loc) adjustDeltaForOffsetM dp - EpaSpan (UnhelpfulSpan _) -> return (SameLine 0) + EpaSpan _ -> return (SameLine 0) mep <- getExtraDP dp' <- case mep of Just (EpaDelta _ edp _) -> do ===================================== utils/check-exact/Parsers.hs ===================================== @@ -305,8 +305,6 @@ fixModuleHeaderComments (GHC.L l p) = GHC.L l p' where moveComments :: GHC.EpaLocation -> GHC.LHsDecl GHC.GhcPs -> GHC.EpAnnComments -> (GHC.LHsDecl GHC.GhcPs, GHC.EpAnnComments) - moveComments GHC.EpaDelta{} dd cs = (dd,cs) - moveComments (GHC.EpaSpan (GHC.UnhelpfulSpan _)) dd cs = (dd,cs) moveComments (GHC.EpaSpan (GHC.RealSrcSpan r _)) (GHC.L (GHC.EpAnn anc an csd) a) cs = (dd,css) where -- Move any comments on the decl that occur prior to the location @@ -318,12 +316,14 @@ fixModuleHeaderComments (GHC.L l p) = GHC.L l p' dd = GHC.L (GHC.EpAnn anc an csd') a css = cs <> GHC.EpaComments move + moveComments _ dd cs = (dd,cs) (ds',an') = rebalance (GHC.hsmodDecls p, GHC.hsmodAnn $ GHC.hsmodExt p) p' = p { GHC.hsmodExt = (GHC.hsmodExt p){ GHC.hsmodAnn = an' }, GHC.hsmodDecls = ds' } + rebalance :: ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule) -> ([GHC.LHsDecl GHC.GhcPs], GHC.EpAnn GHC.AnnsModule) rebalance (ds, GHC.EpAnn a an cs) = (ds1, GHC.EpAnn a an cs') ===================================== utils/check-exact/Transform.hs ===================================== @@ -255,6 +255,8 @@ setEntryDPDecl d dp = setEntryDP d dp setEntryDP :: LocatedAn t a -> DeltaPos -> LocatedAn t a setEntryDP (L (EpAnn (EpaSpan ss@(UnhelpfulSpan _)) an cs) a) dp = L (EpAnn (EpaDelta ss dp []) an cs) a +setEntryDP (L (EpAnn (EpaSpan ss@(GeneratedSrcSpan _)) an cs) a) dp + = L (EpAnn (EpaDelta ss dp []) an cs) a setEntryDP (L (EpAnn (EpaSpan ss) an (EpaComments [])) a) dp = L (EpAnn (EpaDelta ss dp []) an (EpaComments [])) a setEntryDP (L (EpAnn (EpaDelta ss d csd) an cs) a) dp @@ -320,14 +322,12 @@ getEntryDP _ = SameLine 1 addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation addEpaLocationDelta _off _anc (EpaDelta ss d cs) = EpaDelta ss d cs -addEpaLocationDelta _off _anc (EpaSpan ss@(UnhelpfulSpan _)) = EpaDelta ss (SameLine 0) [] addEpaLocationDelta off anc (EpaSpan ss@(RealSrcSpan r _)) = EpaDelta ss (adjustDeltaForOffset off (ss2deltaEnd anc r)) [] +addEpaLocationDelta _off _anc (EpaSpan ss) = EpaDelta ss (SameLine 0) [] -- Set the entry DP for an element coming after an existing keyword annotation setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t -setEntryDPFromAnchor _off (EpaDelta _ _ _) (L la a) = L la a -setEntryDPFromAnchor _off (EpaSpan (UnhelpfulSpan _)) (L la a) = L la a setEntryDPFromAnchor off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP ll dp' where dp' = case la of @@ -335,6 +335,8 @@ setEntryDPFromAnchor off (EpaSpan (RealSrcSpan anc _)) ll@(L la _) = setEntryDP (EpAnn (EpaSpan _) _ _) -> adjustDeltaForOffset off (SameLine 0) (EpAnn (EpaDelta _ dp _) _ _) -> adjustDeltaForOffset off dp +setEntryDPFromAnchor _off _ ll = ll + -- --------------------------------------------------------------------- -- |Take the annEntryDelta associated with the first item and @@ -902,7 +904,7 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where let off = case l of (EpaSpan (RealSrcSpan r _)) -> LayoutStartCol $ snd $ ss2pos r - (EpaSpan (UnhelpfulSpan _)) -> LayoutStartCol 0 + (EpaSpan _) -> LayoutStartCol 0 (EpaDelta _ (SameLine _) _) -> LayoutStartCol 0 (EpaDelta _ (DifferentLine _ c) _) -> LayoutStartCol c ex'' = setEntryDPFromAnchor off i ex ===================================== utils/check-exact/Utils.hs ===================================== @@ -530,9 +530,10 @@ sortEpaComments cs = sortBy cmp cs -- | Makes a comment which originates from a specific keyword. mkKWComment :: String -> NoCommentsLocation -> Comment -mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment kw (EpaSpan (RealSrcSpan ss mb)) ss (Just kw) -mkKWComment kw (EpaSpan (UnhelpfulSpan _)) = Comment kw (EpaDelta noSrcSpan (SameLine 0) NoComments) placeholderRealSpan (Just kw) mkKWComment kw (EpaDelta ss dp cs) = Comment kw (EpaDelta ss dp cs) placeholderRealSpan (Just kw) +mkKWComment kw (EpaSpan (RealSrcSpan ss mb)) = Comment kw (EpaSpan (RealSrcSpan ss mb)) ss (Just kw) +mkKWComment kw (EpaSpan _) = Comment kw (EpaDelta noSrcSpan (SameLine 0) NoComments) placeholderRealSpan (Just kw) + sortAnchorLocated :: [GenLocated EpaLocation a] -> [GenLocated EpaLocation a] sortAnchorLocated = sortBy (compare `on` (epaLocationRealSrcSpan . getLoc)) ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Hyperlinker/Parser.hs ===================================== @@ -155,6 +155,53 @@ parse parserOpts sDocContext fpath bs = case unP (go False []) initState of pure (plainTok : [spaceTok | not (BS.null spaceBStr)], inPrag') + GeneratedSrcSpan rsp -> do + let typ = if inPrag then TkPragma else classify tok + RealSrcLoc lStart _ = srcSpanStart sp -- safe since @sp@ is real + (spaceBStr, bStart) = spanPosition lInit lStart bInit + inPragDef = inPragma inPrag tok + + (bEnd', inPrag') <- case tok of + -- Update internal line + file position if this is a LINE pragma + ITline_prag _ -> tryOrElse (bEnd, inPragDef) $ do + L _ (ITinteger (IL{il_value = line})) <- tryP wrappedLexer + L _ (ITstring _ file) <- tryP wrappedLexer + L spF ITclose_prag <- tryP wrappedLexer + + let newLoc = mkRealSrcLoc file (fromIntegral line - 1) (srcSpanEndCol spF) + (bEnd'', _) <- lift getInput + lift $ setInput (bEnd'', newLoc) + + pure (bEnd'', False) + + -- Update internal column position if this is a COLUMN pragma + ITcolumn_prag _ -> tryOrElse (bEnd, inPragDef) $ do + L _ (ITinteger (IL{il_value = col})) <- tryP wrappedLexer + L spF ITclose_prag <- tryP wrappedLexer + + let newLoc = mkRealSrcLoc (srcSpanFile spF) (srcSpanEndLine spF) (fromIntegral col) + (bEnd'', _) <- lift getInput + lift $ setInput (bEnd'', newLoc) + + pure (bEnd'', False) + _ -> pure (bEnd, inPragDef) + + let tokBStr = splitStringBuffer bStart bEnd' + plainTok = + T.Token + { tkType = typ + , tkValue = tokBStr + , tkSpan = rsp + } + spaceTok = + T.Token + { tkType = TkSpace + , tkValue = spaceBStr + , tkSpan = mkRealSrcSpan lInit lStart + } + + pure (plainTok : [spaceTok | not (BS.null spaceBStr)], inPrag') + -- \| Parse whatever remains of the line as an unknown token (can't fail) unknownLine :: P ([T.Token], Bool) unknownLine = do ===================================== utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs ===================================== @@ -103,6 +103,8 @@ spliceURL' maybe_mod maybe_name maybe_loc = run case span_ of RealSrcSpan span__ _ -> show $ srcSpanStartLine span__ + GeneratedSrcSpan span__ -> + show $ srcSpanStartLine span__ UnhelpfulSpan _ -> "" run "" = "" View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8b97de5bd2cfdeed11c36347a4a0b6d… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8b97de5bd2cfdeed11c36347a4a0b6d… You're receiving this email because of your account on gitlab.haskell.org.

1 0