Jana Chadt pushed to branch wip/VeryMilkyJoe/no-mod-loc-pat at Glasgow Haskell Compiler / GHC Commits: 2249d123 by Jana Chadt at 2026-02-24T12:47:57+01:00 Remove backwards compatability pattern synonym `ModLocation` * Introduce utility to create ShortByteString from an OsString. * Introduce utility to create StringBuffer for a given OsPath. * Add mkFastStringOsString, which returns a FastString for a given OsString. Fixes #24932 - - - - - 10 changed files: - compiler/GHC.hs - compiler/GHC/Cmm/DebugBlock.hs - compiler/GHC/CoreToStg/AddImplicitBinds.hs - compiler/GHC/Data/FastString.hs - compiler/GHC/Data/OsPath.hs - compiler/GHC/Data/StringBuffer.hs - compiler/GHC/Stg/Debug.hs - compiler/GHC/Unit/Module/Location.hs - compiler/GHC/Unit/Module/ModSummary.hs - compiler/ghc.cabal.in Changes: ===================================== compiler/GHC.hs ===================================== @@ -79,7 +79,13 @@ module GHC ( ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries, mgLookupModule, ModSummary(..), ms_mod_name, ModLocation(..), - pattern ModLocation, + ml_hs_file, + ml_hi_file, + ml_dyn_hi_file, + ml_obj_file, + ml_dyn_obj_file, + ml_hie_file, + ml_bytecode_file, getModSummary, getModuleGraph, isLoaded, @@ -457,6 +463,7 @@ import System.Environment ( getEnv, getProgName ) import System.Exit ( exitWith, ExitCode(..) ) import System.FilePath import System.IO.Error ( isDoesNotExistError ) +import GHC.Data.OsPath (OsPath) #if defined(HAVE_INTERNAL_INTERPRETER) import Foreign.C @@ -1575,12 +1582,12 @@ pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a)) -- a module by using 'getModSummary' -- -- XXX: Explain pre-conditions -getModuleSourceAndFlags :: ModSummary -> IO (String, StringBuffer, DynFlags) +getModuleSourceAndFlags :: ModSummary -> IO (OsPath, StringBuffer, DynFlags) getModuleSourceAndFlags m = do - case ml_hs_file $ ms_location m of + case ml_hs_file_ospath $ ms_location m of Nothing -> throwIO $ mkApiErr (ms_hspp_opts m) (text "No source available for module " <+> ppr (ms_mod m)) Just sourceFile -> do - source <- hGetStringBuffer sourceFile + source <- hGetStringBufferOsPath sourceFile return (sourceFile, source, ms_hspp_opts m) @@ -1592,7 +1599,7 @@ getModuleSourceAndFlags m = do getTokenStream :: ModSummary -> IO [Located Token] getTokenStream mod = do (sourceFile, source, dflags) <- getModuleSourceAndFlags mod - let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 + let startLoc = mkRealSrcLoc (mkFastStringOsString sourceFile) 1 1 case lexTokenStream (initParserOpts dflags) source startLoc of POk _ ts -> return ts PFailed pst -> throwErrors (initSourceErrorContext dflags) (GhcPsMessage <$> getPsErrorMessages pst) @@ -1603,7 +1610,7 @@ getTokenStream mod = do getRichTokenStream :: ModSummary -> IO [(Located Token, String)] getRichTokenStream mod = do (sourceFile, source, dflags) <- getModuleSourceAndFlags mod - let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 + let startLoc = mkRealSrcLoc (mkFastStringOsString sourceFile) 1 1 case lexTokenStream (initParserOpts dflags) source startLoc of POk _ ts -> return $ addSourceToTokens startLoc source ts PFailed pst -> throwErrors (initSourceErrorContext dflags) (GhcPsMessage <$> getPsErrorMessages pst) ===================================== compiler/GHC/Cmm/DebugBlock.hs ===================================== @@ -33,7 +33,7 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Reg ( pprGlobalReg, pprGlobalRegUse ) import GHC.Cmm.Utils -import GHC.Data.FastString ( LexicalFastString, nilFS, mkFastString ) +import GHC.Data.FastString ( LexicalFastString, nilFS, mkFastStringOsString ) import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Utils.Panic @@ -156,7 +156,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes rangeRating (span, _) | srcSpanFile span == thisFile = 1 | otherwise = 2 :: Int - thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc + thisFile = maybe nilFS mkFastStringOsString $ ml_hs_file_ospath modLoc -- Returns block tree for this scope as well as all nested -- scopes. Note that if there are multiple blocks in the (exact) ===================================== compiler/GHC/CoreToStg/AddImplicitBinds.hs ===================================== @@ -135,15 +135,16 @@ tick_it :: Bool -> ModLocation -> Name -> CoreExpr -> CoreExpr -- If we want to generate debug info, we put a source note on the -- worker. This is useful, especially for heap profiling. tick_it generate_debug_info mod_loc name - | not generate_debug_info = id + | not generate_debug_info = id | RealSrcSpan span _ <- nameSrcSpan name = tick span - | Just file <- ml_hs_file mod_loc = tick (span1 file) - | otherwise = tick (span1 "???") + | Just file <- ml_hs_file_ospath mod_loc = tick (span2 file) + | otherwise = tick (span1 "???") where tick span = Tick $ SourceNote span $ LexicalFastString $ mkFastString $ renderWithContext defaultSDocContext $ ppr name - span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1 + span1 str = realSrcLocSpan $ mkRealSrcLoc (mkFastString str) 1 1 + span2 file = realSrcLocSpan $ mkRealSrcLoc (mkFastStringOsString file) 1 1 ===================================== compiler/GHC/Data/FastString.hs ===================================== @@ -77,6 +77,7 @@ module GHC.Data.FastString mkFastStringBytes, mkFastStringByteList, mkFastString#, + mkFastStringOsString, -- ** Deconstruction unpackFS, -- :: FastString -> String @@ -147,6 +148,8 @@ import GHC.Conc.Sync (sharedCAF) import GHC.Exts import GHC.IO +import System.OsString.Internal.Types +import Data.Type.Coercion (coerceWith) -- | Gives the Modified UTF-8 encoded bytes corresponding to a 'FastString' bytesFS, fastStringToByteString :: FastString -> ByteString @@ -547,6 +550,14 @@ mkFastStringShortByteString :: ShortByteString -> FastString mkFastStringShortByteString sbs = inlinePerformIO $ mkFastStringWith (mkNewFastStringShortByteString sbs) sbs +-- | Create a 'FastString' from an 'OsString', without copying. +mkFastStringOsString :: OsString -> FastString +mkFastStringOsString os = mkFastStringShortByteString $ + -- Using 'OsPath''s 'unOS' here will unfortunately lead to cyclic dependencies + case coercionToPlatformTypes of + Left (_, windowsStringEv) -> unWS $ coerceWith windowsStringEv os + Right (_, posixStringEv) -> unPS $ coerceWith posixStringEv os + -- | Creates a UTF-8 encoded 'FastString' from a 'String' mkFastString :: String -> FastString {-# NOINLINE[1] mkFastString #-} ===================================== compiler/GHC/Data/OsPath.hs ===================================== @@ -8,6 +8,7 @@ module GHC.Data.OsPath , unsafeDecodeUtf , unsafeEncodeUtf , os + , unOS -- * Common utility functions , () , (<.>) @@ -32,9 +33,17 @@ import System.OsPath import System.OsString (isSuffixOf) import System.Directory.OsPath (doesDirectoryExist, doesFileExist, getDirectoryContents, createDirectoryIfMissing) import System.Directory.Internal (os) +import System.OsString.Internal.Types (coercionToPlatformTypes, unWS, unPS) +import Data.Type.Coercion (coerceWith) +import Data.ByteString.Short (ShortByteString) -- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed. -- Prefer 'decodeUtf' and gracious error handling. unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath unsafeDecodeUtf p = either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p) + +unOS :: OsString -> ShortByteString +unOS os = case coercionToPlatformTypes of + Left (_, windowsStringEv) -> unWS $ coerceWith windowsStringEv os + Right (_, posixStringEv) -> unPS $ coerceWith posixStringEv os ===================================== compiler/GHC/Data/StringBuffer.hs ===================================== @@ -21,6 +21,7 @@ module GHC.Data.StringBuffer -- * Creation\/destruction hGetStringBuffer, hGetStringBufferBlock, + hGetStringBufferOsPath, hPutStringBuffer, appendStringBuffers, stringToStringBuffer, @@ -76,6 +77,8 @@ import GHC.Exts import Foreign import GHC.ForeignPtr (unsafeWithForeignPtr) +import GHC.Data.OsPath (OsPath) +import qualified System.File.OsPath as FileIO -- ----------------------------------------------------------------------------- -- The StringBuffer type @@ -111,6 +114,15 @@ instance Show StringBuffer where hGetStringBuffer :: FilePath -> IO StringBuffer hGetStringBuffer fname = do h <- openBinaryFile fname ReadMode + hGetStringBufferHandle h + +hGetStringBufferOsPath :: OsPath -> IO StringBuffer +hGetStringBufferOsPath fname = do + h <- FileIO.openBinaryFile fname ReadMode + hGetStringBufferHandle h + +hGetStringBufferHandle :: Handle -> IO StringBuffer +hGetStringBufferHandle h = do size_i <- hFileSize h offset_i <- skipBOM h size_i 0 -- offset is 0 initially let size = fromIntegral $ size_i - offset_i ===================================== compiler/GHC/Stg/Debug.hs ===================================== @@ -87,7 +87,7 @@ recordInfo :: Id -> StgExpr -> M () recordInfo bndr new_rhs = do modLoc <- asks rModLocation let - thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc + thisFile = maybe nilFS mkFastStringOsString $ ml_hs_file_ospath modLoc -- A span from the ticks surrounding the new_rhs best_span = quickSourcePos thisFile new_rhs -- A back-up span if the bndr had a source position, many do not (think internally generated ids) ===================================== compiler/GHC/Unit/Module/Location.hs ===================================== @@ -2,22 +2,19 @@ {-# LANGUAGE ViewPatterns #-} -- | Module location module GHC.Unit.Module.Location - ( ModLocation - ( .. - , ml_hs_file - , ml_hi_file - , ml_dyn_hi_file - , ml_obj_file - , ml_dyn_obj_file - , ml_hie_file - , ml_bytecode_file - ) - , pattern ModLocation + ( ModLocation(..) , addBootSuffix , addBootSuffixLocn , addBootSuffixLocnOut , removeBootSuffix , mkFileSrcSpan + , ml_hs_file + , ml_hi_file + , ml_dyn_hi_file + , ml_obj_file + , ml_dyn_obj_file + , ml_hie_file + , ml_bytecode_file ) where @@ -26,7 +23,7 @@ import GHC.Prelude import GHC.Data.OsPath import GHC.Types.SrcLoc import GHC.Utils.Outputable -import GHC.Data.FastString (mkFastString) +import GHC.Data.FastString ( mkFastStringOsString ) import qualified System.OsString as OsString @@ -120,41 +117,31 @@ addBootSuffixLocnOut locn -- | Compute a 'SrcSpan' from a 'ModLocation'. mkFileSrcSpan :: ModLocation -> SrcSpan mkFileSrcSpan mod_loc - = case ml_hs_file mod_loc of - Just file_path -> mkGeneralSrcSpan (mkFastString file_path) + = case ml_hs_file_ospath mod_loc of + Just file_path -> mkGeneralSrcSpan (mkFastStringOsString file_path) Nothing -> interactiveSrcSpan -- Presumably -- ---------------------------------------------------------------------------- -- Helpers for backwards compatibility -- ---------------------------------------------------------------------------- -{-# COMPLETE ModLocation #-} - -pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> ModLocation -pattern ModLocation - { ml_hs_file - , ml_hi_file - , ml_dyn_hi_file - , ml_obj_file - , ml_dyn_obj_file - , ml_hie_file - , ml_bytecode_file - } <- OsPathModLocation - { ml_hs_file_ospath = (fmap unsafeDecodeUtf -> ml_hs_file) - , ml_hi_file_ospath = (unsafeDecodeUtf -> ml_hi_file) - , ml_dyn_hi_file_ospath = (unsafeDecodeUtf -> ml_dyn_hi_file) - , ml_obj_file_ospath = (unsafeDecodeUtf -> ml_obj_file) - , ml_dyn_obj_file_ospath = (unsafeDecodeUtf -> ml_dyn_obj_file) - , ml_hie_file_ospath = (unsafeDecodeUtf -> ml_hie_file) - , ml_bytecode_file_ospath = (unsafeDecodeUtf -> ml_bytecode_file) - } where - ModLocation ml_hs_file ml_hi_file ml_dyn_hi_file ml_obj_file ml_dyn_obj_file ml_hie_file ml_bytecode_file - = OsPathModLocation - { ml_hs_file_ospath = fmap unsafeEncodeUtf ml_hs_file - , ml_hi_file_ospath = unsafeEncodeUtf ml_hi_file - , ml_dyn_hi_file_ospath = unsafeEncodeUtf ml_dyn_hi_file - , ml_obj_file_ospath = unsafeEncodeUtf ml_obj_file - , ml_dyn_obj_file_ospath = unsafeEncodeUtf ml_dyn_obj_file - , ml_hie_file_ospath = unsafeEncodeUtf ml_hie_file - , ml_bytecode_file_ospath = unsafeEncodeUtf ml_bytecode_file - } +ml_hs_file :: ModLocation -> Maybe FilePath +ml_hs_file = fmap unsafeDecodeUtf . ml_hs_file_ospath + +ml_hi_file :: ModLocation -> FilePath +ml_hi_file = unsafeDecodeUtf . ml_hi_file_ospath + +ml_dyn_hi_file :: ModLocation -> FilePath +ml_dyn_hi_file = unsafeDecodeUtf . ml_dyn_hi_file_ospath + +ml_obj_file :: ModLocation -> FilePath +ml_obj_file = unsafeDecodeUtf . ml_obj_file_ospath + +ml_dyn_obj_file :: ModLocation -> FilePath +ml_dyn_obj_file = unsafeDecodeUtf . ml_dyn_obj_file_ospath + +ml_hie_file :: ModLocation -> FilePath +ml_hie_file = unsafeDecodeUtf . ml_hie_file_ospath + +ml_bytecode_file :: ModLocation -> FilePath +ml_bytecode_file = unsafeDecodeUtf . ml_bytecode_file_ospath ===================================== compiler/GHC/Unit/Module/ModSummary.hs ===================================== @@ -46,7 +46,7 @@ import GHC.Types.PkgQual import GHC.Types.Basic import GHC.Data.Maybe -import GHC.Data.OsPath (OsPath) +import GHC.Data.OsPath (OsPath, unsafeDecodeUtf) import GHC.Data.StringBuffer ( StringBuffer ) import GHC.Utils.Fingerprint @@ -213,8 +213,8 @@ findTarget ms ts = summary `matches` Target { targetId = TargetModule m, targetUnitId = unitId } = ms_mod_name summary == m && ms_unitid summary == unitId summary `matches` Target { targetId = TargetFile f _, targetUnitId = unitid } - | Just f' <- ml_hs_file (ms_location summary) - = f == f' && ms_unitid summary == unitid + | Just f' <- ml_hs_file_ospath (ms_location summary) + = f == (unsafeDecodeUtf f') && ms_unitid summary == unitid _ `matches` _ = False ===================================== compiler/ghc.cabal.in ===================================== @@ -125,6 +125,7 @@ Library containers >= 0.6.2.1 && < 0.9, array >= 0.1 && < 0.6, filepath >= 1.5 && < 1.6, + file-io, os-string >= 2.0.1 && < 2.1, hpc >= 0.6 && < 0.8, transformers >= 0.5 && < 0.7, View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2249d12371306338f57107ac9051d67e... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2249d12371306338f57107ac9051d67e... You're receiving this email because of your account on gitlab.haskell.org.